# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1481145125 18000
# Node ID 378a7aae37e31c58c167ee2a004341b2191727db
# Parent  184af4c4e8fc9293dc6c578e7d27731697a29de8
Add some wallpaper

diff -r 184af4c4e8fc -r 378a7aae37e3 .lispwords
--- a/.lispwords	Wed Dec 07 15:14:38 2016 -0500
+++ b/.lispwords	Wed Dec 07 16:12:05 2016 -0500
@@ -3,3 +3,4 @@
 (1 just-once)
 (1 bdd-case)
 (1 sanity-check)
+(1 scancode-case)
diff -r 184af4c4e8fc -r 378a7aae37e3 package.lisp
--- a/package.lisp	Wed Dec 07 15:14:38 2016 -0500
+++ b/package.lisp	Wed Dec 07 16:12:05 2016 -0500
@@ -98,6 +98,20 @@
     :degrees
     :radians))
 
+(defpackage :sand.wallpaper
+  (:use
+    :cl
+    :losh
+    :sketch
+    :iterate
+    :sand.quickutils
+    :sand.utils)
+  (:shadowing-import-from :iterate
+    :in)
+  (:shadowing-import-from :sketch
+    :degrees
+    :radians))
+
 (defpackage :sand.markov
   (:use
     :cl
diff -r 184af4c4e8fc -r 378a7aae37e3 sand.asd
--- a/sand.asd	Wed Dec 07 15:14:38 2016 -0500
+++ b/sand.asd	Wed Dec 07 16:12:05 2016 -0500
@@ -62,11 +62,12 @@
                  (:file "huffman-trees")
                  (:file "streams")
                  (:file "color-difference")
-                 (:file "number-letters")
+                 #+sbcl (:file "number-letters")
                  (:module "terrain"
                   :serial t
                   :components ((:file "diamond-square")))
                  (:module "parenscript"
                   :serial t
                   :components ((:file "compiler")))
-                 (:file "sketch")))))
+                 (:file "sketch")
+                 (:file "wallpaper")))))
diff -r 184af4c4e8fc -r 378a7aae37e3 src/wallpaper.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wallpaper.lisp	Wed Dec 07 16:12:05 2016 -0500
@@ -0,0 +1,110 @@
+(in-package :sand.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))
+
+
+;;;; 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))