--- a/coding-math.asd Mon May 09 01:01:35 2016 +0000
+++ b/coding-math.asd Mon May 09 20:25:10 2016 +0000
@@ -16,17 +16,23 @@
#:fare-quasiquote-readtable)
:serial t
- :components ((:file "quickutils") ; quickutils package ordering crap
- (:file "package")
- (:module "src"
- :serial t
- :components ((:file "utils")
- (:file "math")
- (:file "fps")
- (:file "vectors")
- (:file "particles")
- (:file "points")
- (:file "main")
- (:file "ballistics")
- ))))
+ :components
+ ((:file "quickutils") ; quickutils package ordering crap
+ (:file "package")
+ (:module "src"
+ :serial t
+ :components ((:file "utils")
+ (:file "math")
+ (:file "fps")
+ (:module "2d"
+ :serial t
+ :components ((:file "vectors")
+ (:file "hitboxes")
+ (:file "particles")
+ (:file "points")
+ (:file "demo")
+ (:file "ballistics")))
+ (:module "3d"
+ :serial t
+ :components ())))))
--- a/package.lisp Mon May 09 01:01:35 2016 +0000
+++ b/package.lisp Mon May 09 20:25:10 2016 +0000
@@ -1,3 +1,4 @@
+;;;; Generic stuff
(defpackage #:coding-math.utils
(:use
#:cl
@@ -8,11 +9,9 @@
#:make-sketch
#:scancode-case
#:with-vals
- #:mulf
#:zap%
#:%
- #:dividesp
- #:square))
+ ))
(defpackage #:coding-math.math
(:use
@@ -21,6 +20,8 @@
#:coding-math.utils)
(:export
#:tau
+ #:mulf
+ #:dividesp
#:square
#:distance
#:random-range
@@ -39,18 +40,22 @@
#:round-to-places
#:round-to-nearest
#:ranges-overlap-p
- #:hitbox-x
- #:hitbox-y
- #:hitbox-radius
- #:hitbox-width
- #:hitbox-height
- #:circles-collide-p
- #:circle-point-collide-p
- #:rect-point-collide-p
- #:rects-collide-p
))
-(defpackage #:coding-math.vectors
+(defpackage #:coding-math.fps
+ (:use
+ #:cl
+ #:sketch
+ #:coding-math.quickutils
+ #:coding-math.math
+ #:coding-math.utils)
+ (:export
+ #:with-fps
+ #:draw-fps))
+
+
+;;;; 2D stuff
+(defpackage #:coding-math.2d.vectors
(:use
#:cl
#:coding-math.math
@@ -81,11 +86,12 @@
#:with-vecs
))
-(defpackage #:coding-math.particles
+(defpackage #:coding-math.2d.particles
(:use
#:cl
#:coding-math.math
- #:coding-math.vectors
+ #:coding-math.2d.vectors
+ #:coding-math.2d.hitboxes
#:coding-math.quickutils
#:coding-math.utils)
(:export
@@ -113,12 +119,12 @@
#:particle-spring-add!
#:particle-spring-remove!))
-(defpackage #:coding-math.points
+(defpackage #:coding-math.2d.points
(:use
#:cl
#:sketch
#:coding-math.math
- #:coding-math.vectors
+ #:coding-math.2d.vectors
#:coding-math.quickutils
#:coding-math.utils)
(:export
@@ -130,17 +136,25 @@
#:multicurve
))
-(defpackage #:coding-math.fps
+(defpackage #:coding-math.2d.hitboxes
(:use
#:cl
#:sketch
+ #:coding-math.math
#:coding-math.quickutils
#:coding-math.utils)
(:export
- #:with-fps
- #:draw-fps))
+ #:hitbox-x
+ #:hitbox-y
+ #:hitbox-radius
+ #:hitbox-width
+ #:hitbox-height
+ #:circles-collide-p
+ #:circle-point-collide-p
+ #:rect-point-collide-p
+ #:rects-collide-p))
-(defpackage #:coding-math
+(defpackage #:coding-math.2d.demo
(:use
#:cl
#:sketch
@@ -148,16 +162,20 @@
#:coding-math.utils
#:coding-math.fps
#:coding-math.math
- #:coding-math.vectors
- #:coding-math.points
- #:coding-math.particles))
+ #:coding-math.2d.vectors
+ #:coding-math.2d.points
+ #:coding-math.2d.particles))
-(defpackage #:coding-math.ballistics
+(defpackage #:coding-math.2d.ballistics
(:use
#:cl
#:sketch
#:coding-math.quickutils
- #:coding-math.particles
+ #:coding-math.2d.particles
+ #:coding-math.2d.hitboxes
#:coding-math.utils
#:coding-math.math
#:coding-math.fps))
+
+
+;;;; 3D stuff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/ballistics.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,180 @@
+(in-package #:coding-math.2d.ballistics)
+
+;;;; Config
+(defparameter *width* 600)
+(defparameter *height* 400)
+
+(defparameter *center-x* (/ *width* 2))
+(defparameter *center-y* (/ *height* 2))
+
+
+;;;; Drawing
+(defparameter *gun-pen* (make-pen :stroke (gray 0.0) :fill (gray 0.0)))
+(defparameter *ball-pen* (make-pen :stroke (gray 0.1) :fill (gray 0.6)))
+(defparameter *force-bg-pen* (make-pen :fill (gray 0.6)))
+(defparameter *target-pen* (make-pen :stroke (rgb 0.6 0 0) :weight 2 :fill (rgb 1.0 0 0)))
+(defparameter *force-fg-pen* (make-pen :fill (rgb 1.000 0.478 0.749)))
+
+
+(defun draw-gun (gun)
+ (in-context
+ (translate (getf gun 'x) (getf gun 'y))
+ (with-pen *gun-pen*
+ (circle 0 0 25)
+ (rotate (degrees (getf gun 'angle)))
+ (rect 0 -8 40 16))))
+
+(defun draw-ball (ball)
+ (with-pen *ball-pen*
+ (circle (particle-x ball) (particle-y ball) (particle-radius ball))))
+
+(defun draw-force (force)
+ (with-pen *force-bg-pen*
+ (circle 20 (- *height* 50) 15))
+ (with-pen *force-fg-pen*
+ (circle 20
+ (- *height* 50)
+ (map-range -1.0 1.0 0 15 force))))
+
+(defun draw-target (target)
+ (when target
+ (with-pen *target-pen*
+ (circle (getf target :x)
+ (getf target :y)
+ (getf target :radius)))))
+
+
+;;;; Game
+(defun aim (gun x y)
+ (setf (getf gun 'angle)
+ (clamp (- (/ tau 4))
+ -0.3
+ (atan (- y (getf gun 'y))
+ (- x (getf gun 'x))))))
+
+(defun shoot (game)
+ (force-output)
+ (with-slots (gun cannonball firedp raw-force) game
+ (let ((angle (getf gun 'angle)))
+ (setf
+ firedp t
+ (particle-x cannonball) (+ (getf gun 'x) (* 40 (cos angle)))
+ (particle-y cannonball) (+ (getf gun 'y) (* 40 (sin angle)))
+ (particle-speed cannonball) (map-range -1.0 1.0 2 20.0 raw-force)
+ (particle-direction cannonball) angle))))
+
+(defun update-ball (game)
+ (with-slots (cannonball firedp) game
+ (particle-update! cannonball)
+ (when (> (- (particle-y cannonball)
+ (particle-radius cannonball))
+ *height*)
+ (setf firedp nil))))
+
+(defun check-target (game)
+ (when (and (target game)
+ (circles-collide-p (cannonball game)
+ (target game)))
+ (setf (win game) t)))
+
+(defun random-target ()
+ (list :x (random-range 200 *width*)
+ :y *height*
+ :radius (random-range 10 40)))
+
+
+(defsketch game (:width *width*
+ :height *height*
+ :debug :scancode-d)
+ ((aiming)
+ (gun)
+ (cannonball)
+ (can-shoot-p)
+ (firedp)
+ (force-speed 0.05)
+ (force-angle 0.0)
+ (raw-force)
+ (target)
+ (win)
+ )
+ (with-fps
+ (background (gray 1))
+ ;;
+ (when (not firedp)
+ (incf force-angle force-speed)
+ (setf raw-force (sin force-angle)))
+
+ (when (not target)
+ (setf target (random-target)))
+
+ (draw-ball cannonball)
+ (draw-gun gun)
+ (draw-force raw-force)
+ (draw-target target)
+
+ (when firedp
+ (update-ball sketch::sketch-window)
+ (check-target sketch::sketch-window))
+ (when win
+ (text "You win!" *center-x* *center-y*))
+
+ ;;
+ ))
+
+
+(defun make-game ()
+ (make-sketch 'game
+ (aiming nil)
+ (firedp nil)
+ (gun `(x 40
+ y ,*height*
+ angle ,(- (/ tau 8))))
+ (cannonball (make-particle (getf gun 'x)
+ (getf gun 'y)
+ :speed 15
+ :direction (getf gun 'angle)
+ :radius 7
+ :gravity 0.2))))
+
+
+;;;; Mouse
+(defmethod kit.sdl2:mousebutton-event
+ ((game game) state timestamp button x y)
+ (declare (ignore timestamp x y))
+ (when (= 1 button)
+ (case state
+ (:mousebuttondown (setf (slot-value game 'aiming) t))
+ (:mousebuttonup (setf (slot-value game 'aiming) nil)))))
+
+(defmethod kit.sdl2:mousemotion-event
+ ((game game) timestamp button-mask x y xrel yrel)
+ (declare (ignore timestamp button-mask xrel yrel))
+ (when (slot-value game 'aiming)
+ (aim (slot-value game 'gun) x y)))
+
+
+;;;; Keyboard
+(defun keydown (game scancode)
+ (declare (ignore game))
+ (scancode-case scancode
+ (:scancode-space
+ nil)))
+
+(defun keyup (game scancode)
+ (scancode-case scancode
+ (:scancode-space
+ (when (not (firedp game))
+ (shoot game)))))
+
+
+(defmethod kit.sdl2:keyboard-event ((instance game) state timestamp repeatp keysym)
+ (declare (ignore timestamp repeatp))
+ (cond
+ ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
+ ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
+ (t nil)))
+
+
+
+;;;; Run
+; (defparameter *demo* (make-game))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/demo.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,132 @@
+(in-package #:coding-math.2d.demo)
+
+;;;; Config
+(defparameter *width* 600)
+(defparameter *height* 400)
+
+(defparameter *center-x* (/ *width* 2))
+(defparameter *center-y* (/ *height* 2))
+
+
+;;;; Sketch
+(defun draw-particle (p pen)
+ (with-pen pen
+ (circle (particle-x p) (particle-y p) (particle-radius p))))
+
+(defun draw-line (p1 p2)
+ (with-vecs ((x1 y1) p1 (x2 y2) p2)
+ (line x1 y1 x2 y2)))
+
+(defun draw-circle (p radius)
+ (circle (vec-x p) (vec-y p) radius))
+
+(defun draw-square (p radius)
+ (rect (- (vec-x p) radius)
+ (- (vec-y p) radius)
+ (* 2 radius)
+ (* 2 radius)))
+
+(defun draw-point (p)
+ (point (vec-x p) (vec-y p)))
+
+(defun oob-p (p &optional (r 0.0))
+ (or (outsidep (- 0 r) (+ *width* r) (vec-x p))
+ (outsidep (- 0 r) (+ *height* r) (vec-y p))))
+
+
+(defsketch cm (:width *width*
+ :height *height*
+ :debug :scancode-d)
+ ((ready)
+ (mouse)
+ (start)
+ (end)
+ (controls)
+ (end-pen (make-pen :fill (gray 0.2)))
+ (control-pen (make-pen :stroke (gray 0.1) :fill (gray 0.5)))
+ (line-pen (make-pen :stroke (gray 0.8)))
+ (target-pen (make-pen :fill (rgb 0.5 0.0 0.0)))
+ (fn-pen (make-pen :stroke (rgb 0.0 0 0.5)
+ :weight 1
+ :curve-steps 80))
+ (curve-pen (make-pen :stroke (rgb 0.5 0 0)
+ :weight 1
+ :curve-steps 60
+ :fill (rgb 0.5 0.0 0.0)))
+ )
+ (with-fps
+ (background (gray 1))
+ ;;
+ (when ready
+
+ (with-pen line-pen
+ (loop :for (a b) :on (append (list start) controls (list end))
+ :when b :do (draw-line a b)))
+ (with-pen end-pen
+ (draw-circle start 5)
+ (draw-circle end 5))
+ (with-pen control-pen
+ (mapc (rcurry #'draw-circle 5) controls))
+ (with-pen curve-pen
+ (multicurve start controls end))
+
+ )
+
+ ;;
+ ))
+
+(defun make-cm ()
+ (make-sketch 'cm
+ (mouse (make-vec))))
+
+
+(defun reset (game)
+ (setf (slot-value game 'ready) nil)
+ (setf
+ (slot-value game 'start)
+ (make-vec 0 *center-y*)
+ (slot-value game 'end)
+ (make-vec *width* *center-y*)
+ (slot-value game 'controls)
+ ; (loop :for x :from 100 :below *width* :by 100
+ ; :collect (make-vec x (random *height*)))
+ (loop :repeat 8
+ :collect (make-random-vec *width* *height*))
+ )
+ (setf (slot-value game 'ready) t))
+
+
+;;;; Mouse
+(defmethod kit.sdl2:mousemotion-event ((window cm) ts b x y xrel yrel)
+ (declare (ignore ts b xrel yrel))
+ (with-slots (mouse) window
+ (setf (vec-x mouse) x)
+ (setf (vec-y mouse) y)
+ ;;
+ ;;
+ ))
+
+
+;;;; Keyboard
+(defun keydown (instance scancode)
+ (declare (ignorable instance))
+ (scancode-case scancode
+ (:scancode-space (reset instance))))
+
+(defun keyup (instance scancode)
+ (declare (ignorable instance))
+ (scancode-case scancode
+ (:scancode-space
+ nil)))
+
+
+(defmethod kit.sdl2:keyboard-event ((instance cm) state timestamp repeatp keysym)
+ (declare (ignore timestamp repeatp))
+ (cond
+ ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
+ ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
+ (t nil)))
+
+
+;;;; Run
+; (defparameter *demo* (make-cm))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/hitboxes.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,62 @@
+(in-package #:coding-math.2d.hitboxes)
+
+(defgeneric hitbox-x (object))
+
+(defgeneric hitbox-y (object))
+
+(defgeneric hitbox-radius (object))
+
+(defgeneric hitbox-width (object))
+
+(defgeneric hitbox-height (object))
+
+
+(defmethod hitbox-x ((object list))
+ (getf object :x))
+
+(defmethod hitbox-y ((object list))
+ (getf object :y))
+
+(defmethod hitbox-radius ((object list))
+ (getf object :radius))
+
+(defmethod hitbox-width ((object list))
+ (getf object :width))
+
+(defmethod hitbox-height ((object list))
+ (getf object :height))
+
+
+(defun circles-collide-p (c0 c1)
+ (let ((d (distance (hitbox-x c0) (hitbox-y c0)
+ (hitbox-x c1) (hitbox-y c1))))
+ (< d (+ (hitbox-radius c0)
+ (hitbox-radius c1)))))
+
+(defun circle-point-collide-p (c p)
+ (let ((d (distance (hitbox-x c) (hitbox-y c)
+ (hitbox-x p) (hitbox-y p))))
+ (< d (hitbox-radius c))))
+
+(defun rect-point-collide-p (r p)
+ (with-vals ((rx hitbox-x)
+ (ry hitbox-y)
+ (rw hitbox-width)
+ (rh hitbox-height))
+ r
+ (and (insidep rx (+ rx rw) (hitbox-x p))
+ (insidep ry (+ ry rh) (hitbox-y p)))))
+
+(defun rects-collide-p (r0 r1)
+ (with-vals ((r0x hitbox-x) ; lol
+ (r0y hitbox-y)
+ (r0w hitbox-width)
+ (r0h hitbox-height)) r0
+ (with-vals ((r1x hitbox-x)
+ (r1y hitbox-y)
+ (r1w hitbox-width)
+ (r1h hitbox-height)) r1
+ (and (ranges-overlap-p r0x (+ r0x r0w)
+ r1x (+ r1x r1w))
+ (ranges-overlap-p r0y (+ r0y r0h)
+ r1y (+ r1y r1h))))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/particles.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,148 @@
+(in-package #:coding-math.2d.particles)
+
+(defstruct (particle
+ (:constructor make-particle%))
+ (pos (make-vec) :type vec)
+ (vel (make-vec) :type vec)
+ (grv (make-vec) :type vec)
+ (radius 1 :type fixnum)
+ (friction 0.0 :type single-float)
+ (mass 1.0 :type single-float)
+ (springs nil :type list)
+ (gravitations nil :type list))
+
+(defstruct spring
+ (target (make-vec) :type vec)
+ (constant 0.0 :type single-float)
+ (offset 0.0 :type single-float))
+
+
+(defun make-particle
+ (x y
+ &key
+ (speed 0)
+ (direction 0)
+ (mass 1.0)
+ (radius 1)
+ (gravity 0.0)
+ (friction 0.0))
+ (make-particle%
+ :pos (make-vec x y)
+ :vel (make-vec-md speed direction)
+ :grv (make-vec-md gravity (/ tau 4))
+ :friction friction
+ :mass mass
+ :radius radius))
+
+
+(defun particle-x (particle)
+ (vec-x (particle-pos particle)))
+
+(defun particle-y (particle)
+ (vec-y (particle-pos particle)))
+
+(defun particle-speed (particle)
+ (vec-magnitude (particle-vel particle)))
+
+(defun particle-direction (particle)
+ (vec-direction (particle-vel particle)))
+
+(defun particle-wrap! (particle width height)
+ (let ((radius (particle-radius particle)))
+ (wrapf (particle-x particle)
+ (- radius)
+ (+ radius width))
+ (wrapf (particle-y particle)
+ (- radius)
+ (+ radius height))))
+
+
+(defun (setf particle-x) (new-value particle)
+ (setf (vec-x (particle-pos particle)) new-value))
+
+(defun (setf particle-y) (new-value particle)
+ (setf (vec-y (particle-pos particle)) new-value))
+
+(defun (setf particle-speed) (new-value particle)
+ (setf (vec-magnitude (particle-vel particle)) new-value))
+
+(defun (setf particle-direction) (new-value particle)
+ (setf (vec-direction (particle-vel particle)) new-value))
+
+
+(defun particle-angle-to (particle other-particle)
+ (let ((distance (vec-sub (particle-pos other-particle)
+ (particle-pos particle))))
+ (atan (vec-y distance)
+ (vec-x distance))))
+
+(defun particle-distance-to (particle other-particle)
+ (vec-magnitude (vec-sub (particle-pos particle)
+ (particle-pos other-particle))))
+
+
+(defun particle-accelerate! (particle acceleration)
+ (vec-add! (particle-vel particle)
+ acceleration))
+
+
+(defun particle-gravitate-add! (particle target)
+ (push target (particle-gravitations particle)))
+
+(defun particle-gravitate-remove! (particle target)
+ (zap% (particle-gravitations particle)
+ #'remove target %))
+
+(defun particle-gravitate-to! (particle attractor-particle)
+ (let ((distance (particle-distance-to particle attractor-particle)))
+ (particle-accelerate!
+ particle
+ (make-vec-md (/ (particle-mass attractor-particle)
+ (* distance distance))
+ (particle-angle-to particle attractor-particle)))))
+
+
+(defun particle-spring-to! (particle target spring-constant &optional (offset 0))
+ (let ((distance (vec-sub target (particle-pos particle))))
+ (decf (vec-magnitude distance) offset)
+ (vec-add! (particle-vel particle)
+ (vec-mul distance spring-constant))))
+
+(defun particle-spring-add! (particle target spring-constant &optional (offset 0))
+ (push (make-spring :target target
+ :constant (float spring-constant)
+ :offset (float offset))
+ (particle-springs particle)))
+
+(defun particle-spring-remove! (particle target)
+ (zap% (particle-springs particle)
+ #'remove target % :key #'spring-target))
+
+
+(defun particle-update! (particle)
+ (with-accessors
+ ((pos particle-pos)
+ (vel particle-vel)
+ (grv particle-grv)
+ (friction particle-friction))
+ particle
+ (vec-add! pos vel)
+ (vec-add! vel grv)
+ (vec-mul! vel (- 1 friction))
+ (loop :for g :in (particle-gravitations particle)
+ :do (particle-gravitate-to! particle g))
+ (loop :for s :in (particle-springs particle)
+ :do (particle-spring-to! particle
+ (spring-target s)
+ (spring-constant s)
+ (spring-offset s)))))
+
+
+(defmethod hitbox-x ((p particle))
+ (particle-x p))
+
+(defmethod hitbox-y ((p particle))
+ (particle-y p))
+
+(defmethod hitbox-radius ((p particle))
+ (particle-radius p))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/points.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,56 @@
+(in-package #:coding-math.2d.points)
+
+(defun quadratic-bezier (from to control n)
+ (vec-lerp (vec-lerp from control n)
+ (vec-lerp control to n)
+ n))
+
+(defun fast-quadratic-bezier (from to control n
+ &optional (destination (make-vec)))
+ (with-vecs ((fx fy) from
+ (tx ty) to
+ (cx cy) control)
+ (setf (vec-x destination)
+ (+ (* (square (- 1 n)) fx)
+ (* 2 (- 1 n) n cx)
+ (* n n tx))
+ (vec-y destination)
+ (+ (* (square (- 1 n)) fy)
+ (* 2 (- 1 n) n cy)
+ (* n n ty))))
+ destination)
+
+
+(defun cubic-bezier (from to control-1 control-2 n)
+ (vec-lerp (vec-lerp (vec-lerp from control-1 n)
+ (vec-lerp control-1 control-2 n)
+ n)
+ (vec-lerp (vec-lerp control-1 control-2 n)
+ (vec-lerp control-2 to n)
+ n)
+ n))
+
+
+(declaim (inline draw-function))
+(defun draw-function (fn &key (start 0.0) (end 1.0))
+ (let ((steps (sketch::pen-curve-steps (sketch::env-pen sketch::*env*))))
+ (apply #'polyline
+ (mapcan (compose (rcurry #'coerce 'list) fn)
+ (iota (1+ steps)
+ :start 0.0
+ :step (/ (- end start) steps))))))
+
+(defun quadratic-bezier-curve (from to control)
+ (draw-function (curry #'fast-quadratic-bezier from to control)))
+
+
+(defun multicurve (from controls to)
+ (labels ((midpoint (pair)
+ (vec-lerp (car pair) (cadr pair) 0.5))
+ (midpoints (points)
+ (mapcar #'midpoint (n-grams 2 points))))
+ (let ((mids (midpoints controls)))
+ (loop :for start :in (cons from mids)
+ :for end :in (append mids (list to))
+ :for control :in controls
+ :do (quadratic-bezier-curve start end control)))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/2d/vectors.lisp Mon May 09 20:25:10 2016 +0000
@@ -0,0 +1,121 @@
+(in-package #:coding-math.2d.vectors)
+
+
+(declaim (inline vec-x vec-y make-vec
+ vec-magnitude vec-angle vec-direction
+ vec-add vec-sub vec-mul vec-div
+ vec-add! vec-sub! vec-mul! vec-div!
+ vec-lerp
+ ))
+
+(defstruct (vec
+ (:constructor make-vec
+ (&optional (x 0) (y 0)))
+ (:type vector))
+ (x 0 :type real)
+ (y 0 :type real))
+
+(defun make-random-vec (max-x max-y)
+ (make-vec (random max-x) (random max-y)))
+
+
+(defun make-vec-md (magnitude angle)
+ (let ((v (make-vec 0 0)))
+ (setf (vec-magnitude v) magnitude
+ (vec-angle v) angle)
+ v))
+
+(defun make-vec-ma (magnitude angle)
+ (make-vec-md magnitude angle))
+
+
+(defmacro with-vec (bindings vec &body body)
+ (once-only (vec)
+ `(let ((,(first bindings) (vec-x ,vec))
+ (,(second bindings) (vec-y ,vec)))
+ ,@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-vecs ,remaining ,@body)))))
+
+
+(defun vec-magnitude (vec)
+ (with-vec (x y) vec
+ (sqrt (+ (* x x)
+ (* y y)))))
+
+(defun vec-angle (vec)
+ (with-vec (x y) vec
+ (atan y x)))
+
+(defun vec-direction (vec)
+ (vec-angle vec))
+
+
+(defun (setf vec-angle) (angle vec)
+ (let ((magnitude (vec-magnitude vec)))
+ (setf (vec-x vec) (* magnitude (cos angle)))
+ (setf (vec-y vec) (* magnitude (sin angle))))
+ angle)
+
+(defun (setf vec-direction) (angle vec)
+ (setf (vec-angle vec) angle))
+
+(defun (setf vec-magnitude) (magnitude vec)
+ (let ((angle (vec-angle vec)))
+ (setf (vec-x vec) (* magnitude (cos angle)))
+ (setf (vec-y vec) (* magnitude (sin angle))))
+ magnitude)
+
+
+(defun vec-add (v1 v2)
+ (make-vec (+ (vec-x v1) (vec-x v2))
+ (+ (vec-y v1) (vec-y v2))))
+
+(defun vec-sub (v1 v2)
+ (make-vec (- (vec-x v1) (vec-x v2))
+ (- (vec-y v1) (vec-y v2))))
+
+(defun vec-mul (v s)
+ (make-vec (* (vec-x v) s)
+ (* (vec-y v) s)))
+
+(defun vec-div (v s)
+ (make-vec (/ (vec-x v) s)
+ (/ (vec-y v) s)))
+
+
+(defun vec-add! (v1 v2)
+ (incf (vec-x v1) (vec-x v2))
+ (incf (vec-y v1) (vec-y v2)))
+
+(defun vec-sub! (v1 v2)
+ (decf (vec-x v1) (vec-x v2))
+ (decf (vec-y v1) (vec-y v2)))
+
+(defun vec-mul! (v s)
+ (setf (vec-x v) (* (vec-x v) s)
+ (vec-y v) (* (vec-y v) s)))
+
+(defun vec-div! (v s)
+ (setf (vec-x v) (/ (vec-x v) s)
+ (vec-y v) (/ (vec-y v) s)))
+
+
+(defun vec-lerp (v1 v2 n)
+ (with-vecs ((x1 y1) v1
+ (x2 y2) v2)
+ (make-vec (lerp x1 x2 n)
+ (lerp y1 y2 n))))
+
+
+(defun vec-to-string (v)
+ (format nil "[~A ~A]" (vec-x v) (vec-y v)))
+
+
+(defun vec-distance-between (v0 v1)
+ (distance (vec-x v0) (vec-y v0)
+ (vec-x v1) (vec-y v1)))
--- a/src/ballistics.lisp Mon May 09 01:01:35 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,180 +0,0 @@
-(in-package #:coding-math.ballistics)
-
-;;;; Config
-(defparameter *width* 600)
-(defparameter *height* 400)
-
-(defparameter *center-x* (/ *width* 2))
-(defparameter *center-y* (/ *height* 2))
-
-
-;;;; Drawing
-(defparameter *gun-pen* (make-pen :stroke (gray 0.0) :fill (gray 0.0)))
-(defparameter *ball-pen* (make-pen :stroke (gray 0.1) :fill (gray 0.6)))
-(defparameter *force-bg-pen* (make-pen :fill (gray 0.6)))
-(defparameter *target-pen* (make-pen :stroke (rgb 0.6 0 0) :weight 2 :fill (rgb 1.0 0 0)))
-(defparameter *force-fg-pen* (make-pen :fill (rgb 1.000 0.478 0.749)))
-
-
-(defun draw-gun (gun)
- (in-context
- (translate (getf gun 'x) (getf gun 'y))
- (with-pen *gun-pen*
- (circle 0 0 25)
- (rotate (degrees (getf gun 'angle)))
- (rect 0 -8 40 16))))
-
-(defun draw-ball (ball)
- (with-pen *ball-pen*
- (circle (particle-x ball) (particle-y ball) (particle-radius ball))))
-
-(defun draw-force (force)
- (with-pen *force-bg-pen*
- (circle 20 (- *height* 50) 15))
- (with-pen *force-fg-pen*
- (circle 20
- (- *height* 50)
- (map-range -1.0 1.0 0 15 force))))
-
-(defun draw-target (target)
- (when target
- (with-pen *target-pen*
- (circle (getf target :x)
- (getf target :y)
- (getf target :radius)))))
-
-
-;;;; Game
-(defun aim (gun x y)
- (setf (getf gun 'angle)
- (clamp (- (/ tau 4))
- -0.3
- (atan (- y (getf gun 'y))
- (- x (getf gun 'x))))))
-
-(defun shoot (game)
- (force-output)
- (with-slots (gun cannonball firedp raw-force) game
- (let ((angle (getf gun 'angle)))
- (setf
- firedp t
- (particle-x cannonball) (+ (getf gun 'x) (* 40 (cos angle)))
- (particle-y cannonball) (+ (getf gun 'y) (* 40 (sin angle)))
- (particle-speed cannonball) (map-range -1.0 1.0 2 20.0 raw-force)
- (particle-direction cannonball) angle))))
-
-(defun update-ball (game)
- (with-slots (cannonball firedp) game
- (particle-update! cannonball)
- (when (> (- (particle-y cannonball)
- (particle-radius cannonball))
- *height*)
- (setf firedp nil))))
-
-(defun check-target (game)
- (when (and (target game)
- (circles-collide-p (cannonball game)
- (target game)))
- (setf (win game) t)))
-
-(defun random-target ()
- (list :x (random-range 200 *width*)
- :y *height*
- :radius (random-range 10 40)))
-
-
-(defsketch game (:width *width*
- :height *height*
- :debug :scancode-d)
- ((aiming)
- (gun)
- (cannonball)
- (can-shoot-p)
- (firedp)
- (force-speed 0.05)
- (force-angle 0.0)
- (raw-force)
- (target)
- (win)
- )
- (with-fps
- (background (gray 1))
- ;;
- (when (not firedp)
- (incf force-angle force-speed)
- (setf raw-force (sin force-angle)))
-
- (when (not target)
- (setf target (random-target)))
-
- (draw-ball cannonball)
- (draw-gun gun)
- (draw-force raw-force)
- (draw-target target)
-
- (when firedp
- (update-ball sketch::sketch-window)
- (check-target sketch::sketch-window))
- (when win
- (text "You win!" *center-x* *center-y*))
-
- ;;
- ))
-
-
-(defun make-game ()
- (make-sketch 'game
- (aiming nil)
- (firedp nil)
- (gun `(x 40
- y ,*height*
- angle ,(- (/ tau 8))))
- (cannonball (make-particle (getf gun 'x)
- (getf gun 'y)
- :speed 15
- :direction (getf gun 'angle)
- :radius 7
- :gravity 0.2))))
-
-
-;;;; Mouse
-(defmethod kit.sdl2:mousebutton-event
- ((game game) state timestamp button x y)
- (declare (ignore timestamp x y))
- (when (= 1 button)
- (case state
- (:mousebuttondown (setf (slot-value game 'aiming) t))
- (:mousebuttonup (setf (slot-value game 'aiming) nil)))))
-
-(defmethod kit.sdl2:mousemotion-event
- ((game game) timestamp button-mask x y xrel yrel)
- (declare (ignore timestamp button-mask xrel yrel))
- (when (slot-value game 'aiming)
- (aim (slot-value game 'gun) x y)))
-
-
-;;;; Keyboard
-(defun keydown (game scancode)
- (declare (ignore game))
- (scancode-case scancode
- (:scancode-space
- nil)))
-
-(defun keyup (game scancode)
- (scancode-case scancode
- (:scancode-space
- (when (not (firedp game))
- (shoot game)))))
-
-
-(defmethod kit.sdl2:keyboard-event ((instance game) state timestamp repeatp keysym)
- (declare (ignore timestamp repeatp))
- (cond
- ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
- ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
- (t nil)))
-
-
-
-;;;; Run
-; (defparameter *demo* (make-game))
--- a/src/main.lisp Mon May 09 01:01:35 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,132 +0,0 @@
-(in-package #:coding-math)
-
-;;;; Config
-(defparameter *width* 600)
-(defparameter *height* 400)
-
-(defparameter *center-x* (/ *width* 2))
-(defparameter *center-y* (/ *height* 2))
-
-
-;;;; Sketch
-(defun draw-particle (p pen)
- (with-pen pen
- (circle (particle-x p) (particle-y p) (particle-radius p))))
-
-(defun draw-line (p1 p2)
- (with-vecs ((x1 y1) p1 (x2 y2) p2)
- (line x1 y1 x2 y2)))
-
-(defun draw-circle (p radius)
- (circle (vec-x p) (vec-y p) radius))
-
-(defun draw-square (p radius)
- (rect (- (vec-x p) radius)
- (- (vec-y p) radius)
- (* 2 radius)
- (* 2 radius)))
-
-(defun draw-point (p)
- (point (vec-x p) (vec-y p)))
-
-(defun oob-p (p &optional (r 0.0))
- (or (outsidep (- 0 r) (+ *width* r) (vec-x p))
- (outsidep (- 0 r) (+ *height* r) (vec-y p))))
-
-
-(defsketch cm (:width *width*
- :height *height*
- :debug :scancode-d)
- ((ready)
- (mouse)
- (start)
- (end)
- (controls)
- (end-pen (make-pen :fill (gray 0.2)))
- (control-pen (make-pen :stroke (gray 0.1) :fill (gray 0.5)))
- (line-pen (make-pen :stroke (gray 0.8)))
- (target-pen (make-pen :fill (rgb 0.5 0.0 0.0)))
- (fn-pen (make-pen :stroke (rgb 0.0 0 0.5)
- :weight 1
- :curve-steps 80))
- (curve-pen (make-pen :stroke (rgb 0.5 0 0)
- :weight 1
- :curve-steps 60
- :fill (rgb 0.5 0.0 0.0)))
- )
- (with-fps
- (background (gray 1))
- ;;
- (when ready
-
- (with-pen line-pen
- (loop :for (a b) :on (append (list start) controls (list end))
- :when b :do (draw-line a b)))
- (with-pen end-pen
- (draw-circle start 5)
- (draw-circle end 5))
- (with-pen control-pen
- (mapc (rcurry #'draw-circle 5) controls))
- (with-pen curve-pen
- (multicurve start controls end))
-
- )
-
- ;;
- ))
-
-(defun make-cm ()
- (make-sketch 'cm
- (mouse (make-vec))))
-
-
-(defun reset (game)
- (setf (slot-value game 'ready) nil)
- (setf
- (slot-value game 'start)
- (make-vec 0 *center-y*)
- (slot-value game 'end)
- (make-vec *width* *center-y*)
- (slot-value game 'controls)
- ; (loop :for x :from 100 :below *width* :by 100
- ; :collect (make-vec x (random *height*)))
- (loop :repeat 8
- :collect (make-random-vec *width* *height*))
- )
- (setf (slot-value game 'ready) t))
-
-
-;;;; Mouse
-(defmethod kit.sdl2:mousemotion-event ((window cm) ts b x y xrel yrel)
- (declare (ignore ts b xrel yrel))
- (with-slots (mouse) window
- (setf (vec-x mouse) x)
- (setf (vec-y mouse) y)
- ;;
- ;;
- ))
-
-
-;;;; Keyboard
-(defun keydown (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (:scancode-space (reset instance))))
-
-(defun keyup (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (:scancode-space
- nil)))
-
-
-(defmethod kit.sdl2:keyboard-event ((instance cm) state timestamp repeatp keysym)
- (declare (ignore timestamp repeatp))
- (cond
- ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
- ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
- (t nil)))
-
-
-;;;; Run
-; (defparameter *demo* (make-cm))
--- a/src/math.lisp Mon May 09 01:01:35 2016 +0000
+++ b/src/math.lisp Mon May 09 20:25:10 2016 +0000
@@ -12,6 +12,18 @@
(defun square (x)
(* x x))
+(defun dividesp (n divisor)
+ "Return whether `n` is evenly divisible by `divisor`."
+ (zerop (mod n divisor)))
+
+(defun square (n)
+ "Return the square of `n`."
+ (* n n))
+
+(defmacro mulf (place n)
+ "Multiply `place` by `n` in-place."
+ `(zap% ,place #'* % ,n))
+
;; Geometry
(defun distance (x0 y0 x1 y1)
@@ -110,65 +122,3 @@
(defun round-to-nearest (n divisor)
(* divisor (round n divisor)))
-
-;;;; Collisions
-(defgeneric hitbox-x (object))
-
-(defgeneric hitbox-y (object))
-
-(defgeneric hitbox-radius (object))
-
-(defgeneric hitbox-width (object))
-
-(defgeneric hitbox-height (object))
-
-
-(defmethod hitbox-x ((object list))
- (getf object :x))
-
-(defmethod hitbox-y ((object list))
- (getf object :y))
-
-(defmethod hitbox-radius ((object list))
- (getf object :radius))
-
-(defmethod hitbox-width ((object list))
- (getf object :width))
-
-(defmethod hitbox-height ((object list))
- (getf object :height))
-
-
-(defun circles-collide-p (c0 c1)
- (let ((d (distance (hitbox-x c0) (hitbox-y c0)
- (hitbox-x c1) (hitbox-y c1))))
- (< d (+ (hitbox-radius c0)
- (hitbox-radius c1)))))
-
-(defun circle-point-collide-p (c p)
- (let ((d (distance (hitbox-x c) (hitbox-y c)
- (hitbox-x p) (hitbox-y p))))
- (< d (hitbox-radius c))))
-
-(defun rect-point-collide-p (r p)
- (with-vals ((rx hitbox-x)
- (ry hitbox-y)
- (rw hitbox-width)
- (rh hitbox-height))
- r
- (and (insidep rx (+ rx rw) (hitbox-x p))
- (insidep ry (+ ry rh) (hitbox-y p)))))
-
-(defun rects-collide-p (r0 r1)
- (with-vals ((r0x hitbox-x) ; lol
- (r0y hitbox-y)
- (r0w hitbox-width)
- (r0h hitbox-height)) r0
- (with-vals ((r1x hitbox-x)
- (r1y hitbox-y)
- (r1w hitbox-width)
- (r1h hitbox-height)) r1
- (and (ranges-overlap-p r0x (+ r0x r0w)
- r1x (+ r1x r1w))
- (ranges-overlap-p r0y (+ r0y r0h)
- r1y (+ r1y r1h))))))
--- a/src/particles.lisp Mon May 09 01:01:35 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,148 +0,0 @@
-(in-package #:coding-math.particles)
-
-(defstruct (particle
- (:constructor make-particle%))
- (pos (make-vec) :type vec)
- (vel (make-vec) :type vec)
- (grv (make-vec) :type vec)
- (radius 1 :type fixnum)
- (friction 0.0 :type single-float)
- (mass 1.0 :type single-float)
- (springs nil :type list)
- (gravitations nil :type list))
-
-(defstruct spring
- (target (make-vec) :type vec)
- (constant 0.0 :type single-float)
- (offset 0.0 :type single-float))
-
-
-(defun make-particle
- (x y
- &key
- (speed 0)
- (direction 0)
- (mass 1.0)
- (radius 1)
- (gravity 0.0)
- (friction 0.0))
- (make-particle%
- :pos (make-vec x y)
- :vel (make-vec-md speed direction)
- :grv (make-vec-md gravity (/ tau 4))
- :friction friction
- :mass mass
- :radius radius))
-
-
-(defun particle-x (particle)
- (vec-x (particle-pos particle)))
-
-(defun particle-y (particle)
- (vec-y (particle-pos particle)))
-
-(defun particle-speed (particle)
- (vec-magnitude (particle-vel particle)))
-
-(defun particle-direction (particle)
- (vec-direction (particle-vel particle)))
-
-(defun particle-wrap! (particle width height)
- (let ((radius (particle-radius particle)))
- (wrapf (particle-x particle)
- (- radius)
- (+ radius width))
- (wrapf (particle-y particle)
- (- radius)
- (+ radius height))))
-
-
-(defun (setf particle-x) (new-value particle)
- (setf (vec-x (particle-pos particle)) new-value))
-
-(defun (setf particle-y) (new-value particle)
- (setf (vec-y (particle-pos particle)) new-value))
-
-(defun (setf particle-speed) (new-value particle)
- (setf (vec-magnitude (particle-vel particle)) new-value))
-
-(defun (setf particle-direction) (new-value particle)
- (setf (vec-direction (particle-vel particle)) new-value))
-
-
-(defun particle-angle-to (particle other-particle)
- (let ((distance (vec-sub (particle-pos other-particle)
- (particle-pos particle))))
- (atan (vec-y distance)
- (vec-x distance))))
-
-(defun particle-distance-to (particle other-particle)
- (vec-magnitude (vec-sub (particle-pos particle)
- (particle-pos other-particle))))
-
-
-(defun particle-accelerate! (particle acceleration)
- (vec-add! (particle-vel particle)
- acceleration))
-
-
-(defun particle-gravitate-add! (particle target)
- (push target (particle-gravitations particle)))
-
-(defun particle-gravitate-remove! (particle target)
- (zap% (particle-gravitations particle)
- #'remove target %))
-
-(defun particle-gravitate-to! (particle attractor-particle)
- (let ((distance (particle-distance-to particle attractor-particle)))
- (particle-accelerate!
- particle
- (make-vec-md (/ (particle-mass attractor-particle)
- (* distance distance))
- (particle-angle-to particle attractor-particle)))))
-
-
-(defun particle-spring-to! (particle target spring-constant &optional (offset 0))
- (let ((distance (vec-sub target (particle-pos particle))))
- (decf (vec-magnitude distance) offset)
- (vec-add! (particle-vel particle)
- (vec-mul distance spring-constant))))
-
-(defun particle-spring-add! (particle target spring-constant &optional (offset 0))
- (push (make-spring :target target
- :constant (float spring-constant)
- :offset (float offset))
- (particle-springs particle)))
-
-(defun particle-spring-remove! (particle target)
- (zap% (particle-springs particle)
- #'remove target % :key #'spring-target))
-
-
-(defun particle-update! (particle)
- (with-accessors
- ((pos particle-pos)
- (vel particle-vel)
- (grv particle-grv)
- (friction particle-friction))
- particle
- (vec-add! pos vel)
- (vec-add! vel grv)
- (vec-mul! vel (- 1 friction))
- (loop :for g :in (particle-gravitations particle)
- :do (particle-gravitate-to! particle g))
- (loop :for s :in (particle-springs particle)
- :do (particle-spring-to! particle
- (spring-target s)
- (spring-constant s)
- (spring-offset s)))))
-
-
-(defmethod hitbox-x ((p particle))
- (particle-x p))
-
-(defmethod hitbox-y ((p particle))
- (particle-y p))
-
-(defmethod hitbox-radius ((p particle))
- (particle-radius p))
--- a/src/points.lisp Mon May 09 01:01:35 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,56 +0,0 @@
-(in-package #:coding-math.points)
-
-(defun quadratic-bezier (from to control n)
- (vec-lerp (vec-lerp from control n)
- (vec-lerp control to n)
- n))
-
-(defun fast-quadratic-bezier (from to control n
- &optional (destination (make-vec)))
- (with-vecs ((fx fy) from
- (tx ty) to
- (cx cy) control)
- (setf (vec-x destination)
- (+ (* (square (- 1 n)) fx)
- (* 2 (- 1 n) n cx)
- (* n n tx))
- (vec-y destination)
- (+ (* (square (- 1 n)) fy)
- (* 2 (- 1 n) n cy)
- (* n n ty))))
- destination)
-
-
-(defun cubic-bezier (from to control-1 control-2 n)
- (vec-lerp (vec-lerp (vec-lerp from control-1 n)
- (vec-lerp control-1 control-2 n)
- n)
- (vec-lerp (vec-lerp control-1 control-2 n)
- (vec-lerp control-2 to n)
- n)
- n))
-
-
-(declaim (inline draw-function))
-(defun draw-function (fn &key (start 0.0) (end 1.0))
- (let ((steps (sketch::pen-curve-steps (sketch::env-pen sketch::*env*))))
- (apply #'polyline
- (mapcan (compose (rcurry #'coerce 'list) fn)
- (iota (1+ steps)
- :start 0.0
- :step (/ (- end start) steps))))))
-
-(defun quadratic-bezier-curve (from to control)
- (draw-function (curry #'fast-quadratic-bezier from to control)))
-
-
-(defun multicurve (from controls to)
- (labels ((midpoint (pair)
- (vec-lerp (car pair) (cadr pair) 0.5))
- (midpoints (points)
- (mapcar #'midpoint (n-grams 2 points))))
- (let ((mids (midpoints controls)))
- (loop :for start :in (cons from mids)
- :for end :in (append mids (list to))
- :for control :in controls
- :do (quadratic-bezier-curve start end control)))))
--- a/src/utils.lisp Mon May 09 01:01:35 2016 +0000
+++ b/src/utils.lisp Mon May 09 20:25:10 2016 +0000
@@ -1,14 +1,5 @@
(in-package #:coding-math.utils)
-(defun dividesp (n divisor)
- "Return whether `n` is evenly divisible by `divisor`."
- (zerop (mod n divisor)))
-
-(defun square (n)
- "Return the square of `n`."
- (* n n))
-
-
(defmacro zap% (place function &rest arguments &environment env)
"Update `place` by applying `function` to its current value and `arguments`.
@@ -34,10 +25,6 @@
,@(substitute access-expr '% arguments))))
,store-expr)))
-(defmacro mulf (place n)
- "Multiply `place` by `n` in-place."
- `(zap% ,place #'* % ,n))
-
(defmacro in-context (&body body)
`(prog1
@@ -66,6 +53,7 @@
,@body)))
pairs)))))
+
(defmacro with-vals (bindings value-form &body body)
(with-gensyms (val)
`(let* ((,val ,value-form)
--- a/src/vectors.lisp Mon May 09 01:01:35 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,121 +0,0 @@
-(in-package #:coding-math.vectors)
-
-
-(declaim (inline vec-x vec-y make-vec
- vec-magnitude vec-angle vec-direction
- vec-add vec-sub vec-mul vec-div
- vec-add! vec-sub! vec-mul! vec-div!
- vec-lerp
- ))
-
-(defstruct (vec
- (:constructor make-vec
- (&optional (x 0) (y 0)))
- (:type vector))
- (x 0 :type real)
- (y 0 :type real))
-
-(defun make-random-vec (max-x max-y)
- (make-vec (random max-x) (random max-y)))
-
-
-(defun make-vec-md (magnitude angle)
- (let ((v (make-vec 0 0)))
- (setf (vec-magnitude v) magnitude
- (vec-angle v) angle)
- v))
-
-(defun make-vec-ma (magnitude angle)
- (make-vec-md magnitude angle))
-
-
-(defmacro with-vec (bindings vec &body body)
- (once-only (vec)
- `(let ((,(first bindings) (vec-x ,vec))
- (,(second bindings) (vec-y ,vec)))
- ,@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-vecs ,remaining ,@body)))))
-
-
-(defun vec-magnitude (vec)
- (with-vec (x y) vec
- (sqrt (+ (* x x)
- (* y y)))))
-
-(defun vec-angle (vec)
- (with-vec (x y) vec
- (atan y x)))
-
-(defun vec-direction (vec)
- (vec-angle vec))
-
-
-(defun (setf vec-angle) (angle vec)
- (let ((magnitude (vec-magnitude vec)))
- (setf (vec-x vec) (* magnitude (cos angle)))
- (setf (vec-y vec) (* magnitude (sin angle))))
- angle)
-
-(defun (setf vec-direction) (angle vec)
- (setf (vec-angle vec) angle))
-
-(defun (setf vec-magnitude) (magnitude vec)
- (let ((angle (vec-angle vec)))
- (setf (vec-x vec) (* magnitude (cos angle)))
- (setf (vec-y vec) (* magnitude (sin angle))))
- magnitude)
-
-
-(defun vec-add (v1 v2)
- (make-vec (+ (vec-x v1) (vec-x v2))
- (+ (vec-y v1) (vec-y v2))))
-
-(defun vec-sub (v1 v2)
- (make-vec (- (vec-x v1) (vec-x v2))
- (- (vec-y v1) (vec-y v2))))
-
-(defun vec-mul (v s)
- (make-vec (* (vec-x v) s)
- (* (vec-y v) s)))
-
-(defun vec-div (v s)
- (make-vec (/ (vec-x v) s)
- (/ (vec-y v) s)))
-
-
-(defun vec-add! (v1 v2)
- (incf (vec-x v1) (vec-x v2))
- (incf (vec-y v1) (vec-y v2)))
-
-(defun vec-sub! (v1 v2)
- (decf (vec-x v1) (vec-x v2))
- (decf (vec-y v1) (vec-y v2)))
-
-(defun vec-mul! (v s)
- (setf (vec-x v) (* (vec-x v) s)
- (vec-y v) (* (vec-y v) s)))
-
-(defun vec-div! (v s)
- (setf (vec-x v) (/ (vec-x v) s)
- (vec-y v) (/ (vec-y v) s)))
-
-
-(defun vec-lerp (v1 v2 n)
- (with-vecs ((x1 y1) v1
- (x2 y2) v2)
- (make-vec (lerp x1 x2 n)
- (lerp y1 y2 n))))
-
-
-(defun vec-to-string (v)
- (format nil "[~A ~A]" (vec-x v) (vec-y v)))
-
-
-(defun vec-distance-between (v0 v1)
- (distance (vec-x v0) (vec-y v0)
- (vec-x v1) (vec-y v1)))