--- 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)
--- 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))
--- 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))
--- 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)))
--- 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)))