--- 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))
-
-
--- 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)
--- 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)
--- 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 "<source> <dest>" :blue t)))
-
-
-(setf *linenoise-completion-callback* 'test-compl)
-(setf *linenoise-hints-callback* 'test-hint)
--- 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)
--- 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 ---------------------------------------------------------------------
--- /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 "<source> <dest>" :blue t)))
+
+
+(setf *linenoise-completion-callback* 'test-compl)
+(setf *linenoise-hints-callback* 'test-hint)
--- 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))
--- 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');
--- 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")
-
-
--- 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 @@
-<!DOCTYPE html>
-
-<html>
- <head>
- <title>Parenscript Test</title>
- <script src='hello.js'></script>
- </head>
- <body>
- Testing...
- </body>
-</html>
--- 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"))
--- 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
--- 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))
--- 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)
--- 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)
--- 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)))