Merge pull request kaveh808#239 from kaveh808/kaveh-devel-7

Kaveh devel 7

kons-9.asd

@@ -101,6 +101,7 @@
    (:file "src/plugins/particle")
    (:file "src/plugins/l-system")
    (:file "src/plugins/growth")
+   (:file "src/plugins/sprite")
    (:file "src/plugins/poly-mesh")
    (:file "src/plugins/usd")
    (:file "src/plugins/obj")

src/graphics/opengl/opengl.lisp

@@ -86,7 +86,7 @@
        result)))
 
 (defun gl-set-color (col)
-  (gl:color (c-red col) (c-green col) (c-blue col)))
+  (gl:color (c-red col) (c-green col) (c-blue col) (c-alpha col)))
 
 (defun gl-set-fg-color ()
   (gl-set-color (fg-color *drawing-settings*)))
@@ -188,7 +188,20 @@
     (gl:clear-color (c-red bg-color) (c-green bg-color) (c-blue bg-color) 0.0)
     (gl:clear :color-buffer-bit :depth-buffer-bit)
     (gl:enable :depth-test)
-    (gl:cull-face :back)))
+    (gl:cull-face :back)
+    ;; for sprite transparency
+    (gl:blend-func :src-alpha :one-minus-src-alpha)
+    (gl:blend-func :src-alpha :one-minus-src-alpha)
+    ;; (gl:blend-equation-separate :func-add :func-add)
+    ;; (gl:blend-func-separate :src-alpha :one-minus-src-alpha :one :one-minus-src-alpha)
+    (gl:enable :blend)
+    ))
+
+  ;;   (gl:blend-fun
+
+  ;; (#_glBlendEquationSeparate #$GL_FUNC_ADD #$GL_FUNC_ADD)
+  ;; (#_glBlendFuncSeparate #$GL_SRC_ALPHA #$GL_ONE_MINUS_SRC_ALPHA #$GL_ONE #$GL_ONE_MINUS_SRC_ALPHA)
+
 
 (defun 3d-setup-projection ()
   (gl:matrix-mode :projection)
@@ -207,14 +220,21 @@
   (gl-set-fg-color)
   (gl:flush))
 
+(defun gl-get-float (param)
+  (gl:get-float param))
+
 ;;; 3d display =================================================================
 
 (defun 3d-translate (p)
   (gl:translate (p:x p) (p:y p) (p:z p)))
 
-(defun 3d-push-matrix (matrix)
+(defun 3d-push-matrix (&optional (matrix nil))
   (gl:push-matrix)
-  (gl:mult-matrix (matrix->vector matrix))) ;is order correct?
+  (when matrix
+    (gl:mult-matrix (matrix->vector matrix))))
+
+(defun 3d-load-matrix (matrix)
+  (gl:load-matrix (matrix->vector matrix)))
 
 (defun 3d-pop-matrix ()
   (gl:pop-matrix))
@@ -330,6 +350,14 @@
     (gl:end)
     (gl-set-fg-color)))
 
+(defun 3d-draw-filled-curve (points)
+  (with-gl-disable :lighting
+    (gl:polygon-mode :front-and-back :fill)
+    (gl:begin :polygon)
+    (do-array (i p points)
+      (gl:vertex (p:x p) (p:y p) (p:z p)))
+    (gl:end)))
+
 (defun 3d-draw-points (points point-colors &key (highlight? nil))
   (with-gl-disable :lighting
     (if highlight?

src/kernel/color.lisp

@@ -73,8 +73,10 @@
     (vector (c-255! 255 0 0) (c-255! 255 127 0) (c-255! 255 255 0) (c-255! 0 255 0)
             (c-255! 0 0 255) (c-255! 75 0 130) (c-255! 148 0 211))))
 
-(defun c-rainbow (f)
+(defun c-rainbow (f &optional (alpha 1.0))
   (let ((rainbow-value (* f 6.0)))
     (multiple-value-bind (i frac)
         (floor rainbow-value)
-      (c-lerp frac (aref +rainbow+ i) (aref +rainbow+ (min (1+ i) 6))))))
+      (let ((col (c-lerp frac (aref +rainbow+ i) (aref +rainbow+ (min (1+ i) 6)))))
+        (c-set-alpha col alpha)
+        col))))

src/kernel/matrix.lisp

