--- a/.hgignore Thu Sep 07 15:25:54 2017 -0400
+++ b/.hgignore Fri Jan 26 21:27:01 2018 -0500
@@ -4,3 +4,6 @@
*.dot
sand.prof
qud-items.txt
+*.ppm
+*.pgm
+*.pbm
--- a/package.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/package.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,319 +1,146 @@
-(defpackage :sand.utils
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils)
- (:export
- :average4))
-
-(defpackage :sand.random-numbers
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
+;; (defpackage :sand.parenscript
+;; (:use
+;; :cl
+;; :losh
+;; :sand.quickutils
+;; :cl-fad
+;; :parenscript)
+;; (:shadowing-import-from :losh
+;; :%))
-(defpackage :sand.generic-arithmetic
- (:use
- :cl
- :losh
- :iterate
- :sandalphon.compiler-macro
- :sand.quickutils
- :sand.utils)
- (:shadow
- :+
- :-
- :/
- :*))
-
-(defpackage :sand.sorting
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
-
-(defpackage :sand.parenscript
- (:use
- :cl
- :losh
- :sand.quickutils
- :cl-fad
- :parenscript)
- (:shadowing-import-from :losh
- :%))
-
-(defpackage :sand.ascii
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
+;; (defpackage :sand.terrain.diamond-square
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils))
-(defpackage :sand.terrain.diamond-square
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
-
-(defpackage :sand.dijkstra-maps
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- :dijkstra-map
- :make-dijkstra-map
- :dm-maximum-value
- :dm-map
- :dm-ref))
-
-(defpackage :sand.graphs
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.dijkstra-maps
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; :dijkstra-map
+;; :make-dijkstra-map
+;; :dm-maximum-value
+;; :dm-map
+;; :dm-ref))
-(defpackage :sand.graphviz
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- :graphviz-digraph))
+;; (defpackage :sand.ropes
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :trivia
+;; :sand.quickutils
+;; :sand.utils)
+;; (:shadowing-import-from :losh
+;; :<>)
+;; (:export
+;; ))
-(defpackage :sand.ropes
- (:use
- :cl
- :losh
- :iterate
- :trivia
- :sand.quickutils
- :sand.utils)
- (:shadowing-import-from :losh
- :<>)
- (:export
- ))
-
-(defpackage :sand.hanoi
- (:use
- :cl
- :losh
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.hanoi
+;; (:use
+;; :cl
+;; :losh
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.huffman-trees
- (:use
- :cl
- :losh
- :iterate
- :sand.graphviz
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.streams
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.huffman-trees
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.graphviz
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-#+sbcl
-(defpackage :sand.ffi
- (:use
- :cl
- :losh
- :iterate
- :cffi
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.color-difference
- (:use
- :cl
- :losh
- :iterate
- :rs-colors
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.number-letters
- (:use
- :cl
- :losh
- :iterate
- :function-cache
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.streams
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.urn
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.qud
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.istruct
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; #+sbcl
+;; (defpackage :sand.ffi
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :cffi
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.names
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
-
-(defpackage :sand.surreal-numbers
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.surreal-numbers
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.easing
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.easing
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.serializing-functions
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- ))
+;; (defpackage :sand.serializing-functions
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; ))
-(defpackage :sand.sketch
- (:use
- :cl
- :losh
- :sketch
- :iterate
- :sand.quickutils
- :sand.utils)
- (:shadowing-import-from :iterate
- :in)
- (:shadowing-import-from :sketch
- :degrees
- :radians))
+;; (defpackage :sand.sketch
+;; (:use
+;; :cl
+;; :losh
+;; :sketch
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:shadowing-import-from :iterate
+;; :in)
+;; (:shadowing-import-from :sketch
+;; :degrees
+;; :radians))
-(defpackage :sand.mandelbrot
- (:use
- :cl
- :losh
- :sketch
- :iterate
- :sand.quickutils
- :sand.utils)
- (:shadowing-import-from :iterate
- :in)
- (:shadowing-import-from :sketch
- :degrees
- :radians))
+;; #+sbcl
+;; (defpackage :sand.profiling
+;; (:use
+;; :cl
+;; :losh
+;; :iterate
+;; :sand.quickutils
+;; :sand.utils)
+;; (:export
+;; :start-profiling
+;; :stop-profiling
+;; :profile))
-#+sbcl
-(defpackage :sand.profiling
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils)
- (:export
- :start-profiling
- :stop-profiling
- :profile))
-
-
-(defpackage :sand.turing-omnibus.wallpaper
- (:use
- :cl
- :losh
- :sketch
- :iterate
- :sand.quickutils
- :sand.utils)
- (:shadowing-import-from :iterate
- :in)
- (:shadowing-import-from :sketch
- :degrees
- :radians))
-
-(defpackage :sand.turing-omnibus.monto-carlo
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
-
-(defpackage :sand.turing-omnibus.minimax
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils
- :sand.utils))
--- a/sand.asd Thu Sep 07 15:25:54 2017 -0400
+++ b/sand.asd Fri Jan 26 21:27:01 2018 -0500
@@ -10,32 +10,32 @@
:depends-on (
#+sbcl :sb-sprof
- :cffi
- :cl-algebraic-data-type
- :cl-charms
- :cl-fad
- :cl-ppcre
- :clss
- :compiler-macro
- :cl-conspack
- :drakma
- :easing
- :flexi-streams
- :function-cache
+ ;; :cffi
+ ;; :cl-algebraic-data-type
+ ;; :cl-charms
+ ;; :cl-fad
+ ;; :cl-ppcre
+ ;; :clss
+ ;; :compiler-macro
+ ;; :cl-conspack
+ ;; :drakma
+ ;; :easing
+ ;; :flexi-streams
+ ;; :function-cache
:iterate
:losh
- :parenscript
- :parse-float
- :plump
- :rs-colors
- :sanitize
- :sketch
- :split-sequence
- :storable-functions
- :trivia
- :trivial-main-thread
- :vex
- :yason
+ ;; :parenscript
+ ;; :parse-float
+ ;; :plump
+ ;; :rs-colors
+ ;; :sanitize
+ ;; :sketch
+ ;; :split-sequence
+ ;; :storable-functions
+ ;; :trivia
+ ;; :trivial-main-thread
+ ;; :vex
+ ;; :yason
)
@@ -44,42 +44,4 @@
((:module "vendor"
:serial t
:components ((:file "quickutils")))
- (:file "package")
- (:module "src"
- :serial t
- :components ((:file "utils")
- (:file "graphs")
- (:file "graphviz")
- (:file "hanoi")
- (:file "urn")
- (:file "serializing-functions")
- (:file "random-numbers")
- (:file "generic-arithmetic")
- (:file "ropes")
- (:file "sorting")
- (:file "ascii")
- (:file "dijkstra-maps")
- #+sbcl (:file "ffi")
- #+sbcl (:file "profiling")
- (:file "huffman-trees")
- (:file "streams")
- (:file "color-difference")
- #+sbcl (:file "number-letters")
- (:module "terrain"
- :serial t
- :components ((:file "diamond-square")))
- (:module "parenscript"
- :serial t
- :components ((:file "compiler")))
- (:file "sketch")
- (:file "mandelbrot")
- (:file "qud")
- (:file "istruct")
- (:file "names")
- (:file "easing")
- (:file "surreal-numbers")
- (:module "turing-omnibus"
- :serial t
- :components ((:file "wallpaper")
- (:file "monte-carlo")
- (:file "minimax")))))))
+ (:file "package")))
--- a/src/ascii.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,129 +0,0 @@
-(in-package :sand.ascii)
-
-
-(defparameter *running* nil)
-(defparameter *running* t)
-
-(defparameter *ball* (list :x 0 :y 6 :vx 2))
-(defparameter *width* 1)
-(defparameter *height* 1)
-(defparameter *window-x* 0)
-(defparameter *window-y* 0)
-
-
-(defun render (window)
- (charms:clear-window window)
- (charms:move-cursor window
- (getf *ball* :x)
- (getf *ball* :y))
- (charms:write-char-at-cursor window #\@)
- ; (charms:move-cursor window 0 0)
- )
-
-
-(defun tick ()
- (incf (getf *ball* :x)
- (getf *ball* :vx))
- (when (not (in-range-p 0 (getf *ball* :x) 10))
- (negatef (getf *ball* :vx))
- (zapf (getf *ball* :x)
- (max 0 (min (1- 10) %))))
- ; (setf (getf *ball* :y) (truncate (/ *height* 2)))
- )
-
-(defparameter *input* nil)
-(defun handle-input ()
- (let ((input (charms:get-char charms:*standard-window* :ignore-error t)))
- (when input
- (push input *input*))
- (case input
- ((nil) nil)
- (#\h (zapf *window-x* (1- %)))
- (#\j (zapf *window-y* (1+ %)))
- (#\k (zapf *window-y* (1- %)))
- (#\l (zapf *window-x* (1+ %)))
- (#\q (setf *running* nil)))))
-
-(defun manage-screen ()
- (multiple-value-bind (w h)
- (charms:window-dimensions charms:*standard-window*)
- (setf *width* w *height* h)))
-
-(defun fill-window (window width height ch)
- (iterate (for-nested ((x :from 0 :below width)
- (y :from 0 :below height)))
- (charms:write-char-at-point window ch x y)))
-
-(defmacro with-window ((symbol width height start-x start-y) &body body)
- `(let ((,symbol (charms:make-window ,width ,height ,start-x ,start-y)))
- (unwind-protect (progn ,@body)
- (charms:destroy-window ,symbol))))
-
-(defmacro with-panel ((symbol window) &body body)
- `(let ((,symbol (charms:make-panel ,window)))
- (unwind-protect (progn ,@body)
- (charms:destroy-panel ,symbol))))
-
-(defmacro with-windows (bindings &body body)
- (if (null bindings)
- `(progn ,@body)
- `(with-window ,(first bindings)
- (with-windows ,(rest bindings)
- ,@body))))
-
-(defmacro with-panels (bindings &body body)
- (if (null bindings)
- `(progn ,@body)
- `(with-panel ,(first bindings)
- (with-panels ,(rest bindings)
- ,@body))))
-
-
-; (defun run ()
-; (setf *running* t)
-; (charms:with-curses ()
-; (charms:disable-echoing)
-; (charms:enable-raw-input :interpret-control-characters t)
-; (charms:enable-extra-keys charms:*standard-window*)
-; (charms:enable-non-blocking-mode charms:*standard-window*)
-
-; (with-windows ((x-win 20 20 1 1)
-; (ball-win 10 10 0 0)
-; (o-win 5 5 4 0))
-; (fill-window x-win 20 20 #\x)
-; (fill-window o-win 5 5 #\O)
-; ; (with-panels ((x-pan x-win)
-; ; (ball-pan ball-win)
-; ; (o-pan o-win))
-; (iterate
-; (while *running*)
-; (manage-screen)
-; (handle-input)
-; (tick)
-; ; (charms:move-panel ball-pan *window-x* *window-y*)
-; (render ball-win)
-; ; (charms:update-panels)
-; (charms:update)
-; (sleep 0.1))
-; ; )
-; )))
-
-(defun run ()
- (setf *running* t)
- (charms:with-curses ()
- (charms:disable-echoing)
- (charms:enable-raw-input :interpret-control-characters t)
- (charms:enable-extra-keys charms:*standard-window*)
- (charms:enable-non-blocking-mode charms:*standard-window*)
-
- (fill-window t 20 20 #\#)
- (iterate
- (while *running*)
- (manage-screen)
- (handle-input)
- (tick)
- (charms:refresh-window t)
- (sleep 0.1))))
-
-; (run)
-
--- a/src/color-difference.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,22 +0,0 @@
-(in-package :sand.color-difference)
-
-; https://en.wikipedia.org/wiki/Color_difference
-
-(defparameter *c1* (make-cie-rgb-color 0.0 1.0 1.0))
-(defparameter *c2* (make-cie-rgb-color 0.1 1.0 1.0))
-(defparameter *c3* (make-cie-rgb-color 0.7 1.0 1.0))
-
-
-(defun cie-76-distance (c1 c2)
- (multiple-value-bind (l1 a1 b1) (cie-lab-color-coordinates c1)
- (multiple-value-bind (l2 a2 b2) (cie-lab-color-coordinates c2)
- (sqrt (+ (square (- l2 l1))
- (square (- a2 a1))
- (square (- b2 b1)))))))
-
-
-; (cie-76-distance *c1* *c2*)
-
-; (defparameter *c* )
-
-; (cie-lab-color-coordinates (make-cie-xyz-color 0 0 0))
--- a/src/generic-arithmetic.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/generic-arithmetic.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,20 @@
+(losh:eval-dammit
+ (ql:quickload '(:compiler-macro)))
+
+(defpackage :sand.generic-arithmetic
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sandalphon.compiler-macro
+ :sand.quickutils
+ :sand.utils)
+ (:shadow
+ :+
+ :-
+ :/
+ :*))
+
(in-package :sand.generic-arithmetic)
;;;; ________ __________ __ __________ _ _________ ____ ______
--- a/src/graphs.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,115 +0,0 @@
-(in-package :sand.graphs)
-
-
-(defun make-edge (from to)
- (cons from to))
-
-(defun edge-from (edge)
- (car edge))
-
-(defun edge-to (edge)
- (cdr edge))
-
-(defun edge= (test e1 e2)
- (and (funcall test (edge-from e1) (edge-from e2))
- (funcall test (edge-to e1) (edge-to e2))))
-
-
-(defclass directed-graph ()
- ((edges :initarg :edges :accessor digraph-edges)
- (nodes :initarg :nodes :accessor digraph-nodes)
- (node-test :initarg :node-test :accessor digraph-node-test)
- (edge-test :initarg :edge-test :accessor digraph-edge-test)))
-
-(defun make-directed-graph (&key (test #'eql))
- (make-instance 'directed-graph
- :node-test test
- :edge-test (curry #'edge= test)
- :nodes nil
- :edges nil))
-
-
-(defun digraph-node= (digraph o1 o2)
- (funcall (digraph-node-test digraph) o1 o2))
-
-(defun digraph-edge= (digraph e1 e2)
- (funcall (digraph-edge-test digraph) e1 e2))
-
-
-(defun digraph-map-nodes (function digraph)
- (mapcar function (digraph-nodes digraph)))
-
-(defun digraph-map-edges (function digraph)
- (iterate (for edge :in (digraph-edges digraph))
- (collect (funcall function (edge-from edge) (edge-to edge)))))
-
-(defun digraph-filter-edges (predicate digraph &key (key 'identity))
- (remove-if-not predicate (digraph-edges digraph) :key key))
-
-
-(defun digraph-edges-from (digraph object)
- (digraph-filter-edges (curry #'digraph-node= digraph object)
- digraph
- :key #'edge-from))
-
-(defun digraph-edges-to (digraph object)
- (digraph-filter-edges (curry #'digraph-node= digraph object)
- digraph
- :key #'edge-to))
-
-(defun digraph-edges-involving (digraph object)
- (digraph-filter-edges (lambda (edge)
- (or (digraph-node= digraph object (edge-from edge))
- (digraph-node= digraph object (edge-to edge))))
- digraph))
-
-
-(defun digraph-successors (digraph object)
- (mapcar #'edge-to (digraph-edges-from digraph object)))
-
-(defun digraph-predecessors (digraph object)
- (mapcar #'edge-from (digraph-edges-to digraph object)))
-
-(defun digraph-map-successors (function digraph object)
- (mapcar function (digraph-successors digraph object)))
-
-(defun digraph-map-predecessors (function digraph object)
- (mapcar function (digraph-predecessors digraph object)))
-
-
-(defun digraph-add-node (digraph object)
- (zapf (digraph-nodes digraph)
- (adjoin object % :test (digraph-node-test digraph))))
-
-(defun digraph-add-edge (digraph from to)
- (zapf (digraph-edges digraph)
- (adjoin (make-edge from to) %
- :test (digraph-edge-test digraph))))
-
-(defun digraph-remove-node (digraph object)
- (zapf (digraph-nodes digraph)
- (remove object % :test (digraph-node-test digraph))
- (digraph-edges digraph)
- (set-difference % (digraph-edges-involving digraph object)
- :test (digraph-edge-test digraph)))
- nil)
-
-(defun digraph-remove-edge (digraph from to)
- (zapf (digraph-edges digraph)
- (remove (make-edge from to) %
- :test (digraph-edge-test digraph)))
- nil)
-
-
-(defmethod print-object ((digraph directed-graph) stream)
- (print-unreadable-object (digraph stream :type t :identity t)
- (when (not (null (digraph-nodes digraph)))
- (terpri stream)
- (digraph-map-nodes
- (lambda (node)
- (format stream " ~S -> ~S~%"
- node
- (mapcar #'edge-to (digraph-edges-from digraph node))))
- digraph))))
-
-
--- a/src/graphviz.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-(in-package :sand.graphviz)
-
-(defun graphviz-node (id &key (label id) (shape :box))
- (format t " ~A [shape=~(~A~),label=\"~A\"];~%"
- id shape label))
-
-(defun graphviz-edge (from-id to-id &key (label "") (style :solid))
- (format t " ~A -> ~A [style=~(~A~),label=\"~A\"];~%"
- from-id to-id style label))
-
-(defun %graphviz-digraph (nodes edges)
- (format t "digraph G {~%")
- (mapc (curry #'apply #'graphviz-node) nodes)
- (mapc (curry #'apply #'graphviz-edge) edges)
- (format t "}~%"))
-
-(defun graphviz-digraph (nodes edges &key (path t))
- "Output some Graphviz code to draw a digraph.
-
- If `path` is `t`, output to a string. If `nil`, return a string. Otherwise
- it should be a path designator, and the code will be spit to that file.
-
- Each element in `nodes` will have `graphviz-node` applied to it, so they
- should look like this:
-
- (node-id)
- (node-id :label \"foo\" :shape :circle)
-
- Each element in `edges` will have `graphviz-edge` applied to it, so they
- should look like this:
-
- (from-node-id to-node-id)
- (from-node-id to-node-id :style :dashed :label \"bar\")
-
- "
- (case path
- ((t) (%graphviz-digraph nodes edges))
- ((nil) (with-output-to-string (*standard-output*)
- (%graphviz-digraph nodes edges)))
- (t (with-open-file (*standard-output* path
- :direction :output
- :if-exists :supersede)
- (%graphviz-digraph nodes edges)))))
--- a/src/istruct.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/istruct.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,12 @@
+(defpackage :sand.istruct
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export))
+
(in-package :sand.istruct)
;;;; Equality -----------------------------------------------------------------
--- a/src/mandelbrot.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/mandelbrot.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,116 +1,53 @@
-(in-package :sand.mandelbrot)
+(losh:eval-dammit
+ (ql:quickload '(:trivial-ppm)))
-;;;; Config
-(defparameter *width* 100)
-(defparameter *height* 100)
-(defparameter *black-pen* (make-pen :fill (rgb 0 0 0)))
+(defpackage :sand.mandelbrot
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils))
-;;;; Utils
-(defmacro with-setup (&body body)
- `(progn
- (background (gray 1.0))
- ,@body))
-
-(defmacro in-context (&body body)
- `(prog1
- (push-matrix)
- (progn ,@body)
- (pop-matrix)))
-
-(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)))))
-
-(defmacro just-once (dirty-place &body body)
- `(when ,dirty-place
- (setf ,dirty-place nil)
- ,@body))
+(in-package :sand.mandelbrot)
-;;;; Sketch
-(defun magnitude² (complex-number)
+(defun-inline magnitude-squared (complex-number)
(+ (square (realpart complex-number))
(square (imagpart complex-number))))
-(defun plot (x y)
- (with-pen *black-pen*
- (in-context
- (translate x y)
- (rect 0 0 1 1))))
-
(defun escapesp (x y)
(iterate
(for c = (complex x y))
(for z :first c :then (+ (square z) c))
(repeat 10)
- (thereis (>= (magnitude² z) 4))))
+ (thereis (>= (magnitude-squared z) 4))))
-(defun screen-to-coord (ox oy sx sy)
- (values (- sx ox)
- (- sy oy)))
-
+(defun cycles-to-escape (x y)
+ (declare (optimize speed)
+ (type single-float x y))
+ (iterate
+ (declare (iterate:declare-variables))
+ (for (the (complex single-float) c) = (complex x y))
+ (for (the (complex single-float) z) :first c :then (+ (square z) c))
+ (for (the fixnum cycle) :from 0 :below 255)
+ (finding cycle :such-that (>= (magnitude-squared z) 4))))
-(defsketch demo
- ((width *width*) (height *height*) (y-axis :up) (title "Mandelbrot")
- (copy-pixels t)
- (mouse (list 0 0))
- (mouse-down-left nil)
- (mouse-down-right nil)
- (dirty t)
- ;; Data
- (size 2.0d0)
- (ox 0)
- (oy 0)
- )
- ;;
- (just-once dirty
- (with-setup
- (in-context
- (translate (/ *width* 2)
- (/ *height* 2))
- (iterate
- (with scale = (/ size (/ *width* 2.0d0)))
- (for-nested ((sx :from (- (/ *width* 2)) :below (/ *width* 2))
- (sy :from (- (/ *height* 2)) :below (/ *height* 2))))
- (for x = (* scale sx))
- (for y = (* scale sy))
- (when (not (escapesp x y))
- (plot sx sy))))))
- ;;
+(defun coords (ix iy width height)
+ (values (map-range 0 width -2.3 0.7 ix)
+ (map-range 0 height -1.5 1.5 iy)))
- )
-
-
-;;;; Keyboard
-(defun keydown (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (:scancode-space (sketch::prepare instance))
- (:scancode-up (mulf (slot-value instance 'size) 1.1))
- (:scancode-down (mulf (slot-value instance 'size) 0.9))
- )
- (setf (slot-value instance 'dirty) t))
-
-(defun keyup (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (: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))
+(defun draw (width height &optional (filename "mandelbrot"))
+ (let ((image (make-array (list width height))))
+ (time (iterate (for (pixel ix iy) :in-array image)
+ (for (values x y) = (coords ix iy width height))
+ (for cycles = (cycles-to-escape x y))
+ (for color = (if (null cycles)
+ 0
+ (- 255 cycles)))
+ (setf (aref image ix iy) color)))
+ (trivial-ppm:write-to-file (format nil "~A.pgm" filename) image
+ :format :pgm
+ :encoding :binary
+ :if-exists :supersede)))
--- a/src/names.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/names.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,14 +1,25 @@
+(defpackage :sand.names
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export))
+
(in-package :sand.names)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun normalize-namespec (namespec)
- (trivia:ematch namespec
- ((list pre suf) (list (symbol-name pre)
- nil
- (symbol-name suf)))
- ((list pre in suf) (list (symbol-name pre)
- (symbol-name in)
- (symbol-name suf)))))
+ (ecase (length namespec)
+ (2 (destructuring-bind (pre suf) namespec
+ (list (symbol-name pre)
+ nil
+ (symbol-name suf))))
+ (3 (destructuring-bind (pre in suf) namespec
+ (list (symbol-name pre)
+ (symbol-name in)
+ (symbol-name suf))))))
(defun parse-namespecs (namespecs)
(let ((namespecs (mapcar #'normalize-namespec namespecs)))
--- a/src/number-letters.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/number-letters.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,12 @@
+(defpackage :sand.number-letters
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export))
+
(in-package :sand.number-letters)
; https://www.youtube.com/watch?v=LYKn0yUTIU4
@@ -29,7 +38,7 @@
(declaim (ftype (function ((integer 0)) fixnum)
fast-letter-count))
(defun fast-letter-count (n)
- (declare (optimize (debug 0) (safety 0) (speed 3)))
+ (declare (optimize speed))
(if (zerop n)
4
(iterate
@@ -54,7 +63,7 @@
(1+ (chain-length (fast-letter-count n)))))
(defun print-chain (n)
- (let ((lc (letter-count n)))
+ (let ((lc (fast-letter-count n)))
(format t "~D - ~R -> ~D~%" n n lc)
(when (not (= n 4))
(print-chain lc))))
@@ -73,7 +82,7 @@
(summing 1 :into result)
(declare (type fixnum result))
(when (< i *cache-size*)
- (return (the fixnum (* result (aref *cache+ i)))))))
+ (return (the fixnum (* result (aref *cache* i)))))))
(defun longest-chain (max)
@@ -83,5 +92,5 @@
-; (time
-; (print-chain (longest-chain (expt 10 9))))
+;; (time
+;; (print-chain (longest-chain (expt 10 8))))
--- a/src/qud.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/qud.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,15 @@
+(losh:eval-dammit
+ (ql:quickload '(:plump :clss :parse-float)))
+
+(defpackage :sand.qud
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export))
+
(in-package :sand.qud)
(setf *print-length* 10)
--- a/src/random-numbers.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/random-numbers.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,11 @@
+(defpackage :sand.random-numbers
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils))
+
(in-package :sand.random-numbers)
@@ -115,7 +123,7 @@
;;;; Spectral Test
(defun spectral ()
- (spit "data"
+ #+no (spit "data"
(iterate
(repeat 1000)
(for i = (rand))
--- a/src/sorting.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,81 +0,0 @@
-(in-package :sand.sorting)
-
-
-;; http://cdn.cs50.net/2015/fall/lectures/3/m/notes3m/notes3m.html
-
-
-(defun bubble-sort (vector)
- (iterate
- (with size = (length vector))
- (for done = t)
- (iterate (for i :from 0 :below (1- size))
- (for j = (1+ i))
- (when (< (aref vector j) (aref vector i))
- (rotatef (aref vector i)
- (aref vector j))
- (setf done nil)))
- (until done))
- vector)
-
-
-(defun selection-sort (vector)
- (iterate
- (for target :index-of-vector vector)
- (for smallest = (iterate
- (for value :in-vector vector :from target :with-index i)
- (finding i minimizing value)))
- (prl target smallest)
- (rotatef (aref vector target)
- (aref vector smallest)))
- vector)
-
-(defun merge-with-temporary (vector temp lstart lsize rstart rsize
- &key (predicate #'<))
- "Merge two consecutive subvectors destructively, using `temp` for storage."
- (let ((lend (+ lstart lsize))
- (rend (+ rstart rsize)))
- (recursively ((i 0) (l lstart) (r rstart))
- (cond
- ((= l lend) (replace temp vector ; Done with l, bulk-copy the rest of r
- :start1 i
- :start2 r :end2 rend))
- ((= r rend) (replace temp vector ; Done with r, bulk-copy the rest of l
- :start1 i
- :start2 l :end2 lend))
- ;; Take r only if it's strictly less than l, so we have a stable mege
- ((funcall predicate (aref vector r) (aref vector l))
- (setf (aref temp i) (aref vector r))
- (recur (1+ i) l (1+ r)))
- (t ; Otherwise l <= r, so take l
- (setf (aref temp i) (aref vector l))
- (recur (1+ i) (1+ l) r)))))
- (replace vector temp :start1 lstart :end2 (+ lsize rsize)))
-
-(defun merge-sort (vector)
- "Merge-sort `vector` destructively.
-
- A single vector the same size as `vector` will be consed internally for
- temporary storage.
-
- "
- (let ((temp (make-array (length vector)))) ; just cons one temp array
- (recursively ((start 0)
- (size (length vector)))
- (when (>= size 2)
- (let* ((half (floor size 2))
- (left-start start)
- (right-start (+ start half))
- (left-size half)
- (right-size (- size half)))
- (recur left-start left-size)
- (recur right-start right-size)
- (merge-with-temporary vector temp
- left-start left-size
- right-start right-size)))))
- vector)
-
-
-(defparameter *v* #(1 3 7 0 2))
-; (selection-sort *v*)
-; (bubble-sort *v*)
-; (merge-sort *v*)
--- a/src/turing-omnibus/minimax.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/turing-omnibus/minimax.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,7 +1,15 @@
+(defpackage :sand.turing-omnibus.minimax
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils))
+
(in-package :sand.turing-omnibus.minimax)
-(declaim (optimize (safety 1) (debug 3) (speed 3)))
-(declaim (optimize (safety 0) (debug 0) (speed 3)))
+;; (declaim (optimize (safety 1) (debug 3) (speed 3)))
+;; (declaim (optimize (safety 0) (debug 0) (speed 3)))
;;;; API ----------------------------------------------------------------------
--- a/src/turing-omnibus/monte-carlo.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/turing-omnibus/monte-carlo.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,11 @@
+(defpackage :sand.turing-omnibus.monto-carlo
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils))
+
(in-package :sand.turing-omnibus.monto-carlo)
;;;; From The New Turing Omnibus, Chapter 4
--- a/src/turing-omnibus/wallpaper.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/turing-omnibus/wallpaper.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,110 +1,40 @@
+(losh:eval-dammit
+ (ql:quickload '(:trivial-ppm)))
+
+(defpackage :sand.turing-omnibus.wallpaper
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils))
+
+
(in-package :sand.turing-omnibus.wallpaper)
;;;; From The New Turing Omnibus, Chapter 1
-;;;; Config
-(defparameter *width* 600)
-(defparameter *height* 600)
-
-
-;;;; Utils
-(defmacro with-setup (&body body)
- `(progn
- (background (gray 1.0))
- ,@body))
-
-(defmacro in-context (&body body)
- `(prog1
- (push-matrix)
- (progn ,@body)
- (pop-matrix)))
-
-(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)))))
-
-(defmacro just-once (dirty-place &body body)
- `(when ,dirty-place
- (setf ,dirty-place nil)
- ,@body))
+(defun draw (width height &optional (side 200.0d0) (colors 2))
+ (declare (optimize speed)
+ (type (integer 2 4) colors)
+ (type (integer 0 50000) width height)
+ (type double-float side))
+ (let ((image (make-array (list width height)))
+ (palette #(#(86 50 16)
+ #(255 209 105)
+ #(204 132 76)
+ #(165 144 125))))
+ (time
+ (dotimes (i width)
+ (dotimes (j height)
+ (let* ((x (* i (/ side width)))
+ (y (* j (/ side height)))
+ (c (truncate (+ (* x x) (* y y)))))
+ (setf (aref image i j)
+ (elt palette (mod c colors)))))))
+ (time (trivial-ppm:write-to-file "wallpaper.ppm" image
+ :format :ppm
+ :if-exists :supersede))))
-;;;; Sketch
-(defun plot (x y color)
- (with-pen (make-pen :fill color)
- (in-context
- (translate x y)
- (rect 0 0 1 1))))
-(defsketch wallpaper
- ((width *width*) (height *height*) (y-axis :up) (title "Wallpaper")
- (copy-pixels t)
- (mouse (list 0 0))
- (mouse-down-left nil)
- (mouse-down-right nil)
- (dirty t)
- ;; Data
- (palette (iterate (repeat (random-range 2 10))
- (collect (rgb (random 1.0) (random 1.0) (random 1.0))
- :result-type 'vector)))
- (corner-a (random 100))
- (corner-b (random 100))
- (side (random-range 10.0 20.0))
- (tiles (random-range 40 110))
- (number-of-colors (length palette)))
- ;;
- (just-once dirty
- (with-setup
- (in-context
- (scale (/ *width* tiles))
- (iterate
- (for-nested ((i :from 0 :below tiles)
- (j :from 0 :below tiles)))
- (for x = (+ corner-a (* i (/ side tiles))))
- (for y = (+ corner-b (* j (/ side tiles))))
- (for c = (truncate (+ (* x x) (* y y))))
- (plot i j (aref palette (mod c number-of-colors)))))
- (with-pen (make-pen :fill (rgb 1.0 1.0 1.0))
- (rect 0 0 110 20))
- (text (format nil "Side: ~8F" side) 0 0)))
- ;;
-
- )
-
-
-;;;; Keyboard
-(defun keydown (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (:scancode-space (sketch::prepare instance))
- (:scancode-up (mulf (slot-value instance 'side) 1.01))
- (:scancode-down (mulf (slot-value instance 'side) 0.99))
- (:scancode-l (decf (slot-value instance 'corner-a)))
- (:scancode-h (incf (slot-value instance 'corner-a)))
- (:scancode-k (decf (slot-value instance 'corner-b)))
- (:scancode-j (incf (slot-value instance 'corner-b)))
- )
- (setf (slot-value instance 'dirty) t))
-
-(defun keyup (instance scancode)
- (declare (ignorable instance))
- (scancode-case scancode
- (:scancode-space nil)))
-
-
-(defmethod kit.sdl2:keyboard-event ((instance wallpaper) 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 *wallpaper* (make-instance 'wallpaper))
--- a/src/urn.lisp Thu Sep 07 15:25:54 2017 -0400
+++ b/src/urn.lisp Fri Jan 26 21:27:01 2018 -0500
@@ -1,3 +1,12 @@
+(defpackage :sand.urn
+ (:use
+ :cl
+ :losh
+ :iterate
+ :sand.quickutils
+ :sand.utils)
+ (:export))
+
(in-package :sand.urn)
(defun make-vec-from (contents)
--- a/src/utils.lisp Thu Sep 07 15:25:54 2017 -0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,6 +0,0 @@
-(in-package :sand.utils)
-
-
-(defun average4 (a b c d)
- (/ (+ a b c d) 4))
-