Better channels, revised examples

vydd · 934d31de05af1eade82ddc92ca566721cf104539 · vydd committed Dec 26, 2015 · Dec 26, 2015 · 934d31d
1 parent 5ebcec0
commit 934d31de05af1eade82ddc92ca566721cf104539
Unified Split

Showing with 112 additions and 69 deletions.

+8 −20 examples/brownian.lisp

+1 −1 examples/hello-world.lisp

+2 −2 sketch.asd

+69 −44 src/channels.lisp

+32 −2 src/sketch.lisp
@@ -9,16 +9,12 @@
 ;; |____/|_| \_\\___/  \_/\_/  |_| \_|___/_/   \_\_| \_|
 
 (defsketch brownian
-    (:title "Brownian" :width 800 :height 600
-	    :framerate :auto :copy-pixels t :debug :scancode-f1)
+    (:title "Brownian" :width 800 :height 600 :copy-pixels t :debug :scancode-f1)
     ((pos '(400 . 300)) (dir '(1 . 0))
-     (pen (make-pen :stroke (gray 0.5) :weight 1))
-     (bg (gray 1))
-     (len 3)
-     (flower-pos nil)
-     (flower-timer 30)
-     (flower-color nil)
-     (flower-size (+ 200 (random 200))))
+     (pen (make-pen :stroke (gray 0.5) :fill (gray 0.5) :weight 1))
+     (line-length 3)
+     (points (make-array 256 :initial-element (cons 400 300)))
+     (points-pointer 0))
   (flet ((draw (paces)
 	   (dotimes (i paces)
 	     (let ((new-pos (cons (+ (car pos) (car dir))
@@ -31,17 +27,9 @@
 	     (setf dir (cons (cos (radians a))
 			     (sin (radians a)))))))
     (rotate (- (random 180) 90))
-    (draw (+ (random len) len))
+    (draw (+ (random line-length) line-length))
     (setf (car pos) (alexandria:clamp (car pos) -10 810)
-	  (cdr pos) (alexandria:clamp (cdr pos) -10 610))
-    (setf flower-timer (mod (+ flower-timer 1) flower-size))
-    (when flower-pos
-      (with-pen (make-pen :fill flower-color)
-	(ellipse (car flower-pos) (cdr flower-pos) (/ flower-timer 40) (/ flower-timer 40))))
-    (when (zerop flower-timer)
-      (setf flower-pos pos
-	    flower-color (random-color)
-	    flower-size (+ 200 (random 200))))))
+	  (cdr pos) (alexandria:clamp (cdr pos) -10 610))))
 
 (define-sketch-setup brownian
-  (background bg))
+  (background (gray 1)))
@@ -10,5 +10,5 @@
 
 (defsketch hello-world (:title "Hello, World!" :debug :scancode-f1) ()
   (background (gray 0.6))
-  (with-pen (make-pen :stroke (rgb 1 1 0) :weight 2)
+  (with-pen (make-pen :fill (rgb 0.380 0.695 0.086) :stroke (rgb 1 1 0) :weight 4)
     (polygon 200 40 40 360 360 360)))
@@ -17,6 +17,7 @@
   :components ((:file "package")
 	       (:file "math")
 	       (:file "utils" :depends-on ("package" "math"))
+	       (:file "channels" :depends-on ("package" "utils"))
 	       (:file "shaders" :depends-on ("package"))
 	       (:file "environment" :depends-on ("package" "shaders"))
 	       (:file "color" :depends-on ("package" "utils"))
@@ -25,5 +26,4 @@
 	       (:file "drawing" :depends-on ("package" "geometry"))
 	       (:file "shapes" :depends-on ("package" "drawing"))
 	       (:file "transforms" :depends-on ("package" "environment"))
-               (:file "sketch")
-	       (:file "channels" :depends-on ("sketch"))))
+               (:file "sketch")))
@@ -11,8 +11,6 @@
 ;;; Channel interface
 
 (defparameter *channels* (make-hash-table))
