# HG changeset patch # User Steve Losh # Date 1462825510 0 # Node ID bf847793a69aa8dffe6ceb7cd084b77014312d0e # Parent 564d579c018b65d579320f2483b5a5a5e39532be http://bit.ly/happening-bunker/ diff -r 564d579c018b -r bf847793a69a coding-math.asd --- 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 ()))))) diff -r 564d579c018b -r bf847793a69a package.lisp --- 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 diff -r 564d579c018b -r bf847793a69a src/2d/ballistics.lisp --- /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)) diff -r 564d579c018b -r bf847793a69a src/2d/demo.lisp --- /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)) diff -r 564d579c018b -r bf847793a69a src/2d/hitboxes.lisp --- /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)))))) diff -r 564d579c018b -r bf847793a69a src/2d/particles.lisp --- /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)) diff -r 564d579c018b -r bf847793a69a src/2d/points.lisp --- /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))))) diff -r 564d579c018b -r bf847793a69a src/2d/vectors.lisp --- /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))) diff -r 564d579c018b -r bf847793a69a src/ballistics.lisp --- 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)) diff -r 564d579c018b -r bf847793a69a src/main.lisp --- 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)) diff -r 564d579c018b -r bf847793a69a src/math.lisp --- 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)))))) diff -r 564d579c018b -r bf847793a69a src/particles.lisp --- 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)) diff -r 564d579c018b -r bf847793a69a src/points.lisp --- 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))))) diff -r 564d579c018b -r bf847793a69a src/utils.lisp --- 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) diff -r 564d579c018b -r bf847793a69a src/vectors.lisp --- 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)))