# HG changeset patch # User Steve Losh # Date 1517020021 18000 # Node ID bc8ed2a9b4c0ba46002a841f356a8de48a8f1cc5 # Parent ddd06eaac1cb585f60a3df8de40fe370f6f1fd8c Start cleaning this repo up diff -r ddd06eaac1cb -r bc8ed2a9b4c0 .hgignore --- 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 diff -r ddd06eaac1cb -r bc8ed2a9b4c0 package.lisp --- 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)) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 sand.asd --- 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"))) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/ascii.lisp --- 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) - diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/color-difference.lisp --- 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)) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/generic-arithmetic.lisp --- 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) ;;;; ________ __________ __ __________ _ _________ ____ ______ diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/graphs.lisp --- 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)))) - - diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/graphviz.lisp --- 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))))) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/istruct.lisp --- 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 ----------------------------------------------------------------- diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/mandelbrot.lisp --- 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))) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/names.lisp --- 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))) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/number-letters.lisp --- 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)))) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/qud.lisp --- 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) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/random-numbers.lisp --- 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)) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/sorting.lisp --- 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*) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/turing-omnibus/minimax.lisp --- 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 ---------------------------------------------------------------------- diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/turing-omnibus/monte-carlo.lisp --- 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 diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/turing-omnibus/wallpaper.lisp --- 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)) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/urn.lisp --- 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) diff -r ddd06eaac1cb -r bc8ed2a9b4c0 src/utils.lisp --- 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)) -