Skip to content
Browse files

Better channels, revised examples

1 parent 5ebcec0 commit 934d31de05af1eade82ddc92ca566721cf104539 @vydd committed
Showing with 112 additions and 69 deletions.
  1. +8 −20 examples/brownian.lisp
  2. +1 −1 examples/hello-world.lisp
  3. +2 −2 sketch.asd
  4. +69 −44 src/channels.lisp
  5. +32 −2 src/sketch.lisp
View
28 examples/brownian.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)))
View
2 examples/hello-world.lisp
@@ -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)))
View
4 sketch.asd
@@ -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")))
View
113 src/channels.lisp
@@ -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)
View
34 src/sketch.lisp
@@ -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."

0 comments on commit 934d31d

Please sign in to comment.
Something went wrong with that request. Please try again.