--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,2 @@
+scratch.lisp
+data
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,2 @@
+(1 spit)
+(1 recursively)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Mon Aug 01 15:16:37 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 Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,1 @@
+https://itch.io/jam/august-2016-lisp-game-jam
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/make-quickutils.lisp Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,19 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+ "quickutils.lisp"
+ :utilities '(
+ :with-gensyms
+ :once-only
+ :compose
+ :curry
+ :rcurry
+ ; :n-grams
+ :define-constant
+ ; :switch
+ ; :while
+ ; :ensure-boolean
+ ; :iota
+ ; :zip
+ )
+ :package "SILT.QUICKUTILS")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,46 @@
+(defpackage #:silt.utils
+ (:use
+ #:cl
+ #:iterate
+ #:cl-arrows
+ #:sand.quickutils)
+ (:export
+ #:zap%
+ #:%
+ #:recursively
+ #:recur
+ #:dis
+ #:spit
+
+ #:dlambda
+
+ #:hash-set
+ #:make-set
+ #:set-contains-p
+ #:set-add
+ #:set-remove
+ #:set-add-all
+ #:set-remove-all
+ #:set-random
+ #:set-pop
+ #:set-empty-p
+ #:set-clear
+
+ #:averaging
+ #:timing
+ #:real-time
+ #:run-time
+ #:since-start-into
+ #:per-iteration-into
+ #:in-whatever
+
+ )
+ (:shadowing-import-from #:cl-arrows
+ #:->))
+
+(defpackage #:silt
+ (:use #:cl
+ #:iterate
+ #:cl-arrows
+ #:silt.quickutils
+ #:silt.utils))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/quickutils.lisp Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,226 @@
+;;;; 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 :COMPOSE :CURRY :RCURRY :DEFINE-CONSTANT) :ensure-package T :package "SILT.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "SILT.QUICKUTILS")
+ (defpackage "SILT.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "SILT.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+ :MAKE-GENSYM-LIST :ONCE-ONLY
+ :ENSURE-FUNCTION :COMPOSE :CURRY
+ :RCURRY :DEFINE-CONSTANT))))
+
+ (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)
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (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))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(with-gensyms with-unique-names once-only compose curry rcurry
+ define-constant)))
+
+;;;; END OF quickutils.lisp ;;;;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/silt.asd Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,21 @@
+(asdf:defsystem #:silt
+ :name "silt"
+ :description "Lisp Game Jam, August 2016"
+
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT/X11"
+ :version "0.0.1"
+
+ :depends-on (#:iterate
+ #:cl-charms
+ #:cl-arrows)
+
+ :serial t
+ :components
+ ((:file "quickutils") ; quickutils package ordering crap
+ (:file "package")
+ (:module "src"
+ :serial t
+ :components ((:file "utils")
+ (:file "main")))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,50 @@
+(in-package #:silt)
+
+
+(defparameter *running* nil)
+(defparameter *running* t)
+
+(defparameter *width* 1)
+(defparameter *height* 1)
+
+(defun render ()
+ (charms:move-cursor charms:*standard-window*
+ (- (floor *width* 2) 3)
+ (floor *height* 2))
+ (charms:write-string-at-cursor charms:*standard-window* "S I L T")
+ (charms:move-cursor charms:*standard-window* 0 0))
+
+
+(defun tick ()
+ )
+
+(defun handle-input ()
+ (let ((input (charms:get-char charms:*standard-window* :ignore-error t)))
+ (case input
+ ((nil) nil)
+ (#\q (setf *running* nil)))))
+
+(defun manage-screen ()
+ (multiple-value-bind (w h)
+ (charms:window-dimensions charms:*standard-window*)
+ (setf *width* w *height* h)))
+
+(defun run ()
+ (setf *running* t)
+ (charms:with-curses ()
+ (charms:disable-echoing)
+ (charms:enable-raw-input :interpret-control-characters t)
+ (charms:enable-non-blocking-mode charms:*standard-window*)
+
+ (iterate
+ (while *running*)
+ (charms:clear-window charms:*standard-window*)
+ (manage-screen)
+ (handle-input)
+ (tick)
+ (render)
+ (charms:refresh-window charms:*standard-window*)
+ (sleep 0.03))))
+
+
+; (run)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/utils.lisp Mon Aug 01 15:16:37 2016 +0000
@@ -0,0 +1,202 @@
+(in-package #:silt.utils)
+
+;;;; Miscellaneous
+(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 recursively (bindings &body body)
+ "Execute body recursively, like Clojure's `loop`/`recur`.
+
+ `bindings` should contain a list of symbols and (optional) default values.
+
+ In `body`, `recur` will be bound to the function for recurring.
+
+ Example:
+
+ (defun length (some-list)
+ (recursively ((list some-list) (n 0))
+ (if (null list)
+ n
+ (recur (cdr list) (1+ n)))))
+
+ "
+ (flet ((extract-var (binding)
+ (if (atom binding) binding (first binding)))
+ (extract-val (binding)
+ (if (atom binding) nil (second binding))))
+ `(labels ((recur ,(mapcar #'extract-var bindings)
+ ,@body))
+ (recur ,@(mapcar #'extract-val bindings)))))
+
+(defmacro dis (arglist &body body)
+ "Disassemble the code generated for a `lambda*` with `arglist` and `body`.
+
+ It will also spew compiler notes so you can see why the garbage box isn't
+ doing what you think it should be doing.
+
+ "
+ `(->> '(lambda ,arglist
+ (declare (optimize speed))
+ ,@body)
+ (compile nil)
+ #+sbcl sb-disassem:disassemble-code-component
+ #-sbcl disassemble))
+
+(defmacro spit (filename &body body)
+ `(with-open-file (*standard-output* ,filename
+ :direction :output
+ :if-exists :supersede)
+ ,@body))
+
+
+;;;; dlambda
+(defmacro dlambda (&rest clauses)
+ (with-gensyms (message arguments)
+ (flet ((parse-clause (clause)
+ (destructuring-bind (key arglist &rest body)
+ clause
+ `(,key (apply (lambda ,arglist ,@body) ,arguments)))))
+ `(lambda (,message &rest ,arguments)
+ (ecase ,message
+ ,@(mapcar #'parse-clause clauses))))))
+
+
+;;;; Sets
+;;; Janky implementation of basic sets.
+(defclass hash-set ()
+ ((data :initarg :data)))
+
+
+(defun make-set (&key (test #'eql) (initial-data nil))
+ (let ((set (make-instance 'hash-set
+ :data (make-hash-table :test test))))
+ (mapcar (curry #'set-add set) initial-data)
+ set))
+
+
+(defun set-contains-p (set value)
+ (nth-value 1 (gethash value (slot-value set 'data))))
+
+(defun set-empty-p (set)
+ (zerop (hash-table-count (slot-value set 'data))))
+
+(defun set-add (set value)
+ (setf (gethash value (slot-value set 'data)) t)
+ value)
+
+(defun set-add-all (set seq)
+ (map nil (curry #'set-add set) seq))
+
+(defun set-remove (set value)
+ (remhash value (slot-value set 'data))
+ value)
+
+(defun set-remove-all (set seq)
+ (map nil (curry #'set-remove set) seq))
+
+(defun set-clear (set)
+ (clrhash (slot-value set 'data))
+ set)
+
+(defun set-random (set)
+ (if (set-empty-p set)
+ (values nil nil)
+ (loop :with data = (slot-value set 'data)
+ :with target = (random (hash-table-count data))
+ :for i :from 0
+ :for k :being :the :hash-keys :of data
+ :when (= i target)
+ :do (return (values k t)))))
+
+(defun set-pop (set)
+ (multiple-value-bind (val found) (set-random set)
+ (if found
+ (progn
+ (set-remove set val)
+ (values val t))
+ (values nil nil))))
+
+
+(defmethod print-object ((set hash-set) stream)
+ (print-unreadable-object (set stream :type t)
+ (format stream "~{~S~^ ~}"
+ (iterate
+ (for (key) :in-hashtable (slot-value set 'data))
+ (collect key)))))
+
+
+;;;; Iterate
+(defmacro-clause (AVERAGING expr &optional INTO var)
+ (with-gensyms (count)
+ (let ((average (or var (gensym "average"))))
+ `(progn
+ (for ,average
+ :first ,expr
+ ;; continuously recompute the running average instead of keeping
+ ;; a running total to avoid bignums when possible
+ :then (/ (+ (* ,average ,count)
+ ,expr)
+ (1+ ,count)))
+ (for ,count :from 1)
+ ,(when (null var)
+ ;; todo handle this better
+ `(finally (return ,average)))))))
+
+(defmacro-clause (TIMING time-type &optional SINCE-START-INTO var PER-ITERATION-INTO per)
+ (let ((timing-function (ecase time-type
+ ((real-time) #'get-internal-real-time)
+ ((run-time) #'get-internal-run-time)))
+ (since (or var (gensym))))
+ (with-gensyms (start-time current-time previous-time)
+ `(progn
+ (with ,start-time = (funcall ,timing-function))
+ (for ,current-time = (funcall ,timing-function))
+ (for ,previous-time :previous ,current-time :initially ,start-time)
+ (for ,since = (- ,current-time ,start-time))
+ ,(when per
+ `(for ,per = (- ,current-time ,previous-time)))
+ ,(when (and (null var) (null per))
+ `(finally (return ,since)))))))
+
+(defmacro-driver (FOR var IN-WHATEVER seq)
+ "Iterate over items in the given sequence.
+
+ Unlike iterate's own `in-sequence` this won't use the horrifically inefficient
+ `elt`/`length` functions on a list.
+
+ "
+ (let ((kwd (if generate 'generate 'for)))
+ (with-gensyms (is-list source i len)
+ `(progn
+ (with ,source = ,seq)
+ (with ,is-list = (typep ,source 'list))
+ (with ,len = (if ,is-list -1 (length ,source)))
+ (for ,i :from 0)
+ (,kwd ,var next (if ,is-list
+ (if ,source
+ (pop ,source)
+ (terminate))
+ (if (< ,i ,len)
+ (elt ,source ,i)
+ (terminate))))))))