@@ -39,6 +39,12 @@
                           (list (aref matrix 2 0) (aref matrix 2 1) (aref matrix 2 2) (aref matrix 2 3))
                           (list (aref matrix 3 0) (aref matrix 3 1) (aref matrix 3 2) (aref matrix 3 3)))))
 
+(defun make-matrix-from-vector (vec)
+  (make-matrix-with (list (list (aref vec  0) (aref vec  1) (aref vec  2) (aref vec  3))
+                          (list (aref vec  4) (aref vec  5) (aref vec  6) (aref vec  7))
+                          (list (aref vec  8) (aref vec  9) (aref vec 10) (aref vec 11))
+                          (list (aref vec 12) (aref vec 13) (aref vec 14) (aref vec 15)))))
+
 ;;; transformation matrices
 
 (defun make-translation-matrix (point)

src/kernel/point-cloud.lisp

@@ -68,13 +68,16 @@
 (defmethod set-point-colors-by-xyz ((p-cloud point-cloud) color-fn)
   (allocate-point-colors p-cloud)
   (do-array (i p (points p-cloud))
-    (setf (aref (point-colors p-cloud) i) (funcall color-fn p))))
+    (setf (aref (point-colors p-cloud) i) (funcall color-fn p)))
+  p-cloud)
 
 (defmethod set-point-colors-by-order ((p-cloud point-cloud) color-fn)
   (allocate-point-colors p-cloud)
   (let ((n (length (points p-cloud))))
     (do-array (i p (points p-cloud))
-      (setf (aref (point-colors p-cloud) i) (funcall color-fn (/ i n))))))
+      (declare (ignore p))
+      (setf (aref (point-colors p-cloud) i) (funcall color-fn (/ i n)))))
+  p-cloud)
 
 ;;; point generator functions --------------------------------------------------
 

src/kernel/protocol.lisp

@@ -20,6 +20,19 @@
         (face-centers polyh)
         (call-next-method))))
 
+(defgeneric source-point-colors (obj)
+
+  (:method ((obj t)) 
+    (error "Method SOURCE-POINT-COLORS not implemented for object ~a" obj))
+
+  (:method ((p-cloud point-cloud))
+    (point-colors p-cloud))
+
+  (:method ((polyh polyhedron))
+    (if (point-source-use-face-centers? polyh)
+        nil                             ;TODO -- provide some color values
+        (call-next-method))))
+
 (defgeneric source-directions (obj)
 
   (:method ((obj t)) 

src/kernel/scene-draw.lisp

@@ -41,14 +41,14 @@
   (:method ((p-cloud point-cloud))
     (when (is-visible? p-cloud)
       (when *display-points?*
-        (draw-points p-cloud t))))
+        (draw-points p-cloud))))
 
   (:method ((curve curve))
     (when (is-visible? curve)
       (when *display-wireframe?*
         (draw-wireframe curve))
       (when *display-points?*
-        (draw-points curve nil))))
+        (draw-points curve))))
 
   (:method ((polyh polyhedron))
     (when (is-visible? polyh)
@@ -62,7 +62,7 @@
       (when *display-wireframe?*
         (3d-draw-wireframe-polygons (points polyh) (faces polyh)))
       (when *display-points?*
-        (draw-points polyh nil))
+        (draw-points polyh))
       (when (show-normals polyh)
         (draw-normals polyh))))
   )
@@ -83,8 +83,8 @@
 
 ;;; point-cloud helper methods -------------------------------------------------
 
-(defmethod draw-points ((p-cloud point-cloud) use-point-colors?)
-  (3d-draw-points (points p-cloud) (if use-point-colors? (point-colors p-cloud) nil)))
+(defmethod draw-points ((p-cloud point-cloud))
+  (3d-draw-points (points p-cloud) (point-colors p-cloud)))
 
 ;;; curve helper methods -----------------------------------------------------
 (defmethod draw-wireframe ((curve curve))

src/kernel/shape-group.lisp

@@ -35,11 +35,13 @@
 
 (defmethod set-point-colors-by-xyz ((group shape-group) color-fn)
   (do-children (child group)
-    (set-point-colors-by-xyz child color-fn)))
+    (set-point-colors-by-xyz child color-fn))
+  group)
 
 (defmethod set-point-colors-by-point-and-normal ((group shape-group) color-fn)
   (do-children (child group)
-    (set-point-colors-by-point-and-normal child color-fn)))
+    (set-point-colors-by-point-and-normal child color-fn))
+  group)
 
 ;;;; modeling with groups ======================================================
 

