# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1460242757 0
# Node ID 21b9503510dc1b9a284246d728e605870c58f6f3

Initial commit

diff -r 000000000000 -r 21b9503510dc Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,4 @@
+.PHONY: 
+
+quickutils.lisp: make-quickutils.lisp
+	sbcl --noinform --load make-quickutils.lisp  --eval '(quit)'
diff -r 000000000000 -r 21b9503510dc README.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,2 @@
+Working through https://www.youtube.com/user/codingmath/videos in Common Lisp
+with Sketch.
diff -r 000000000000 -r 21b9503510dc coding-math.asd
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/coding-math.asd	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,27 @@
+(asdf:defsystem #:coding-math
+  :name "coding-math"
+  :description "Working through the Coding Math videos."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+  :version "0.0.1"
+
+  :depends-on (#:defstar
+               #:optima
+               #:sketch
+               #:trivial-types
+               #:cl-arrows
+               #:fare-quasiquote-optima
+               #:fare-quasiquote-readtable)
+
+  :serial t
+  :components ((:file "quickutils") ; quickutils package ordering crap
+               (:file "package")
+               (:module "src"
+                :components ((:file "utils")
+                             (:file "math")
+                             (:file "vectors")
+                             (:file "particles")
+                             (:file "main")))))
+
diff -r 000000000000 -r 21b9503510dc make-quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/make-quickutils.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,11 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(:define-constant
+               :switch
+               :while
+               :ensure-boolean
+               :with-gensyms
+               )
+  :package "CODING-MATH.QUICKUTILS")
diff -r 000000000000 -r 21b9503510dc package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,10 @@
+(defpackage #:coding-math.utils
+  (:use #:cl #:coding-math.quickutils)
+  (:export
+    #:dividesp))
+
+(defpackage #:coding-math
+  (:use #:cl
+        #:sketch
+        #:coding-math.quickutils
+        #:coding-math.utils))
diff -r 000000000000 -r 21b9503510dc quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,172 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS) :ensure-package T :package "CODING-MATH.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "CODING-MATH.QUICKUTILS")
+    (defpackage "CODING-MATH.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "CODING-MATH.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :STRING-DESIGNATOR
+                                         :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
+                                         :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN))))
+
+  (defun %reevaluate-constant (name value test)
+    (if (not (boundp name))
+        value
+        (let ((old (symbol-value name))
+              (new value))
+          (if (not (constantp name))
+              (prog1 new
+                (cerror "Try to redefine the variable as a constant."
+                        "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+              (if (funcall test old new)
+                  old
+                  (restart-case
+                      (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                    (ignore ()
+                      :report "Retain the current value."
+                      old)
+                    (continue ()
+                      :report "Try to redefine the constant."
+                      new)))))))
+
+  (defmacro define-constant (name initial-value &key (test ''eql) documentation)
+    "Ensures that the global variable named by `name` is a constant with a value
+that is equal under `test` to the result of evaluating `initial-value`. `test` is a
+function designator that defaults to `eql`. If `documentation` is given, it
+becomes the documentation string of the constant.
+
+Signals an error if `name` is already a bound non-constant variable.
+
+Signals an error if `name` is already a constant variable whose value is not
+equal under `test` to result of evaluating `initial-value`."
+    `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+       ,@(when documentation `(,documentation))))
+  
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-gensyms (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(let ,(mapcar (lambda (name)
+                     (multiple-value-bind (symbol string)
+                         (etypecase name
+                           (symbol
+                            (values name (symbol-name name)))
+                           ((cons symbol (cons string-designator null))
+                            (values (first name) (string (second name)))))
+                       `(,symbol (gensym ,string))))
+            names)
+       ,@forms))
+
+  (defmacro with-unique-names (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(with-gensyms ,names ,@forms))
+  )                                        ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun extract-function-name (spec)
+    "Useful for macros that want to mimic the functional interface for functions
+like `#'eq` and `'eq`."
+    (if (and (consp spec)
+             (member (first spec) '(quote function)))
+        (second spec)
+        spec))
+  )                                        ; eval-when
+
+  (eval-when (:compile-toplevel :load-toplevel :execute)
+    (defun generate-switch-body (whole object clauses test key &optional default)
+      (with-gensyms (value)
+        (setf test (extract-function-name test))
+        (setf key (extract-function-name key))
+        (when (and (consp default)
+                   (member (first default) '(error cerror)))
+          (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+                                    ,value ',test)))
+        `(let ((,value (,key ,object)))
+           (cond ,@(mapcar (lambda (clause)
+                             (if (member (first clause) '(t otherwise))
+                                 (progn
+                                   (when default
+                                     (error "Multiple default clauses or illegal use of a default clause in ~S."
+                                            whole))
+                                   (setf default `(progn ,@(rest clause)))
+                                   '(()))
+                                 (destructuring-bind (key-form &body forms) clause
+                                   `((,test ,value ,key-form)
+                                     ,@forms))))
+                           clauses)
+                 (t ,default))))))
+
+  (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+                    &body clauses)
+    "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of `default` if no keys match."
+    (generate-switch-body whole object clauses test key))
+
+  (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                     &body clauses)
+    "Like `switch`, but signals an error if no key matches."
+    (generate-switch-body whole object clauses test key '(error)))
+
+  (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+                     &body clauses)
+    "Like `switch`, but signals a continuable error if no key matches."
+    (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+  
+
+  (defmacro until (expression &body body)
+    "Executes `body` until `expression` is true."
+    `(do ()
+         (,expression)
+       ,@body))
+  
+
+  (defmacro while (expression &body body)
+    "Executes `body` while `expression` is true."
+    `(until (not ,expression)
+       ,@body))
+  
+
+  (defun ensure-boolean (x)
+    "Convert `x` into a Boolean value."
+    (and x t))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(define-constant switch eswitch cswitch while ensure-boolean
+            with-gensyms with-unique-names)))
+
+;;;; END OF quickutils.lisp ;;;;
diff -r 000000000000 -r 21b9503510dc src/main.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,124 @@
+(in-package #:coding-math)
+
+;;;; Config
+(defparameter *width* 600)
+(defparameter *height* 400)
+
+(defparameter center-x (/ *width* 2))
+(defparameter center-y (/ *height* 2))
+
+
+;;;; FPS
+(defvar *last-draw*
+  (get-internal-real-time))
+
+(defvar *fps* 0.0)
+
+
+(defun calc-fps (frames)
+  (let* ((current-draw (get-internal-real-time))
+         (elapsed (float (/ (- current-draw *last-draw*)
+                            internal-time-units-per-second))))
+    (setf *last-draw* current-draw)
+    (setf *fps* (* frames (/ 1 elapsed)))))
+
+(defun draw-fps ()
+  (text (format nil "FPS: ~,1F" *fps*) 0 0))
+
+
+;;;; Sketch
+(defmacro in-context (&rest body)
+  `(prog1
+     (push-matrix)
+     (progn ,@body)
+     (pop-matrix)))
+
+
+(defun draw-ship (ship angle thrustingp)
+  (in-context
+    (translate (particle-x ship) (particle-y ship))
+    (rotate (degrees angle))
+    (when thrustingp
+      (with-pen (make-pen :fill (rgb 1.0 0.0 0.0))
+        (ngon 3 -15 0 10 6))) ; fire 
+    (with-pen (make-pen :stroke (gray 0) :fill (gray 0.5))
+      (rect -10 -3 10 6) ; engine
+      (ngon 3 0 0 10 10) ; hull
+      (ngon 3 6 0 6 3)))) ; cockpit
+
+(defun wrap (position-vec)
+  (when (< (vec-x position-vec) 0) (setf (vec-x position-vec) *width*))
+  (when (> (vec-x position-vec) *width*) (setf (vec-x position-vec) 0))
+  (when (< (vec-y position-vec) 0) (setf (vec-y position-vec) *height*))
+  (when (> (vec-y position-vec) *height*) (setf (vec-y position-vec) 0)))
+
+
+(defsketch cm (:width *width*
+               :height *height*
+               :debug :scancode-d)
+    ((mx 0)
+     (my 0)
+     (ship (make-particle center-x center-y 0 0))
+     (angle 0)
+     (frame 1)
+     (turning-left nil)
+     (turning-right nil)
+     (thrusting nil))
+  (background (gray 1))
+  (incf frame)
+  (when (zerop (mod frame 20))
+    (calc-fps 20))
+  (particle-update! ship)
+  (wrap (particle-pos ship))
+  (when turning-left (decf angle 0.05))
+  (when turning-right (incf angle 0.05))
+  (when thrusting
+    (particle-accelerate! ship (make-vec-md 0.1 angle)))
+  (draw-ship ship angle thrusting)
+  (draw-fps))
+
+
+;;;; Mouse
+(defmethod mousemotion-event ((window cm) ts b x y xrel yrel)
+  (declare (ignore ts b xrel yrel))
+  (with-slots (mx my) window
+    (setf mx x)
+    (setf my y)))
+
+
+;;;; Keyboard
+(defmacro scancode-case (scancode-form &rest pairs)
+  (let ((scancode (gensym "scancode")))
+    `(let ((,scancode ,scancode-form))
+      (cond
+        ,@(mapcar (lambda (pair)
+                    (destructuring-bind (key-scancode &rest body) pair
+                      `((sdl2:scancode= ,scancode ,key-scancode)
+                        ,@body)))
+                  pairs)))))
+
+
+(defun keydown (instance scancode)
+  (scancode-case scancode
+    (:scancode-left (setf (slot-value instance 'turning-left) t))
+    (:scancode-right (setf (slot-value instance 'turning-right) t))
+    (:scancode-up (setf (slot-value instance 'thrusting) t))))
+
+(defun keyup (instance scancode)
+  (scancode-case scancode
+    (:scancode-left (setf (slot-value instance 'turning-left) nil))
+    (:scancode-right (setf (slot-value instance 'turning-right) nil))
+    (:scancode-up (setf (slot-value instance 'thrusting) 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-instance 'cm))
+
diff -r 000000000000 -r 21b9503510dc src/math.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/math.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,11 @@
+(in-package #:coding-math)
+
+;;;; Constants
+(defconstant tau (* pi 2))
+
+
+;;;; Maths
+(defun normalize (n min max)
+  (/ (- n min)
+     (- max min)))
+
diff -r 000000000000 -r 21b9503510dc src/particles.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/particles.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,33 @@
+(in-package #:coding-math)
+
+(defclass particle ()
+  ((pos :type 'vec :initarg :pos :accessor particle-pos)
+   (vel :type 'vec :initarg :vel :accessor particle-vel)
+   (grv :type 'vec :initarg :grv :accessor particle-grv)))
+
+
+(defun make-particle (x y speed direction &optional (gravity 0))
+  (make-instance 'particle
+    :pos (make-vec x y)
+    :vel (make-vec-md speed direction)
+    :grv (make-vec-md gravity (/ tau 4))))
+
+
+(defun particle-x (particle)
+  (vec-x (particle-pos particle)))
+
+(defun particle-y (particle)
+  (vec-y (particle-pos particle)))
+
+
+(defun particle-update! (particle)
+  (vec-add! (particle-pos particle)
+            (particle-vel particle))
+  (vec-add! (particle-vel particle)
+            (particle-grv particle)))
+
+
+(defun particle-accelerate! (particle acceleration)
+  (vec-add! (particle-vel particle)
+            acceleration))
+
diff -r 000000000000 -r 21b9503510dc src/utils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utils.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,6 @@
+(in-package #:coding-math.utils)
+
+(defun dividesp (n divisor)
+  "Return whether `n` is evenly divisible by `divisor`."
+  (zerop (mod n divisor)))
+
diff -r 000000000000 -r 21b9503510dc src/vectors.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vectors.lisp	Sat Apr 09 22:59:17 2016 +0000
@@ -0,0 +1,80 @@
+(in-package #:coding-math)
+
+(defclass vec ()
+  ((x :type 'real :initarg :x :accessor vec-x)
+   (y :type 'real :initarg :y :accessor vec-y)))
+
+
+(defun make-vec (x y)
+  (make-instance 'vec :x x :y y))
+
+(defun make-vec-md (magnitude angle)
+  (let ((v (make-vec 0 0)))
+    (setf (vec-magnitude v) magnitude
+          (vec-angle v) angle)
+    v))
+
+
+(defun vec-magnitude (vec)
+  (with-slots (x y) vec
+    (sqrt (+ (* x x)
+             (* y y)))))
+
+(defun vec-angle (vec)
+  (with-slots (x y) vec
+    (atan y x)))
+
+
+(defun (setf vec-angle) (angle vec)
+  (let ((magnitude (vec-magnitude vec)))
+    (with-slots (x y) vec
+      (setf x (* magnitude (cos angle)))
+      (setf y (* magnitude (sin angle)))))
+  angle)
+
+(defun (setf vec-magnitude) (magnitude vec)
+  (let ((angle (vec-angle vec)))
+    (with-slots (x y) vec
+      (setf x (* magnitude (cos angle)))
+      (setf y (* 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-to-string (v)
+  (format nil "[~A ~A]" (vec-x v) (vec-y v)))
+
+