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

Kaveh devel 7

src/graphics/glfw/glfw-gui.lisp

@@ -318,14 +318,14 @@
 (defmethod draw-scene-view ((view scene-view))
   (3d-setup-buffer)
   (3d-setup-projection)
-  (3d-update-light-settings)
-  (when (scene view)
-    (draw (scene view)))
-  (3d-cleanup-render)
   (when *display-axes?*
     (draw-world-axes))
   (when *display-ground-plane?*
     (draw-ground-plane))
+  (3d-update-light-settings)
+  (when (scene view)
+    (draw (scene view)))
+  (3d-cleanup-render)
 
   ;; object picking
 

src/kernel/color.lisp

@@ -18,9 +18,11 @@
 (defun c-set-rgb (c1 c2)
   (setf (aref c1 0) (aref c2 0))
   (setf (aref c1 1) (aref c2 1))
-  (setf (aref c1 2) (aref c2 2)))
+  (setf (aref c1 2) (aref c2 2))
+  c1)
 (defun c-set-alpha (c alpha)
-  (setf (aref c 3) alpha))
+  (setf (aref c 3) alpha)
+  c)
 
 #+nil
 (defun c-lerp (f c1 c2)
@@ -59,6 +61,15 @@
 (defun c-jitter (c c-delta)
   (c+ c (map 'vector #'(lambda (a) (rand1 a)) c-delta)))
 
+(defun c/ (c val)
+  (c! (/ (c-red c) val) (/ (c-green c) val) (/ (c-blue c) val)))
+
+(defun c-center (colors)
+  (c/ (reduce #'c+ colors) (length colors)))
+
+(defun c-average (&rest colors)
+  (c-center colors))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
   (defun c-255! (r g b &optional (a 255))

src/kernel/curve.lisp

@@ -13,6 +13,8 @@
   (let ((len (length points))
 	i1
 	i2)
+    (when (= len 1)
+      (return-from curve-point-tangent (p! 0 0 0)))
     (if (= len 2)
 	(progn (setf i1 0)
 	       (setf i2 1))

src/kernel/point-cloud.lisp

@@ -4,7 +4,8 @@
 
 (defclass point-cloud (shape)
   ((points :accessor points :initarg :points :initform (make-array 0 :adjustable t :fill-pointer t))
-   (point-colors :accessor point-colors :initarg :point-colors :initform nil)))
+   (point-colors :accessor point-colors :initarg :point-colors :initform nil)
+   (draw-colored-points? :accessor draw-colored-points? :initarg :draw-colored-points? :initform nil)))
 
 (defmethod printable-data ((self point-cloud))
   (strcat (call-next-method) (format nil ", ~a points" (length (points self)))))
@@ -15,6 +16,14 @@
     (return-from get-bounds (values (p! -1 -1 -1) (p! 1 1 1))))
   (points-bounds (points p-cloud)))
 
+;;; TODO -- not tested
+(defmethod world-space-points ((p-cloud point-cloud))
+  (if (scene p-cloud)
+      (let* ((matrix (shape-global-matrix (scene p-cloud) p-cloud))
+             (world-space-points (transform-points (points p-cloud) matrix)))
+        world-space-points)
+      (points p-cloud)))
+
 ;;; TODO -- not tested
 (defmethod get-global-bounds ((p-cloud point-cloud))
   (when (= 0 (length (points p-cloud)))
@@ -51,6 +60,14 @@
   (reset-transform (transform p-cloud))
   p-cloud)
 
+;;; TODO -- not tested (also in polyhedron.lisp)
+;; (defmethod world-space-duplicate ((p-cloud point-cloud))
+;;   (let ((dup (duplicate p-cloud))
+;;         (matrix (shape-global-matrix (scene p-cloud) p-cloud)))
+;;     (transform-point-array! (points dup) matrix)
+;;     (reset-transform (transform dup))
+;;     dup))
+
 (defmethod allocate-point-colors ((p-cloud point-cloud)
                                   &optional (color (fg-color *drawing-settings*)))
   (setf (point-colors p-cloud) (make-array (length (points p-cloud))

src/kernel/polyhedron.lisp

@@ -14,8 +14,7 @@
 
 (defmethod initialize-instance :after ((polyh polyhedron) &rest initargs)
   (declare (ignore initargs))
-  (compute-face-normals polyh)
-  (compute-point-normals polyh))
+  (compute-normals polyh))
 
 (defmethod empty-polyhedron ((polyh polyhedron))
   (setf (points polyh) (make-array 0 :adjustable t :fill-pointer t))
@@ -46,15 +45,25 @@
         (vector-push-extend (nreverse p-refs) (faces polyh))))))
 
 (defmethod freeze-transform :after ((polyh polyhedron))
-  (compute-face-normals polyh)
-  (compute-point-normals polyh))  
+  (compute-normals polyh))
+
+;;; TODO -- not tested (also in point-cloud.lisp)
+;; (defmethod world-space-duplicate :after ((polyh polyhedron))
+;;   (compute-face-normals polyh)
+;;   (compute-point-normals polyh))  
 
 (defmethod face-center ((polyh polyhedron) face)
   (apply #'p-average (face-points-list polyh face)))
 
 (defmethod face-centers ((polyh polyhedron))
   (map 'vector #'(lambda (f) (face-center polyh f)) (faces polyh)))
 
+(defmethod face-color ((polyh polyhedron) face)
+  (apply #'c-average (face-colors-list polyh face)))
+
+(defmethod face-colors ((polyh polyhedron))
+  (map 'vector #'(lambda (f) (face-color polyh f)) (faces polyh)))
+
 ;; no checking, asssumes well-formed faces
 (defmethod face-normal ((polyh polyhedron) face)
   (cond ((< (length face) 3)
@@ -76,6 +85,11 @@
                (p1 (aref (points polyh) (elt face 1))))
            (triangle-normal center p0 p1)))))
 
+(defmethod compute-normals ((polyh polyhedron))
+  (compute-face-normals polyh)
+  (compute-point-normals polyh)
+  polyh)
+
 (defmethod compute-face-normals ((polyh polyhedron))
   (setf (face-normals polyh)
         (map 'vector #'(lambda (f) (face-normal polyh f)) (faces polyh))))
@@ -105,11 +119,11 @@
           (p:normalize (aref (point-normals polyh) n)))))
 
 (defmethod face-points-list ((polyh polyhedron) (i integer))
-  (mapcar #'(lambda (pref) (aref (points polyh) pref))
+  (mapcar (lambda (pref) (aref (points polyh) pref))
           (aref (faces polyh) i)))
 
 (defmethod face-points-list ((polyh polyhedron) (face list))
-  (mapcar #'(lambda (pref) (aref (points polyh) pref))
+  (mapcar (lambda (pref) (aref (points polyh) pref))
           face))
 
 (defmethod face-points-array ((polyh polyhedron) (i integer))
@@ -118,6 +132,13 @@
 (defmethod face-points-array ((polyh polyhedron) (face list))
   (coerce (face-points-list polyh face) 'vector))
 
+(defmethod face-colors-list ((polyh polyhedron) (face list))
+  (if (point-colors polyh)
+      (mapcar (lambda (pref) (aref (point-colors polyh) pref))
+              face)
+      (mapcar (lambda (pref) (declare (ignore pref)) (c! 1 1 1))
+              face)))
+
 (defmethod triangles-list ((polyh polyhedron) &key (matrix nil))
   ;; TODO: this function will only work for convex polyhedrons but it should
   ;; work for all cases.
@@ -190,6 +211,46 @@
                 (push face faces)))))
         (refine-polyhedron (make-polyhedron (coerce points 'vector) (coerce faces 'vector)) (1- levels)))))
 
