422 lines
15 KiB
Scheme
422 lines
15 KiB
Scheme
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(require scheme/class)
|
|
(require mzlib/string)
|
|
|
|
(osc-destination "osc.udp://127.0.0.255:4001")
|
|
(osc-source "4002")
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; pixel primitive things for getting connection points
|
|
|
|
; converts a 2D vector into an angle, with some dodgy dave maths
|
|
(define (2dvec->angle x y)
|
|
(let ((q (/ 3.141 2)))
|
|
(when (zero? y) (set! y 0.0001))
|
|
(cond
|
|
((>= y 0)
|
|
(fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
|
|
(else
|
|
(fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))
|
|
|
|
(define (i->pos i)
|
|
(vector (modulo i (pixels-width))
|
|
(quotient i (pixels-width)) 0))
|
|
|
|
(define (pos->i pos)
|
|
(+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))
|
|
|
|
(define (pixels-ref name pos)
|
|
(pdata-ref name (pos->i pos)))
|
|
|
|
(define (pixels-set! name pos s)
|
|
(pdata-set! name (pos->i pos) s))
|
|
|
|
(define (search i)
|
|
(cond
|
|
((eq? i (pdata-size)) i)
|
|
((< (vr (pdata-ref "c" i)) 0.5) i)
|
|
(else (search (+ i 1)))))
|
|
|
|
(define (flood pos tc av)
|
|
(define (rec-flood pos)
|
|
(pixels-set! "c" pos (vector 1 0 1))
|
|
(set! tc (+ tc 1))
|
|
(set! av (vadd av pos))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector -1 0 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 1 0 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 0 1 0))))
|
|
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
|
|
(rec-flood (vadd pos (vector 0 -1 0)))))
|
|
(rec-flood pos)
|
|
(vmul av (/ 1 tc)))
|
|
|
|
(define (find-centroids pos l)
|
|
(let ((i (search pos)))
|
|
(cond ((eq? i (pdata-size)) l)
|
|
(else
|
|
(find-centroids i
|
|
(cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))
|
|
|
|
(define (convert-to-pos l)
|
|
(map
|
|
(lambda (cp)
|
|
(vector (- (- (/ (vx cp) (pixels-width)) 0.5))
|
|
(- 1 (/ (vy cp) (pixels-height))) 0))
|
|
l))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; a cache for the connection points - should save this out
|
|
|
|
(define connection-cache '())
|
|
|
|
(define (get-connection-list id)
|
|
(let ((ret (assoc id connection-cache)))
|
|
(cond
|
|
(ret (cdr ret))
|
|
(else
|
|
(let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
|
|
(connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
|
|
(set! connection-cache (cons (cons id connections) connection-cache))
|
|
(destroy tex)
|
|
connections)))))
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; a plant component
|
|
|
|
(define-struct component (root children))
|
|
|
|
(define (build-component id children)
|
|
(cond
|
|
((null? children)
|
|
(let ((root (with-state
|
|
(translate (vector 0 0.5 0))
|
|
(rotate (vector 0 0 180))
|
|
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
|
(build-plane))))
|
|
(make-component root '())))
|
|
(else
|
|
(let* ((connection-list (get-connection-list id))
|
|
(root (with-state
|
|
(translate (vector 0 0.5 (* 0.1 (rndf))))
|
|
(rotate (vector 0 0 180))
|
|
(texture (load-texture (string-append "textures/comp-" id ".png")))
|
|
(build-plane)))
|
|
(comp (make-component root
|
|
(map
|
|
(lambda (child connection)
|
|
(with-state
|
|
(parent root)
|
|
(translate (vadd connection (vector 0 0 (* 0.1 (rndf)))))
|
|
(rotate (vector 0 0 (2dvec->angle
|
|
(vx connection) (- (vy connection) 0.5))))
|
|
(rotate (vector 0 0 0))
|
|
(build-component (car child) (cadr child))))
|
|
children
|
|
connection-list))))
|
|
(with-primitive root (apply-transform))
|
|
comp))))
|
|
|
|
(define (random-leaf component)
|
|
(cond
|
|
((null? (component-children component)) component)
|
|
(else (random-leaf (choose (component-children component))))))
|
|
|
|
|
|
(define (component-print component)
|
|
(printf "~a~n" (component-children component)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; utils for building random plants
|
|
|
|
(define (choose l)
|
|
(list-ref l (random (length l))))
|
|
|
|
(define (make-random-plant depth)
|
|
(let ((num-children (if (> depth 3) 0 (choose (list 0 1 2 3)))))
|
|
(cond
|
|
((eq? num-children 0) (list (choose (list "2" "3" "4" "5" "6" "7" "8" "9" "10")) (list)))
|
|
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)))))
|
|
((eq? num-children 3) (list "3-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
|
|
((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)))))
|
|
((eq? num-children 5) (list "5-1" (list (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
|
|
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; the world things live in
|
|
|
|
(define world%
|
|
(class object%
|
|
(init-field (size 1))
|
|
|
|
(field
|
|
(root 0)
|
|
(entity-list '())
|
|
(id 0)
|
|
(pollen 0))
|
|
|
|
(define/public (init)
|
|
|
|
(set! pollen (with-state
|
|
(translate (vector 0 0 0.1))
|
|
(texture (load-texture "textures/pollen.png"))
|
|
(build-particles 300)))
|
|
|
|
(with-primitive pollen
|
|
(hint-depth-sort)
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(vmul (vector (crndf) (crndf) 0) 10))
|
|
"p")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector (rndf) (rndf) (rndf) 0.5))
|
|
"c")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(let ((s (* 0.1 (grndf))))
|
|
(vector s s 1)))
|
|
"s"))
|
|
|
|
|
|
#;(set! root (with-state
|
|
(rotate (vector 90 0 0))
|
|
(scale 100)
|
|
(build-plane)))
|
|
(with-state
|
|
(hint-depth-sort)
|
|
; (parent root)
|
|
(with-state
|
|
(colour 0.5)
|
|
(scale (vector 20 13 1))
|
|
(translate (vector 0 0.4 0))
|
|
(rotate (vector 0 0 180))
|
|
(texture (load-texture "textures/bg.png"))
|
|
(hint-unlit)
|
|
(build-plane))
|
|
(with-state
|
|
(scale (vector 19 8 1))
|
|
(translate (vector 0 0.2 1.5))
|
|
(rotate (vector 0 0 180))
|
|
(texture (load-texture "textures/mid.png"))
|
|
(hint-unlit)
|
|
(build-plane))))
|
|
|
|
(define (inc-id!)
|
|
(set! id (+ id 1)))
|
|
|
|
(define/public (get-entity-list)
|
|
entity-list)
|
|
|
|
(define/public (get-entity id)
|
|
(foldl
|
|
(lambda (entity ret)
|
|
(if (eq? (send entity get-id) id)
|
|
entity
|
|
ret))
|
|
#f
|
|
entity-list))
|
|
|
|
(define/public (choose)
|
|
(list-ref entity-list (random (length entity-list))))
|
|
|
|
(define/public (add-entity entity)
|
|
(inc-id!)
|
|
(send entity set-id! id)
|
|
(set! entity-list (cons entity entity-list))
|
|
id)
|
|
|
|
(define/public (destroy-entity id)
|
|
(set! plants
|
|
(filter
|
|
(lambda (entity)
|
|
(cond ((eq? (send entity get-id) id)
|
|
(send entity destroy)
|
|
#f)
|
|
(else #t)))
|
|
entity-list)))
|
|
|
|
(define/public (update)
|
|
(with-primitive pollen
|
|
(animate-pollen))
|
|
(for-each
|
|
(lambda (entity)
|
|
(send entity update this))
|
|
entity-list))
|
|
|
|
; pollen stuff
|
|
|
|
(define (animate-pollen)
|
|
(pdata-map!
|
|
(lambda (p)
|
|
(let* ((pp (vmul p 0.5))
|
|
(v (vector (- (noise (vx pp) (vy pp) (time)) 0.5)
|
|
(- (noise (vx pp) (+ (vy pp) 112.3) (time)) 0.5) 0)))
|
|
(vadd (vadd p (vmul v 0.2))
|
|
(vmul (vector (crndf) (crndf) 0) 0.01))))
|
|
"p"))
|
|
|
|
(define (cirndvec)
|
|
(let ((o (srndvec)))
|
|
(vector (vx o) (vy o) 0)))
|
|
|
|
(define/public (puff-pollen pos col size np)
|
|
(with-primitive pollen
|
|
(for ((i (in-range 0 np)))
|
|
(let ((c (random (pdata-size)))
|
|
(cc (vadd col (vmul (grndvec) 0.2))))
|
|
(pdata-set! "p" c (vadd (vmul (cirndvec) size) pos))
|
|
(pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
|
|
|
|
(super-new)
|
|
(init)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; the entity base class
|
|
|
|
(define entity%
|
|
(class object%
|
|
(init-field (id 0))
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (set-id! s)
|
|
(set! id s))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; finally, a plant...
|
|
|
|
(define plant%
|
|
(class entity%
|
|
(init-field
|
|
(pos (vector 0 0 0))
|
|
(col (vector 1 1 1))
|
|
(plant-desc '()))
|
|
|
|
(field
|
|
(root-component 0)
|
|
(spray-t 0))
|
|
|
|
(define/public (init)
|
|
(with-state
|
|
(hint-depth-sort)
|
|
;(parent (send world get-root))
|
|
;(colour col)
|
|
(hint-unlit)
|
|
(translate pos)
|
|
(printf "building from:~a~n" plant-desc)
|
|
(set! root-component (build-component "1-0" plant-desc))))
|
|
|
|
(define/public (destroy-plant)
|
|
(destroy root))
|
|
|
|
(define/public (update world)
|
|
0
|
|
#;(with-primitive root
|
|
(colour col)
|
|
(when (> spray-t 1)
|
|
(set! spray-t (* spray-t 0.9))
|
|
(colour spray-t))))
|
|
|
|
(define/public (spray world type)
|
|
(let ((pos (vtransform (vector 0 0 0)
|
|
(with-primitive (component-root (random-leaf root-component))
|
|
(get-global-transform)))))
|
|
(send world puff-pollen pos (vector 1 1 1) 0.2 100)))
|
|
|
|
(super-new)
|
|
(init)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define network-dispatch%
|
|
(class object%
|
|
|
|
(define (stringify l)
|
|
(cond
|
|
((null? l) l)
|
|
((symbol? (car l))
|
|
(cons (symbol->string (car l))
|
|
(stringify (cdr l))))
|
|
((number? (car l))
|
|
(cons (number->string (car l))
|
|
(stringify (cdr l))))
|
|
((list? (car l))
|
|
(cons (stringify (car l)) (stringify (cdr l))))
|
|
(else (error "oops"))))
|
|
|
|
|
|
(define/public (dispatch world)
|
|
(cond
|
|
((osc-msg "/add-plant")
|
|
(printf "add plant message recieved : ~a~n" (osc 6))
|
|
(send world add-entity (make-object plant%
|
|
(vector (osc 0) (osc 1) (osc 2))
|
|
(vector (osc 3) (osc 4) (osc 5))
|
|
(stringify (eval-string (osc 6))))))
|
|
((osc-msg "/destroy-plant")
|
|
(printf "destroy plant message recieved...~n")
|
|
(send world destroy-entity (osc 0)))
|
|
((osc-msg "/spray")
|
|
; (printf "destroy plant message recieved...~n")
|
|
(send (send world get-entity (osc 0)) spray world (osc 1)))))
|
|
|
|
(define/public (add-plant world)
|
|
(printf "sending add plant...~n")
|
|
|
|
(let* ((pos (vector (* (crndf) 5) 2 1))
|
|
(col (rndvec))
|
|
(desc (list (make-random-plant 0)))
|
|
(desc-str (format "'~a" desc)))
|
|
(printf "sending:~a~n" desc-str)
|
|
(osc-send "/add-plant" "ffffffs" (list (vx pos) (vy pos) (vz pos)
|
|
(vx col) (vy col) (vz col) desc-str))
|
|
(send world add-entity (make-object plant% pos col desc))))
|
|
|
|
(define/public (destroy-plant world id)
|
|
(printf "sending destroy plant...~n")
|
|
(osc-send "/destroy-plant" "i" (list id))
|
|
(send world destroy-entity id))
|
|
|
|
(define/public (spray world id type)
|
|
; (printf "sending destroy plant...~n")
|
|
(osc-send "/spray" "ii" (list id type))
|
|
(send (send world get-entity id) spray world type))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(clear)
|
|
(clear-colour 0)
|
|
(set-camera-transform (mtranslate (vector 0 -5 -10)))
|
|
|
|
(define w (make-object world% 1))
|
|
(define n (make-object network-dispatch%))
|
|
|
|
|
|
(define (animate)
|
|
(when (key-pressed " ") (send n add-plant w))
|
|
(send n dispatch w)
|
|
(send w update)
|
|
(when (and (zero? (random 50)) (not (null? (send w get-entity-list))) )
|
|
(send n spray w (send (send w choose) get-id) 0)))
|
|
|
|
(every-frame (animate))
|
|
|
|
|