diff options
| -rw-r--r-- | examples/10-canvas.lisp | 142 | ||||
| -rw-r--r-- | src/interactive/canvas.lisp | 16 |
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." |