added spirograph demo

Added spirograph demo and two parametric curves.

src/kernel/point-cloud.lisp

@@ -37,8 +37,14 @@
               (get-bounds p-cloud)))
         (get-bounds p-cloud))))
 
-(defun make-point-cloud (points)
-  (make-instance 'point-cloud :points points))
+(defun make-point-cloud (points &optional (colors nil))
+  (make-instance 'point-cloud :points points :point-colors colors))
+
+(defmethod append-point ((p-cloud point-cloud) point &optional (color nil))
+  (vector-push-extend point (points p-cloud))
+  (when (point-colors p-cloud)
+    (vector-push-extend (or color (shading-color *drawing-settings*)) (point-colors p-cloud)))
+  p-cloud)
 
 (defmethod freeze-transform ((p-cloud point-cloud))
   (transform-point-array! (points p-cloud) (transform-matrix (transform p-cloud)))

src/kernel/scene-hierarchy.lisp

@@ -204,6 +204,9 @@
 (defmethod get-shape-paths ((scene scene) (item scene-item))
   (get-shape-paths-aux scene item))
 
+(defmethod get-shape-first-path ((scene scene) (item scene-item))
+  (first (get-shape-paths-aux scene item)))
+
 (defgeneric get-shape-paths-aux (obj item)
 
   (:method ((scene scene) item)
@@ -234,20 +237,24 @@
 
 ;;; shape-path matrix ----------------------------------------------------------
 
-(defmethod shape-global-matrix ((scene scene) shape-path)
-  (let ((matrix-list (get-shape-matrix-list scene shape-path)))
+(defmethod shape-global-matrix ((scene scene) shape)
+ (shape-path-global-matrix scene (get-shape-first-path scene shape)))
+
+;;; we need to reverse the order of the matrix-list to get the correct transformation
+(defmethod shape-path-global-matrix ((scene scene) shape-path)
+  (let ((matrix-list (reverse (get-shape-path-matrix-list scene shape-path))))
     (if matrix-list
         (apply #'matrix-multiply-n matrix-list)
         (error "Shape not found for scene path ~a" shape-path))))
 
-(defgeneric get-shape-matrix-list (obj shape-path)
+(defgeneric get-shape-path-matrix-list (obj shape-path)
 
   (:method ((scene scene) shape-path)
     (if (null shape-path)
         (make-id-matrix)
         (let ((child (find (first shape-path) (children (shape-root scene)) :key #'name)))
           (if child
-              (get-shape-matrix-list child (rest shape-path))
+              (get-shape-path-matrix-list child (rest shape-path))
               nil))))
 
   (:method ((group shape-group) shape-path)
@@ -256,7 +263,7 @@
         (let* ((child (find (first shape-path) (children group) :key #'name)))
           (if child
               (cons (transform-matrix (transform group))
-                    (get-shape-matrix-list child (rest shape-path)))
+                    (get-shape-path-matrix-list child (rest shape-path)))
               nil))))
 
   (:method ((shape shape) shape-path)
@@ -265,6 +272,14 @@
         nil))
   )
 
+;;; shape-path global point ----------------------------------------------------
+
+(defmethod shape-global-point ((scene scene) shape point)
+  (shape-path-global-point scene (get-shape-first-path scene shape) point))
+
+(defmethod shape-path-global-point ((scene scene) shape-path point)
+  (transform-point point (shape-path-global-matrix scene shape-path)))
+
 ;;;; scene motion hierarchy functions ==========================================
 
 ;;; find-motions ----------------------------------------------------------------

src/plugins/parametric-curve.lisp

@@ -71,7 +71,7 @@ NOTE: This won't work with the existing procedural mixin set up, because
 
 ;;; parametric-curve shape functions ----------------------------------------------------
 
-;;; just a fun mathematical curve
+;;; just a fun mathematical curve -- https://en.wikipedia.org/wiki/Butterfly_curve_(transcendental)
 (defun make-butterfly-curve (num-segments)
   (let ((points (make-array num-segments))
         (angle-delta (/ (* 12 pi) num-segments)))
@@ -85,3 +85,37 @@ NOTE: This won't work with the existing procedural mixin set up, because
                   0))))
     (make-curve points)))
 
+;;; the two functions below are inspired by spirograph curves
+
+;;; hypotrochoid curve -- https://en.wikipedia.org/wiki/Hypotrochoid
+;;; NOTE: fixed-r and rolling-r must be integer values due to lcm calculation
+;;; resulting curve is scaled by 1/fixed-r
+(defun make-hypotrochoid-curve (fixed-r rolling-r dist num-segments)
+  (let* ((points (make-array num-segments))
+         (total-sweep (* 2 pi (/ (lcm fixed-r rolling-r) fixed-r)))
+         (theta-delta (/ total-sweep num-segments)))
+    (dotimes (i num-segments)
+      (let* ((theta (* i theta-delta))
+             (angle (* (/ (- fixed-r rolling-r) rolling-r) theta)))
+        (setf (aref points i)
+              (p! (+ (* (- fixed-r rolling-r) (cos theta)) (* dist (cos angle)))
+                  (- (* (- fixed-r rolling-r) (sin theta)) (* dist (sin angle)))
+                  0))))
+    (scale-by (make-curve points) (/ 1.0 fixed-r))))
+
+;;; epitrochoid curve -- https://en.wikipedia.org/wiki/Epitrochoid
+;;; NOTE: fixed-r and rolling-r must be integer values due to lcm calculation
+;;; resulting curve is scaled by 1/fixed-r
+(defun make-epitrochoid-curve (fixed-r rolling-r dist num-segments)
+  (let* ((points (make-array num-segments))
+         (total-sweep (* 2 pi (/ (lcm fixed-r rolling-r) fixed-r)))
+         (theta-delta (/ total-sweep num-segments)))
+    (dotimes (i num-segments)
+      (let* ((theta (* i theta-delta))
+             (angle (* (/ (+ fixed-r rolling-r) rolling-r) theta)))
+        (setf (aref points i)
+              (p! (- (* (+ fixed-r rolling-r) (cos theta)) (* dist (cos angle)))
+                  (- (* (+ fixed-r rolling-r) (sin theta)) (* dist (sin angle)))
+                  0))))
+    (scale-by (make-curve points) (/ 1.0 fixed-r))))
+

test/demo-kernel.lisp

@@ -441,8 +441,8 @@ Animate the scene and evaluate the expression below again to see updated
 matrices.
 |#
 (let ((paths (get-shape-paths *scene* (find-shape-by-name *scene* 'tetra))))
-  (pprint (shape-global-matrix *scene* (first paths)))
-  (pprint (shape-global-matrix *scene* (second paths))))
+  (pprint (shape-path-global-matrix *scene* (first paths)))
+  (pprint (shape-path-global-matrix *scene* (second paths))))
 
 #|
 Find motions by name.

test/demo-parametric-curve.lisp

@@ -0,0 +1,74 @@
+(in-package #:kons-9)
+
+#|
+These demos assume that you have succeeded in loading the system and opening
+the graphics window. If you have not, please check the README file.
+
+Make sure you have opened the graphics window by doing:
+
+(in-package :kons-9)
+(run)
+|#
+
+;;;; start parametric-curve demos ==============================================
+
+;;; parametric-curve -----------------------------------------------------------
+
+(format t "  parametric-curve...~%") (finish-output)
+
+(with-clear-scene
+  (add-shape *scene* (make-bezier-curve (p! -2 0 0) (p! -1 2 0) (p! 1 1 0) (p! 2 0 0))))
+
+(with-clear-scene
+  (add-shape *scene* (make-butterfly-curve 1024)))
+
+(with-clear-scene
+  (add-shape *scene* (make-hypotrochoid-curve 5 3 5 128)))
+
+;; special case -- ellipse
+(with-clear-scene
+  (add-shape *scene* (make-hypotrochoid-curve 10 5 1 32)))
+
+(with-clear-scene
+  (add-shape *scene* (make-epitrochoid-curve 3 1 .5 128)))
+
+(with-clear-scene
+  (add-shape *scene* (make-epitrochoid-curve 9 7 5 512)))
+
+;;; spirograph-like setup ------------------------------------------------------
+
+(with-clear-scene
+  (let* ((ring-radius 2.5)
+         (gear-radius 0.7)
+         (arm-length 0.5)
+         (gear-inside-ring? t)
+         (rotation-increment 5)
+         (gear-rotation-step (* (/ ring-radius gear-radius)
+                                rotation-increment
+                                (if gear-inside-ring? -1.0 1.0)))
+         (gear-offset (if gear-inside-ring?
+                          (- ring-radius gear-radius)
+                          (+ ring-radius gear-radius)))
+         (curve (make-instance 'curve :is-closed-curve? nil))
+         (gear (make-circle (* 2 gear-radius) 16))
+         (arm (make-line-curve (p! 0 0 0) (p! 0 arm-length 0) 1))
+         (gear-assembly (translate-by (make-shape-group (list gear arm))
+                                       (p! 0 gear-offset 0)))
+         (top-assembly (make-shape-group (list gear-assembly)))
+         (anim (make-instance 'animator
+                              :update-fn (lambda ()
+                                           (rotate-by top-assembly (p! 0 0 rotation-increment))
+                                           (rotate-by gear-assembly (p! 0 0 gear-rotation-step))
+                                           (append-point curve
+                                                         (shape-global-point *scene*
+                                                                             gear
+                                                                             (p! 0 arm-length 0)))
+                                           ))))
+    (setf (end-frame *scene*) 10000)
+    (add-shape *scene* top-assembly)
+    (add-shape *scene* (make-circle (* 2 ring-radius) 64))
+    (add-shape *scene* curve)
+    (add-motion *scene* anim)))
+
+;;;; END ========================================================================
+

test/test-demos.lisp

@@ -10,6 +10,7 @@ functions and the like.
 
 (let ((demo-files '("demo-kernel"
                     "demo-procedural-curve"
+                    "demo-parametric-curve"
                     "demo-uv-mesh"
                     "demo-superquadric"
                     "demo-heightfield"