two types of plant rendering working
This commit is contained in:
Dave Griffiths
parent
fe0c0f0aab
commit
79c4093f5d
3 changed files with 1234 additions and 916 deletions
|
|
@ -1,601 +0,0 @@
|
||||||
#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 branch-probability 3) ; 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)
|
|
||||||
|
|
||||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
||||||
; 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 (void) 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
|
|
||||||
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(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-point point-index)
|
|
||||||
(list-ref points point-index))
|
|
||||||
|
|
||||||
(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)))))
|
|
||||||
(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 (> 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)))))
|
|
||||||
(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))
|
|
||||||
))
|
|
||||||
(set! twigs (cons (list point-index twig) twigs)))
|
|
||||||
|
|
||||||
(define/public (get-twig point-index)
|
|
||||||
(cadr (assq point-index twigs)))
|
|
||||||
|
|
||||||
(define/public (add-ornament point-index ornament)
|
|
||||||
(send-message 'new-ornament
|
|
||||||
(list
|
|
||||||
(send plant get-id)
|
|
||||||
id
|
|
||||||
point-index))
|
|
||||||
(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/add-ornament pickup)
|
|
||||||
; check each point in our twig
|
|
||||||
(let ((found (foldl
|
|
||||||
(lambda (point found)
|
|
||||||
; 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))))
|
|
||||||
(add-ornament (send pickup create-ornament plant))
|
|
||||||
#t)
|
|
||||||
(else #f)))
|
|
||||||
#f
|
|
||||||
points)))
|
|
||||||
; now check each sub-twig
|
|
||||||
(if (not found)
|
|
||||||
(foldl
|
|
||||||
(lambda (twig found)
|
|
||||||
(if (not found)
|
|
||||||
(send twig check/add-ornament)
|
|
||||||
#f))
|
|
||||||
#f
|
|
||||||
twigs)
|
|
||||||
found)))
|
|
||||||
|
|
||||||
(define/augment (update)
|
|
||||||
(append
|
|
||||||
(map
|
|
||||||
(lambda (ornament)
|
|
||||||
(send 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
|
|
||||||
(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-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%
|
|
||||||
(field
|
|
||||||
(type 'none)
|
|
||||||
(pos (vector 0 0 0)))
|
|
||||||
|
|
||||||
(define/public (get-pos)
|
|
||||||
pos)
|
|
||||||
|
|
||||||
; converts pickup->ormament
|
|
||||||
; override this
|
|
||||||
(define/public (create-ornament plant)
|
|
||||||
(make-object ornament-logic% plant)) ; todo twig/point-index???
|
|
||||||
|
|
||||||
(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
|
|
||||||
(age 0) ; the age of this plant
|
|
||||||
(max-twigs 10) ; the maximum twigs allowed at any time - oldest removed first
|
|
||||||
(next-twig-id 0))
|
|
||||||
|
|
||||||
(inherit send-message)
|
|
||||||
|
|
||||||
(define/public (get-id)
|
|
||||||
id)
|
|
||||||
|
|
||||||
(define/public (get-pos)
|
|
||||||
pos)
|
|
||||||
|
|
||||||
(define/public (grow)
|
|
||||||
(for-each
|
|
||||||
(lambda (twig)
|
|
||||||
(send twig grow))
|
|
||||||
twigs))
|
|
||||||
|
|
||||||
; 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))
|
|
||||||
|
|
||||||
(define/public (check/add-ornament pickup)
|
|
||||||
(foldl
|
|
||||||
(lambda (twig found)
|
|
||||||
(if (not found)
|
|
||||||
(send twig check/add-ornament 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))
|
|
||||||
(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))))
|
|
||||||
(set! twigs (cons-twig twig twigs max-twigs '())))
|
|
||||||
|
|
||||||
(define/augment (update)
|
|
||||||
(map
|
|
||||||
(lambda (twig)
|
|
||||||
(send twig update))
|
|
||||||
twigs))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
||||||
|
|
||||||
(define game-logic%
|
|
||||||
(class game-logic-object%
|
|
||||||
(field
|
|
||||||
(plants '())
|
|
||||||
(pickups '()))
|
|
||||||
|
|
||||||
(inherit send-message)
|
|
||||||
|
|
||||||
(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-pickups pickup)
|
|
||||||
(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/add-ormament pickup))
|
|
||||||
plants))
|
|
||||||
pickups)
|
|
||||||
(map
|
|
||||||
(lambda (plant)
|
|
||||||
(send plant update))
|
|
||||||
plants))
|
|
||||||
|
|
||||||
(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
|
|
||||||
(root (let ((p (with-state
|
|
||||||
(translate pos)
|
|
||||||
(hint-unlit)
|
|
||||||
;(concat (maim dir (vector 0 0 1)))
|
|
||||||
(build-ribbon num-points))))
|
|
||||||
(with-primitive p
|
|
||||||
(pdata-map!
|
|
||||||
(lambda (w)
|
|
||||||
0)
|
|
||||||
"w")
|
|
||||||
(pdata-set! "w" 0 radius))
|
|
||||||
p))
|
|
||||||
(index 0)
|
|
||||||
(parent-twig-id -1)
|
|
||||||
(child-twig-ids '()))
|
|
||||||
|
|
||||||
(define/public (get-id)
|
|
||||||
id)
|
|
||||||
|
|
||||||
(define/public (get-root)
|
|
||||||
root)
|
|
||||||
|
|
||||||
(define/public (set-parent-twig-id s)
|
|
||||||
(set! parent-twig-id s))
|
|
||||||
|
|
||||||
(define/public (get-point point-index)
|
|
||||||
(with-primitive root
|
|
||||||
(pdata-ref "p" point-index)))
|
|
||||||
|
|
||||||
(define/public (add-child-twig-id twig-id)
|
|
||||||
(set! child-twig-ids (cons twig-id child-twig-ids)))
|
|
||||||
|
|
||||||
(define/public (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)))
|
|
||||||
|
|
||||||
(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)
|
|
||||||
(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))
|
|
||||||
(set! twigs (cons (list (send twig get-id) twig) 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))
|
|
||||||
(translate (send ptwig get-point point-index)))
|
|
||||||
|
|
||||||
; 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 (update t)
|
|
||||||
|
|
||||||
(with-primitive root
|
|
||||||
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
|
|
||||||
|
|
||||||
(for-each
|
|
||||||
(lambda (twig)
|
|
||||||
(send twig update t))
|
|
||||||
twigs))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
||||||
|
|
||||||
(define game-view%
|
|
||||||
(class object%
|
|
||||||
(field
|
|
||||||
(plants '())) ; map of ids -> plants
|
|
||||||
|
|
||||||
(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 (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 (update messages)
|
|
||||||
(when debug-messages
|
|
||||||
(for-each
|
|
||||||
(lambda (msg)
|
|
||||||
(send msg print))
|
|
||||||
messages))
|
|
||||||
(for-each
|
|
||||||
(lambda (msg)
|
|
||||||
(cond
|
|
||||||
|
|
||||||
((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) 'new-branch-twig)
|
|
||||||
(add-branch-twig (send msg get-data 'plant-id)
|
|
||||||
(make-object 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)
|
|
||||||
(make-object 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)))
|
|
||||||
|
|
||||||
))
|
|
||||||
messages))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
||||||
|
|
||||||
(clear)
|
|
||||||
(define gl (make-object game-logic%))
|
|
||||||
(define gv (make-object game-view%))
|
|
||||||
|
|
||||||
(define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
|
|
||||||
(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 6 0 0)))
|
|
||||||
|
|
||||||
(send gl add-plant plant1)
|
|
||||||
(send gl add-plant plant2)
|
|
||||||
|
|
||||||
(send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width))
|
|
||||||
|
|
||||||
(define t 0)
|
|
||||||
(define tick-time 0)
|
|
||||||
(define tick 0.5)
|
|
||||||
|
|
||||||
(define (animate)
|
|
||||||
(when (< tick-time t)
|
|
||||||
(set! tick-time (+ t tick))
|
|
||||||
(send plant2 grow)
|
|
||||||
(send gv update (send gl update)))
|
|
||||||
(set! t (+ t 0.02)))
|
|
||||||
|
|
||||||
#;(for ((i (in-range 0 100)))
|
|
||||||
(animate))
|
|
||||||
|
|
||||||
(every-frame (animate))
|
|
||||||
343
plant-eyes/plant-eyes-proto.scm
Normal file
343
plant-eyes/plant-eyes-proto.scm
Normal file
|
|
@ -0,0 +1,343 @@
|
||||||
|
;#lang scheme/base
|
||||||
|
;(require fluxus-016/drflux)
|
||||||
|
(require scheme/class)
|
||||||
|
|
||||||
|
|
||||||
|
;=====================================================================
|
||||||
|
|
||||||
|
(clear)
|
||||||
|
|
||||||
|
(define (build-ring n sr er)
|
||||||
|
(let ((p (build-polygons (+ (* n 2) 2) 'triangle-strip)))
|
||||||
|
(with-primitive p
|
||||||
|
(pdata-index-map!
|
||||||
|
(lambda (i p)
|
||||||
|
(let ((a (* (/ (quotient i 2) n) (* 2 3.141)))
|
||||||
|
(s (* (if (odd? i) sr er) 5)))
|
||||||
|
(vector (* (cos a) s) (* (sin a) s) (if (odd? i) 0 5 ))))
|
||||||
|
"p")
|
||||||
|
|
||||||
|
(recalc-normals 1))
|
||||||
|
p))
|
||||||
|
|
||||||
|
(define camera (build-locator))
|
||||||
|
|
||||||
|
(define twig%
|
||||||
|
(class object%
|
||||||
|
(init-field
|
||||||
|
(size 100)
|
||||||
|
(radius 1)
|
||||||
|
(speed 0.2))
|
||||||
|
(field
|
||||||
|
(root (build-locator))
|
||||||
|
(child-twigs '())
|
||||||
|
(age 0)
|
||||||
|
(tx (mident))
|
||||||
|
(next-ring-time 0))
|
||||||
|
|
||||||
|
(define/public (build pos dir)
|
||||||
|
(with-primitive root
|
||||||
|
(translate pos)
|
||||||
|
(cond (dir
|
||||||
|
(concat (maim dir (vector 0 0 1)))
|
||||||
|
(rotate (vector 0 -90 0)))
|
||||||
|
(else (rotate (vmul (crndvec) 20))))))
|
||||||
|
|
||||||
|
(define/public (update t)
|
||||||
|
|
||||||
|
(for-each
|
||||||
|
(lambda (child)
|
||||||
|
(send child update t))
|
||||||
|
child-twigs)
|
||||||
|
|
||||||
|
(when (and (< age size) (< next-ring-time t))
|
||||||
|
(set! next-ring-time (+ t speed))
|
||||||
|
(let ((p (with-state
|
||||||
|
(parent root)
|
||||||
|
(hint-depth-sort)
|
||||||
|
(colour (vector 0.8 1 0.6))
|
||||||
|
(texture (load-texture "textures/skin.png"))
|
||||||
|
;(hint-none)
|
||||||
|
;(hint-wire)
|
||||||
|
(backfacecull 1)
|
||||||
|
(let* ((s (- size age))
|
||||||
|
(sr (* radius (/ s size)))
|
||||||
|
(er (* radius (/ (- s 1) size))))
|
||||||
|
(translate (vector 0 0 (* age 5)))
|
||||||
|
(when (zero? (random 3))
|
||||||
|
(with-state
|
||||||
|
(identity)
|
||||||
|
(set! child-twigs (cons
|
||||||
|
(make-object twig% (/ size 2) sr speed) child-twigs))
|
||||||
|
(send (car child-twigs) build (vector 0 0 (* age 5) ) #f)))
|
||||||
|
|
||||||
|
(build-ring 5 sr er)))))
|
||||||
|
(with-primitive camera (parent p)))
|
||||||
|
(set! age (+ age 1))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define pickup%
|
||||||
|
(class object%
|
||||||
|
(init-field
|
||||||
|
(pos (vector 0 0 0)))
|
||||||
|
(field
|
||||||
|
(col (vmul (rndvec) 0.1))
|
||||||
|
(root (let ((p (with-state
|
||||||
|
(translate pos)
|
||||||
|
(hint-depth-sort)
|
||||||
|
(blend-mode 'src-alpha 'one)
|
||||||
|
(texture (load-texture "textures/particle.png"))
|
||||||
|
(build-particles 20))))
|
||||||
|
(with-primitive p
|
||||||
|
(pdata-add "vel" "v")
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (vel)
|
||||||
|
(vmul (vector (crndf) (* 2 (rndf)) (crndf)) 0.02))
|
||||||
|
"vel")
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (s)
|
||||||
|
(vector 2 2 2))
|
||||||
|
"s")
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (c)
|
||||||
|
col)
|
||||||
|
"c"))
|
||||||
|
p)))
|
||||||
|
|
||||||
|
(define/public (get-pos)
|
||||||
|
pos)
|
||||||
|
|
||||||
|
(define/public (update t)
|
||||||
|
(with-primitive root
|
||||||
|
(pdata-op "+" "p" "vel")
|
||||||
|
(pdata-op "*" "c" 0.996)
|
||||||
|
(pdata-op "*" "s" 1.005)
|
||||||
|
(when (zero? (random 5))
|
||||||
|
(let ((reset (random (pdata-size))))
|
||||||
|
(pdata-set! "c" reset col)
|
||||||
|
(pdata-set! "p" reset (vector 0 0 0))
|
||||||
|
(pdata-set! "s" reset (vector 2 2 2))))))
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
(define seed%
|
||||||
|
(class object%
|
||||||
|
(field
|
||||||
|
(twigs '())
|
||||||
|
(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))
|
||||||
|
(pickups (build-list 1 (lambda (_)
|
||||||
|
(make-object pickup% (vmul (vsub (crndvec) (vector 0 1 0)) 50)))))
|
||||||
|
(indicator (let ((p (with-state
|
||||||
|
(hint-depth-sort)
|
||||||
|
;(blend-mode 'src-alpha 'one )
|
||||||
|
(texture (load-texture "textures/particle.png"))
|
||||||
|
(build-particles 200))))
|
||||||
|
(with-primitive p
|
||||||
|
(pdata-add "vel" "v")
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (vel)
|
||||||
|
(srndvec))
|
||||||
|
"vel")
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (c)
|
||||||
|
(vector 0 0 0.1))
|
||||||
|
"c")
|
||||||
|
|
||||||
|
(pdata-map!
|
||||||
|
(lambda (s)
|
||||||
|
(let ((sz (rndf)))
|
||||||
|
(vector sz sz sz)))
|
||||||
|
"s"))
|
||||||
|
p))
|
||||||
|
(debounce #t)
|
||||||
|
(debounce-time 0)
|
||||||
|
(pos (vector 0 0 0))
|
||||||
|
(root (with-state
|
||||||
|
(scale 5)
|
||||||
|
(translate pos)
|
||||||
|
(texture (load-texture "textures/skin.png"))
|
||||||
|
(backfacecull 0)
|
||||||
|
(opacity 0.6)
|
||||||
|
(colour (vector 0.8 1 0.6))
|
||||||
|
(hint-depth-sort)
|
||||||
|
(hint-unlit)
|
||||||
|
(load-primitive "meshes/seed.obj"))))
|
||||||
|
|
||||||
|
(define/public (add-twig dir)
|
||||||
|
(let ((t (make-object twig% 10 0.2 2)))
|
||||||
|
(set! twigs (cons (with-state
|
||||||
|
(colour (vector 0.3 0.8 0.4))
|
||||||
|
(send t build (vector 0 0 0) dir) t) twigs))))
|
||||||
|
|
||||||
|
|
||||||
|
(define/public (update t)
|
||||||
|
|
||||||
|
(let ((closest (foldl
|
||||||
|
(lambda (pickup r)
|
||||||
|
(if (< (vdist (send pickup get-pos) pos)
|
||||||
|
(vdist pos r))
|
||||||
|
(send pickup get-pos) r))
|
||||||
|
(vector 999 999 999)
|
||||||
|
pickups)))
|
||||||
|
|
||||||
|
(with-primitive indicator
|
||||||
|
(pdata-op "+" "p" "vel")
|
||||||
|
(when (< (sin (* 2 t)) 0)
|
||||||
|
(let ((reset (random (pdata-size))))
|
||||||
|
(let ((pos (vmul (vnormalise (vsub closest pos)) 10)))
|
||||||
|
(pdata-set! "vel" reset (vadd (vmul (srndvec) 0.01)
|
||||||
|
(vmul (vsub closest pos) (* (rndf) 0.01))))
|
||||||
|
(pdata-set! "p" reset pos))))))
|
||||||
|
|
||||||
|
(with-primitive root
|
||||||
|
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
|
||||||
|
|
||||||
|
(when (key-pressed "r") (with-primitive camera (parent 1)))
|
||||||
|
|
||||||
|
(when (and debounce (key-pressed " "))
|
||||||
|
(add-twig (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform))))
|
||||||
|
(set! debounce #f)
|
||||||
|
(set! debounce-time (+ t 1)))
|
||||||
|
|
||||||
|
(when (> t debounce-time)
|
||||||
|
(set! debounce #t))
|
||||||
|
|
||||||
|
(for-each
|
||||||
|
(lambda (twig)
|
||||||
|
(send twig update t))
|
||||||
|
twigs)
|
||||||
|
(for-each
|
||||||
|
(lambda (pickup)
|
||||||
|
(send pickup update t))
|
||||||
|
pickups))
|
||||||
|
|
||||||
|
(super-new)))
|
||||||
|
|
||||||
|
; build world
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(scale 5 )
|
||||||
|
(translate (vector 0 0 0))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/top.png"))
|
||||||
|
(translate (vector 0 20 0))
|
||||||
|
(rotate (vector 90 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/left.png"))
|
||||||
|
(translate (vector 0 0 -20))
|
||||||
|
(rotate (vector 0 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/back.png"))
|
||||||
|
(translate (vector 20 0 0))
|
||||||
|
(rotate (vector 0 90 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/right.png"))
|
||||||
|
(translate (vector 0 0 20))
|
||||||
|
(rotate (vector 0 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/front.png"))
|
||||||
|
(translate (vector -20 0 0))
|
||||||
|
(rotate (vector 0 90 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/bottom.png"))
|
||||||
|
(opacity 0.8)
|
||||||
|
(hint-depth-sort)
|
||||||
|
(translate (vector 0 2 0))
|
||||||
|
(rotate (vector 90 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
; soil
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/sback.png"))
|
||||||
|
(translate (vector 0 -15 -19.99))
|
||||||
|
(rotate (vector 0 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/sleft.png"))
|
||||||
|
(translate (vector 19.9 -15 0))
|
||||||
|
(rotate (vector 0 90 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/sfront.png"))
|
||||||
|
(translate (vector 0 -15 19.9))
|
||||||
|
(rotate (vector 0 0 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane))
|
||||||
|
|
||||||
|
(with-state
|
||||||
|
(texture (load-texture "textures/sright.png"))
|
||||||
|
(translate (vector -19.9 -15 0))
|
||||||
|
(rotate (vector 0 90 0))
|
||||||
|
(scale 40)
|
||||||
|
(hint-unlit)
|
||||||
|
(build-plane)))
|
||||||
|
|
||||||
|
(lock-camera camera)
|
||||||
|
(camera-lag 0.05)
|
||||||
|
|
||||||
|
(define l (make-light 'point 'free))
|
||||||
|
(light-diffuse 0 (vector 0 0 0))
|
||||||
|
(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.01 1 100)
|
||||||
|
(define s (make-object seed%))
|
||||||
|
|
||||||
|
(define t 0)
|
||||||
|
|
||||||
|
(define (animate)
|
||||||
|
(send s update t)
|
||||||
|
(set! t (+ t 0.02)))
|
||||||
|
|
||||||
|
(every-frame (animate))
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load diff
Loading…
Reference in a new issue