From 55acc817ad919c47de39e0febe8630304792793f Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Fri, 15 Jul 2022 22:08:13 -0500
Subject: [example] tweaking canvas example

---
 examples/10-canvas.lisp | 142 ++++++++++++++++++++++++++++++++----------------
 1 file changed, 96 insertions(+), 46 deletions(-)

(limited to 'examples')

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/"
-- 
cgit v1.2.3