-(defparameter *channel-propagators* (make-hash-table))
-(defparameter *channel-propagator-body-hashes* '())
 
 (defun drop-first (&optional a b) (declare (ignore a)) b)
 
@@ -23,11 +21,12 @@
 	    (cons (cons reducer (funcall reducer))
 		  channel-reducers)))))
 
-(defun in (channel &optional (reducer #'drop-first))
+(defun in (channel &optional (initial nil) (reducer #'drop-first))
   (register-input channel reducer)
-  (cdr (assoc reducer (gethash channel *channels*))))
+  (let ((a (assoc reducer (gethash channel *channels*))))
+    (if a (cdr a) initial)))
 
-(defun out (channel message)
+(defun out-1 (channel message)
   (register-input channel #'drop-first)
   (mapcar (lambda (reducer-value-cons)
 	    (setf (cdr reducer-value-cons)
@@ -37,10 +36,24 @@
 	  (gethash channel *channels*))
   (propagate channel))
 
+(defun out (&rest channel-message)
+  (mapcar (lambda (x) (out-1 (first x) (second x)))
+	  (group channel-message)))
+
 ;;; Channel propagation
 
+(defstruct propagation
+  name
+  inputs
+  outputs
+  function)
+
+(defparameter *propagations* (make-hash-table))
+(defparameter *channel-propagations* (make-hash-table))
+
 (defun propagate (channel)
-  (mapcar #'funcall (gethash channel *channel-propagators*)))
+  (mapcar (lambda (p) (funcall (propagation-function p)))
+	  (gethash channel *channel-propagations*)))
 
 (defun find-inputs-and-outputs (body)
   (let ((flat-body (alexandria:flatten body))
@@ -57,45 +70,57 @@
     inputs-and-outputs))
 
 (defun extract-input-registration (body)
-  (mapcar
-   (lambda (in-form) (cons 'register-in (cdr in-form)))
-   (remove-if #'atom (flatten body (lambda (x) (eql (car x) 'in))))))
-
-(defmacro define-channel-propagation (&body body)
-  (let* ((body-hash (object-to-keyword-hash body))
-	 (inputs-and-outputs (find-inputs-and-outputs body))
+  (mapcar (lambda (in-form) (cons 'register-input (cdr in-form)))
+	  (remove-if #'atom (flatten body (lambda (x) (eql (car x) 'in))))))
+
+(defun delete-channel-propagation (channel propagation)
+  (setf (gethash channel *channel-propagations*)
+	(remove-if (lambda (x) (eql x propagation))
+		   (gethash channel *channel-propagations*))))
+
+(defun update-propagation-data (name inputs outputs)
+  (let ((propagation (gethash name *propagations*)))
+    (if propagation
+      (mapcar (lambda (channel)
+		(delete-channel-propagation channel propagation))
+	      (propagation-inputs propagation))
+      (setf propagation (make-propagation :name name)
+	    (gethash name *propagations*) propagation))
+    (setf (propagation-inputs propagation) inputs
+	  (propagation-outputs propagation) outputs)
+    (mapcar (lambda (channel)
+	      (push propagation (gethash channel *channel-propagations*)))
+	    inputs)))
+
+(defmacro define-channel-propagation (name &body body)
+  (let* ((inputs-and-outputs (find-inputs-and-outputs body))
 	 (inputs (cdr (assoc 'in inputs-and-outputs)))
-	 (input-registrations (extract-input-registration body))
-	 (channels (append (assoc 'in inputs-and-outputs)
-			   (assoc 'out inputs-and-outputs))))
-    (unless (member body-hash *channel-propagator-body-hashes*)
-      (push body-hash *channel-propagator-body-hashes*)
-      `(progn
-	 ,@input-registrations
-	 ,@(mapcar (lambda (input)
-		     `(push (lambda () ,@body)
-			    (gethash ,input *channel-propagators*)))
-		   inputs)))))
-
-;;; Utility reset functions
+	 (outputs (cdr (assoc 'out inputs-and-outputs)))
+	 (input-registrations (extract-input-registration body)))
+    (update-propagation-data name inputs outputs)
+    `(progn
+       ,@input-registrations
+       (setf (propagation-function (gethash ',name *propagations*))
+	      (lambda () ,@body))
+       (mapcar #'propagate ',inputs))))
+
+;;; Utility functions
+
+(defun reset-channel (channel)
+  (remhash channel *channels*)
+  (remhash channel *channel-propagations*)
+  (maphash (lambda (name propagation)
+	     (setf (propagation-inputs propagation)
+		   (remove-if (lambda (x) (eql x channel))
+			      (propagation-inputs propagation))
+		   (propagation-outputs propagation)
+		   (remove-if (lambda (x) (eql x channel))
+			      (propagation-outputs propagation))))
+	   *propagations*)
+  nil)
 
 (defun reset-all-channels ()
   (setf *channels* (make-hash-table)
-	*channel-propagators* (make-hash-table)
-	*channel-propagator-body-hashes* '()))
-
-;;; Default Sketch channels
-
-(defmethod kit.sdl2:mousewheel-event ((sketch-window sketch) timestamp x y)
-  (out :mouse-wheel (cons x y))
-  (out :mouse-wheel-x x)
-  (out :mouse-wheel-y y))
-
-(defmethod kit.sdl2:mousemotion-event ((sketch-window sketch)
-				       timestamp button-mask x y xrel yrel)
-  (out :mouse (cons x y))
-  (out :mouse-x x)
-  (out :mouse-y y)
-  (out :mouse-rel (cons xrel yrel))
-  (out :mouse-xrel xrel)
-  (out :mouse-yrel yrel))
+	*propagations* (make-hash-table)
+	*channel-propagations* (make-hash-table))
+  nil)
@@ -68,7 +68,8 @@ used for drawing.")
   (with-slots (env width height restart-sketch copy-pixels) sketch-window
     (with-environment env
       (with-pen *default-pen*
-	(background (gray 0.4))
+	(unless copy-pixels
+	  (background (gray 0.4)))
 	;; Restart sketch on setup and when recovering from an error.
 	(when restart-sketch
 	  (gl-catch (rgb 1 1 0)
@@ -132,6 +133,9 @@ all slot names."
     (setf (gethash sketch-name *sketch-slot-hash-table*) slots)
 
     `(progn
+
+       ;; Sketch Initialization
+
        (defclass ,sketch-name (sketch)
 	 ,initforms)
 
@@ -157,7 +161,33 @@ all slot names."
 	     (with-slots (env) sketch-window
 	       (when (and (env-red-screen env)
 			  (sdl2:scancode= (sdl2:scancode-value keysym) ,debug-scancode))
-		 (setf (env-debug-key-pressed env) t))))))))
+		 (setf (env-debug-key-pressed env) t)))))
+
+       ;; Sketch Events
+
+       (out :mouse-wheel '(0 . 0) :mouse-wheel-x 0 :mouse-wheel-y 0
+	    :mouse '(0 . 0) :mouse-x 0 :mouse-y 0
+	    :mouse-rel '(0 . 0) :mouse-xrel 0 :mouse-yrel 0
+	    :mouse-button 0)
+
+       (defmethod kit.sdl2:mousewheel-event :after ((sketch-window ,sketch-name)
+						    timestamp x y)
+	 (out :mouse-wheel (cons x y)
+	      :mouse-wheel-x x
+	      :mouse-wheel-y y))
+
+       (defmethod kit.sdl2:mousemotion-event :after ((sketch-window ,sketch-name)
+						     timestamp button-mask x y xrel yrel)
+	 (out :mouse (cons x y)
+	      :mouse-x x
+	      :mouse-y y
+	      :mouse-rel (cons xrel yrel)
+	      :mouse-xrel xrel
+	      :mouse-yrel yrel))
+
+       (defmethod kit.sdl2:mousebutton-event :after ((sketch-window ,sketch-name)
+						     state timestamp button x y)
+	 (out :mouse-button button)))))
 
 (defmacro define-sketch-setup (sketch-name &body body)
   "Defines a sketch SETUP method. Body is wrapped with WITH-SLOTS for all slots defined."