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