+(defun point-array-hash (point-array)
+  (let ((hash (make-hash-table :test 'equal)))
+    (do-array (i p point-array)
+      (setf (gethash (point->list p) hash) t))
+    hash))
+
+(defmethod displace-points-along-normals ((polyh polyhedron) distance
+                                          &key (randomize nil) (fixed-point-array nil))
+  (let ((points (points polyh))
+        (normals (point-normals polyh))
+        (hash (if fixed-point-array (point-array-hash fixed-point-array) nil)))
+    (do-array (i p points)
+      (when (or (null hash) (null (gethash (point->list p) hash)))
+        (setf (aref points i) (p+ p (p* (aref normals i) (if randomize
+                                                             (rand1 distance)
+                                                             distance))))))
+    (compute-normals polyh)))
+
+(defmethod fractalize-polyhedron ((polyh polyhedron) displacement &optional (levels 1))
+  (let ((new-polyh polyh)
+        (disp displacement))
+    (dotimes (i levels)
+      (let ((old-points (points new-polyh))) ;only displace new points, not existing ones
+        (setf new-polyh (refine-polyhedron new-polyh))
+        (displace-points-along-normals new-polyh disp :randomize t :fixed-point-array old-points)
+        (setf disp (/ disp 2.0))))
+    new-polyh))
+
+;;; return array of all fractal levels of polyhedron
+(defmethod fractalize-polyhedron-into-array ((polyh polyhedron) displacement &optional (levels 1))
+  (let* ((polyh-array (make-array levels))
+         (displ displacement)
+         (curr-polyh polyh))
+    (dotimes (i levels)
+      (let ((level-polyh (if (= 0 i) polyh (fractalize-polyhedron curr-polyh displ 1))))
+        (setf (aref polyh-array i) level-polyh)
+        (setf curr-polyh level-polyh)
+        (setf displ (/ displ 2.0))))
+    polyh-array))
+
 (defmethod merge-points ((polyh polyhedron))
   (when (or (= 0 (length (points polyh)))
             (= 0 (length (faces polyh))))
@@ -235,6 +296,7 @@
         (push (random-barycentric-point p0 p1 p2) points))
       points)))
 
+;;; TODO -- generate point colors and directions (from normals)
 (defmethod generate-point-cloud ((polyh polyhedron) &optional (density 1.0))
   (let* ((tri-polyh (if (is-triangulated-polyhedron? polyh)
                         polyh
@@ -464,6 +526,4 @@
   (let ((polyh (refine-polyhedron (make-cube side :name name :mesh-type mesh-type) subdiv-levels))
         (radius (/ side 2)))
     (setf (points polyh) (map 'vector (lambda (p) (p-sphericize p radius)) (points polyh)))
-    (compute-face-normals polyh)
-    (compute-point-normals polyh)
-    polyh))
+    (compute-normals polyh)))

src/kernel/protocol.lisp

@@ -7,74 +7,58 @@
   (:method ((p-cloud point-cloud)) t)
   )
 
-(defgeneric source-points (obj)
+(defgeneric point-source-data (obj)
 
-  (:method ((obj t)) 
-    (error "Method SOURCE-POINTS not implemented for object ~a" obj))
-
-  (:method ((p-cloud point-cloud))
-    (points p-cloud))
-
-  (:method ((polyh polyhedron))
-    (if (point-source-use-face-centers? polyh)
-        (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)) 
-    (error "Method SOURCE-DIRECTIONS not implemented for object ~a" obj))
+  (:method ((obj t))
+    (error "Method POINT-SOURCE-DATA not implemented for object ~a" obj))
 
   (:method ((p-cloud point-cloud))
-    ;; arbitrarily return (1 1 1) for use as velocity multiplier
-    ;; (make-array (length (points p-cloud))
-    ;;             :initial-element (p! 1 1 1)))
-;;    (source-radial-directions p-cloud))
-    (source-random-directions p-cloud))
-
+    (let ((n (length (points p-cloud))))
+      (values (points p-cloud)
+              (or (point-colors p-cloud)
+                  (make-array-with-fn n (lambda () (c! 0 0 0))))
+              (make-array-with-fn n #'p-rand))))
+    
   (:method ((curve curve))
-    (curve-tangents curve))
-
+    (let ((n (length (points curve))))
+      (values (points curve)
+              (or (point-colors curve)
+                  (make-array-with-fn n (lambda () (c! 0 0 0))))
+              (curve-tangents curve))))
+
   (:method ((polyh polyhedron))
-    (if (point-source-use-face-centers? polyh)
-        (face-normals polyh)
-        (point-normals polyh))))
-
-(defgeneric source-random-directions (obj)
-  (:method ((obj t))
-    (let ((dir (make-array (length (source-points obj)))))
-      (dotimes (i (length dir))
-        (setf (aref dir i) (p-rand)))
-      dir)))
-
-(defgeneric source-radial-directions (obj)
-  (:method ((obj t)) 
-    (map 'vector #'p:normalize (source-points obj))))
-
-(defgeneric source-closest-point (obj point)
-  (:method ((obj t) point)
-    (let* ((points (source-points obj))
-           (min-dist (p-dist point (aref points 0)))
-           (closest-index 0))
-      (do-array (i p points)
-        (let ((dist (p-dist point p)))
-          (when (< dist min-dist)
-            (setf min-dist dist)
-            (setf closest-index i))))
-      (aref points closest-index))))
+    (let ((n (length (points polyh))))
+      (if (point-source-use-face-centers? polyh)
+          (values (face-centers polyh)
+                  (face-colors polyh)
+                  (face-normals polyh))
+          (values (points polyh)
+                  (or (point-colors polyh)
+                      (make-array-with-fn n (lambda () (c! 0 0 0))))
+                  (point-normals polyh))))))
+
+;; (defgeneric source-random-directions (obj)
+;;   (:method ((obj t))
+;;     (let ((dir (make-array (length (source-points obj)))))
+;;       (dotimes (i (length dir))
+;;         (setf (aref dir i) (p-rand)))
+;;       dir)))
+
+;; (defgeneric source-radial-directions (obj)
+;;   (:method ((obj t)) 
+;;     (map 'vector #'p:normalize (source-points obj))))
+
+;; (defgeneric source-closest-point (obj point)
+;;   (:method ((obj t) point)
+;;     (let* ((points (source-points obj))
+;;            (min-dist (p-dist point (aref points 0)))
+;;            (closest-index 0))
+;;       (do-array (i p points)
+;;         (let ((dist (p-dist point p)))
+;;           (when (< dist min-dist)
+;;             (setf min-dist dist)
+;;             (setf closest-index i))))
+;;       (aref points closest-index))))
 
 ;;;; curve-source-protocol =====================================================
 

src/kernel/scene-draw.lisp

@@ -84,7 +84,9 @@
 ;;; point-cloud helper methods -------------------------------------------------
 
 (defmethod draw-points ((p-cloud point-cloud))
-  (3d-draw-points (points p-cloud) (point-colors p-cloud)))
+  (3d-draw-points (points p-cloud) (if (draw-colored-points? p-cloud)
+                                       (point-colors p-cloud)
+                                       nil)))
 
 ;;; curve helper methods -----------------------------------------------------
 (defmethod draw-wireframe ((curve curve))