diff --git a/plant-eyes/plant-eyes.scm b/plant-eyes/plant-eyes.scm index ebe3574..74c900b 100644 --- a/plant-eyes/plant-eyes.scm +++ b/plant-eyes/plant-eyes.scm @@ -1,5 +1,5 @@ -;#lang scheme/base -;(require fluxus-016/drflux) +#lang scheme/base +(require fluxus-016/drflux) (require scheme/class) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -40,6 +40,7 @@ (define branch-jitter 1) (define max-twig-points 40) (define start-twig-width 0.1) +(define default-max-twigs 5) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; a message for sending betwixt logic and render side @@ -110,7 +111,8 @@ (points '()) ; the 3d points for this twig (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 - (last-point (vector 0 0 0))) + (last-point (vector 0 0 0)) + (dist 1)) ; distance between points (inherit send-message) @@ -138,11 +140,16 @@ (define/public (get-point point-index) (list-ref points point-index)) + (define/public (scale a) + (set! width (* width a)) + (set! dist (* dist a)) + (printf "~a~n" dist)) + (define/public (grow) (when (< (length points) num-points) (let ((new-point (if (zero? (length points)) (vector 0 0 0) ; first point should be at the origin - (vadd last-point dir (vmul (srndvec) twig-jitter))))) + (vadd last-point (vmul dir dist) (vmul (srndvec) twig-jitter))))) (set! last-point new-point) (set! points (append points (list new-point))) (send-message 'twig-grow (list @@ -276,9 +283,10 @@ (field (twigs '()) ; a assoc list map of ages to twigs - (age 0) ; the age of this plant - (max-twigs 10) ; the maximum twigs allowed at any time - oldest removed first - (next-twig-id 0)) + (size 1) ; the age of this plant + (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first + (next-twig-id 0) + (grow-amount 1.1)) (inherit send-message) @@ -327,6 +335,12 @@ (define/public (add-twig twig) (send twig set-id! (get-next-twig-id)) + (set! size (* size grow-amount)) + (send twig scale size) + + (send-message 'grow-seed (list + (list 'pland-id id) + (list 'amount grow-amount))) (send-message 'new-branch-twig (list (list 'plant-id id) (list 'twig-id (send twig get-id)) @@ -336,6 +350,7 @@ (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/augment (update) @@ -573,8 +588,14 @@ (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)) @@ -741,6 +762,22 @@ (send twig build) (set! twigs (cons (list (send twig get-id) twig) twigs))) + (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/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 @@ -877,6 +914,9 @@ (set! current-twig-id (send twig get-id))) (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)) @@ -910,7 +950,10 @@ ((eq? (send msg get-name) 'new-plant) (add-plant (make-object plant-view% (send msg get-data 'plant-id) - (send msg get-data 'pos)) #f)) + (send msg get-data 'pos)) #f)) + + ((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) @@ -999,17 +1042,17 @@ (vtransform-rot (vector 0 0 -1) (minverse (get-camera-transform))) start-twig-width 20 'extruded)) (set! debounce #f) - (set! debounce-time (+ (time) 0.2))) + (set! debounce-time (+ (flxtime) 0.2))) - (when (> (time) debounce-time) + (when (> (flxtime) debounce-time) (set! debounce #t)) - (when (< tick-time (time)) - (set! tick-time (+ (time) tick)) + (when (< tick-time (flxtime)) + (set! tick-time (+ (flxtime) tick)) (send plant1 grow) (send plant2 grow) - (send gv update (time) (delta) (send gl update))) + (send gv update (flxtime) (delta) (send gl update))) - (send gv update (time) (delta) '())) + (send gv update (flxtime) (delta) '())) (every-frame (animate))