--- /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)'
--- /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.
--- /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")))))
+
--- /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")
--- /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))
--- /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 ;;;;
--- /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))
+
--- /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)))
+
--- /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))
+
--- /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)))
+
--- /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)))
+
+