From cb7915058c0ffab80c83cefd4ee00c7e12a4ac5a Mon Sep 17 00:00:00 2001 From: Dave Griffiths Date: Mon, 13 Jul 2009 12:39:34 +0100 Subject: [PATCH] broke apart the source, added jabberer and xmpp --- flatgarden/flatgarden.scm | 1 - plant-eyes/controller.ss | 125 ++++ plant-eyes/jabberer.ss | 63 ++ plant-eyes/list-utils.ss | 20 + plant-eyes/logic.ss | 499 ++++++++++++++ plant-eyes/message.ss | 24 + plant-eyes/ornament-view.ss | 41 ++ plant-eyes/pickup-view.ss | 49 ++ plant-eyes/plant-eyes.scm | 1304 +---------------------------------- plant-eyes/view.ss | 649 +++++++++++++++++ plant-eyes/xmpp.ss | 421 +++++++++++ pluggable/pluggable.scm | 10 +- 12 files changed, 1901 insertions(+), 1305 deletions(-) create mode 100644 plant-eyes/controller.ss create mode 100644 plant-eyes/jabberer.ss create mode 100644 plant-eyes/list-utils.ss create mode 100644 plant-eyes/logic.ss create mode 100644 plant-eyes/message.ss create mode 100644 plant-eyes/ornament-view.ss create mode 100644 plant-eyes/pickup-view.ss create mode 100644 plant-eyes/view.ss create mode 100644 plant-eyes/xmpp.ss diff --git a/flatgarden/flatgarden.scm b/flatgarden/flatgarden.scm index 5e53430..d77c0a9 100644 --- a/flatgarden/flatgarden.scm +++ b/flatgarden/flatgarden.scm @@ -142,5 +142,4 @@ (set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F"))) (+ 10 (random 20)) 0.9) trees)))) -(start-framedump "wind" "jpg") (every-frame (animate trees)) diff --git a/plant-eyes/controller.ss b/plant-eyes/controller.ss new file mode 100644 index 0000000..143726e --- /dev/null +++ b/plant-eyes/controller.ss @@ -0,0 +1,125 @@ +#lang scheme/base +(require scheme/class fluxus-016/drflux "logic.ss" "view.ss") +(provide (all-defined-out)) + +; reads input events and tells the logic side what to do + +(define controller% + (class object% + (init-field + (game-view #f)) + + (field + (fwd (vector 0 0 1)) + (up (vector 0 1 0)) + (pos (vector 0 0 0)) + (mtx (mident)) + (cam (build-locator)) + (current-twig #f) + (current-twig-growing #f) + (current-point 0) + (tilt 0) + (yaw 0) + (player-plant #f)) + + (define/public (set-player-plant s) + (set! player-plant s)) + + (define/public (get-cam-obj) + cam) + + (define/public (set-pos s) + (set! pos s)) + + (define/public (set-fwd s) + (set! fwd s)) + + (define/public (get-fwd) + fwd) + + (define/public (setup) + (lock-camera cam) + (camera-lag 0.2) + (clip 1 1000) + (set-camera-transform (mtranslate (vector 0 0 -4)))) + + (define/public (update) + (when (key-pressed-this-frame " ") + (cond ((and current-twig (not current-twig-growing)) + (let ((new-twig (send current-twig add-twig current-point + (vector 0 1 0) #;(vsub (send current-twig get-point current-point) + (send current-twig get-point (- current-point 1)))))) + (set! current-twig-growing #t) + (set! current-twig new-twig))) + (else + (set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root + (vmul fwd -1) + start-twig-width max-twig-points 'extruded)) + (send player-plant add-twig current-twig) + (set! current-twig-growing #t)))) + + (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2))) + (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2))) + (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2))) + (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2))) + + ; clamp tilt to prevent gimbal lock + (when (> tilt 88) (set! tilt 88)) + (when (< tilt -88) (set! tilt -88)) + + (when (not current-twig-growing) + (when (key-pressed-this-frame "q") + (cond ((not current-twig) + (set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1))) + (set! current-point 2)) + (else + (when (< current-point (- (send current-twig get-num-points) 1)) + (set! current-point (+ current-point 1)))))) + + (when (key-pressed-this-frame "z") + (cond (current-twig + (set! current-point (- current-point 1)) + (when (< current-point 2) + (set! current-twig #f) + (set! pos (vector 0 0 0)) + #;(set-camera-transform (mtranslate (vector 0 0 -1)))))))) + + ; get camera fwd vector from key-presses + (set! fwd (vtransform (vector 0 0 1) + (mmul + (mrotate (vector 0 yaw 0)) + (mrotate (vector tilt 0 0))))) + + + ; if we are on a twig not growing + (cond ((and current-twig (not current-twig-growing)) + (set! pos (send current-twig get-point current-point)) + #;(when (> current-point 0) + (set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point + (- current-point 1)) + pos)) 0.5)))) + + (else + (when current-twig-growing + (let ((twig-view (send (send game-view get-plant (send player-plant get-id)) + get-twig (send current-twig get-id)))) + (when twig-view + (set! pos (vsub (send twig-view get-end-pos) + (vmul (send current-twig get-dir) 1))))) + (when (eq? (send current-twig get-num-points) + (send current-twig get-length)) + (set! current-twig-growing #f) + (set! current-point (- (send current-twig get-num-points) 1)))))) + + + (let* ((side (vnormalise (vcross up fwd))) + (up (vnormalise (vcross fwd side)))) + + (with-primitive cam + (identity) + (concat (vector (vx side) (vy side) (vz side) 0 + (vx up) (vy up) (vz up) 0 + (vx fwd) (vy fwd) (vz fwd) 0 + (vx pos) (vy pos) (vz pos) 1))))) + + (super-new))) diff --git a/plant-eyes/jabberer.ss b/plant-eyes/jabberer.ss new file mode 100644 index 0000000..d17827a --- /dev/null +++ b/plant-eyes/jabberer.ss @@ -0,0 +1,63 @@ +#lang scheme/base +(require scheme/class fluxus-016/drflux openssl (prefix-in xmpp: "xmpp.ss")) +(provide (all-defined-out)) + +; a class which wraps the xmpp in a thread and allows messages to be picked up +; and sent by the game + +(define debug-netloop #f) + +(define jabberer% + (class object% + (init-field + (jid "none@nowhere") + (pass "xxxx")) + + (field + (incoming '()) + (outgoing '()) + (thr 0) + (debug-jab #f)) + + (define/public (get-incoming) + incoming) + + (define/public (clear-incoming) + (set! incoming '())) + + (define/public (msg-waiting?) + (not (null? incoming))) + + (define/public (get-msg) + (let ((msg (car incoming))) + (set! incoming (cdr incoming)) + msg)) + + (define/public (send-msg to msg) + (set! outgoing (cons (list to msg) outgoing))) + + (define (message-handler sz) + (when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz))) + (set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming))) + + (define/public (start) + (set! thr (thread run))) + + (define/public (stop) + (kill-thread thr)) + + (define (run) + (xmpp:with-xmpp-session jid pass + (xmpp:set-xmpp-handler 'message message-handler) + (let loop () + (when debug-netloop (printf ".~n")) + (when (not (null? outgoing)) + (for-each + (lambda (msg) + (when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg))) + (xmpp:send (xmpp:message (car msg) (cadr msg)))) + outgoing) + (set! outgoing '())) + (sleep 0.5) + (loop)))) + (super-new))) diff --git a/plant-eyes/list-utils.ss b/plant-eyes/list-utils.ss new file mode 100644 index 0000000..11f30f1 --- /dev/null +++ b/plant-eyes/list-utils.ss @@ -0,0 +1,20 @@ +#lang scheme/base +(provide (all-defined-out)) + +(define (assoc-remove k l) + (cond + ((null? l) '()) + ((eq? (car (car l)) k) + (assoc-remove k (cdr l))) + (else + (cons (car l) (assoc-remove k (cdr l)))))) + +(define (choose l) + (list-ref l (random (length l)))) + +(define (list-contains k l) + (cond + ((null? l) #f) + ((eq? (car l) k) #t) + (else (list-contains k (cdr l))))) + diff --git a/plant-eyes/logic.ss b/plant-eyes/logic.ss new file mode 100644 index 0000000..ace2883 --- /dev/null +++ b/plant-eyes/logic.ss @@ -0,0 +1,499 @@ +#lang scheme +(require scheme/class fluxus-016/drflux "message.ss" "list-utils.ss") +(provide (all-defined-out)) + +(define branch-probability 6) ; as in one in branch-probability chance +(define branch-width-reduction 0.5) +(define twig-jitter 0.1) +(define branch-jitter 0.5) +(define max-twig-points 30) +(define start-twig-dist 0.05) +(define start-twig-width 0.2) +(define default-max-twigs 10) +(define default-scale-factor 1.05) +(define num-pickups 10) +(define pickup-dist-radius 200) +(define pickup-size 1) +(define ornament-grow-probability 4) +(define curl-amount 40) +(define start-size 50) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; the base class logic object - all logic side objects can +; send messages to the render side at any time by calling add-message +; this takes care of the propagation of information. (not just oo fetish, I hope) +(define game-logic-object% + (class object% + (field + (messages '()) + (children '())) + + (define/public (send-message name data) + (set! messages (cons (make-object message% name data) messages))) + + ; convert a list of lists in to just a single list - needed to convert + ; the update lists into one big list of messages + (define (flatten l) + (cond + ((null? l) '()) + ((list? (car l)) (append (flatten (car l)) (flatten (cdr l)))) + (else (cons (car l) (flatten (cdr l)))))) + + (define/pubment (update) ; need to augement this if we have child logic objects, + (let ((m messages)) ; and call update on them too. + (set! messages '()) + (append + m + (flatten (inner '() update))))) ; the augmented method gets called here + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; a twig, which can contain other twigs things. +; (roots and shoots are both twigs) +(define twig-logic% + (class game-logic-object% + (init-field + (last-point (vector 0 0 0)) + (id #f) ; our id (for matching up with the renderer geometry) + (plant #f) ; the plant we belong to + (type 'root) ; or 'shoot + (dir (vector 0 1 0)) ; the general direction we are pointing in + (width 0) ; the width of this root + (num-points max-twig-points) ; number of points in this twig + (render-type 'extruded) ; the way to tell the view to render this twig + (dist start-twig-dist)) ; distance between points + + (field + (points '()) ; the 3d points for this twig + (widths '()) + (twigs '()) ; children are stored with the point number they are connected to. + (ornaments '()) ; the things attached to this twig, an assoc list with point index + (branch #f) ; are we a main branch twig? + (w 0) ; the width of this segment + (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly + + (inherit send-message) + + (define/public (set-pos s) + (set! last-point s)) + + (define/public (get-id) + id) + + (define/public (set-id! s) + (set! id s)) + + (define/public (get-type) + type) + + (define/public (get-dir) + dir) + + (define/public (get-width) + width) + + (define/public (get-num-points) + num-points) + + (define/public (get-render-type) + render-type) + + (define/public (set-branch! s) + (set! branch s)) + + (define/public (get-point point-index) + (list-ref points point-index)) + + (define/public (get-length) + (length points)) + + (define/public (get-end-pos) + (if (not (null? points)) + (list-ref points (- (get-length) 1)) + #f)) + + (define/public (scale a) + (set! width (* width a)) + (set! dist (* dist a))) + + (define/public (grow ndir) + (when (< (length points) num-points) + (let ((new-point (if (zero? (length points)) + ; first point should be at edge of the seed if we are a branch + (if branch (vadd last-point (vmul dir dist)) + last-point) + (vadd last-point (vmul dir dist))))) + + (set! dir ndir) + (set! w (* width (- 1 (/ (length points) num-points)))) + + (set! last-point new-point) + (set! points (append points (list new-point))) + (set! widths (append widths (list w))) + (send-message 'twig-grow (list + (list 'plant-id (send plant get-id)) + (list 'twig-id id) + (list 'point new-point) + (list 'width w))) + #;(when (and (> (length points) 1) (> num-points 1) + (zero? (random branch-probability))) + (add-twig (- (length points) 1) (vadd dir (vmul (srndvec) branch-jitter)))))) + (for-each + (lambda (twig) + (send (cadr twig) grow ndir)) + twigs)) + + (define/public (add-twig point-index dir) + (let ((twig (make-object twig-logic% + (get-point point-index) + (send plant get-next-twig-id) + plant + type + dir + (list-ref widths point-index) + (quotient num-points 2) + render-type + dist))) + + (send-message 'new-twig (list + (list 'plant-id (send plant get-id)) + (list 'parent-twig-id id) + (list 'point-index point-index) + (list 'twig-id (send twig get-id)) + (list 'type (send twig get-type)) + (list 'dir (send twig get-dir)) + (list 'width (send twig get-width)) + (list 'num-points (send twig get-num-points)) + (list 'render-type (send twig get-render-type)) + )) + (set! twigs (cons (list point-index twig) twigs)) + twig)) + + (define/public (get-twig point-index) + (cadr (assq point-index twigs))) + + (define/public (get-random-twig) + (if (or (null? twigs) (zero? (random 10))) + this + (send (cadr (choose twigs)) get-random-twig))) + + (define/public (add-ornament point-index ornament) + ; todo - check max ornaments + (send-message 'new-ornament + (list + (list 'plant-id (send plant get-id)) + (list 'twig-id id) + (list 'point-index point-index) + (list 'property (send ornament get-property)))) + (set! ornaments (cons (list point-index ornament) ornaments))) + + (define/public (get-ornament point-index) + (cadr (assq point-index ornaments))) + + ; adds the ornament if it's close, and checks sub-twigs + ; returns true if it's succeded + (define/public (check-pickup pickup) + ; check each point in our twig + (let* ((i -1) (found (foldl + (lambda (point found) + (set! i (+ i 1)) + ; if we havent found anything yet and it's intersecting + (cond ((and (not found) (< (vdist point (send pickup get-pos)) + (+ width (send pickup get-size)))) + (send plant add-property (send pickup get-type)) + (send pickup pick-up) ; this will remove the pickup for us + (send-message 'pick-up-pickup + (list + (list 'pickup-id (send pickup get-id)))) + #t) + (else #f))) + #f + points))) + ; now check each sub-twig + (if (not found) + (foldl + (lambda (twig found) + (if (not found) + (send (cadr twig) check-pickup pickup) + #f)) + #f + twigs) + found))) + + (define/augment (update) + (append + (map + (lambda (ornament) + (send (cadr ornament) update)) + ornaments) + (map + (lambda (twig) + (send (cadr twig) update)) + twigs))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; abilities live on twigs, and can do things. +; this is the base class for all abilities. +(define ornament-logic% + (class game-logic-object% + (init-field + (id -1) + (property 'none) + (plant #f) ; the plant we belong to + (twig #f) ; the twig we are on + (point-index -1)) ; the index to the point on our twig + + (field + (pos (send twig get-point point-index))) ; figure out the position here + + (define/public (get-property) + property) + + (define/public (get-pos) + pos) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; pickups map to abilities, and live out in space +; this is the base class for all pickups. +(define pickup-logic% + (class game-logic-object% + (init-field + (id -1) + (type 'none) + (pos (vector 0 0 0))) + + (field + (size pickup-size) + (picked-up #f)) + + (define/public (picked-up?) + picked-up) + + (define/public (pick-up) + (set! picked-up #t)) + + (define/public (get-id) + id) + + (define/public (get-type) + type) + + (define/public (get-pos) + pos) + + (define/public (get-size) + size) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define plant-logic% + (class game-logic-object% + (init-field + (id #f) + (pos (vector 0 0 0))) + + (field + (twigs '()) ; a assoc list map of ages to twigs + (properties '()) ; a list of symbols - properties come from pickups + (ornaments '()) ; map of ids to ornaments on the plant + (size start-size) ; the age of this plant + (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first + (next-twig-id 0) + (next-ornament-id 0) + (grow-amount default-scale-factor)) + + (inherit send-message) + + (define/public (get-id) + id) + + (define/public (get-pos) + pos) + + (define/public (get-size) + size) + + (define/public (grow dir) + (for-each + (lambda (twig) + (send twig grow dir)) + twigs)) + + (define/public (add-property name) + (set! properties (cons name properties))) + + ; we need to maintain our list of twig ids here, for this plant + (define/public (get-next-twig-id) + (let ((id next-twig-id)) + (set! next-twig-id (+ next-twig-id 1)) + next-twig-id)) + + ; we need to maintain our list of ornament ids here, for this plant + (define/public (get-next-ornament-id) + (let ((id next-ornament-id)) + (set! next-ornament-id (+ next-ornament-id 1)) + next-ornament-id)) + + (define/public (check-pickup pickup) + (foldl + (lambda (twig found) + (if (not found) + (send twig check-pickup pickup) + #f)) + #f + twigs)) + + (define/public (destroy-twig twig) + (send-message 'destroy-branch-twig (list + (list 'plant-id id) + (list 'twig-id (send twig get-id)) + ))) + + ; a util to keep a fixed size list of twigs, calling destroy twig when needed. + (define (cons-twig thing in count out) + (cond + ((null? in) + (cons thing out)) + ((zero? count) + (destroy-twig (car in)) + (cons thing out)) + (else (cons-twig thing (cdr in) (- count 1) (append out (list (car in))))))) + + (define/public (add-twig twig) + (send twig set-id! (get-next-twig-id)) + (set! size (* size grow-amount)) + (send twig scale size) + (send twig set-branch! #t) + (send twig set-pos pos) + + (send-message 'grow-seed (list + (list 'plant-id id) + (list 'amount grow-amount))) + (send-message 'new-branch-twig (list + (list 'plant-id id) + (list 'twig-id (send twig get-id)) + (list 'type (send twig get-type)) + (list 'dir (send twig get-dir)) + (list 'width (send twig get-width)) + (list 'num-points (send twig get-num-points)) + (list 'render-type (send twig get-render-type)) + )) + + (set! twigs (cons-twig twig twigs max-twigs '()))) + + + (define/public (get-random-twig) + (if (not (null? twigs)) + (send (choose twigs) get-random-twig) + #f)) + + (define/public (get-twig-from-dir dir) + (let ((dir (vnormalise dir))) + (cadr (foldl + (lambda (twig l) + (let ((d (vdot (vnormalise (send twig get-dir)) dir))) + (if (> d (car l)) + (list d twig) + l))) + (list -99 #f) + twigs)))) + + + (define/augment (update) + ; grow a new ornament? + (when (and (not (null? properties)) (zero? (random ornament-grow-probability))) + (let ((twig (get-random-twig))) + (when twig + (let + ((property (choose properties)) + (point-index (random (send twig get-length)))) + + (when (not (eq? property 'curly)) + (send twig add-ornament point-index + (cond + ((or + (eq? property 'leaf) + (eq? property 'wiggle)) + (make-object ornament-logic% + (get-next-ornament-id) + property + this + twig + point-index)) + (else + (error "property not understood " property))))))))) + (map + (lambda (twig) + (send twig update)) + twigs)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define game-logic% + (class game-logic-object% + (field + (plants '()) + (pickups '())) + + (inherit send-message) + + (define/public (setup) + (for ((i (in-range 0 num-pickups))) + (add-pickup (make-object pickup-logic% i (choose (list 'leaf 'curly 'wiggle)) + (vmul (srndvec) pickup-dist-radius))))) + + (define/public (add-player plant) + (send-message 'player-plant (list + (list 'plant-id (send plant get-id)) + (list 'pos (send plant get-pos)))) + (set! plants (cons plant plants))) + + (define/public (add-plant plant) + (send-message 'new-plant (list + (list 'plant-id (send plant get-id)) + (list 'pos (send plant get-pos)) + (list 'size (send plant get-size)))) + (set! plants (cons plant plants))) + + (define/public (add-pickup pickup) + (send-message 'new-pickup + (list + (list 'pickup-id (send pickup get-id)) + (list 'type (send pickup get-type)) + (list 'pos (send pickup get-pos)))) + (set! pickups (cons pickup pickups))) + + + ; todo - distribute the checking of stuff like + ; this to a random selection of pickups/plants + ; to distribute the cpu load + (define/augment (update) + (for-each + (lambda (pickup) + (for-each + (lambda (plant) + (send plant check-pickup pickup)) + plants)) + pickups) + + ; remove the pickups that have been 'picked up' + (set! pickups (filter + (lambda (pickup) + (not (send pickup picked-up?))) + pickups)) + + (map + (lambda (plant) + (send plant update)) + plants)) + + (super-new))) diff --git a/plant-eyes/message.ss b/plant-eyes/message.ss new file mode 100644 index 0000000..abf7e6a --- /dev/null +++ b/plant-eyes/message.ss @@ -0,0 +1,24 @@ +#lang scheme/base +(require scheme/class) +(provide (all-defined-out)) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; a message for sending betwixt logic and view side +(define message% + (class object% + (init-field + (name 'none) ; a symbol denoting the type of the message + (data '())) ; should be an assoc list map of name to values, eg: + ; '((name "archibold") (age 53)) + ; shouldn't put logic objects in here - 'raw' data only + + (define/public (get-name) + name) + + (define/public (get-data arg-name) + (cadr (assoc arg-name data))) + + (define/public (print) + (printf "msg: ~a ~a~n" name data)) + + (super-new))) diff --git a/plant-eyes/ornament-view.ss b/plant-eyes/ornament-view.ss new file mode 100644 index 0000000..d419f59 --- /dev/null +++ b/plant-eyes/ornament-view.ss @@ -0,0 +1,41 @@ +#lang scheme +#lang scheme/base + +(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss") +(provide (all-defined-out)) + +(define ornament-view% + (class object% + (init-field + (pos (vector 0 0 0)) + (property 'none) + (time 0)) + + (field + (rot (vmul (rndvec) 360)) + (root (with-state + (translate pos) + (rotate rot) + (scale 0.01) + (cond + ((eq? property 'wiggle) +; (opacity 1) + (hint-depth-sort) + (colour (vector 0.5 0.0 0.0)) + (load-primitive "meshes/wiggle.obj")) + ((eq? property 'leaf) + (colour (vector 0.8 1 0.6)) + (texture (load-texture "textures/leaf2.png")) + (load-primitive "meshes/leaf.obj")) + (else (error "")))))) + + (define/public (update t d) + (when (< time 1) + (with-primitive root + (identity) + (translate pos) + (rotate rot) + (scale (* 0.2 time))) + (set! time (+ time (* 0.1 d))))) + + (super-new))) \ No newline at end of file diff --git a/plant-eyes/pickup-view.ss b/plant-eyes/pickup-view.ss new file mode 100644 index 0000000..e5910f3 --- /dev/null +++ b/plant-eyes/pickup-view.ss @@ -0,0 +1,49 @@ +#lang scheme/base +(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss") +(provide (all-defined-out)) + +(define pickup-view% + (class object% + (init-field + (id -1) + (type 'none) + (pos (vector 0 0 0))) + + (field + (rot (vmul (rndvec) 360)) + (root (with-state + (translate pos) + (rotate rot) + (colour (pickup-colour)) + (scale 0.3) + (texture + (cond + ((eq? type 'wiggle) (load-texture "textures/wiggle.png")) + ((eq? type 'leaf) (load-texture "textures/leaf.png")) + ((eq? type 'curly) (load-texture "textures/curl.png")))) + (load-primitive "meshes/pickup.obj"))) + (from pos) + (destination (vector 0 0 0)) + (speed 0.05) + (t -1)) + + (define/public (pick-up) + (destroy root)) + + (define/public (move-to s) + (set! t 0) + (set! from pos) + (set! destination s)) + + (define/public (update t d) + (with-primitive root + (rotate (vector (* d 10) 0 0))) + #;(when (and (>= t 0) (< t 1)) + (set! pos (vadd pos (vmul (vsub destination from) speed))) + (with-primitive root + (identity) + (translate pos) + (rotate rot)) + (set! t (+ t speed)))) + + (super-new))) diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index ecd4ef4..9838344 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -1,6 +1,7 @@ -;#lang scheme/base -;(require fluxus-016/drflux) -(require scheme/class) +#lang scheme/base +(require fluxus-016/drflux) +(require scheme/class "logic.ss" "view.ss" "controller.ss") +(require "jabberer.ss") ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; p l a n t e y e s @@ -32,1305 +33,10 @@ ; * in the same way, the line segments can be created in any way by the logic ; side - eg. lsystem, or different methods per plant (or per twig even) -(define (ornament-colour) (vector 0.5 1 0.4)) -(define (pickup-colour) (vector 1 1 1)) -(define (earth-colour) (vector 0.2 0.1 0)) - -(define wire-mode #f) -(define fog-col (earth-colour)) -(define fog-strength 0.001) - -(define debug-messages #f) ; prints out all the messages sent to the renderer (define logic-tick 0.5) ; time between logic updates -(define branch-probability 6) ; as in one in branch-probability chance -(define branch-width-reduction 0.5) -(define twig-jitter 0.1) -(define branch-jitter 0.5) -(define max-twig-points 30) -(define start-twig-dist 0.05) -(define start-twig-width 0.2) -(define default-max-twigs 10) -(define default-scale-factor 1.05) -(define default-grow-speed (/ 1 logic-tick)) -(define root-camera-time (* max-twig-points logic-tick)) -(define num-pickups 10) -(define pickup-dist-radius 200) -(define pickup-size 1) -(define max-ornaments 2) ; per twig -(define ornament-grow-probability 4) -(define curl-amount 40) -(define start-size 50) - -(define (assoc-remove k l) - (cond - ((null? l) '()) - ((eq? (car (car l)) k) - (assoc-remove k (cdr l))) - (else - (cons (car l) (assoc-remove k (cdr l)))))) - -(define (choose l) - (list-ref l (random (length l)))) - -(define (list-contains k l) - (cond - ((null? l) #f) - ((eq? (car l) k) #t) - (else (list-contains k (cdr l))))) - - -(oa-start) ;; start openAL audio - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -; a message for sending betwixt logic and render side -(define message% - (class object% - (init-field - (name 'none) ; a symbol denoting the type of the message - (data '())) ; should be an assoc list map of name to values, eg: - ; '((name "archibold") (age 53)) - ; shouldn't put logic objects in here - 'raw' data only - - (define/public (get-name) - name) - - (define/public (get-data arg-name) - (cadr (assoc arg-name data))) - - (define/public (print) - (printf "msg: ~a ~a~n" name data)) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -; the base class logic object - all logic side objects can -; send messages to the render side at any time by calling add-message -; this takes care of the propagation of information. (not just oo fetish, I hope) -(define game-logic-object% - (class object% - (field - (messages '()) - (children '())) - - (define/public (send-message name data) - (set! messages (cons (make-object message% name data) messages))) - - ; convert a list of lists in to just a single list - needed to convert - ; the update lists into one big list of messages - (define (flatten l) - (cond - ((null? l) '()) - ((list? (car l)) (append (flatten (car l)) (flatten (cdr l)))) - (else (cons (car l) (flatten (cdr l)))))) - - (define/pubment (update) ; need to augement this if we have child logic objects, - (let ((m messages)) ; and call update on them too. - (set! messages '()) - (append - m - (flatten (inner '() update))))) ; the augmented method gets called here - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -; a twig, which can contain other twigs things. -; (roots and shoots are both twigs) -(define twig-logic% - (class game-logic-object% - (init-field - (last-point (vector 0 0 0)) - (id #f) ; our id (for matching up with the renderer geometry) - (plant #f) ; the plant we belong to - (type 'root) ; or 'shoot - (dir (vector 0 1 0)) ; the general direction we are pointing in - (width 0) ; the width of this root - (num-points max-twig-points) ; number of points in this twig - (render-type 'extruded) ; the way to tell the view to render this twig - (dist start-twig-dist)) ; distance between points - - (field - (points '()) ; the 3d points for this twig - (widths '()) - (twigs '()) ; children are stored with the point number they are connected to. - (ornaments '()) ; the things attached to this twig, an assoc list with point index - (branch #f) ; are we a main branch twig? - (w 0) ; the width of this segment - (curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly - - (inherit send-message) - - (define/public (set-pos s) - (set! last-point s)) - - (define/public (get-id) - id) - - (define/public (set-id! s) - (set! id s)) - - (define/public (get-type) - type) - - (define/public (get-dir) - dir) - - (define/public (get-width) - width) - - (define/public (get-num-points) - num-points) - - (define/public (get-render-type) - render-type) - - (define/public (set-branch! s) - (set! branch s)) - - (define/public (get-point point-index) - (list-ref points point-index)) - - (define/public (get-length) - (length points)) - - (define/public (get-end-pos) - (if (not (null? points)) - (list-ref points (- (get-length) 1)) - #f)) - - (define/public (scale a) - (set! width (* width a)) - (set! dist (* dist a))) - - (define/public (grow ndir) - (when (< (length points) num-points) - (let ((new-point (if (zero? (length points)) - ; first point should be at edge of the seed if we are a branch - (if branch (vadd last-point (vmul dir dist)) - last-point) - (vadd last-point (vmul dir dist))))) - - (set! dir ndir) - (set! w (* width (- 1 (/ (length points) num-points)))) - - (set! last-point new-point) - (set! points (append points (list new-point))) - (set! widths (append widths (list w))) - (send-message 'twig-grow (list - (list 'plant-id (send plant get-id)) - (list 'twig-id id) - (list 'point new-point) - (list 'width w))) - #;(when (and (> (length points) 1) (> num-points 1) - (zero? (random branch-probability))) - (add-twig (- (length points) 1) (vadd dir (vmul (srndvec) branch-jitter)))))) - (for-each - (lambda (twig) - (send (cadr twig) grow ndir)) - twigs)) - - (define/public (add-twig point-index dir) - (let ((twig (make-object twig-logic% - (get-point point-index) - (send plant get-next-twig-id) - plant - type - dir - (list-ref widths point-index) - (quotient num-points 2) - render-type - dist))) - - (send-message 'new-twig (list - (list 'plant-id (send plant get-id)) - (list 'parent-twig-id id) - (list 'point-index point-index) - (list 'twig-id (send twig get-id)) - (list 'type (send twig get-type)) - (list 'dir (send twig get-dir)) - (list 'width (send twig get-width)) - (list 'num-points (send twig get-num-points)) - (list 'render-type (send twig get-render-type)) - )) - (set! twigs (cons (list point-index twig) twigs)) - twig)) - - (define/public (get-twig point-index) - (cadr (assq point-index twigs))) - - (define/public (get-random-twig) - (if (or (null? twigs) (zero? (random 10))) - this - (send (cadr (choose twigs)) get-random-twig))) - - (define/public (add-ornament point-index ornament) - ; todo - check max ornaments - (send-message 'new-ornament - (list - (list 'plant-id (send plant get-id)) - (list 'twig-id id) - (list 'point-index point-index) - (list 'property (send ornament get-property)))) - (set! ornaments (cons (list point-index ornament) ornaments))) - - (define/public (get-ornament point-index) - (cadr (assq point-index ornaments))) - - ; adds the ornament if it's close, and checks sub-twigs - ; returns true if it's succeded - (define/public (check-pickup pickup) - ; check each point in our twig - (let* ((i -1) (found (foldl - (lambda (point found) - (set! i (+ i 1)) - ; if we havent found anything yet and it's intersecting - (cond ((and (not found) (< (vdist point (send pickup get-pos)) - (+ width (send pickup get-size)))) - (send plant add-property (send pickup get-type)) - (send pickup pick-up) ; this will remove the pickup for us - (send-message 'pick-up-pickup - (list - (list 'pickup-id (send pickup get-id)))) - #t) - (else #f))) - #f - points))) - ; now check each sub-twig - (if (not found) - (foldl - (lambda (twig found) - (if (not found) - (send (cadr twig) check-pickup pickup) - #f)) - #f - twigs) - found))) - - (define/augment (update) - (append - (map - (lambda (ornament) - (send (cadr ornament) update)) - ornaments) - (map - (lambda (twig) - (send (cadr twig) update)) - twigs))) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -; abilities live on twigs, and can do things. -; this is the base class for all abilities. -(define ornament-logic% - (class game-logic-object% - (init-field - (id -1) - (property 'none) - (plant #f) ; the plant we belong to - (twig #f) ; the twig we are on - (point-index -1)) ; the index to the point on our twig - - (field - (pos (send twig get-point point-index))) ; figure out the position here - - (define/public (get-property) - property) - - (define/public (get-pos) - pos) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -; pickups map to abilities, and live out in space -; this is the base class for all pickups. -(define pickup-logic% - (class game-logic-object% - (init-field - (id -1) - (type 'none) - (pos (vector 0 0 0))) - - (field - (size pickup-size) - (picked-up #f)) - - (define/public (picked-up?) - picked-up) - - (define/public (pick-up) - (set! picked-up #t)) - - (define/public (get-id) - id) - - (define/public (get-type) - type) - - (define/public (get-pos) - pos) - - (define/public (get-size) - size) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define plant-logic% - (class game-logic-object% - (init-field - (id #f) - (pos (vector 0 0 0))) - - (field - (twigs '()) ; a assoc list map of ages to twigs - (properties '()) ; a list of symbols - properties come from pickups - (ornaments '()) ; map of ids to ornaments on the plant - (size start-size) ; the age of this plant - (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first - (next-twig-id 0) - (next-ornament-id 0) - (grow-amount default-scale-factor)) - - (inherit send-message) - - (define/public (get-id) - id) - - (define/public (get-pos) - pos) - - (define/public (grow dir) - (for-each - (lambda (twig) - (send twig grow dir)) - twigs)) - - (define/public (add-property name) - (set! properties (cons name properties))) - - ; we need to maintain our list of twig ids here, for this plant - (define/public (get-next-twig-id) - (let ((id next-twig-id)) - (set! next-twig-id (+ next-twig-id 1)) - next-twig-id)) - - ; we need to maintain our list of ornament ids here, for this plant - (define/public (get-next-ornament-id) - (let ((id next-ornament-id)) - (set! next-ornament-id (+ next-ornament-id 1)) - next-ornament-id)) - - (define/public (check-pickup pickup) - (foldl - (lambda (twig found) - (if (not found) - (send twig check-pickup pickup) - #f)) - #f - twigs)) - - (define/public (destroy-twig twig) - (send-message 'destroy-branch-twig (list - (list 'plant-id id) - (list 'twig-id (send twig get-id)) - ))) - - ; a util to keep a fixed size list of twigs, calling destroy twig when needed. - (define (cons-twig thing in count out) - (cond - ((null? in) - (cons thing out)) - ((zero? count) - (destroy-twig (car in)) - (cons thing out)) - (else (cons-twig thing (cdr in) (- count 1) (append out (list (car in))))))) - - (define/public (add-twig twig) - (send twig set-id! (get-next-twig-id)) - (set! size (* size grow-amount)) - (send twig scale size) - (send twig set-branch! #t) - (send twig set-pos pos) - - (send-message 'grow-seed (list - (list 'plant-id id) - (list 'amount grow-amount))) - (send-message 'new-branch-twig (list - (list 'plant-id id) - (list 'twig-id (send twig get-id)) - (list 'type (send twig get-type)) - (list 'dir (send twig get-dir)) - (list 'width (send twig get-width)) - (list 'num-points (send twig get-num-points)) - (list 'render-type (send twig get-render-type)) - )) - - (set! twigs (cons-twig twig twigs max-twigs '()))) - - - (define/public (get-random-twig) - (if (not (null? twigs)) - (send (choose twigs) get-random-twig) - #f)) - - (define/public (get-twig-from-dir dir) - (let ((dir (vnormalise dir))) - (cadr (foldl - (lambda (twig l) - (let ((d (vdot (vnormalise (send twig get-dir)) dir))) - (if (> d (car l)) - (list d twig) - l))) - (list -99 #f) - twigs)))) - - - (define/augment (update) - ; grow a new ornament? - (when (and (not (null? properties)) (zero? (random ornament-grow-probability))) - (let ((twig (get-random-twig))) - (when twig - (let - ((property (choose properties)) - (point-index (random (send twig get-length)))) - - (when (not (eq? property 'curly)) - (send twig add-ornament point-index - (cond - ((or - (eq? property 'leaf) - (eq? property 'wiggle)) - (make-object ornament-logic% - (get-next-ornament-id) - property - this - twig - point-index)) - (else - (error "property not understood " property))))))))) - (map - (lambda (twig) - (send twig update)) - twigs)) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define game-logic% - (class game-logic-object% - (field - (plants '()) - (pickups '())) - - (inherit send-message) - - (define/public (setup) - (for ((i (in-range 0 num-pickups))) - (add-pickup (make-object pickup-logic% i (choose (list 'leaf 'curly 'wiggle)) - (vmul (srndvec) pickup-dist-radius))))) - - (define/public (add-player plant) - (send-message 'player-plant (list - (list 'plant-id (send plant get-id)) - (list 'pos (send plant get-pos)))) - (set! plants (cons plant plants))) - - (define/public (add-plant plant) - (send-message 'new-plant (list - (list 'plant-id (send plant get-id)) - (list 'pos (send plant get-pos)))) - (set! plants (cons plant plants))) - - (define/public (add-pickup pickup) - (send-message 'new-pickup - (list - (list 'pickup-id (send pickup get-id)) - (list 'type (send pickup get-type)) - (list 'pos (send pickup get-pos)))) - (set! pickups (cons pickup pickups))) - - - ; todo - distribute the checking of stuff like - ; this to a random selection of pickups/plants - ; to distribute the cpu load - (define/augment (update) - (for-each - (lambda (pickup) - (for-each - (lambda (plant) - (send plant check-pickup pickup)) - plants)) - pickups) - - ; remove the pickups that have been 'picked up' - (set! pickups (filter - (lambda (pickup) - (not (send pickup picked-up?))) - pickups)) - - (map - (lambda (plant) - (send plant update)) - plants)) - - (super-new))) - -;============================================================================== -;============================================================================== - -(define ornament-view% - (class object% - (init-field - (pos (vector 0 0 0)) - (property 'none) - (time 0)) - - (field - (rot (vmul (rndvec) 360)) - (root (with-state - (translate pos) - (rotate rot) - (scale 0.01) - (cond - ((eq? property 'wiggle) -; (opacity 1) - (hint-depth-sort) - (colour (vector 0.5 0.0 0.0)) - (load-primitive "meshes/wiggle.obj")) - ((eq? property 'leaf) - (colour (vector 0.8 1 0.6)) - (texture (load-texture "textures/leaf2.png")) - (load-primitive "meshes/leaf.obj")) - (else (error "")))))) - - (define/public (update t d) - (when (< time 1) - (with-primitive root - (identity) - (translate pos) - (rotate rot) - (scale (* 0.2 time))) - (set! time (+ time (* 0.1 d))))) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define pickup-view% - (class object% - (init-field - (id -1) - (type 'none) - (pos (vector 0 0 0))) - - (field - (rot (vmul (rndvec) 360)) - (root (with-state - (translate pos) - (rotate rot) - (colour (pickup-colour)) - (scale 0.3) - (texture - (cond - ((eq? type 'wiggle) (load-texture "textures/wiggle.png")) - ((eq? type 'leaf) (load-texture "textures/leaf.png")) - ((eq? type 'curly) (load-texture "textures/curl.png")))) - (load-primitive "meshes/pickup.obj"))) - (from pos) - (destination (vector 0 0 0)) - (speed 0.05) - (t -1)) - - (define/public (pick-up) - (destroy root)) - - (define/public (move-to s) - (set! t 0) - (set! from pos) - (set! destination s)) - - (define/public (update t d) - (with-primitive root - (rotate (vector (* d 10) 0 0))) - #;(when (and (>= t 0) (< t 1)) - (set! pos (vadd pos (vmul (vsub destination from) speed))) - (with-primitive root - (identity) - (translate pos) - (rotate rot)) - (set! t (+ t speed)))) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define twig-view% - (class object% - (init-field - (id 0) - (pos (vector 0 0 0)) - (type 'none) - (dir (vector 0 1 0)) - (radius 1) - (num-points 0)) - - (field - (index 0) - (parent-twig-id -1) - (child-twig-ids '()) - (ornaments '())) - - (define/public (get-id) - id) - - (define/public (get-dir) - dir) - - (define/public (build) - 0) - - (define/public (set-pos! s) - (set! pos s)) - - (define/public (get-child-twig-ids) - child-twig-ids) - - (define/public (get-root) - (error "need to overide this")) - - (define/public (destroy-twig) - (destroy (get-root))) - - (define/public (set-parent-twig-id s) - (set! parent-twig-id s)) - - (define/public (get-point point-index) - (error "need to overide this")) - - (define/public (add-child-twig-id twig-id) - (set! child-twig-ids (cons twig-id child-twig-ids))) - - (define/pubment (grow point width) - (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav")))) - (oa-play growing-noise (vector 0 0 0) (rndf) 0.3)) - (inner (void) grow point width)) - - (define/public (add-ornament point-index property) - (when (< (length ornaments) max-ornaments) - (with-state - (parent (get-root)) - ; todo - different ornament-view objects per property needed? - ; todo - delete existing ornaments here - (set! ornaments (cons (list point-index - (make-object ornament-view% - (get-point point-index) - property)) - ornaments))))) - - (define/pubment (update t d) - (for-each - (lambda (ornament) - (send (cadr ornament) update t d)) - ornaments) - - (inner (void) update t d)) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define ribbon-twig-view% - (class twig-view% - - (inherit-field pos radius num-points index) - - (field - (root 0)) - - (define/override (build) - (set! root (let ((p (with-state - (translate pos) - (colour (vector 0.8 1 0.6)) - (texture (load-texture "textures/root.png")) - (build-ribbon num-points)))) - (with-primitive p - (pdata-map! - (lambda (w) - 0) - "w") - (pdata-set! "w" 0 radius)) - p))) - - - (define/override (get-root) - root) - - (define/override (get-point point-index) - (with-primitive root - (pdata-ref "p" point-index))) - - (define/augment (grow point width) - (with-primitive root - (pdata-index-map! ; set all the remaining points to the end - (lambda (i p) ; in order to hide them - (if (< i index) - p - point)) - "p") - (pdata-index-map! ; do a similar thing with the width - (lambda (i w) - (if (< i (+ index 1)) - w - width)) - "w")) - (set! index (+ index 1))) - - (define/augment (update t d) - 0) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define extruded-twig-view% - (class twig-view% - - (inherit-field index radius num-points pos dir) - - (field - (profile '()) - (path '()) - (root 0) - (grow-speed default-grow-speed) - (anim-t 0) - (widths '())) - - (define/override (build) - (set! profile (build-circle-profile 12 1)) - (set! path (build-list num-points (lambda (_) (vector 0 0 0)))) - (set! widths (build-list num-points (lambda (_) 1))) - (set! root (let ((p (with-state - (backfacecull 0) - (when wire-mode - (hint-none) - (hint-wire)) - (texture (load-texture "textures/root2.png")) - ;(opacity 0.6) - (colour (vmul (vector 0.8 1 0.6) 2)) - #;(colour (vector 1 1 1)) - #;(texture (load-texture "textures/root.png")) - (build-partial-extrusion profile path 3)))) - p))) - - (define/override (get-root) - root) - - (define/override (get-point point-index) - (list-ref path point-index)) - - (define (list-set l c s) - (cond ((null? l) '()) - ((zero? c) (cons s (list-set (cdr l) (- c 1) s))) - (else (cons (car l) (list-set (cdr l) (- c 1) s))))) - - (define/augment (grow point width) - (set! path (list-set path index point)) - (set! widths (list-set widths index width)) - (set! anim-t 0) - (set! index (+ index 1))) - - (define/augment (update t d) - (when (< anim-t 1) - (with-primitive root - (partial-extrude (+ (- index 2) anim-t) - profile path widths (vector 1 0 0) 0.05))) - (set! anim-t (+ anim-t (* d grow-speed)))) - - (define/public (get-end-pos) - (with-primitive root (pdata-ref "p" (- (* index (length profile)) 1)))) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define plant-view% - (class object% - - (init-field - (id "none") - (pos (vector 0 0 0))) - - (field - (twigs '()) ; a assoc list map between ids and twigs stored flat here, - ; for fast access, but prims heirachically in the scenegraph - (root (with-state - (translate pos) - (build-locator))) - (seed (with-state - (parent root) - (texture (load-texture "textures/root2.png")) - (backfacecull 0) - (opacity 0.6) - (colour (vector 0.8 1 0.6)) - (hint-depth-sort) - (scale (* 0.12 start-size)) - (when wire-mode - (hint-none) - (hint-wire)) - ;(hint-unlit) - (load-primitive "meshes/seed.obj")))) - - (define/public (get-id) - id) - - (define/public (get-twig twig-id) - (let ((l (assq twig-id twigs))) - (if l - (cadr (assq twig-id twigs)) - #f))) - - (define/public (add-branch-twig twig) - ; attach to seed - (with-primitive (send twig get-root) - (parent root)) - (send twig build) - (set! twigs (cons (list (send twig get-id) twig) twigs))) - - (define/public (destroy-branch-twig twig-id) - (for-each - (lambda (twig-id) - (destroy-branch-twig twig-id)) - (send (get-twig twig-id) get-child-twig-ids)) - (send (get-twig twig-id) destroy-twig) - (set! twigs (assoc-remove twig-id twigs))) - - (define/public (add-twig parent-twig-id point-index twig) - (let ((ptwig (get-twig parent-twig-id))) - ; attach to parent twig - (send twig set-pos! (send ptwig get-point point-index)) - (send twig build) - (with-primitive (send twig get-root) - (parent (send ptwig get-root))) - - - ; tell the twigs about this relationship (might turn out to be overkill) - (send ptwig add-child-twig-id (send twig get-id)) - (send twig set-parent-twig-id parent-twig-id) - - (set! twigs (cons (list (send twig get-id) twig) twigs)))) - - (define/public (grow-twig twig-id point width) - (send (get-twig twig-id) grow point width)) - - (define/public (grow-seed amount) - (with-primitive seed (scale amount))) - - (define/public (add-ornament twig-id point-index property) - (send (get-twig twig-id) add-ornament point-index property)) - - (define/public (update t d) - - (with-primitive seed - (scale (+ 1 (* 0.001 (sin (* 2 t)))))) - - (for-each - (lambda (twig) - (send (cadr twig) update t d)) - twigs)) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define (build-env-box top bottom left right front back lower) - (let ((p (build-locator))) - (with-state - (parent p) - (hint-unlit) - - (let ((t (with-state - (texture (load-texture top)) - (translate (vector 0 0.5 0)) - (rotate (vector 90 0 0)) - (build-plane)))) - (when lower (with-primitive t - (pdata-map! - (lambda (t) - (vmul t 10)) - "t")))) - - (with-state - (texture (load-texture left)) - (translate (vector 0 0 -0.5)) - (rotate (vector 0 0 0)) - (build-plane)) - - (with-state - (texture (load-texture back)) - (translate (vector 0.5 0 0)) - (rotate (vector 0 90 0)) - (build-plane)) - - (with-state - (texture (load-texture right)) - (translate (vector 0 0 0.5)) - (rotate (vector 0 0 0)) - (build-plane)) - - (with-state - (texture (load-texture front)) - (translate (vector -0.5 0 0)) - (rotate (vector 0 90 0)) - (build-plane)) - - (when lower - (with-state - (texture (load-texture bottom)) - (translate (vector 0 -0.5 0)) - (rotate (vector 90 0 0)) - (build-plane))) - - p))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define game-view% - (class object% - - (field - (plants '()) ; map of ids -> plants - (pickups '()) ; map of ids -> pickups - (camera-dist 1) - (env-root (with-state (scale 1000) (build-locator))) - (root-camera-t 0) - #;(upper-env (with-state - (parent env-root) - (hint-depth-sort) - (colour 2) - (translate (vector 0 0.28 0)) - (build-env-box "textures/top.png" "textures/bottom-trans.png" - "textures/left.png" "textures/right.png" - "textures/front.png" "textures/back.png"))) - #;(lower-env (with-state - (parent env-root) - (hint-depth-sort) - (translate (vector 0 -0.22001 0)) - (build-env-box "textures/bottom-trans.png" "textures/bottom.png" - "textures/sleft.png" "textures/sright.png" - "textures/sfront.png" "textures/sback.png"))) - (upper-env (with-state - (parent env-root) - ;(hint-depth-sort) - (hint-unlit) - (translate (vector 0 0.28 0)) - (build-env-box "textures/sky-top.png" "textures/floor.png" - "textures/sky-side.png" "textures/sky-side.png" - "textures/sky-side.png" "textures/sky-side.png" #f))) - (lower-env (with-state - (parent env-root) - ;(hint-depth-sort) - (hint-unlit) - (colour (earth-colour)) - (translate (vector 0 -0.22001 0)) - (build-env-box "textures/floor.png" "textures/earth-bottom.png" - "textures/earth-side.png" "textures/earth-side.png" - "textures/earth-side.png" "textures/earth-side.png" #t))) - (nutrients (let ((p (with-state - (hint-depth-sort) - (texture (load-texture "textures/particle.png")) - (build-particles 5000)))) - (with-primitive p - (pdata-map! - (lambda (p) - (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) - "p") - (pdata-map! - (lambda (s) - (vector 1 1 1)) - "s")) - p))) - - (define/public (setup) - (let ((l (make-light 'point 'free))) - (light-diffuse 0 (vector 0.5 0.5 0.5)) - (light-diffuse l (vector 1 1 1)) - (light-position l (vector 10 50 -4))) - - (clear-colour fog-col) - (clip 0.5 10000) - (fog fog-col fog-strength 1 100)) - - (define/public (add-plant plant) - (set! plants (cons (list (send plant get-id) plant) plants))) - - (define/public (get-plant plant-id) - (cadr (assq plant-id plants))) - - (define/public (add-branch-twig plant-id twig) - (send (get-plant plant-id) add-branch-twig twig)) - - (define/public (destroy-branch-twig plant-id twig-id) - (send (get-plant plant-id) destroy-branch-twig twig-id)) - - (define/public (add-twig plant-id parent-twig-id point-index twig) - (send (get-plant plant-id) add-twig parent-twig-id point-index twig)) - - (define/public (grow-seed plant-id amount) - (send (get-plant plant-id) grow-seed amount)) - - (define/public (get-pickup pickup-id) - (cadr (assq pickup-id pickups))) - - (define/public (add-pickup pickup-id type pos) - (set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups))) - - (define/public (pick-up-pickup pickup-id) - (send (get-pickup pickup-id) pick-up) - (set! pickups (assoc-remove pickup-id pickups))) - - (define/public (add-ornament plant-id twig-id point-index property) - (send (get-plant plant-id) add-ornament twig-id point-index property)) - - (define/public (update t d messages) - - (for-each - (lambda (plant) - (send (cadr plant) update t d)) - plants) - - (for-each - (lambda (pickup) - (send (cadr pickup) update t d)) - pickups) - - (when debug-messages - (for-each - (lambda (msg) - (send msg print)) - messages)) - (for-each - (lambda (msg) - (cond - ((eq? (send msg get-name) 'player-plant) ; not really any difference now - (add-plant (make-object plant-view% - (send msg get-data 'plant-id) - (send msg get-data 'pos)))) - - ((eq? (send msg get-name) 'new-plant) - (add-plant (make-object plant-view% - (send msg get-data 'plant-id) - (send msg get-data 'pos)))) - - ((eq? (send msg get-name) 'grow-seed) - (grow-seed (send msg get-data 'plant-id) - (send msg get-data 'amount))) - - ((eq? (send msg get-name) 'destroy-branch-twig) - (destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id))) - - ((eq? (send msg get-name) 'new-branch-twig) - (add-branch-twig (send msg get-data 'plant-id) - (cond - ((eq? (send msg get-data 'render-type) 'ribbon) - (make-object ribbon-twig-view% - (send msg get-data 'twig-id) - (vector 0 0 0) - (send msg get-data 'type) - (send msg get-data 'dir) - (send msg get-data 'width) - (send msg get-data 'num-points))) - - ((eq? (send msg get-data 'render-type) 'extruded) - (make-object extruded-twig-view% - (send msg get-data 'twig-id) - (vector 0 0 0) - (send msg get-data 'type) - (send msg get-data 'dir) - (send msg get-data 'width) - (send msg get-data 'num-points)))))) - - ((eq? (send msg get-name) 'new-twig) - (add-twig (send msg get-data 'plant-id) - (send msg get-data 'parent-twig-id) - (send msg get-data 'point-index) - (cond - ((eq? (send msg get-data 'render-type) 'ribbon) - (make-object ribbon-twig-view% - (send msg get-data 'twig-id) - (vector 0 0 0) ; will be filled in by add-twig - (send msg get-data 'type) - (send msg get-data 'dir) - (send msg get-data 'width) - (send msg get-data 'num-points))) - - ((eq? (send msg get-data 'render-type) 'extruded) - (make-object extruded-twig-view% - (send msg get-data 'twig-id) - (vector 0 0 0) ; will be filled in by add-twig - (send msg get-data 'type) - (send msg get-data 'dir) - (send msg get-data 'width) - (send msg get-data 'num-points)))))) - - ((eq? (send msg get-name) 'twig-grow) - (send (get-plant (send msg get-data 'plant-id)) grow-twig - (send msg get-data 'twig-id) - (send msg get-data 'point) - (send msg get-data 'width))) - - ((eq? (send msg get-name) 'new-pickup) - (add-pickup - (send msg get-data 'pickup-id) - (send msg get-data 'type) - (send msg get-data 'pos))) - - ((eq? (send msg get-name) 'pick-up-pickup) - (pick-up-pickup - (send msg get-data 'pickup-id))) - - ((eq? (send msg get-name) 'new-ornament) - (add-ornament - (send msg get-data 'plant-id) - (send msg get-data 'twig-id) - (send msg get-data 'point-index) - (send msg get-data 'property))) - - )) - messages)) - - - - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -(define controller% - (class object% - (init-field - (game-view #f)) - - (field - (fwd (vector 0 0 1)) - (up (vector 0 1 0)) - (pos (vector 0 0 0)) - (mtx (mident)) - (cam (build-locator)) - (current-twig #f) - (current-twig-growing #f) - (current-point 0) - (tilt 0) - (yaw 0) - (player-plant #f)) - - (define/public (set-player-plant s) - (set! player-plant s)) - - (define/public (get-cam-obj) - cam) - - (define/public (set-pos s) - (set! pos s)) - - (define/public (set-fwd s) - (set! fwd s)) - - (define/public (get-fwd) - fwd) - - (define/public (setup) - (lock-camera cam) - (camera-lag 0.2) - (clip 1 1000) - (set-camera-transform (mtranslate (vector 0 0 -4)))) - - (define/public (update) - (when (key-pressed-this-frame " ") - (cond ((and current-twig (not current-twig-growing)) - (let ((new-twig (send current-twig add-twig current-point - (vector 0 1 0) #;(vsub (send current-twig get-point current-point) - (send current-twig get-point (- current-point 1)))))) - (set! current-twig-growing #t) - (set! current-twig new-twig))) - (else - (set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root - (vmul fwd -1) - start-twig-width max-twig-points 'extruded)) - (send player-plant add-twig current-twig) - (set! current-twig-growing #t)))) - - (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2))) - (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2))) - (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2))) - (when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2))) - - ; clamp tilt to prevent gimbal lock - (when (> tilt 88) (set! tilt 88)) - (when (< tilt -88) (set! tilt -88)) - - (when (key-pressed-this-frame "q") - (cond ((not current-twig) - (set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1))) - (set! current-point 2)) - (else - (when (< current-point (- (send current-twig get-num-points) 1)) - (set! current-point (+ current-point 1)))))) - - (when (key-pressed-this-frame "z") - (cond (current-twig - (set! current-point (- current-point 1)) - (when (< current-point 2) - (set! current-twig #f) - (set! pos (vector 0 0 0)) - #;(set-camera-transform (mtranslate (vector 0 0 -1))))))) - - ; get camera fwd vector from key-presses - (set! fwd (vtransform (vector 0 0 1) - (mmul - (mrotate (vector 0 yaw 0)) - (mrotate (vector tilt 0 0))))) - - - ; if we are on a twig not growing - (cond ((and current-twig (not current-twig-growing)) - (set! pos (send current-twig get-point current-point)) - #;(when (> current-point 0) - (set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point - (- current-point 1)) - pos)) 0.5)))) - - (else - (when current-twig-growing - (let ((twig-view (send (send game-view get-plant (send player-plant get-id)) - get-twig (send current-twig get-id)))) - (when twig-view - (set! pos (vsub (send twig-view get-end-pos) - (vmul (send current-twig get-dir) 1))))) - (when (eq? (send current-twig get-num-points) - (send current-twig get-length)) - (set! current-twig-growing #f) - (set! current-point (- (send current-twig get-num-points) 1)))))) - - - (let* ((side (vnormalise (vcross up fwd))) - (up (vnormalise (vcross fwd side)))) - - (with-primitive cam - (identity) - (concat (vector (vx side) (vy side) (vz side) 0 - (vx up) (vy up) (vz up) 0 - (vx fwd) (vy fwd) (vz fwd) 0 - (vx pos) (vy pos) (vz pos) 1))))) - - (super-new))) - -;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (clear) + (define gl (make-object game-logic%)) (define gv (make-object game-view%)) (define c (make-object controller% gv)) diff --git a/plant-eyes/view.ss b/plant-eyes/view.ss new file mode 100644 index 0000000..0992e57 --- /dev/null +++ b/plant-eyes/view.ss @@ -0,0 +1,649 @@ +#lang scheme/base +(require scheme/class fluxus-016/drflux "message.ss" "list-utils.ss") +(provide (all-defined-out)) + +; the fluxus code to make things look the way they do + +(define debug-messages #f) ; prints out all the messages sent to the renderer +(define audio-on #f) + +(define (ornament-colour) (vector 0.5 1 0.4)) +(define (pickup-colour) (vector 1 1 1)) +(define (earth-colour) (vector 0.2 0.1 0)) + +(define wire-mode #f) +(define fog-col (earth-colour)) +(define fog-strength 0.001) +(define max-ornaments 2) ; per twig +(define default-grow-speed 2) + +(when audio-on (oa-start)) ;; start openAL audio + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define ornament-view% + (class object% + (init-field + (pos (vector 0 0 0)) + (property 'none) + (time 0)) + + (field + (rot (vmul (rndvec) 360)) + (root (with-state + (translate pos) + (rotate rot) + (scale 0.01) + (cond + ((eq? property 'wiggle) +; (opacity 1) + (hint-depth-sort) + (colour (vector 0.5 0.0 0.0)) + (load-primitive "meshes/wiggle.obj")) + ((eq? property 'leaf) + (colour (vector 0.8 1 0.6)) + (texture (load-texture "textures/leaf2.png")) + (load-primitive "meshes/leaf.obj")) + (else (error "")))))) + + (define/public (update t d) + (when (< time 1) + (with-primitive root + (identity) + (translate pos) + (rotate rot) + (scale (* 0.2 time))) + (set! time (+ time (* 0.1 d))))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define pickup-view% + (class object% + (init-field + (id -1) + (type 'none) + (pos (vector 0 0 0))) + + (field + (rot (vmul (rndvec) 360)) + (root (with-state + (translate pos) + (rotate rot) + (colour (pickup-colour)) + (scale 0.3) + (texture + (cond + ((eq? type 'wiggle) (load-texture "textures/wiggle.png")) + ((eq? type 'leaf) (load-texture "textures/leaf.png")) + ((eq? type 'curly) (load-texture "textures/curl.png")))) + (load-primitive "meshes/pickup.obj"))) + (from pos) + (destination (vector 0 0 0)) + (speed 0.05) + (t -1)) + + (define/public (pick-up) + (destroy root)) + + (define/public (move-to s) + (set! t 0) + (set! from pos) + (set! destination s)) + + (define/public (update t d) + (with-primitive root + (rotate (vector (* d 10) 0 0))) + #;(when (and (>= t 0) (< t 1)) + (set! pos (vadd pos (vmul (vsub destination from) speed))) + (with-primitive root + (identity) + (translate pos) + (rotate rot)) + (set! t (+ t speed)))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define twig-view% + (class object% + (init-field + (id 0) + (pos (vector 0 0 0)) + (type 'none) + (dir (vector 0 1 0)) + (radius 1) + (num-points 0)) + + (field + (index 0) + (parent-twig-id -1) + (child-twig-ids '()) + (ornaments '())) + + (define/public (get-id) + id) + + (define/public (get-dir) + dir) + + (define/public (build) + 0) + + (define/public (set-pos! s) + (set! pos s)) + + (define/public (get-child-twig-ids) + child-twig-ids) + + (define/public (get-root) + (error "need to overide this")) + + (define/public (destroy-twig) + (destroy (get-root))) + + (define/public (set-parent-twig-id s) + (set! parent-twig-id s)) + + (define/public (get-point point-index) + (error "need to overide this")) + + (define/public (add-child-twig-id twig-id) + (set! child-twig-ids (cons twig-id child-twig-ids))) + + (define/pubment (grow point width) + (when audio-on (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav")))) + (oa-play growing-noise (vector 0 0 0) (rndf) 0.3))) + (inner (void) grow point width)) + + (define/public (add-ornament point-index property) + (when (< (length ornaments) max-ornaments) + (with-state + (parent (get-root)) + ; todo - different ornament-view objects per property needed? + ; todo - delete existing ornaments here + (set! ornaments (cons (list point-index + (make-object ornament-view% + (get-point point-index) + property)) + ornaments))))) + + (define/pubment (update t d) + (for-each + (lambda (ornament) + (send (cadr ornament) update t d)) + ornaments) + + (inner (void) update t d)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define ribbon-twig-view% + (class twig-view% + + (inherit-field pos radius num-points index) + + (field + (root 0)) + + (define/override (build) + (set! root (let ((p (with-state + (translate pos) + (colour (vector 0.8 1 0.6)) + (texture (load-texture "textures/root.png")) + (build-ribbon num-points)))) + (with-primitive p + (pdata-map! + (lambda (w) + 0) + "w") + (pdata-set! "w" 0 radius)) + p))) + + + (define/override (get-root) + root) + + (define/override (get-point point-index) + (with-primitive root + (pdata-ref "p" point-index))) + + (define/augment (grow point width) + (with-primitive root + (pdata-index-map! ; set all the remaining points to the end + (lambda (i p) ; in order to hide them + (if (< i index) + p + point)) + "p") + (pdata-index-map! ; do a similar thing with the width + (lambda (i w) + (if (< i (+ index 1)) + w + width)) + "w")) + (set! index (+ index 1))) + + (define/augment (update t d) + 0) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define extruded-twig-view% + (class twig-view% + + (inherit-field index radius num-points pos dir) + + (field + (profile '()) + (path '()) + (root 0) + (grow-speed default-grow-speed) + (anim-t 0) + (widths '())) + + (define/override (build) + (set! profile (build-circle-profile 12 1)) + (set! path (build-list num-points (lambda (_) (vector 0 0 0)))) + (set! widths (build-list num-points (lambda (_) 1))) + (set! root (let ((p (with-state + (backfacecull 0) + (when wire-mode + (hint-none) + (hint-wire)) + (texture (load-texture "textures/root2.png")) + ;(opacity 0.6) + (colour (vmul (vector 0.8 1 0.6) 2)) + #;(colour (vector 1 1 1)) + #;(texture (load-texture "textures/root.png")) + (build-partial-extrusion profile path 3)))) + p))) + + (define/override (get-root) + root) + + (define/override (get-point point-index) + (list-ref path point-index)) + + (define (list-set l c s) + (cond ((null? l) '()) + ((zero? c) (cons s (list-set (cdr l) (- c 1) s))) + (else (cons (car l) (list-set (cdr l) (- c 1) s))))) + + (define/augment (grow point width) + (set! path (list-set path index point)) + (set! widths (list-set widths index width)) + (set! anim-t 0) + (set! index (+ index 1))) + + (define/augment (update t d) + (when (< anim-t 1) + (with-primitive root + (partial-extrude (+ (- index 2) anim-t) + profile path widths (vector 1 0 0) 0.05))) + (set! anim-t (+ anim-t (* d grow-speed)))) + + (define/public (get-end-pos) + (with-primitive root (pdata-ref "p" (- (* index (length profile)) 1)))) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define plant-view% + (class object% + + (init-field + (id "none") + (pos (vector 0 0 0)) + (size 0)) + + (field + (twigs '()) ; a assoc list map between ids and twigs stored flat here, + ; for fast access, but prims heirachically in the scenegraph + (root (with-state + (translate pos) + (build-locator))) + (seed (with-state + (parent root) + (texture (load-texture "textures/root2.png")) + (backfacecull 0) + (opacity 0.6) + (colour (vector 0.8 1 0.6)) + (hint-depth-sort) + (scale (* 0.12 size)) + (when wire-mode + (hint-none) + (hint-wire)) + ;(hint-unlit) + (load-primitive "meshes/seed.obj")))) + + (define/public (get-id) + id) + + (define/public (get-twig twig-id) + (let ((l (assq twig-id twigs))) + (if l + (cadr (assq twig-id twigs)) + #f))) + + (define/public (add-branch-twig twig) + ; attach to seed + (with-primitive (send twig get-root) + (parent root)) + (send twig build) + (set! twigs (cons (list (send twig get-id) twig) twigs))) + + (define/public (destroy-branch-twig twig-id) + (for-each + (lambda (twig-id) + (destroy-branch-twig twig-id)) + (send (get-twig twig-id) get-child-twig-ids)) + (send (get-twig twig-id) destroy-twig) + (set! twigs (assoc-remove twig-id twigs))) + + (define/public (add-twig parent-twig-id point-index twig) + (let ((ptwig (get-twig parent-twig-id))) + ; attach to parent twig + (send twig set-pos! (send ptwig get-point point-index)) + (send twig build) + (with-primitive (send twig get-root) + (parent (send ptwig get-root))) + + + ; tell the twigs about this relationship (might turn out to be overkill) + (send ptwig add-child-twig-id (send twig get-id)) + (send twig set-parent-twig-id parent-twig-id) + + (set! twigs (cons (list (send twig get-id) twig) twigs)))) + + (define/public (grow-twig twig-id point width) + (send (get-twig twig-id) grow point width)) + + (define/public (grow-seed amount) + (with-primitive seed (scale amount))) + + (define/public (add-ornament twig-id point-index property) + (send (get-twig twig-id) add-ornament point-index property)) + + (define/public (update t d) + + (with-primitive seed + (scale (+ 1 (* 0.001 (sin (* 2 t)))))) + + (for-each + (lambda (twig) + (send (cadr twig) update t d)) + twigs)) + + (super-new))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define (build-env-box top bottom left right front back lower) + (let ((p (build-locator))) + (with-state + (parent p) + (hint-unlit) + + (let ((t (with-state + (texture (load-texture top)) + (translate (vector 0 0.5 0)) + (rotate (vector 90 0 0)) + (build-plane)))) + (when lower (with-primitive t + (pdata-map! + (lambda (t) + (vmul t 10)) + "t")))) + + (with-state + (texture (load-texture left)) + (translate (vector 0 0 -0.5)) + (rotate (vector 0 0 0)) + (build-plane)) + + (with-state + (texture (load-texture back)) + (translate (vector 0.5 0 0)) + (rotate (vector 0 90 0)) + (build-plane)) + + (with-state + (texture (load-texture right)) + (translate (vector 0 0 0.5)) + (rotate (vector 0 0 0)) + (build-plane)) + + (with-state + (texture (load-texture front)) + (translate (vector -0.5 0 0)) + (rotate (vector 0 90 0)) + (build-plane)) + + (when lower + (with-state + (texture (load-texture bottom)) + (translate (vector 0 -0.5 0)) + (rotate (vector 90 0 0)) + (build-plane))) + + p))) + +;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +(define game-view% + (class object% + + (field + (plants '()) ; map of ids -> plants + (pickups '()) ; map of ids -> pickups + (camera-dist 1) + (env-root (with-state (scale 1000) (build-locator))) + (root-camera-t 0) + #;(upper-env (with-state + (parent env-root) + (hint-depth-sort) + (colour 2) + (translate (vector 0 0.28 0)) + (build-env-box "textures/top.png" "textures/bottom-trans.png" + "textures/left.png" "textures/right.png" + "textures/front.png" "textures/back.png"))) + #;(lower-env (with-state + (parent env-root) + (hint-depth-sort) + (translate (vector 0 -0.22001 0)) + (build-env-box "textures/bottom-trans.png" "textures/bottom.png" + "textures/sleft.png" "textures/sright.png" + "textures/sfront.png" "textures/sback.png"))) + (upper-env (with-state + (parent env-root) + ;(hint-depth-sort) + (hint-unlit) + (translate (vector 0 0.28 0)) + (build-env-box "textures/sky-top.png" "textures/floor.png" + "textures/sky-side.png" "textures/sky-side.png" + "textures/sky-side.png" "textures/sky-side.png" #f))) + (lower-env (with-state + (parent env-root) + ;(hint-depth-sort) + (hint-unlit) + (colour (earth-colour)) + (translate (vector 0 -0.22001 0)) + (build-env-box "textures/floor.png" "textures/earth-bottom.png" + "textures/earth-side.png" "textures/earth-side.png" + "textures/earth-side.png" "textures/earth-side.png" #t))) + (nutrients (let ((p (with-state + (hint-depth-sort) + (texture (load-texture "textures/particle.png")) + (build-particles 5000)))) + (with-primitive p + (pdata-map! + (lambda (p) + (vmul (vadd (crndvec) (vector 0 -1 0)) 900)) + "p") + (pdata-map! + (lambda (s) + (vector 1 1 1)) + "s")) + p))) + + (define/public (setup) + (let ((l (make-light 'point 'free))) + (light-diffuse 0 (vector 0.5 0.5 0.5)) + (light-diffuse l (vector 1 1 1)) + (light-position l (vector 10 50 -4))) + + (clear-colour fog-col) + (clip 0.5 10000) + (fog fog-col fog-strength 1 100)) + + (define/public (add-plant plant) + (set! plants (cons (list (send plant get-id) plant) plants))) + + (define/public (get-plant plant-id) + (cadr (assq plant-id plants))) + + (define/public (add-branch-twig plant-id twig) + (send (get-plant plant-id) add-branch-twig twig)) + + (define/public (destroy-branch-twig plant-id twig-id) + (send (get-plant plant-id) destroy-branch-twig twig-id)) + + (define/public (add-twig plant-id parent-twig-id point-index twig) + (send (get-plant plant-id) add-twig parent-twig-id point-index twig)) + + (define/public (grow-seed plant-id amount) + (send (get-plant plant-id) grow-seed amount)) + + (define/public (get-pickup pickup-id) + (cadr (assq pickup-id pickups))) + + (define/public (add-pickup pickup-id type pos) + (set! pickups (cons (list pickup-id (make-object pickup-view% pickup-id type pos)) pickups))) + + (define/public (pick-up-pickup pickup-id) + (send (get-pickup pickup-id) pick-up) + (set! pickups (assoc-remove pickup-id pickups))) + + (define/public (add-ornament plant-id twig-id point-index property) + (send (get-plant plant-id) add-ornament twig-id point-index property)) + + (define/public (update t d messages) + + (for-each + (lambda (plant) + (send (cadr plant) update t d)) + plants) + + (for-each + (lambda (pickup) + (send (cadr pickup) update t d)) + pickups) + + (when debug-messages + (for-each + (lambda (msg) + (send msg print)) + messages)) + (for-each + (lambda (msg) + (cond + ((eq? (send msg get-name) 'player-plant) ; not really any difference now + (add-plant (make-object plant-view% + (send msg get-data 'plant-id) + (send msg get-data 'pos) + (send msg get-data 'size)))) + + ((eq? (send msg get-name) 'new-plant) + (add-plant (make-object plant-view% + (send msg get-data 'plant-id) + (send msg get-data 'pos)))) + + ((eq? (send msg get-name) 'grow-seed) + (grow-seed (send msg get-data 'plant-id) + (send msg get-data 'amount))) + + ((eq? (send msg get-name) 'destroy-branch-twig) + (destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id))) + + ((eq? (send msg get-name) 'new-branch-twig) + (add-branch-twig (send msg get-data 'plant-id) + (cond + ((eq? (send msg get-data 'render-type) 'ribbon) + (make-object ribbon-twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points))) + + ((eq? (send msg get-data 'render-type) 'extruded) + (make-object extruded-twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points)))))) + + ((eq? (send msg get-name) 'new-twig) + (add-twig (send msg get-data 'plant-id) + (send msg get-data 'parent-twig-id) + (send msg get-data 'point-index) + (cond + ((eq? (send msg get-data 'render-type) 'ribbon) + (make-object ribbon-twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) ; will be filled in by add-twig + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points))) + + ((eq? (send msg get-data 'render-type) 'extruded) + (make-object extruded-twig-view% + (send msg get-data 'twig-id) + (vector 0 0 0) ; will be filled in by add-twig + (send msg get-data 'type) + (send msg get-data 'dir) + (send msg get-data 'width) + (send msg get-data 'num-points)))))) + + ((eq? (send msg get-name) 'twig-grow) + (send (get-plant (send msg get-data 'plant-id)) grow-twig + (send msg get-data 'twig-id) + (send msg get-data 'point) + (send msg get-data 'width))) + + ((eq? (send msg get-name) 'new-pickup) + (add-pickup + (send msg get-data 'pickup-id) + (send msg get-data 'type) + (send msg get-data 'pos))) + + ((eq? (send msg get-name) 'pick-up-pickup) + (pick-up-pickup + (send msg get-data 'pickup-id))) + + ((eq? (send msg get-name) 'new-ornament) + (add-ornament + (send msg get-data 'plant-id) + (send msg get-data 'twig-id) + (send msg get-data 'point-index) + (send msg get-data 'property))) + + )) + messages)) + + + + + (super-new))) diff --git a/plant-eyes/xmpp.ss b/plant-eyes/xmpp.ss new file mode 100644 index 0000000..df4cfe4 --- /dev/null +++ b/plant-eyes/xmpp.ss @@ -0,0 +1,421 @@ +;;; A basic XMPP library which should conform to RFCs 3920 and 3921 +;;; +;;; Copyright (C) 2009 FoAM vzw. +;;; +;;; This package is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation, either +;;; version 3 of the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You can find a copy of the GNU Lesser General Public License at +;;; http://www.gnu.org/licenses/lgpl-3.0.html. +;;; +;;; Authors +;;; +;;; nik gaffney +;;; +;;; Requirements +;;; +;;; PLT for now. TLS requires a version of PLT > 4.1.5.3 +;;; +;;; Commentary +;;; +;;; Still a long way from implementing even a minimal subset of XMPP +;;; +;;; features implemented +;;; - plaintext sessions on port 5222 +;;; - "old sytle" ssl sessions on port 5223 (default) +;;; - authenticate using an existing account +;;; - send messages (rfc 3921 sec.4) +;;; - send presence (rfc 3921 sec.5) +;;; - parse (some) xml reponses from server +;;; - handlers for responses +;;; - basic roster handling (rfc 3921 sec.7) +;;; +;;; features to implement +;;; - account creation +;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8) +;;; - error handling for rosters (rfc 3921 sec.7) +;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6) +;;; - encrypted connections using tls on port 5222 +;;; - correct namespaces in sxml +;;; - message types +;;; - maintain session ids +;;; - maintain threads +;;; - error handling +;;; - events +;;; - [...] +;;; - rfc 3920 +;;; - rfc 3921 +;;; +;;; bugs and/or improvements +;;; - start & stop functions for multiple sessions +;;; - pubsub (XEP-0060) & group chats (XEP-0045) +;;; - 'send' using call/cc & parameterize'd i/o ports +;;; - coroutines for sasl negotiation +;;; - read-async & repsonse-handler +;;; - ssax:xml->sxml or lazy:xml->sxml +;;; - default handlers +;;; - syntax for defining sxpath based handlers +;;; - improve parsing +;;; - chatbot exmples +;;; + +(module xmpp scheme + + (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml + (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml + (require mzlib/os) ;; hostname + (require scheme/tcp) ;; networking + (require openssl) ;; ssl/tls + (require srfi/13) ;; jid decoding + + (provide (all-defined-out)) + + ;;;; ; ;; ; + ;; + ;; debugging + ;; + ;;;; ; ; + + (define debug? #t) + + (define debugf + (case-lambda + ((str) (when debug? (printf str))) + ((str . dir) (when debug? (apply printf (cons str dir)))))) + + ;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ; + ;; + ;; networking + ;; + ;;;;;; ;; ;; ; ; ; ; + + (define port 5222) + (define ssl-port 5223) + + (define (open-connection machine port handler) + (let-values (((in out) + (tcp-connect machine port))) + (handler in out) + (close-output-port out) + (close-input-port in))) + + (define (open-ssl-connection machine port handler) + (let-values (((in out) + (ssl-connect machine port 'tls))) + (handler in out) + (close-output-port out) + (close-input-port in))) + + (define (read-async in) + (bytes->string/utf-8 (list->bytes (read-async-bytes in)))) + + (define (read-async-bytes in) + (let ((bstr '())) + (when (sync/timeout 0 in) + (set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr)) + + (define ssxml srl:sxml->xml-noindent) + + ;;;;;; ; ; ; ; ;; ;;;;;; ; + ;; + ;; XMPP stanzas + ;; + ;;;;;;;;;; ;;; ; ;; ; ; + + ;; intialization + (define (xmpp-stream host) + (string-append "" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223 + "")) + + ;; authentication + (define (xmpp-auth username password resource) + (ssxml `(iq (@ (type "set") (id "auth")) + (query (@ (xmlns "jabber:iq:auth")) + (username ,username) + (password ,password) + (resource ,resource))))) + + (define (xmpp-session host) + (ssxml `(iq (@ (to ,host) (type "set") (id "session")) + (session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session")))))) + + ;; messages + (define (message to body) + (ssxml `(message (@ (to ,to)) (body ,body)))) + + ;; presence + (define (presence #:from (from "") + #:to (to "") + #:type (type "") + #:show (show "") + #:status (status "")) + (cond ((not (string=? status "")) + (ssxml `(presence (@ (type "probe")) (status ,status)))) + ((string=? type "") "") + (else (ssxml `(presence (@ (type ,type))))))) + + ;; queries + (define (iq body + #:from (from "") + #:to (to "") + #:type (type "") + #:id (id "")) + (ssxml `(iq (@ (to ,to) (type ,type) ,body)))) + + ;; curried stanza disection (sxml stanza -> string) + (define ((sxpath-element xpath (ns "")) stanza) + (let ((node ((sxpath xpath (list (cons 'ns ns))) stanza))) + (if (empty? node) "" (car node)))) + + ;; message + (define message-from (sxpath-element "message/@from/text()")) + (define message-to (sxpath-element "message/@to/text()")) + (define message-id (sxpath-element "message/@id/text()")) + (define message-type (sxpath-element "message/@type/text()")) + (define message-body (sxpath-element "message/body/text()")) + (define message-subject (sxpath-element "message/subject/text()")) + + ;; info/query + (define iq-type (sxpath-element "iq/@type/text()")) + (define iq-id (sxpath-element "iq/@id/text()")) + (define iq-error-type (sxpath-element "iq/error/@type/text()")) + (define iq-error-text (sxpath-element "iq/error/text()")) + (define iq-error (sxpath-element "iq/error")) + + ;; presence + (define presence-show (sxpath-element "presence/show/text()")) + (define presence-from (sxpath-element "presence/@from/text()")) + (define presence-status (sxpath-element "presence/status/text()")) + + + ;;;;;;;;;; ; ; ; ;; ; + ;; + ;; rosters + ;; + ;;;;;; ; ;; ; + + ;; request the roster from server + (define (request-roster from) + (ssxml `(iq (@ (from ,from) (type "get") (id "roster_1")) + (query (@ (xmlns "jabber:iq:roster")))))) + + ;; add an item to the roster + (define (add-to-roster from jid name group) + (ssxml `(iq (@ (from ,from) (type "set") (id "roster_2")) + (query (@ (xmlns "jabber:iq:roster")) + (item (@ (jid ,jid) (name ,name)) + (group ,group)))))) + + ;; update an item in the roster + (define (update-roster from jid name group) + (ssxml `(iq (@ (from ,from) (type "set") (id "roster_3")) + (query (@ (xmlns "jabber:iq:roster")) + (item (@ (jid ,jid) (name ,name)) + (group ,group)))))) + + ;; remove an item from the roster + (define (remove-from-roster from jid) + (ssxml `(iq (@ (from ,from) (type "set") (id "roster_4")) + (query (@ (xmlns "jabber:iq:roster")) + (item (@ (jid ,jid) (subscription "remove"))))))) + + + ;;;;; ; ; ;; ; ; + ;; + ;; in-band registration + ;; + ;;;;;; ;; ;; ; + + (define (reg1) + (ssxml `(iq (@ (type "get") (id "reg1")) + (query (@ (xmlns "jabber:iq:register")))))) + + ;;;; ;; ; ;;; ; + ;; + ;; tls & sasl + ;; - http://xmpp.org/rfcs/rfc3920.html#tls + ;; - http://xmpp.org/rfcs/rfc3920.html#sasl + ;; + ;;;; ;; + + (define session->tls? #f) ;; changes state when a tls proceed is recived + + ;; moved to xmpp-sasl until it 'works' + + + ;;;;;;;;; ; ;; ; ; ;; ;; ; ; + ;; + ;; parsing & message/iq/error handlers + ;; - minimal parsing + ;; - handlers match on a tag (eg. 'message) + ;; - handlers are called with a single relevant xmpp stanza + ;; + ;;;;;; ;; ; ; ;; ; + + (define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers) + + (define (set-xmpp-handler type fcn) + (dict-set! xmpp-handlers type fcn)) + + (define (remove-xmpp-handler type fcn) + (dict-remove! xmpp-handlers type fcn)) + + (define (run-xmpp-handler type sz) + (let ((fcn (dict-ref xmpp-handlers type #f))) + (when fcn (begin + (debugf "attempting to run handler ~a.~%" fcn) + (fcn sz))))) + + ;; no real parsing yet. dispatches any received xml stanzas as sxml + + (define (parse-xmpp-response str) + (when (> (string-length str) 0) + (let ((sz (ssax:xml->sxml (open-input-string (clean str)) '()))) + ;;(let ((sz (lazy:xml->sxml (open-input-string str) '()))) + (cond + ((equal? '(null) (cadr sz)) + (newline)) + ((equal? 'message (caadr sz)) + (run-xmpp-handler 'message sz)) + ((equal? 'iq (caadr sz)) + (run-xmpp-handler 'iq sz)) + ((equal? 'presence (caadr sz)) + (run-xmpp-handler 'presence sz)) + (else (run-xmpp-handler 'other sz)))))) + + ;; example handlers to print stanzas or their contents + (define (print-message sz) + (printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz))) + + (define (print-iq sz) + (printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz))) + + (define (print-presence sz) + (printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status))) + + (define (print-stanza sz) + (printf "? ?? -> ~%~a~%" sz)) + + ;; handler to print roster + + (define (roster-jids sz) + ((sxpath "iq/ns:query/ns:item/@jid/text()" '(( ns . "jabber:iq:roster"))) sz)) + + (define (roster-items sz) + ((sxpath-element "iq/ns:query/ns:item" '(( ns . "jabber:iq:roster"))) sz)) + + (define (print-roster sz) + (when (and (string=? (iq-type sz) "result") + (string=? (iq-id sz) "roster_1")) + (printf "~a~%" (roster-jids sz)))) + + ;; QND hack to filter out anything not a message, iq or presence + (define (clean str) + (let ((test (substring str 0 3))) + (cond ((string-ci=? test "~%~%" str) + "")))) + + + ;; response handler + (define (xmpp-response-handler in) + (thread (lambda () + (let loop () + (parse-xmpp-response (read-async in)) + (sleep 0.1) ;; slight delay to avoid a tight loop + (loop))))) + + ;; jid splicing (assuming the jid is in the format user@host/resource) + (define (jid-user jid) + (string-take jid (string-index jid #\@))) + + (define (jid-host jid) + (let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1))) + (v (string-index s #\/))) + (if v (string-take s v) s ))) + + (define (jid-resource jid) + (let ((r (jid-resource-0 jid))) + (if (void? r) (gethostname) r))) + + (define (jid-resource-0 jid) + (let ((v (string-index jid #\/))) + (when v (string-take-right jid (- (string-length jid) v 1))))) + + + ;;;; ;; ; ; ;; ;; ;;;; ; + ;; + ;; interfaces + ;; + ;;;;; ;; ;;;; ; ;; ; + + (define xmpp-in-port (make-parameter #f)) + (define xmpp-out-port (make-parameter #F)) + + (define (send str) + (debugf "sending: ~a ~%~%" str) + (let* ((p-out (xmpp-out-port)) + (out (if p-out p-out xmpp-out-port-v))) + (fprintf out "~A~%" str) (flush-output out))) + + (define-syntax with-xmpp-session + (syntax-rules () + ((_ jid pass form . forms) + (let ((host (jid-host jid)) + (user (jid-user jid)) + (resource (jid-resource jid))) + (let-values (((in out) + (ssl-connect host ssl-port 'tls))) + ;;(tcp-connect host port))) + (parameterize ((xmpp-in-port in) + (xmpp-out-port out)) + (file-stream-buffer-mode out 'line) + (xmpp-response-handler in) + (send (xmpp-stream host)) + (send (xmpp-session host)) + ;(starttls in out) + (send (xmpp-auth user pass resource)) + (send (presence)) + (begin form . forms) + (close-output-port out) + (close-input-port in))))))) + + ;; NOTE: this will only work with a single connection to a host, however multiple sessions to that host may be possible + (define xmpp-in-port-v (current-input-port)) + (define xmpp-out-port-v (current-output-port)) + + (define (start-xmpp-session jid pass) + (let ((host (jid-host jid)) + (user (jid-user jid)) + (resource (jid-resource jid))) + (let-values (((in out) + (ssl-connect host ssl-port 'tls))) + ;;(tcp-connect host port))) + (set! xmpp-in-port-v in) + (set! xmpp-out-port-v out) + (file-stream-buffer-mode out 'line) + (xmpp-response-handler in) + (send (xmpp-stream host)) + (send (xmpp-session host)) + ;;(starttls in out) + (send (xmpp-auth user pass resource)) + (send (presence))))) + + (define (close-xmpp-session) + (close-output-port xmpp-out-port-v) + (close-input-port xmpp-in-port-v)) + + ) ;; end module \ No newline at end of file diff --git a/pluggable/pluggable.scm b/pluggable/pluggable.scm index 4247515..ece84fc 100644 --- a/pluggable/pluggable.scm +++ b/pluggable/pluggable.scm @@ -67,7 +67,7 @@ (cond (ret (cdr ret)) (else - (let* ((tex (load-primitive (string-append "plant-2/comp-cp-" id ".png"))) + (let* ((tex (load-primitive (string-append "plant-1/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) @@ -85,7 +85,7 @@ (let ((root (with-state (translate (vector 0 0.5 0)) (hint-ignore-depth) - (texture (load-texture (string-append "plant-2/comp-" id ".png"))) + (texture (load-texture (string-append "plant-1/comp-" id ".png"))) (build-plane)))) (with-primitive root (apply-transform)) (make-component root '()))) @@ -93,7 +93,7 @@ (let* ((connection-list (get-connection-list id)) (root (with-state (translate (vector 0 0.5 0)) - (texture (load-texture (string-append "plant-2/comp-" id ".png"))) + (texture (load-texture (string-append "plant-1/comp-" id ".png"))) (build-plane))) (comp (make-component root (map @@ -127,9 +127,9 @@ (cond ((eq? num-children 0) (list (choose (list "3" "4" "8" "9")) (list))) ((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1))))) - ((eq? num-children 2) (list (string-append "2-" (choose (list "1" "2" "6" "10" "13" "16"))) (list (make-random-plant (+ depth 1)) + ((eq? num-children 2) (list (string-append "2-" (choose (list "1"))) (list (make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))) - ((eq? num-children 3) (list (string-append "3-" (choose (list "7"))) + ((eq? num-children 3) (list (string-append "3-" (choose (list "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))