From 4024374fc22de1fdcd4952a87d36e4ae01f99710 Mon Sep 17 00:00:00 2001 From: Kaveh Kardan <103860793+kaveh808@users.noreply.github.com> Date: Thu, 20 Jul 2023 13:58:23 -1000 Subject: [PATCH] added spirograph demo Added spirograph demo and two parametric curves. --- src/kernel/point-cloud.lisp | 10 ++++- src/kernel/scene-hierarchy.lisp | 25 ++++++++--- src/plugins/parametric-curve.lisp | 36 ++++++++++++++- test/demo-kernel.lisp | 4 +- test/demo-parametric-curve.lisp | 74 +++++++++++++++++++++++++++++++ test/test-demos.lisp | 1 + 6 files changed, 140 insertions(+), 10 deletions(-) create mode 100644 test/demo-parametric-curve.lisp diff --git a/src/kernel/point-cloud.lisp b/src/kernel/point-cloud.lisp index 87358f1..2bbb4d1 100644 --- a/src/kernel/point-cloud.lisp +++ b/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))) diff --git a/src/kernel/scene-hierarchy.lisp b/src/kernel/scene-hierarchy.lisp index 5c8122d..cac22e6 100644 --- a/src/kernel/scene-hierarchy.lisp +++ b/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 ---------------------------------------------------------------- diff --git a/src/plugins/parametric-curve.lisp b/src/plugins/parametric-curve.lisp index 6ddcda0..61c7fc3 100644 --- a/src/plugins/parametric-curve.lisp +++ b/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)))) + diff --git a/test/demo-kernel.lisp b/test/demo-kernel.lisp index 314c83d..217614e 100644 --- a/test/demo-kernel.lisp +++ b/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. diff --git a/test/demo-parametric-curve.lisp b/test/demo-parametric-curve.lisp new file mode 100644 index 0000000..8acd8c8 --- /dev/null +++ b/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 ======================================================================== + diff --git a/test/test-demos.lisp b/test/test-demos.lisp index 7201307..f707e8c 100644 --- a/test/test-demos.lisp +++ b/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"