# HG changeset patch # User Steve Losh # Date 1517021745 18000 # Node ID 6eccaf72df12e5af24693242a823ed072e5119a1 # Parent bc8ed2a9b4c0ba46002a841f356a8de48a8f1cc5 Finish cleanup diff -r bc8ed2a9b4c0 -r 6eccaf72df12 package.lisp --- a/package.lisp Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,146 +0,0 @@ -;; (defpackage :sand.parenscript -;; (:use -;; :cl -;; :losh -;; :sand.quickutils -;; :cl-fad -;; :parenscript) -;; (:shadowing-import-from :losh -;; :%)) - -;; (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.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.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 -;; )) - -;; #+sbcl -;; (defpackage :sand.ffi -;; (:use -;; :cl -;; :losh -;; :iterate -;; :cffi -;; :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.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)) - -;; #+sbcl -;; (defpackage :sand.profiling -;; (:use -;; :cl -;; :losh -;; :iterate -;; :sand.quickutils -;; :sand.utils) -;; (:export -;; :start-profiling -;; :stop-profiling -;; :profile)) - - diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/dijkstra-maps.lisp --- a/src/dijkstra-maps.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/dijkstra-maps.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,16 @@ +(defpackage :sand.dijkstra-maps + (:use + :cl + :losh + :iterate + :sand.quickutils) + (:export + :dijkstra-map + :make-dijkstra-map + :dm-maximum-value + :dm-map + :dm-ref)) + (in-package :sand.dijkstra-maps) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/easing.lisp --- a/src/easing.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/easing.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,13 @@ +(losh:eval-dammit + (ql:quickload '(:easing))) + +(defpackage :sand.easing + (:use + :cl + :losh + :iterate + :sand.quickutils)) + (in-package :sand.easing) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/ffi.lisp --- a/src/ffi.lisp Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,130 +0,0 @@ -(in-package :sand.ffi) - - -;;;; Library ------------------------------------------------------------------ -(define-foreign-library linenoise - (:darwin "~/src/linenoise/linenoise.dylib")) - -(use-foreign-library linenoise) - - -;;;; Simple Functions --------------------------------------------------------- -(defcfun ("linenoiseClearScreen" linenoise-clear-screen) :void) - -(defcfun ("linenoiseSetMultiLine" %linenoise-set-multi-line) :void - (ml :int)) - -(defun linenoise-set-multi-line (flag) - (%linenoise-set-multi-line (convert-to-foreign flag :boolean))) - -(defcfun ("linenoiseHistorySetMaxLen" linenoise-history-set-max-length) :int - (len :int)) - -(defcfun ("linenoiseHistorySave" linenoise-history-save) :int - (filename :string)) - -(defcfun ("linenoiseHistoryLoad" linenoise-history-load) :int - (filename :string)) - -(defcfun ("linenoiseHistoryAdd" linenoise-history-add) :int - (line :string)) - -(defcfun ("linenoiseFree" linenoise-free) :void - (pointer :pointer)) - -(defun linenoise (prompt &key (add-to-history t)) - (let ((ptr (foreign-funcall "linenoise" :string prompt (:pointer :char)))) - (unwind-protect - (let ((result (convert-from-foreign ptr :string))) - (when add-to-history - (linenoise-history-add result)) - result) - (linenoise-free ptr)))) - - -;;;; Completion Callbacks ----------------------------------------------------- -(defparameter *linenoise-completion-callback* nil) - - -(defcfun ("linenoiseAddCompletion" linenoise-add-completion) :void - (lc :pointer) - (str :string)) - -(defcfun ("linenoiseSetCompletionCallback" linenoise-set-completion-callback) - :void - (callback :pointer)) - -(defcallback linenoise-completion-callback :void - ((prefix (:pointer :char)) - (lc :pointer)) - (when *linenoise-completion-callback* - (mapc (curry #'linenoise-add-completion lc) - (funcall *linenoise-completion-callback* - (convert-from-foreign prefix :string)))) - (values)) - -(linenoise-set-completion-callback (callback linenoise-completion-callback)) - - -;;;; Hints Callbacks ---------------------------------------------------------- -(defparameter *linenoise-hints-callback* nil) - -(defcfun ("linenoiseSetHintsCallback" linenoise-set-hints-callback) :void - (callback :pointer)) - -(defcfun ("linenoiseSetFreeHintsCallback" linenoise-set-free-hints-callback) - :void - (callback :pointer)) - -(defcallback linenoise-hints-callback :string - ((prefix (:pointer :char)) - (color (:pointer :int)) - (bold (:pointer :int))) - (if *linenoise-hints-callback* - (multiple-value-bind (hint hint-color hint-bold) - (funcall *linenoise-hints-callback* - (convert-from-foreign prefix :string)) - (if hint - (prog1 - (foreign-string-alloc hint) - (when hint-color - (setf (mem-ref color :int) (ecase hint-color - (:red 31) - (:green 32) - (:yellow 33) - (:blue 34) - (:magenta 35) - (:cyan 36) - (:white 37)))) - (when hint-bold - (setf (mem-ref bold :boolean) hint-bold))) - (null-pointer))) - (null-pointer))) - -(defcallback linenoise-free-hints-callback :void - ((hint-string :pointer)) - (foreign-string-free hint-string)) - -(linenoise-set-hints-callback (callback linenoise-hints-callback)) -(linenoise-set-free-hints-callback (callback linenoise-free-hints-callback)) - - -;;;; Scratch ------------------------------------------------------------------ -(defun test-compl (prefix) - (let ((result nil)) - (when (not (string= "" prefix)) - (when (char= #\f (aref prefix 0)) - (pushnew "foo" result) - (pushnew "frob" result) - (pushnew "flip" result)) - (when (char= #\b (aref prefix 0)) - (pushnew "bar" result))) - result)) - -(defun test-hint (prefix) - (when (string= "cp " prefix) - (values " " :blue t))) - - -(setf *linenoise-completion-callback* 'test-compl) -(setf *linenoise-hints-callback* 'test-hint) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/hanoi.lisp --- a/src/hanoi.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/hanoi.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,9 @@ +(defpackage :sand.hanoi + (:use + :cl + :losh + :sand.quickutils)) + (in-package :sand.hanoi) (defun move (disc from to) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/huffman-trees.lisp --- a/src/huffman-trees.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/huffman-trees.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,11 @@ +(defpackage :sand.huffman-trees + (:use + :cl + :losh + :iterate + :sand.quickutils) + (:export)) + (in-package :sand.huffman-trees) ;;;; Data --------------------------------------------------------------------- diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/linenoise.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/linenoise.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -0,0 +1,141 @@ +(losh:eval-dammit + (ql:quickload '(:cffi))) + +(defpackage :sand.linenoise + (:use + :cl + :losh + :iterate + :cffi + :sand.quickutils)) + +(in-package :sand.linenoise) + + +;;;; Library ------------------------------------------------------------------ +(define-foreign-library linenoise + (:darwin "~/src/linenoise/linenoise.dylib")) + +(use-foreign-library linenoise) + + +;;;; Simple Functions --------------------------------------------------------- +(defcfun ("linenoiseClearScreen" linenoise-clear-screen) :void) + +(defcfun ("linenoiseSetMultiLine" %linenoise-set-multi-line) :void + (ml :int)) + +(defun linenoise-set-multi-line (flag) + (%linenoise-set-multi-line (convert-to-foreign flag :boolean))) + +(defcfun ("linenoiseHistorySetMaxLen" linenoise-history-set-max-length) :int + (len :int)) + +(defcfun ("linenoiseHistorySave" linenoise-history-save) :int + (filename :string)) + +(defcfun ("linenoiseHistoryLoad" linenoise-history-load) :int + (filename :string)) + +(defcfun ("linenoiseHistoryAdd" linenoise-history-add) :int + (line :string)) + +(defcfun ("linenoiseFree" linenoise-free) :void + (pointer :pointer)) + +(defun linenoise (prompt &key (add-to-history t)) + (let ((ptr (foreign-funcall "linenoise" :string prompt (:pointer :char)))) + (unwind-protect + (let ((result (convert-from-foreign ptr :string))) + (when add-to-history + (linenoise-history-add result)) + result) + (linenoise-free ptr)))) + + +;;;; Completion Callbacks ----------------------------------------------------- +(defparameter *linenoise-completion-callback* nil) + + +(defcfun ("linenoiseAddCompletion" linenoise-add-completion) :void + (lc :pointer) + (str :string)) + +(defcfun ("linenoiseSetCompletionCallback" linenoise-set-completion-callback) + :void + (callback :pointer)) + +(defcallback linenoise-completion-callback :void + ((prefix (:pointer :char)) + (lc :pointer)) + (when *linenoise-completion-callback* + (mapc (curry #'linenoise-add-completion lc) + (funcall *linenoise-completion-callback* + (convert-from-foreign prefix :string)))) + (values)) + +(linenoise-set-completion-callback (callback linenoise-completion-callback)) + + +;;;; Hints Callbacks ---------------------------------------------------------- +(defparameter *linenoise-hints-callback* nil) + +(defcfun ("linenoiseSetHintsCallback" linenoise-set-hints-callback) :void + (callback :pointer)) + +(defcfun ("linenoiseSetFreeHintsCallback" linenoise-set-free-hints-callback) + :void + (callback :pointer)) + +(defcallback linenoise-hints-callback :string + ((prefix (:pointer :char)) + (color (:pointer :int)) + (bold (:pointer :int))) + (if *linenoise-hints-callback* + (multiple-value-bind (hint hint-color hint-bold) + (funcall *linenoise-hints-callback* + (convert-from-foreign prefix :string)) + (if hint + (prog1 + (foreign-string-alloc hint) + (when hint-color + (setf (mem-ref color :int) (ecase hint-color + (:red 31) + (:green 32) + (:yellow 33) + (:blue 34) + (:magenta 35) + (:cyan 36) + (:white 37)))) + (when hint-bold + (setf (mem-ref bold :boolean) hint-bold))) + (null-pointer))) + (null-pointer))) + +(defcallback linenoise-free-hints-callback :void + ((hint-string :pointer)) + (foreign-string-free hint-string)) + +(linenoise-set-hints-callback (callback linenoise-hints-callback)) +(linenoise-set-free-hints-callback (callback linenoise-free-hints-callback)) + + +;;;; Scratch ------------------------------------------------------------------ +(defun test-compl (prefix) + (let ((result nil)) + (when (not (string= "" prefix)) + (when (char= #\f (aref prefix 0)) + (pushnew "foo" result) + (pushnew "frob" result) + (pushnew "flip" result)) + (when (char= #\b (aref prefix 0)) + (pushnew "bar" result))) + result)) + +(defun test-hint (prefix) + (when (string= "cp " prefix) + (values " " :blue t))) + + +(setf *linenoise-completion-callback* 'test-compl) +(setf *linenoise-hints-callback* 'test-hint) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/parenscript/compiler.lisp --- a/src/parenscript/compiler.lisp Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -(in-package :sand.parenscript) - -(defun compile-parenscript-file (source) - (let* ((source-path (pathname source)) - (target-path (make-pathname :type "js" - :defaults source-path))) - (with-open-file (output target-path - :direction :output - :if-exists :supersede) - (write-string (ps-compile-file source-path) output))) - (values)) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/parenscript/hello.js --- a/src/parenscript/hello.js Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -function sayHello(name) { - return alert('Hello, ' + name + '!'); -}; -sayHello('cocks'); diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/parenscript/hello.paren --- a/src/parenscript/hello.paren Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,9 +0,0 @@ -(in-package :cl-user) - -(defun say-hello (name) - (alert (+ "Hello, " name "!"))) - - -(say-hello "cocks") - - diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/parenscript/index.html --- a/src/parenscript/index.html Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ - - - - - Parenscript Test - - - - Testing... - - diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/ropes.lisp --- a/src/ropes.lisp Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,187 +0,0 @@ -(in-package :sand.ropes) - -;;;; De-crazifying Trivia's struct pattern matching -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun struct% (name vars-and-accessors) - (with-gensyms (instance) - `(guard1 - (,instance :type ,name) (typep ,instance ',name) - ,@(iterate (for (var accessor) :in vars-and-accessors) - (unless (string= (symbol-name var) "_") - (collect `(,accessor ,instance)) - (collect `(guard1 ,var t))))))) - - (defun find-accessors (name-and-options slots-and-vars) - (destructuring-bind - (name &key (conc-name (symb name '-))) - name-and-options - (iterate (for (slot var) :in slots-and-vars) - (for accessor = (symb conc-name slot)) - (collect (list var accessor)))))) - -(defpattern struct (name-and-options &rest slots) - (let ((name-and-options (ensure-list name-and-options))) - (struct% - (first name-and-options) - (when slots - (etypecase (first slots) - (keyword (find-accessors name-and-options (subdivide slots 2))) - (symbol (find-accessors name-and-options (mapcar #'list slots slots))) - (cons slots)))))) - - -;;;; Ropes -------------------------------------------------------------------- -(deftype rope () - '(or simple-string concat)) - -(deftype non-negative-fixnum () - `(integer 0 ,most-positive-fixnum)) - -(deftype array-index () - `(integer 0 ,array-dimension-limit)) - - -(defstruct (concat (:constructor make-concat%)) - (size 0 :type non-negative-fixnum :read-only t) - (left-size 0 :type non-negative-fixnum :read-only t) - (left nil :type rope :read-only t) - (right nil :type (or null rope) :read-only t)) - -(defpattern concat (size left-size left right) - `(struct concat :size ,size :left-size ,left-size :left ,left :right ,right)) - - -(declaim (ftype (function (*) array-index) size)) - -(defun-ematch size (rope) - ((type simple-string) (length rope)) - ((concat size _ _ _) size)) - -(defun minimalp (left right) - (and (typep left 'simple-string) - (typep right 'simple-string) - (< (+ (length left) - (length right)) - 25) - t)) - -(defun make-concat (left right) - (cond ((equal right "") left) - ((equal left "") right) - ((minimalp left right) (concatenate 'string left right)) - (t (make-concat% :size (+ (size left) (size right)) - :left-size (size left) - :left left - :right right)))) - - -(defmacro sanity-check ((rope &optional indexes char) - &body body) - `(progn - (check-type ,rope rope) - ,@(when char - `((check-type ,char character))) - ,@(when indexes - (mapcar (lambda (i) `(check-type ,i array-index)) - indexes)) - (locally - (declare (type rope ,rope) - ,@(when indexes `((type array-index ,@indexes))) - ,@(when char `((type character ,char)))) - ,@(mapcar (lambda (i) `(assert (< ,i (size ,rope)) - (,rope ,i) - "Index ~D is out of bounds for rope ~S" - ,i ,rope)) - indexes) - ,@body))) - - -;;;; Lookup -(declaim (ftype (function (rope array-index) (values character &optional)) - lookup%)) -(defun lookup% (rope index) - ; (declare (optimize (speed 3) (safety 0) (debug 0))) - (ematch rope - ((type simple-string) - (aref rope index)) - - ((concat _ left-size left right) - (if (< index left-size) - (lookup% left index) - (lookup% right (- index left-size)))))) - -(defun lookup (rope index) - (sanity-check (rope (index)) - (lookup% rope index))) - - -;;;; Set -(defun set-char% (rope index new-char) - (ematch rope - ((type string) (let ((result (copy-seq rope))) - (setf (aref result index) new-char) - result)) - ((concat _ left-size left right) - (if (< index left-size) - (make-concat (set-char left index new-char) - right) - (make-concat left - (set-char right (- index left-size) new-char)))))) - -(defun set-char (rope index new-char) - (sanity-check (rope (index) new-char) - (set-char% rope index new-char))) - - -;;;; Concat -(defun rope-concat (left right) - (sanity-check (left) - (sanity-check (right) - (make-concat left right)))) - - -;;;; Substring -(declaim (ftype (function (rope array-index array-index) - (values rope &optional)) - rope-substring%)) - -(defun rope-substring% (rope start end) - ; (declare (optimize (speed 3) (safety 0) (debug 0))) - (etypecase rope - (simple-string (subseq rope start end)) - (concat (let ((ls (concat-left-size rope))) - (cond ((< end ls) (rope-substring% (concat-left rope) - start - end)) - ((>= start ls) (rope-substring% (concat-right rope) - (- start ls) - (- end ls))) - (t (make-concat - (rope-substring% (concat-left rope) start ls) - (rope-substring% (concat-right rope) 0 (- end ls))))))))) - -(defun rope-substring (rope start end) - (sanity-check (rope (start end)) - (rope-substring% rope start end))) - - -;;;; Stringifying -(declaim (ftype (function (rope) (values simple-string &optional)) - rope-to-string%)) - -(defun rope-to-string% (rope) - (declare (optimize (speed 3) (safety 0) (debug 0))) - (ematch rope - ((type simple-string) rope) - ((concat _ _ left right) - (concatenate 'string - (rope-to-string% left) - (rope-to-string% right))))) - -(defun rope-to-string (rope) - (sanity-check (rope) - (rope-to-string% rope))) - - -;;;; Scratch -(defparameter *r* (rope-concat "foo" "bar")) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/serializing-functions.lisp --- a/src/serializing-functions.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/serializing-functions.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,15 @@ +(losh:eval-dammit + (ql:quickload '(:cl-conspack :storable-functions))) + +(defpackage :sand.serializing-functions + (:use + :cl + :losh + :iterate + :sand.quickutils)) + + + (in-package :sand.serializing-functions) (conspack:defencoding st-fun::function-referrer diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/sketch.lisp --- a/src/sketch.lisp Fri Jan 26 21:27:01 2018 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,198 +0,0 @@ -(in-package :sand.sketch) - -;;;; Config -; (setf *bypass-cache* t) -(defparameter *wat* nil) -(defparameter *width* 600) -(defparameter *height* 600) - - -(defparameter *center-x* (/ *width* 2)) -(defparameter *center-y* (/ *height* 2)) - - -(defvar *shift* nil) -(defvar *control* nil) -(defvar *command* nil) -(defvar *option* nil) - - -(defparameter *black-pen* - (make-pen :stroke (rgb 0 0 0) :fill (rgb 0.4 0.4 0.4) :weight 1 :curve-steps 50)) - -(defparameter *red-pen* - (make-pen :stroke (rgb 0.6 0 0) :fill (rgb 0.9 0 0) :weight 1 :curve-steps 50)) - -(defparameter *green-pen* - (make-pen :stroke (rgb 0 0.6 0) :fill (rgb 0 0.9 0) :weight 1 :curve-steps 50)) - -(defparameter *blue-pen* - (make-pen :stroke (rgb 0 0 0.6) :fill (rgb 0 0 0.9) :weight 1 :curve-steps 50)) - - -;;;; 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)) - - -;;;; Sketch -(defsketch demo - ((width *width*) (height *height*) (y-axis :up) (title "Sketch") - (copy-pixels t) - (mouse (list 0 0)) - (mouse-down-left nil) - (mouse-down-right nil) - (dirty t) - ;; Data - (palette (iterate (repeat 45) - (collect (rgb (random 1.0) (random 1.0) (random 1.0))))) - (ideal (rgb (random 1.0) (random 1.0) (random 1.0))) - (lol (progn - - ))) - ;; - (just-once dirty - (with-setup - (iterate - (with tile-size = 40) - (with tile-count = (/ *width* tile-size)) - (for-nested ((y :from 0 :below 100) - (x :from 0 :below tile-count))) - (for color :in palette) - (with-pen (make-pen :fill color) - (rect (* x tile-size) (* y tile-size) tile-size tile-size))) - (text "Ideal Color" 0 (- *center-y* 20)) - (with-pen (make-pen :fill ideal) - (rect 0 *center-y* - (- (/ *width* 2) 10) - (/ *height* 2))) - (text "Closest Color" (+ 10 *center-x*) (- *center-y* 20)) - (with-pen (make-pen :fill (gray 0.5)) - (rect (+ 10 *center-x*) *center-y* - (- (/ *width* 2) 10) - (/ *height* 2))))) - ;; - - ) - - -;;;; Mouse -(defun mouse-in-bounds-p (x y) - (and (>= x 0) - (>= y 0) - (< x *width*) - (< y *height*))) - -(defun mousemove (instance x y) - (when (mouse-in-bounds-p x y) - (with-slots (mouse) instance - (setf mouse (list x (- *height* y 1))) - ;; - - ;; - )) - ) - - -(defun mousedown-left (instance x y) - (when (mouse-in-bounds-p x y) - (setf (slot-value instance 'mouse-down-left) t) - ;; - (mousemove instance x y) - ;; - )) - -(defun mousedown-right (instance x y) - (when (mouse-in-bounds-p x y) - (setf (slot-value instance 'mouse-down-right) t) - ;; - (mousemove instance x y) - ;; - )) - -(defun mouseup-left (instance x y) - (declare (ignorable x y)) - (setf (slot-value instance 'mouse-down-left) nil) - ;; - ) - -(defun mouseup-right (instance x y) - (declare (ignorable x y)) - (setf (slot-value instance 'mouse-down-right) nil) - ) - - -(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 -(defun keydown (instance scancode) - (declare (ignorable instance)) - (scancode-case scancode - (:scancode-space (sketch::prepare instance)) - (:scancode-lshift (setf *shift* t)) - (:scancode-lctrl (setf *control* t)) - (:scancode-lgui (setf *command* t)) - (:scancode-lalt (setf *option* t)) - ;; - ;; - )) - -(defun keyup (instance scancode) - (declare (ignorable instance)) - (scancode-case scancode - (:scancode-lshift (setf *shift* nil)) - (:scancode-lctrl (setf *control* nil)) - (:scancode-lgui (setf *command* nil)) - (:scancode-lalt (setf *option* nil)) - (:scancode-space nil))) - - -(defmethod kit.sdl2:keyboard-event ((instance demo) state timestamp repeatp keysym) - (declare (ignore timestamp repeatp)) - (cond - ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym))) - ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym))) - (t nil))) - - -;;;; Run -; (defparameter *demo* (make-instance 'demo)) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/streams.lisp --- a/src/streams.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/streams.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,10 @@ +(defpackage :sand.streams + (:use + :cl + :losh + :iterate + :sand.quickutils)) + (in-package :sand.streams) @@ -40,7 +47,7 @@ (defmacro str* (&rest args) (if (null (cdr args)) (car args) - `(scons ,(car args) (stream* ,@(cdr args))))) + `(scons ,(car args) (str* ,@(cdr args))))) (defun str (&rest args) (if (null args) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/surreal-numbers.lisp --- a/src/surreal-numbers.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/surreal-numbers.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,10 @@ +(defpackage :sand.surreal-numbers + (:use + :cl + :losh + :iterate + :sand.quickutils)) + (in-package :sand.surreal-numbers) diff -r bc8ed2a9b4c0 -r 6eccaf72df12 src/terrain/diamond-square.lisp --- a/src/terrain/diamond-square.lisp Fri Jan 26 21:27:01 2018 -0500 +++ b/src/terrain/diamond-square.lisp Fri Jan 26 21:55:45 2018 -0500 @@ -1,3 +1,10 @@ +(defpackage :sand.terrain.diamond-square + (:use + :cl + :losh + :iterate + :sand.quickutils)) + (in-package :sand.terrain.diamond-square) @@ -45,18 +52,20 @@ (defun ds-square (heightmap x y radius spread) (setf (aref heightmap x y) - (random-around (average4 (hm-ref heightmap (- x radius) (- y radius)) - (hm-ref heightmap (- x radius) (+ y radius)) - (hm-ref heightmap (+ x radius) (- y radius)) - (hm-ref heightmap (+ x radius) (+ y radius))) + (random-around (/ (+ (hm-ref heightmap (- x radius) (- y radius)) + (hm-ref heightmap (- x radius) (+ y radius)) + (hm-ref heightmap (+ x radius) (- y radius)) + (hm-ref heightmap (+ x radius) (+ y radius))) + 4) spread))) (defun ds-diamond (heightmap x y radius spread) (setf (aref heightmap x y) - (random-around (average4 (hm-ref heightmap (- x radius) y) - (hm-ref heightmap (+ x radius) y) - (hm-ref heightmap x (- y radius)) - (hm-ref heightmap x (+ y radius))) + (random-around (/ (+ (hm-ref heightmap (- x radius) y) + (hm-ref heightmap (+ x radius) y) + (hm-ref heightmap x (- y radius)) + (hm-ref heightmap x (+ y radius))) + 4) spread)))