[example] tweaking canvas example

2 files changed, 107 insertions, 51 deletions

diff --git a/examples/10-canvas.lisp b/examples/10-canvas.lisp
index 7d701df..5539bdf 100644
--- a/examples/10-canvas.lisp
+++ b/examples/10-canvas.lisp
@@ -9,56 +9,106 @@
 
 ;;; CLASSES
 
-(defclass/std canvas-example (ww::application)
-  ())
-
-(defun color-clamp ( x)
-  (max (min (round x) 255) 0))
-
-(ww:defhandler color-shifts
-    (ww:on-perframe ()
-      (let ((time-class (1+ (mod time 256))))
-        (ww::with-pixels-rect (x y r g b a) (target)
-          (if (or (zerop (mod time-class (1+ x)))
-                  (zerop (mod time-class (1+ y))))
-              
-              (setf
-               r (mod (* x time) time-class)
-               g (mod (* y time) time-class)
-               b (mod time time-class)
-               a 255)
-              (ww::setf-many r g b a 0))))
-      (ww::blit target)))
-
-(defmethod ww::boot ((app canvas-example))
+(defclass/std sneking (ww::application)
+  ((sneks snek-pit)))
+
+(defclass/std snek ()
+  ((x y)
+   (dx dy :std 1)
+   (brain :std 0.0)
+   (bod :std (list))
+   (len :std 4)
+   (color :std (list 255 255 255))
+   (home :std (list 0 0 100 100))))
+
+(defun snek-is-home-p (snek)
+  (with-slots (x y home) snek
+    (destructuring-bind (left bottom right top) home
+      (and (<= left x (1- right))
+           (<= bottom y (1- top))))))
+
+(defun snek-change-mind (snek)
+  (when (zerop (random 2))
+    (setf (dx snek) (* -1 (dx snek))))
+  (when (zerop (random 2))
+    (setf (dy snek) (* -1 (dy snek)))))
+
+(defun advance-snek-pos (snek)
+  (with-slots (x y dx dy home bod len) snek
+    (incf x dx)
+    (incf y dy)
+    (unless (snek-is-home-p snek)
+      (decf y dy)
+      (decf x dx)
+      (snek-change-mind snek))
+    (push y bod)
+    (push x bod)
+    (when (< len (length bod)) 
+      (setf bod (nreverse (cddr (nreverse bod)))))))
+
+(defun snek-thots (snek)
+  (incf (brain snek) 0.01)
+  (when (< (random 1.0) (brain snek))
+    (setf (brain snek) 0.0)
+    (snek-change-mind snek)))
+
+(defun update-snek (snek)
+  (advance-snek-pos snek)
+  (snek-thots snek))
+
+(defun draw-snek (snek canvas)
+  (with-slots (bod color) snek
+    (destructuring-bind (red green blue) color 
+      (let ((alpha 255))
+        (loop
+          for (x y . more) on bod by #'cddr
+          do (ww::with-pixel (r g b a) (ww::pixel canvas x y)
+               (setf r red g green b blue a alpha))
+             (setf alpha (max 0 (- alpha  10))))))))
+
+
+(defun random-between (lo hi)
+  (+ lo (random (- hi lo))))
+
+(defun random-snek (&optional (boundx 100) (boundy 100))
+  (make-instance 'snek
+                 :color (list (random 256) (random 256) (random 256))
+                 :dy (random-between -1 1)
+                 :dx (random-between -1 1)
+                 :len (random-between 50 70)
+                 :home (list 0 0 boundx boundy)
+                 :x (random boundx)
+                 :y (random boundy)))
+
+(ww:defhandler sneks-a-go-go
+    (ww::on-perframe (app ticks)
+      (with-slots (sneks snek-pit) app
+        (ww::clear-canvas snek-pit)
+        (dolist (snek sneks)
+          (update-snek snek)
+          (draw-snek snek snek-pit))
+        (ww::blit snek-pit))))
+
+(defmethod ww::boot ((app sneking ))
   "Adds the intro text and sets up the start button handler."
-  (let ((c (make-instance
-            'ww::canvas
-            :pixel-height 10
-            :pixel-width 10)))
-    
-    (ww::with-pixels-rect (x y r g b a) (c)
-      (setf r (- 255 (* 25 x))
-            g (- 255 (* 25 y))
-            b (color-clamp (* 25 (+ x y)))))
-    
-    (ww::blit c)
-    (setf (ww:width c) 800
-          (ww:height c) 600)
-    
-    (ww:add-unit app c)
-    (ww:add-handler c #'color-shifts )))
-
-(defun start (&optional (scale 1.0))
+  (setf (snek-pit app)
+        (make-instance 'ww:canvas :pixel-width 100 :pixel-height 100)
+        (sneks app)
+        (loop repeat 60 collect (random-snek 100 100)))
+  (setf (ww:width (snek-pit app)) 800
+        (ww:height (snek-pit app)) 800)
+  (ww::add-unit app (snek-pit app))
+  (ww:add-handler app #'sneks-a-go-go))
+
+(defun start ()
   (ww::start
    (make-instance
-    'canvas-example 
-    :fps 30
-    :width (round (* 800 scale))
-    :height (round (* 600 scale))
-    :scale scale
+    'sneking    
+    :fps 20
+    :width 800
+    :height 800
     :refocus-on-mousedown-p nil
-    :title "canvas demo"
+    :title "sneks"
     :asset-root
     (merge-pathnames
      "examples/"
diff --git a/src/interactive/canvas.lisp b/src/interactive/canvas.lisp
index 2fa341c..ce7829b 100644
--- a/src/interactive/canvas.lisp
+++ b/src/interactive/canvas.lisp
@@ -12,6 +12,9 @@
                             :element-type 'unsigned-byte
                             :initial-element 255))))
 
+(defun pixel-offset (x y pixels)
+  (* 4 (+ x (* y (pixel-width pixels)))))
+
 (let ((cached-pixel))
   (defun pixel (pixels x y &optional (use-cached t))
     "When USE-CACHED is NIL, return a fresh array displaced to
@@ -50,8 +53,7 @@
                          (,a (aref ,pixel-var 3)))
          ,@body))))
 
-(defun pixel-offset (x y pixels)
-  (* 4 (+ x (* y (pixel-width pixels)))))
+
 
 (defmacro with-pixels-rect ((x y r g b a) (pixels &key left right top bottom) &body body)
   "Executes BODY on all pixels in the box bounded by LEFT RIGHT TOP and BOTTOM of PIXELS.
@@ -73,11 +75,15 @@
          (loop for ,x from (if ,lv ,lv 0) below (if ,rv ,rv (pixel-width ,pxs)) do
            (loop for ,y from (if ,bv ,bv 0) below (if ,tv ,tv (pixel-height ,pxs))
                  do (progn
-                      (setf  ,px (adjust-array ,px 4
-                                               :displaced-to (pixels-data ,pxs)
-                                               :displaced-index-offset (pixel-offset ,x ,y ,pxs)))
+                      (setf ,px (adjust-array ,px 4
+                                              :displaced-to (pixels-data ,pxs)
+                                              :displaced-index-offset (pixel-offset ,x ,y ,pxs)))
                       ,@body)))))))
 
+(defun clear-canvas (canvas &key (r 0) (g 0) (b 0) (a 255))
+  (with-pixels-rect (x y pr pg pb pa) (canvas)
+    (setf pr r pg g pb b pa a)))
+
 (defmacro with-pixels-line ((x y r g b a) (pixels start-x start-y end-x end-y) &body body)
   "A convenience macro for doing something to a whole line of pixels -
 e.g., drawing a line in a particular color."