# HG changeset patch # User Steve Losh # Date 1463339286 0 # Node ID d9b504caca3bcb9055e681043ae2cd7eb7fcfa3a # Parent c716dc6a9a476375758a18e4bccb9ee3d0028012 Episode 25: 3D Points and Lines (Part 2) diff -r c716dc6a9a47 -r d9b504caca3b .lispwords --- a/.lispwords Sun May 15 17:46:49 2016 +0000 +++ b/.lispwords Sun May 15 19:08:06 2016 +0000 @@ -1,8 +1,7 @@ (1 scancode-case) (1 make-sketch) (2 with-vals) -(2 with-vec with-vec3) -(1 with-vecs with-vec3s with-vec3-slots) +(1 with-vec with-vecs) (2 with-shape-perspective) (1 setf-slots) (2 with-cga) diff -r c716dc6a9a47 -r d9b504caca3b package.lisp --- a/package.lisp Sun May 15 17:46:49 2016 +0000 +++ b/package.lisp Sun May 15 19:08:06 2016 +0000 @@ -11,6 +11,10 @@ #:zap% #:% #:setf-slots + #:symbolicate + #:ensure-car + #:ensure-cadr + #:with-place )) (defpackage #:coding-math.math @@ -195,6 +199,7 @@ #:vec-x #:vec-y #:vec-z #:vec-r #:vec-a #:vec-h #:random-vec + #:zero-vec #:with-vec #:with-vecs #:angle-between)) diff -r c716dc6a9a47 -r d9b504caca3b src/3d/demo.lisp --- a/src/3d/demo.lisp Sun May 15 17:46:49 2016 +0000 +++ b/src/3d/demo.lisp Sun May 15 19:08:06 2016 +0000 @@ -24,81 +24,78 @@ ;;;; Draw -(declaim (inline perspective apply-perspective)) -(defun perspective (focal-length z) - (/ focal-length (+ focal-length z))) - -(defun apply-perspective (vec focal-length) - (let ((p (perspective focal-length (aref vec 2)))) - (sb-cga:transform-point vec (sb-cga:scale* p p p)))) +(defun draw-point (screen size) + (circle (vec-x screen) (vec-y screen) size)) -(defun draw-point (point focal-length size) - (let ((p (apply-perspective point focal-length))) - (in-context - (translate (aref p 0) (aref p 1)) - (circle 0 0 size)))) - -(defun draw-line (p1 p2 focal-length) - (let ((p1 (apply-perspective p1 focal-length)) - (p2 (apply-perspective p2 focal-length))) - (line (aref p1 0) (aref p1 1) - (aref p2 0) (aref p2 1)))) +;;;; Structs +(defstruct (point (:constructor make-point (world &optional screen))) + world screen) ;;;; Sketch +(defun project (points focal-length) + (map nil + (lambda (p) + (with-vecs ((screen (point-screen p)) + (world (point-world p))) + (let ((scale (/ focal-length (+ focal-length world.z)))) + (setf screen.x (* scale world.x) + screen.y (* scale world.y))))) + points)) + +(defun translate-model (points x y z) + (map nil (lambda (p) + (with-vec (p (point-world p)) + (incf p.x x) + (incf p.y y) + (incf p.z z))) + points)) + (defsketch demo - ((width *width*) - (height *height*) + ((width *width*) (height *height*) (y-axis :down) (title "Coding Math") (mouse (cons 0 0)) + ;; variables (fl 300.0) - (cz 700.0) - (radius 400.0) - (cyl-height 380.0) - (wraps 6) - (base-angle 0.0) - (angle-speed -0.02) - (circle-size 3) - (y-speed -0.5) - (shapes (loop - :with nshapes = 400 - :for i :from 0 :to nshapes - :collect - (vec radius - (* i (/ (* wraps tau) (1+ nshapes))) - (+ #+no (random-around 0.0 50.0) - (map-range 0.0 nshapes cyl-height (- cyl-height) i))))) - (model-to-world (sb-cga:translate* 0.0 0.0 cz)) - ;; + (r 200.0) + (points + (make-array 8 + :initial-contents + (list + (make-point (vec (- r) (- r) 1000.0) (zero-vec)) + (make-point (vec r (- r) 1000.0) (zero-vec)) + (make-point (vec r (- r) 500.0) (zero-vec)) + (make-point (vec (- r) (- r) 500.0) (zero-vec)) + (make-point (vec (- r) r 1000.0) (zero-vec)) + (make-point (vec r r 1000.0) (zero-vec)) + (make-point (vec r r 500.0) (zero-vec)) + (make-point (vec (- r) r 500.0) (zero-vec))))) + (dirty t) + ;; pens (simple-pen (make-pen :fill (gray 0.1))) (line-pen (make-pen :stroke (gray 0.1) :weight 1)) ) (with-setup - ; (setf angle-speed (map-range 0 *height* -0.08 0.08 (cdr mouse))) - ; (setf shapes (sort shapes #'> :key (rcurry #'getf :z))) - (with-pen simple-pen - (loop :for shape :in shapes - :do - (setf (aref shape 0) (map-range 0.0 *width* 10 600 (car mouse))) - (incf (aref shape 1) angle-speed) - (incf (aref shape 2) (random-around 0.0 0.2)) - ; (incf (aref shape 2) y-speed) - ; (wrapf (aref shape 2) (- cyl-height) cyl-height) - #+debug (draw-point - (sb-cga:transform-point - (cylindrical-to-cartesian-cga shape) - model-to-world) - fl - circle-size)) - ) - (with-pen line-pen - (loop :for (a b) :in (n-grams 2 shapes) :do - (draw-line (sb-cga:transform-point - (cylindrical-to-cartesian-cga a) - model-to-world) - (sb-cga:transform-point - (cylindrical-to-cartesian-cga b) - model-to-world) - fl))) + (flet + ((draw-line (&rest vertices) + (loop :for (a b) ; lame way to close the loop... + :in (n-grams 2 (append vertices (list (car vertices)))) + :do (with-vecs ((a (point-screen (aref points a))) + (b (point-screen (aref points b)))) + (line a.x a.y b.x b.y))))) + (when dirty + (setf dirty nil) + (project points fl)) + (with-pen simple-pen + ; (loop :for p :across points + ; :do (draw-point (point-screen p) 5)) + nil) + (with-pen line-pen + (draw-line 0 1 2 3) + (draw-line 0 3 7 4) + (draw-line 1 2 6 5) + (draw-line 6 5 4 7) + nil + )) ;; )) @@ -151,8 +148,18 @@ ;;;; Keyboard (defun keydown (instance scancode) (declare (ignorable instance)) + (setf (slot-value instance 'dirty) t) (scancode-case scancode - (:scancode-space (sketch::prepare instance)))) + (:scancode-space (sketch::prepare instance)) + ;; + (:scancode-left (translate-model (slot-value instance 'points) -15 0 0)) + (:scancode-right (translate-model (slot-value instance 'points) 15 0 0)) + (:scancode-up (translate-model (slot-value instance 'points) 0 -15 0)) + (:scancode-down (translate-model (slot-value instance 'points) 0 15 0)) + (:scancode-s (translate-model (slot-value instance 'points) 0 0 -15)) + (:scancode-w (translate-model (slot-value instance 'points) 0 0 15)) + ;; + )) (defun keyup (instance scancode) (declare (ignorable instance)) diff -r c716dc6a9a47 -r d9b504caca3b src/3d/vectors.lisp --- a/src/3d/vectors.lisp Sun May 15 17:46:49 2016 +0000 +++ b/src/3d/vectors.lisp Sun May 15 19:08:06 2016 +0000 @@ -3,7 +3,10 @@ ;; Wrappers around sb-cga (declaim (inline vec3-x vec3-y vec3-z - vec3-r vec3-a vec3-h)) + vec3-r vec3-a vec3-h + (setf vec3-x) (setf vec3-y) (setf vec3-z) + (setf vec3-r) (setf vec3-a) (setf vec3-h))) + (defun vec-x (v) (aref v 0)) (defun vec-y (v) (aref v 1)) @@ -12,6 +15,16 @@ (defun vec-a (v) (aref v 1)) (defun vec-h (v) (aref v 2)) +(defun (setf vec-x) (n v) (setf (aref v 0) n)) +(defun (setf vec-y) (n v) (setf (aref v 1) n)) +(defun (setf vec-z) (n v) (setf (aref v 2) n)) +(defun (setf vec-r) (n v) (setf (aref v 0) n)) +(defun (setf vec-a) (n v) (setf (aref v 1) n)) +(defun (setf vec-h) (n v) (setf (aref v 2) n)) + +(defun zero-vec () + (vec 0.0 0.0 0.0)) + (defun random-vec (max-x max-y max-z) (vec (random max-x) (random max-y) (random max-z))) @@ -22,16 +35,34 @@ (vec-length v2))))) -(defmacro with-vec (bindings vec &body body) - (once-only (vec) - `(symbol-macrolet ((,(first bindings) (aref ,vec 0)) - (,(second bindings) (aref ,vec 1)) - (,(third bindings) (aref ,vec 2))) - ,@body))) +; (defmacro with-vec (bindings vec &body body) +; (once-only (vec) +; `(symbol-macrolet ((,(first bindings) (aref ,vec 0)) +; (,(second bindings) (aref ,vec 1)) +; (,(third bindings) (aref ,vec 2))) +; ,@body))) + +; (defmacro with-vecs (bindings &body body) +; (if (null bindings) +; `(progn ,@body) +; (destructuring-bind (vars vec-form . remaining) bindings +; `(with-vec ,vars ,vec-form +; (with-vec3s ,remaining ,@body))))) + -(defmacro with-vecs (bindings &body body) - (if (null bindings) - `(progn ,@body) - (destructuring-bind (vars vec-form . remaining) bindings - `(with-vec ,vars ,vec-form - (with-vec3s ,remaining ,@body))))) +;; thanks squirl +(defmacro with-vec (form &body body) + "FORM is either a symbol bound to a `vec', or a list of the form: + (name form) +where NAME is a symbol, and FORM evaluates to a `vec'. +WITH-VEC binds NAME.x and NAME.y in the same manner as `with-accessors'." + (let* ((name (ensure-car form)) + (place (ensure-cadr form)) + (*package* (symbol-package name))) + `(with-place (,(symbolicate name ".") vec-) + (x y z r a h) ,place + ,@body))) + +(defmacro with-vecs ((form &rest forms) &body body) + "Convenience macro for nesting WITH-VEC forms" + `(with-vec ,form ,@(if forms `((with-vecs ,forms ,@body)) body))) diff -r c716dc6a9a47 -r d9b504caca3b src/utils.lisp --- a/src/utils.lisp Sun May 15 17:46:49 2016 +0000 +++ b/src/utils.lisp Sun May 15 19:08:06 2016 +0000 @@ -59,3 +59,36 @@ (setf ,@(loop :for (slot val) :on bindings :by #'cddr :append (list slot val))))) + + +;; snagged from squirl +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun symbolicate (&rest things) + "Concatenate together the names of some strings and symbols, +producing a symbol in the current package." + (let ((name (make-string (reduce #'+ things + :key (compose #'length #'string))))) + (let ((index 0)) + (dolist (thing things (values (intern name))) + (let ((x (string thing))) + (replace name x :start1 index) + (incf index (length x)))))))) + +(macrolet + ((define-ensure-foo (place) ; Lisp macros are nice + `(defun ,(symbolicate "ENSURE-" place) (place &optional (default place)) + (if (atom place) default (,place place))))) + (define-ensure-foo car) + (define-ensure-foo cadr)) + +(defmacro with-place (conc-name (&rest slots) form &body body) + (let* ((sm-prefix (ensure-car conc-name)) + (acc-prefix (ensure-cadr conc-name)) + (*package* (symbol-package sm-prefix))) + `(with-accessors + ,(mapcar (lambda (v) + (list (symbolicate sm-prefix (ensure-car v)) + (symbolicate acc-prefix (ensure-cadr v)))) + slots) + ,form + ,@body)))