aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorColin Okay <colin@cicadas.surf>2022-07-19 10:58:40 -0500
committerColin Okay <colin@cicadas.surf>2022-07-19 10:58:40 -0500
commit9920cd41fe11871a835ad3f8325d779b172d2c33 (patch)
treecd311c932856f67ebc550a3c11ff41a64caca4f1
parent24b0c51a3b51c52dbba855787170107a6a7e47fb (diff)
[example] fiddling with the example
-rw-r--r--examples/12-canvas-drawing-language.lisp26
-rw-r--r--src/canvas-language.lisp5
2 files changed, 27 insertions, 4 deletions
diff --git a/examples/12-canvas-drawing-language.lisp b/examples/12-canvas-drawing-language.lisp
index 526ec2d..d79bc82 100644
--- a/examples/12-canvas-drawing-language.lisp
+++ b/examples/12-canvas-drawing-language.lisp
@@ -28,14 +28,32 @@
(defun filled-triangle-at (x y)
(ww::move-to x y)
(ww::fill-rel-path
- '((-10 100)
- (10 -30))))
+ '((100 100)
+ (100 -100))))
+
+(defun lower-the-bluer (x y)
+ (list (* 256 (/ x 500))
+ (* 256 (/ y 500))
+ 255
+ 255))
+
+(defun plaid1 (x y)
+ (list (mod (* x x) 256)
+ (mod (* y y) 256)
+ (mod (* x y) 256)
+ 255))
(defun draw-stuff (canvas time)
(declare (ignorable time))
(ww::with-canvas canvas
(triangle-at 100 100)
- (filled-triangle-at 200 200)))
+ (ww::canvas-pen-color-function #'plaid1)
+ (filled-triangle-at 250 200)
+ (ww::canvas-pen-color-function #'lower-the-bluer)
+ (ww::canvas-pen-width 2)
+ (ww::stroke-bezier
+ '((0 0) (200 120) (50 350) (200 100) (300 400))
+ 1000)))
(defmethod ww:boot ((app canvas-lang-demo ))
(let ((canvas
@@ -50,7 +68,7 @@
(ww:add-unit app canvas)
;; handlers
- (ww::add-handler canvas #'clear-and-draw)
+ (ww:add-handler canvas #'clear-and-draw)
(ww:add-handler app #'quit)
(ww:add-handler canvas #'quit)))
diff --git a/src/canvas-language.lisp b/src/canvas-language.lisp
index 24a3394..b77ad02 100644
--- a/src/canvas-language.lisp
+++ b/src/canvas-language.lisp
@@ -27,6 +27,11 @@
(defun canvas-pen-color (r g b a)
(setf *current-pen-color* (mapcar #'colfix (list r g b a))))
+(defun canvas-pen-color-function (fn)
+ (setf *current-pen-color-function*
+ (lambda (x y)
+ (mapcar #'colfix (funcall fn x y)))))
+
(defun canvas-pen-width (n)
(setf *current-pen-width* (round n)))