# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1463702716 0
# Node ID e6b1ce8ed0844d45c7732a14a9fd45862a882909

Initial commit

diff -r 000000000000 -r e6b1ce8ed084 .hgignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,1 @@
+scratch.lisp
diff -r 000000000000 -r e6b1ce8ed084 .lispwords
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,2 @@
+(1 scancode-case)
+(1 make-sketch)
diff -r 000000000000 -r e6b1ce8ed084 Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,4 @@
+.PHONY:
+
+quickutils.lisp: make-quickutils.lisp
+	sbcl-rlwrap --noinform --load make-quickutils.lisp  --eval '(quit)'
diff -r 000000000000 -r e6b1ce8ed084 README.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,2 @@
+Working through https://pragprog.com/book/jbmaze/mazes-for-programmers in Common
+Lisp with [Sketch](https://github.com/vydd/sketch).
diff -r 000000000000 -r e6b1ce8ed084 make-quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/make-quickutils.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,18 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(
+               ; :define-constant
+               ; :switch
+               ; :while
+               ; :ensure-boolean
+               :with-gensyms
+               :once-only
+               ; :iota
+               ; :curry
+               ; :rcurry
+               ; :compose
+               ; :n-grams
+               )
+  :package "MAZES.QUICKUTILS")
diff -r 000000000000 -r e6b1ce8ed084 mazes.asd
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/mazes.asd	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,25 @@
+(asdf:defsystem #:mazes
+  :name "mazes"
+  :description "Working through the Mazes for Programmers book."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+
+  :license "MIT/X11"
+  :version "0.0.1"
+
+  :depends-on (#:defstar
+               #:sketch
+               #:sb-cga
+               #:cl-arrows)
+
+  :serial t
+  :components
+  ((:file "quickutils") ; quickutils package ordering crap
+   (:file "package")
+   (:module "src"
+    :serial t
+    :components ((:file "utils")
+                 (:file "fps")
+                 (:file "grid")
+                 (:file "demo")
+                 ))))
diff -r 000000000000 -r e6b1ce8ed084 package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,37 @@
+(defpackage #:mazes.utils
+  (:use
+    #:cl
+    #:sketch
+    #:mazes.quickutils)
+  (:export
+    #:dividesp
+    #:in-context
+    #:zap%
+    #:%))
+
+(defpackage #:mazes.fps
+  (:use
+    #:cl
+    #:sketch
+    #:mazes.quickutils
+    #:mazes.utils)
+  (:export
+    #:with-fps
+    #:draw-fps))
+
+(defpackage #:mazes.grid
+  (:use
+    #:cl
+    #:mazes.quickutils
+    #:mazes.utils)
+  (:export))
+
+(defpackage #:mazes.demo
+  (:use
+    #:cl
+    #:sketch
+    #:mazes.grid
+    #:mazes.quickutils
+    #:mazes.utils
+    #:mazes.fps))
+
diff -r 000000000000 -r e6b1ce8ed084 quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,112 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "MAZES.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "MAZES.QUICKUTILS")
+    (defpackage "MAZES.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "MAZES.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+                                         :MAKE-GENSYM-LIST :ONCE-ONLY))))
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+
+  (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 (:compile-toplevel :load-toplevel :execute)
+  (defun make-gensym-list (length &optional (x "G"))
+    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+    (let ((g (if (typep x '(integer 0)) x (string x))))
+      (loop repeat length
+            collect (gensym g))))
+  )                                        ; eval-when
+
+  (defmacro once-only (specs &body forms)
+    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+    (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+    (symbol symbol)
+
+Example:
+
+    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+          (names-and-forms (mapcar (lambda (spec)
+                                     (etypecase spec
+                                       (list
+                                        (destructuring-bind (name form) spec
+                                          (cons name form)))
+                                       (symbol
+                                        (cons spec spec))))
+                                   specs)))
+      ;; bind in user-macro
+      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+              gensyms names-and-forms)
+         ;; bind in final expansion
+         `(let (,,@(mapcar (lambda (g n)
+                             ``(,,g ,,(cdr n)))
+                           gensyms names-and-forms))
+            ;; bind in user-macro
+            ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                    names-and-forms gensyms)
+               ,@forms)))))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(with-gensyms with-unique-names once-only)))
+
+;;;; END OF quickutils.lisp ;;;;
diff -r 000000000000 -r e6b1ce8ed084 src/demo.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/demo.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,138 @@
+(in-package #:mazes.demo)
+
+
+;;;; Config
+(setf *bypass-cache* t)
+
+(defparameter *width* 800)
+(defparameter *height* 800)
+
+(defparameter *center-x* (/ *width* 2))
+(defparameter *center-y* (/ *height* 2))
+
+
+;;;; Globals
+(defvar *shift* nil)
+(defvar *control* nil)
+(defvar *command* nil)
+(defvar *option* nil)
+
+
+;;;; Utils
+(defmacro with-centered-coords (&body body)
+  `(in-context
+     (translate *center-x* *center-y*)
+     ,@body))
+
+(defmacro with-setup (&body body)
+  `(with-fps
+    (background (gray 0.1))
+    (with-centered-coords
+      ,@body)))
+
+
+;;;; Sketch
+(defsketch demo
+    ((width *width*) (height *height*) (y-axis :up) (title "Mazes")
+     (mouse (cons 0 0))
+     ;; Variables
+     ;; Pens
+     (simple-pen (make-pen :fill (gray 0.1)))
+     (line-pen (make-pen :stroke (gray 0.1) :weight 1))
+     )
+  (with-setup
+    ;;
+    ;;
+    ))
+
+
+;;;; Mouse
+(defun mousemove (instance x y)
+  (with-slots (mouse) instance
+    (setf (car mouse) x)
+    (setf (cdr mouse) y)
+    ;;
+    ;;
+    )
+  )
+
+(defun mousedown-left (instance x y)
+  (declare (ignorable instance x y))
+  )
+
+(defun mousedown-right (instance x y)
+  (declare (ignorable instance x y))
+  )
+
+(defun mouseup-left (instance x y)
+  (declare (ignorable instance x y))
+  )
+
+(defun mouseup-right (instance x y)
+  (declare (ignorable instance x y))
+  )
+
+
+(defmethod kit.sdl2:mousemotion-event ((window demo) ts b x y xrel yrel)
+  (declare (ignore ts b xrel yrel))
+  (mousemove window x y))
+
+(defmethod kit.sdl2:mousebutton-event ((window demo) state ts button x y)
+  (declare (ignore ts))
+  (funcall (case state
+             (:mousebuttondown
+              (case button
+                (1 #'mousedown-left)
+                (3 #'mousedown-right)))
+             (:mousebuttonup
+              (case button
+                (1 #'mouseup-left)
+                (3 #'mouseup-right))))
+           window x y))
+
+
+;;;; Keyboard
+(defmacro scancode-case (scancode-form &rest pairs)
+  (with-gensyms (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)
+  (declare (ignorable instance))
+  (scancode-case scancode
+    (:scancode-space (sketch::prepare instance))
+    (:scancode-lshift (setf *shift* t))
+    (:scancode-lctrl (setf *control* t))
+    (:scancode-lgui (setf *command* t))
+    (:scancode-lalt (setf *option* t))
+    ;;
+    ;;
+    ))
+
+(defun keyup (instance scancode)
+  (declare (ignorable instance))
+  (scancode-case scancode
+    (:scancode-lshift (setf *shift* nil))
+    (:scancode-lctrl (setf *control* nil))
+    (:scancode-lgui (setf *command* nil))
+    (:scancode-lalt (setf *option* nil))
+    (:scancode-space nil)))
+
+
+(defmethod kit.sdl2:keyboard-event
+    ((instance demo) 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 'demo))
diff -r 000000000000 -r e6b1ce8ed084 src/fps.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/fps.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,40 @@
+(in-package #:mazes.fps)
+
+;;;; FPS
+(defvar *last-draw* 0)
+(defvar *fps* 0.0)
+(defvar *mspf* 0.0)
+(defvar *frame* 0)
+
+
+(defparameter *rolling-average* 0.0)
+(defparameter *rolling-average-count* 10)
+
+
+(defun update-average (frame-time)
+  (setf *rolling-average*
+        (/ (+ frame-time
+              (* *rolling-average* *rolling-average-count*))
+           (1+ *rolling-average-count*))))
+
+(defun update-fps ()
+  (setf *mspf* (* 1000.0
+                  (/ *rolling-average*
+                     internal-time-units-per-second))
+        *fps* (/ 1000.0 *mspf*)))
+
+(defun draw-fps ()
+  (with-font (make-font :color (gray 0.9))
+    (text (format nil "MSPF: ~,2F" *mspf*) 0 0)
+    (text (format nil "PFPS: ~,2F" *fps*) 0 20)))
+
+
+(defmacro with-fps (&body body)
+  (let ((start (gensym "start")))
+    `(let ((,start (get-internal-real-time)))
+      ,@body
+      (update-average (- (get-internal-real-time) ,start))
+      (draw-fps)
+      (incf *frame*)
+      (when (dividesp *frame* 15)
+        (update-fps)))))
diff -r 000000000000 -r e6b1ce8ed084 src/grid.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/grid.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,1 @@
+(in-package #:mazes.grid)
diff -r 000000000000 -r e6b1ce8ed084 src/utils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utils.lisp	Fri May 20 00:05:16 2016 +0000
@@ -0,0 +1,38 @@
+(in-package #:mazes.utils)
+
+(defmacro zap% (place function &rest arguments &environment env)
+  "Update `place` by applying `function` to its current value and `arguments`.
+
+  `arguments` should contain the symbol `%`, which is treated as a placeholder
+  where the current value of the place will be substituted into the function
+  call.
+
+  For example:
+
+  (zap% foo #'- % 10) => (setf foo (- foo 10)
+  (zap% foo #'- 10 %) => (setf foo (- 10 foo)
+
+  "
+  ;; original idea/name from http://malisper.me/2015/09/29/zap/
+  (assert (find '% arguments) ()
+    "Placeholder % not included in zap macro form.")
+  (multiple-value-bind (temps exprs stores store-expr access-expr)
+      (get-setf-expansion place env)
+    `(let* (,@(mapcar #'list temps exprs)
+            (,(car stores)
+             (funcall ,function
+                      ,@(substitute access-expr '% arguments))))
+      ,store-expr)))
+
+
+(defmacro in-context (&body body)
+  `(prog1
+    (push-matrix)
+    (progn ,@body)
+    (pop-matrix)))
+
+
+(defun dividesp (n divisor)
+  "Return whether `n` is evenly divisible by `divisor`."
+  (zerop (mod n divisor)))
+