src/plugins/l-system.lisp

@@ -93,7 +93,7 @@
   (when *display-wireframe?*
     (draw-wireframe l-sys))
   (when *display-points?*
-    (draw-points l-sys nil)))         ;TODO -- maybe implement point-colors later
+    (draw-points l-sys))) ; nil)))         ;TODO -- maybe implement point-colors later
 
 (defmethod draw-wireframe ((l-sys l-system))
   (3d-draw-wireframe-polygons (points l-sys) (faces l-sys) :closed? nil))

src/plugins/parametric-curve.lisp

@@ -37,7 +37,7 @@ NOTE: This won't work with the existing procedural mixin set up, because
       (when *display-wireframe?*
         (3d-draw-curve hull nil nil (secondary-line-thickness *drawing-settings*)))
       (when *display-points?*
-        (3d-draw-points hull nil)))))
+        (3d-draw-points hull)))))
 
 ;;; bezier-curve class =========================================================
 

src/plugins/particle.lisp

@@ -55,6 +55,7 @@
 (defclass-kons-9 particle ()
   ((pos (p! 0 0 0))
    (vel (p! 0 0 0))
+   (col (c! 0 0 0 1))
    (is-alive? t)
    (generation 1)
    (life-span -1) ; -1 = immortal
@@ -63,7 +64,10 @@
    ;; size, color, alpha
 
    (points (make-array 0 :adjustable t :fill-pointer t))
+   (point-colors (make-array 0 :adjustable t :fill-pointer t))
 ;;   (behaviors (make-array 0 :adjustable t :fill-pointer t))
+
+   (update-color-fn nil)
 
    (update-angle (range-float 0.0 0))
 
@@ -91,6 +95,21 @@
   (setf (spawn-velocity-factor ptcl) (range-mutate (spawn-velocity-factor ptcl) factor))
   ptcl)
 
+(defun particle-random-color-fn ()
+  (lambda (ptcl)
+    (declare (ignore ptcl))
+    (c-rand)))
+
+(defun particle-velocity-color-fn (vel-1 col-1 vel-2 col-2)
+  (lambda (ptcl)
+    (c-lerp (clamp (tween (p:length (vel ptcl)) vel-1 vel-2) 0.0 1.0)
+            col-1
+            col-2)))
+
+(defmethod update-color ((ptcl particle))
+  (when (update-color-fn ptcl)
+    (setf (col ptcl) (funcall (update-color-fn ptcl) ptcl))))
+
 (defmethod update-velocity ((ptcl particle))
   (let* ((vel (vel ptcl))
          (rnd (p-rand))
@@ -110,6 +129,7 @@
           (< (age ptcl) (life-span ptcl)))
       (progn
         (update-position ptcl)
+        (update-color ptcl)
         (incf (age ptcl)))
       (setf (is-alive? ptcl) nil)))
 
@@ -127,7 +147,8 @@
                               :vel (spawn-velocity ptcl)
                               :generation (1+ (generation ptcl))
                               :life-span (* (life-span ptcl)
-                                            (range-value (spawn-life-span-factor ptcl))))))
+                                            (range-value (spawn-life-span-factor ptcl)))
+                              :update-color-fn (update-color-fn ptcl))))
     (copy-particle-data child ptcl)   ;transfer data
     (when (spawn-mutate? ptcl)
         (mutate-particle child 1.0))
@@ -231,7 +252,9 @@
 (defclass-kons-9 particle-system (shape animator)
   ((particles (make-array 0 :adjustable t :fill-pointer t))
    (max-generations -1) ; -1 = no maximum
-   (draw-live-points-only? :initform t)))
+   (use-point-colors? t)
+   (draw-live-points-only? t)
+   (draw-as-streaks? nil)))
 
 (defmethod print-object ((self particle-system) stream)
   (print-unreadable-object (self stream :type t :identity t)
@@ -252,26 +275,34 @@
   (when *display-wireframe?*
     (draw-wireframe p-sys))
   (when *display-points?*
-    (draw-points p-sys nil)))
+    (draw-points p-sys)))
 
