1368 lines
47 KiB
Scheme
1368 lines
47 KiB
Scheme
#lang scheme/base
|
|
(require fluxus-016/drflux)
|
|
(require scheme/class)
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; p l a n t e y e s
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
; notes:
|
|
;
|
|
; * keeping with a view/logic separation, although this is quite different to
|
|
; the hexagon game. the main advantages:
|
|
; - just a divide and conquer strategy for staying sane
|
|
; - able to debug the logic without the view, or vice versa
|
|
; - the logic can be ticked at a lower frequency - or even different
|
|
; parts at different rates, whereas the view needs ticking every frame
|
|
;
|
|
; * need to try to keep all the intensive 'every thing vs every thing' checking
|
|
; in the logic side, where it can be done over many frames (i'm thinking the
|
|
; lags involved with things like nutrients getting absorbed may not matter
|
|
; too much in this game)
|
|
;
|
|
; * using a message passing system to formalise the passing of information on
|
|
; the logic side. this makes it possible to have objects sending messages
|
|
; at any point, and have them automatically collected up and dispatched to
|
|
; the view
|
|
;
|
|
; * line segments are computed in the logic side, and can be represented any
|
|
; way by the view - maybe the players plant will be geometry and everyone
|
|
; elses will be ribbons (stoopid LOD)
|
|
;
|
|
; * 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 debug-messages #f) ; prints out all the messages sent to the renderer
|
|
(define logic-tick 1) ; time between logic updates
|
|
|
|
(define branch-probability 2) ; as in one in branch-probability chance
|
|
(define branch-width-reduction 0.5)
|
|
(define twig-jitter 0.5)
|
|
(define branch-jitter 1)
|
|
(define max-twig-points 10)
|
|
(define start-twig-width 0.1)
|
|
(define default-max-twigs 10)
|
|
(define default-scale-factor 1.05)
|
|
(define default-grow-speed 1)
|
|
(define root-camera-time (* default-max-twigs logic-tick))
|
|
(define num-pickups 100)
|
|
(define pickup-dist-radius 20)
|
|
(define pickup-size 1)
|
|
(define max-ornaments 2) ; per twig
|
|
(define ornament-grow-probability 4)
|
|
|
|
(define (ornament-colour) (vector 0.5 1 0.4))
|
|
(define (pickup-colour) (vector 1 1 1))
|
|
|
|
(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))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; 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
|
|
(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 1)) ; distance between points
|
|
|
|
(field
|
|
(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)) ; distance between points
|
|
(branch #f)) ; are we a main branch twig?
|
|
|
|
(inherit send-message)
|
|
|
|
(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 (scale a)
|
|
(set! width (* width a))
|
|
(set! dist (* dist a)))
|
|
|
|
(define/public (grow)
|
|
(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 (vmul dir dist) (vector 0 0 0))
|
|
(vadd last-point (vmul dir dist) (vmul (srndvec) (* dist twig-jitter))))))
|
|
(set! last-point new-point)
|
|
(set! points (append points (list new-point)))
|
|
(send-message 'twig-grow (list
|
|
(list 'plant-id (send plant get-id))
|
|
(list 'twig-id id)
|
|
(list 'point new-point))))
|
|
(when (and (> (length points) 1) (> num-points 1) (zero? (random branch-probability)))
|
|
(add-twig (- (length points) 1)
|
|
(make-object twig-logic% (send plant get-next-twig-id)
|
|
plant
|
|
type
|
|
(vadd dir (vmul (srndvec) branch-jitter))
|
|
(* width branch-width-reduction)
|
|
(quotient num-points 2)
|
|
render-type
|
|
dist))))
|
|
(for-each
|
|
(lambda (twig)
|
|
(send (cadr twig) grow))
|
|
twigs))
|
|
|
|
(define/public (add-twig point-index twig)
|
|
(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)))
|
|
|
|
(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 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)
|
|
(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)
|
|
(for-each
|
|
(lambda (twig)
|
|
(send twig grow))
|
|
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-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/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))))
|
|
|
|
(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 "unkown property ~a~n" 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 '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"))))))
|
|
|
|
(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"))))
|
|
(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)
|
|
(inner (void) grow point))
|
|
|
|
(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)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
; extrusion code
|
|
|
|
(define (draw-profile index profile offset)
|
|
(cond ((not (null? profile))
|
|
(pdata-set! "p" index (vadd (car profile) offset))
|
|
(draw-profile (+ index 1) (cdr profile) offset))))
|
|
|
|
|
|
(define (transform-profile profile m)
|
|
(cond
|
|
((null? profile) '())
|
|
(else
|
|
(cons (vtransform (car profile) m)
|
|
(transform-profile (cdr profile) m)))))
|
|
|
|
; figures out the vector for rotation of the profile
|
|
(define (path-vector first-segment path lv)
|
|
(let* ((v (if (null? (cdr path)) ; last segment?
|
|
lv ; use the last vector used
|
|
(vsub (cadr path) (car path)))) ; use the next point
|
|
(vd (if first-segment v ; first segment?
|
|
(vadd (vmul lv 0.5) ; blend with the last vector
|
|
(vmul v 0.5)))))
|
|
vd))
|
|
|
|
(define (extrude-segment index profile path lv)
|
|
(cond ((not (null? path))
|
|
(let ((v (path-vector (zero? index) path lv)))
|
|
(draw-profile index (transform-profile profile
|
|
(mmul
|
|
(maim v (vector 1 0 0))
|
|
(mrotate (vector 0 90 0))))
|
|
(car path))
|
|
v))))
|
|
|
|
|
|
(define (extrude-segment-blend index profile path lv t)
|
|
(cond ((not (null? path))
|
|
; figure out the vector for rotation of the profile
|
|
(let ((v (path-vector (zero? index) path lv)))
|
|
(cond ((null? (cdr path))
|
|
(draw-profile index (transform-profile profile
|
|
(mmul
|
|
(maim v (vector 1 0 0))
|
|
(mrotate (vector 0 90 0))))
|
|
(car path)))
|
|
(else
|
|
(let ((v2 (path-vector (zero? index) (cdr path) v)))
|
|
(draw-profile index (transform-profile profile
|
|
(mmul
|
|
(maim (vmix (vnormalise v) (vnormalise v2) t) (vector 1 0 0))
|
|
(mrotate (vector 0 90 0))))
|
|
(vmix (car path) (vadd (car path) v2) t)))))
|
|
v))))
|
|
|
|
|
|
(define (extrude index profile path lv)
|
|
(cond ((not (null? path))
|
|
(let ((v (extrude-segment index profile path lv)))
|
|
(extrude (+ index (length profile)) profile (cdr path) v)))))
|
|
|
|
(define (stitch-face index count profile-size in)
|
|
(cond
|
|
((eq? 1 count)
|
|
(append in (list (+ (- index profile-size) 1) index (+ index profile-size)
|
|
(+ (- index profile-size) 1 profile-size))))
|
|
(else
|
|
(append
|
|
(list (+ index 1) index
|
|
(+ index profile-size) (+ index profile-size 1))
|
|
(stitch-face (+ index 1) (- count 1) profile-size in)))))
|
|
|
|
(define (stitch-indices index profile-size path-size in)
|
|
(cond
|
|
((eq? 1 path-size) in)
|
|
(else
|
|
(append
|
|
(stitch-face index profile-size profile-size '())
|
|
(stitch-indices (+ index profile-size)
|
|
profile-size
|
|
(- path-size 1)
|
|
in)))))
|
|
|
|
(define (build-tex-coords profile-size path-size vscale)
|
|
(pdata-index-map!
|
|
(lambda (i t)
|
|
(vector (* vscale (/ (quotient i profile-size) path-size))
|
|
(/ (modulo i profile-size) profile-size) 0))
|
|
"t"))
|
|
|
|
(define (build-extrusion profile path tex-vscale)
|
|
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
|
|
(with-primitive p
|
|
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
|
|
(build-tex-coords (length profile) (length path) tex-vscale)
|
|
(extrude 0 profile path (vector 0 0 0))
|
|
(recalc-normals 0))
|
|
p))
|
|
|
|
; partial extrusions are for animating
|
|
|
|
(define (build-partial-extrusion profile path tex-vscale)
|
|
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
|
|
(with-primitive p
|
|
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
|
|
(build-tex-coords (length profile) (length path) tex-vscale))
|
|
p))
|
|
|
|
(define (chop-front l n)
|
|
(cond ((null? l) l)
|
|
(else
|
|
(if (zero? n) (cons (car l) (chop-front (cdr l) n))
|
|
(chop-front (cdr l) (- n 1))))))
|
|
|
|
; returns the last vector
|
|
(define (partial-extrude p t v profile path)
|
|
(with-primitive p 0
|
|
|
|
(let* ((start (* (floor t) (length profile)))
|
|
(end (* (length path) (length profile)))
|
|
(v (extrude-segment start profile
|
|
(chop-front path (floor t)) v)))
|
|
|
|
(when (< t (- (length path) 1))
|
|
(for ((i (in-range (+ start (length profile)) (+ start (* 2 (length profile))))))
|
|
(pdata-set! "p" i (vsub (pdata-ref "p" (- i (length profile)))
|
|
(vmul v (- (floor t) t)))))
|
|
|
|
; collapse the yet un-extruded part into the last vert
|
|
(for ((i (in-range (+ start (* (length profile) 2)) end)))
|
|
(pdata-set! "p" i (pdata-ref "p" (+ (length profile) start)))))
|
|
|
|
(recalc-normals 0)
|
|
v)))
|
|
|
|
#;(define (partial-extrude p t v profile path)
|
|
(with-primitive p 0
|
|
|
|
(let* ((start (* (floor t) (length profile)))
|
|
(end (* (length path) (length profile)))
|
|
(v (extrude-segment-blend start profile
|
|
(chop-front path (floor t)) v (- (floor t) t))))
|
|
|
|
(when (< t (- (length path) 1))
|
|
#;(for ((i (in-range (+ start (length profile)) (+ start (* 2 (length profile))))))
|
|
(pdata-set! "p" i (vsub (pdata-ref "p" (- i (length profile)))
|
|
(vmul v (- (floor t) t)))))
|
|
|
|
; collapse the yet un-extruded part into the last vert
|
|
(for ((i (in-range (+ start (* (length profile) 1)) end)))
|
|
(pdata-set! "p" i (pdata-get "p" start))))
|
|
|
|
(recalc-normals 0)
|
|
v)))
|
|
|
|
(define (build-circle-profile n r)
|
|
(define (_ n c l)
|
|
(cond ((zero? c) l)
|
|
(else
|
|
(let ((a (* (/ c n) (* 2 3.141))))
|
|
(_ n (- c 1)
|
|
(cons (vmul (vector (sin a) (cos a) 0) r) l))))))
|
|
(_ n n '()))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(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)
|
|
(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
|
|
radius))
|
|
"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)
|
|
(v (vector 0 0 0))
|
|
(grow-speed default-grow-speed)
|
|
(anim-t 0))
|
|
|
|
(define/override (build)
|
|
(set! profile (build-circle-profile 5 radius))
|
|
(set! path (build-list num-points (lambda (n) (vector 0 0 0))))
|
|
(set! root (let ((p (with-state
|
|
(backfacecull 0)
|
|
(translate pos)
|
|
(colour (vector 0.8 1 0.6))
|
|
(texture (load-texture "textures/root.png"))
|
|
(build-partial-extrusion profile path 6))))
|
|
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)
|
|
(when (zero? index) (set! path (list-set path index point)))
|
|
(set! path (list-set path (+ index 1) point))
|
|
(set! anim-t 0)
|
|
(set! v (partial-extrude root index v profile path))
|
|
(set! index (+ index 1)))
|
|
|
|
(define/augment (update t d)
|
|
(when (< anim-t 1)
|
|
(set! v (partial-extrude root (+ (- index 1) anim-t) v profile path)))
|
|
(set! anim-t (+ anim-t (* d grow-speed))))
|
|
|
|
(define/public (get-end-pos)
|
|
(with-primitive root
|
|
(pdata-ref "p" (* index (length profile)))))
|
|
|
|
(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/skin.png"))
|
|
(backfacecull 0)
|
|
(opacity 0.6)
|
|
(colour (vector 0.8 1 0.6))
|
|
(hint-depth-sort)
|
|
(scale 0.5)
|
|
(hint-unlit)
|
|
(load-primitive "meshes/seed.obj"))))
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (get-twig twig-id)
|
|
(cadr (assq twig-id twigs)))
|
|
|
|
(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
|
|
(with-primitive (send twig get-root)
|
|
(parent (send ptwig get-root)))
|
|
|
|
(send twig set-pos! (send ptwig get-point point-index))
|
|
(send twig build)
|
|
|
|
; 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)
|
|
(send (get-twig twig-id) grow point))
|
|
|
|
(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)
|
|
(let ((p (build-locator)))
|
|
(with-state
|
|
(parent p)
|
|
(hint-unlit)
|
|
(with-state
|
|
(texture (load-texture top))
|
|
(translate (vector 0 0.5 0))
|
|
(rotate (vector 90 0 0))
|
|
(build-plane))
|
|
|
|
(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))
|
|
|
|
(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 (build-locator))
|
|
(player-plant-id #f)
|
|
(current-twig-id #f)
|
|
(camera-dist 1)
|
|
(env-root (with-state (scale 20) (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")))
|
|
(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)) 90))
|
|
"p")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vector 1 1 1))
|
|
"s"))
|
|
p)))
|
|
|
|
(define/public (setup)
|
|
(lock-camera camera)
|
|
(camera-lag 0.05)
|
|
(set-camera-position (vector 0 0 -1))
|
|
|
|
(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 (vector 0.1 0.3 0.2))
|
|
|
|
(fog (vector 0.2 0.5 0.3) 0.02 1 100))
|
|
|
|
(define/public (get-player)
|
|
(get-plant player-plant-id))
|
|
|
|
(define/public (add-plant plant player)
|
|
(set! plants (cons (list (send plant get-id) plant) plants))
|
|
(when player (set! player-plant-id (send plant get-id))))
|
|
|
|
(define/public (get-plant plant-id)
|
|
(cadr (assq plant-id plants)))
|
|
|
|
(define/public (add-branch-twig plant-id twig)
|
|
(when (eq? plant-id player-plant-id)
|
|
(set! current-twig-id (send twig get-id))
|
|
(set! root-camera-t 0))
|
|
(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)
|
|
(when (eq? plant-id player-plant-id)
|
|
(set! camera-dist (* camera-dist amount))
|
|
(with-primitive env-root (scale amount))
|
|
#;(fog (vector 0.2 0.5 0.3) (* 0.01 (* amount amount amount)) 1 100))
|
|
(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)
|
|
|
|
(if current-twig-id
|
|
(let ((twig (send (get-player) get-twig current-twig-id)))
|
|
(with-primitive camera
|
|
(identity)
|
|
(translate (vadd (send twig get-end-pos)
|
|
(vmul (send twig get-dir) (* camera-dist -2))
|
|
(vcross (send twig get-dir) (vector 0 1 0))))
|
|
))
|
|
(with-primitive camera (identity)))
|
|
|
|
|
|
|
|
(when (> root-camera-t root-camera-time)
|
|
;(set-camera-position (vector 0 0 (- camera-dist)))
|
|
(set! current-twig-id #f))
|
|
|
|
(set! root-camera-t (+ root-camera-t d))
|
|
|
|
(when debug-messages
|
|
(for-each
|
|
(lambda (msg)
|
|
(send msg print))
|
|
messages))
|
|
(for-each
|
|
(lambda (msg)
|
|
(cond
|
|
((eq? (send msg get-name) 'player-plant)
|
|
(add-plant (make-object plant-view%
|
|
(send msg get-data 'plant-id)
|
|
(send msg get-data 'pos)) #t))
|
|
|
|
((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))
|
|
|
|
((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)))
|
|
|
|
((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)))
|
|
|
|
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(clear)
|
|
(define gl (make-object game-logic%))
|
|
(define gv (make-object game-view%))
|
|
|
|
(send gv setup)
|
|
(send gl setup)
|
|
|
|
(define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
|
|
(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 9)))
|
|
|
|
(send gl add-player plant1)
|
|
(send gl add-plant plant2)
|
|
|
|
(send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon))
|
|
|
|
(define tick-time 0)
|
|
(define debounce #t)
|
|
(define debounce-time 0)
|
|
|
|
(define pt 0)
|
|
(define pd 0.02)
|
|
(define (pe-time) pt)
|
|
(define (pe-delta) pd)
|
|
(define (pt-update) (set! pt (+ pt pd)))
|
|
|
|
(define (animate)
|
|
(when (and debounce (key-pressed " "))
|
|
(send plant1 add-twig (make-object twig-logic% 0 plant1 'root
|
|
(vtransform-rot (vector 0 0 -1) (minverse (get-camera-transform)))
|
|
start-twig-width max-twig-points 'extruded))
|
|
(set! tick-time 0)
|
|
(set! debounce #f)
|
|
(set! debounce-time (+ (pe-time) 0.2)))
|
|
|
|
(when (> (pe-time) debounce-time)
|
|
(set! debounce #t))
|
|
|
|
(when (< tick-time (pe-time))
|
|
(set! tick-time (+ (pe-time) logic-tick))
|
|
(send plant1 grow)
|
|
(send plant2 grow)
|
|
(send gv update (pe-time) (pe-delta) (send gl update)))
|
|
|
|
(send gv update (pe-time) (pe-delta) '())
|
|
(pt-update))
|
|
|
|
#;(for ((i (in-range 0 10000)))
|
|
(animate))
|
|
|
|
(every-frame (animate))
|