-;;; TODO -- support point colors
 (defmethod draw-wireframe ((p-sys particle-system))
   (do-array (i ptcl (particles p-sys))
-    (3d-draw-curve (points ptcl) nil nil)))
-
-(defmethod draw-live-points ((p-sys particle-system) use-point-colors?)
-  (declare (ignore use-point-colors?))  ;TODO -- maybe implement later
-  (let ((visible-points '()))
+    (if (draw-as-streaks? p-sys)
+        (let* ((i0 (1- (length (points ptcl))))
+               (i1 (max 0 (1- i0))))
+          (3d-draw-curve (vector (aref (points ptcl) i0) (aref (points ptcl) i1))
+                         (if (use-point-colors? p-sys)
+                             (vector (aref (point-colors ptcl) i0) (aref (point-colors ptcl) i1))
+                             nil)
+                         nil))
+        (3d-draw-curve (points ptcl) (if (use-point-colors? p-sys) (point-colors ptcl) nil) nil))))
+
+(defmethod draw-live-points ((p-sys particle-system))
+  (let ((visible-points (make-array 0 :adjustable t :fill-pointer t))
+        (visible-point-colors (make-array 0 :adjustable t :fill-pointer t)))
     (do-array-if (i ptcl #'is-alive? (particles p-sys))
-      (push (pos ptcl) visible-points))
-    (3d-draw-points (make-array (length visible-points) :initial-contents visible-points)
-                    nil)))
+      (vector-push-extend (pos ptcl) visible-points)
+      (when (use-point-colors? p-sys)
+        (vector-push-extend (col ptcl) visible-point-colors)))
+    (3d-draw-points visible-points (if (use-point-colors? p-sys) visible-point-colors nil))))
 
-(defmethod draw-points ((p-sys particle-system) use-point-colors?)
+(defmethod draw-points ((p-sys particle-system))
   (if (draw-live-points-only? p-sys)
-      (draw-live-points p-sys use-point-colors?)
+      (draw-live-points p-sys)
       (do-array (i ptcl (particles p-sys))
-        (3d-draw-points (points ptcl) nil))))
+        (3d-draw-points (points ptcl) (if (use-point-colors? p-sys) (point-colors ptcl) nil)))))
 
 (defmethod draw-normals ((p-sys particle-system))
   ;; do nothing
@@ -280,6 +311,7 @@
 (defmethod add-particle ((p-sys particle-system) ptcl)
   (vector-push-extend ptcl (particles p-sys))
   (vector-push-extend (pos ptcl) (points ptcl))   ;store initial pos in points
+  (vector-push-extend (col ptcl) (point-colors ptcl))   ;store initial pos in points
   p-sys)
 
 (defmethod update-motion ((p-sys particle-system) parent-absolute-timing)
@@ -289,12 +321,20 @@
               (<= (generation ptcl) (max-generations p-sys)))
       (when (is-alive? ptcl)
         (update-particle ptcl)
-        (vector-push-extend (pos ptcl) (points ptcl)))
+        (vector-push-extend (pos ptcl) (points ptcl))
+        (vector-push-extend (col ptcl) (point-colors ptcl)))
       (dolist (child (do-spawn ptcl))
         (add-particle p-sys child)))))
 
 (defmethod points ((p-sys particle-system))
-  (apply #'concatenate 'vector (map 'list #'points (particles p-sys))))
+  (if (draw-live-points-only? p-sys)
+      (map 'vector #'pos (particles p-sys))
+      (apply #'concatenate 'vector (map 'list #'points (particles p-sys)))))
+
+(defmethod point-colors ((p-sys particle-system))
+  (if (draw-live-points-only? p-sys)
+      (map 'vector #'col (particles p-sys))
+      (apply #'concatenate 'vector (map 'list #'point-colors (particles p-sys)))))
 
 (defmethod curves ((p-sys particle-system))
   (map 'list #'points (particles p-sys)))
@@ -313,6 +353,9 @@
 (defmethod source-points ((p-sys particle-system))
   (points p-sys))
 
+(defmethod source-point-colors ((p-sys particle-system))
+  (point-colors p-sys))
+
 (defmethod source-directions ((p-sys particle-system))
   (apply #'concatenate 'vector (map
                                 'list

src/plugins/poly-strand.lisp

@@ -68,7 +68,7 @@
     (when *display-wireframe?*
       (draw-wireframe poly))
     (when *display-points?*
-      (draw-points poly nil))))         ;TODO -- maybe implement point-colors later
+      (draw-points poly)))) ; nil))))         ;TODO -- maybe implement point-colors later
 
 (defmethod draw-wireframe ((poly poly-strand))
   (let ((lines '())