544 lines
18 KiB
Scheme
544 lines
18 KiB
Scheme
|
#lang scheme
|
||
|
|
(require scheme/class fluxus-016/fluxus "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 (append messages (list (make-object message% name data)))))
|
||
|
|
|
||
|
|
; 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
|
||
|
|
(parent-twig-id -1)
|
||
|
|
(parent-twig-point-index -1))
|
||
|
|
|
||
|
|
(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
|
||
|
|
(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 (get-id)
|
||
|
|
id)
|
||
|
|
|
||
|
|
(define/public (set-id! s)
|
||
|
|
(set! id s))
|
||
|
|
|
||
|
|
(define/public (get-type)
|
||
|
|
type)
|
||
|
|
|
||
|
|
(define/public (get-dist)
|
||
|
|
dist)
|
||
|
|
|
||
|
|
(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 (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 (growing?)
|
||
|
|
(< (length points) num-points))
|
||
|
|
|
||
|
|
(define/public (scale a)
|
||
|
|
(set! width (* width a))
|
||
|
|
(set! dist (* dist a)))
|
||
|
|
|
||
|
|
(define/public (grow pos)
|
||
|
|
(when (growing?)
|
||
|
|
(let ((new-point (if (zero? (length points))
|
||
|
|
; first point should be at edge of the seed if we are a branch
|
||
|
|
(if (eq? parent-twig-id -1) pos
|
||
|
|
last-point)
|
||
|
|
pos)))
|
||
|
|
|
||
|
|
|
||
|
|
(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 'add-twig-point (list
|
||
|
|
(list 'plant-id (send plant get-id))
|
||
|
|
(list 'twig-id id)
|
||
|
|
(list 'point new-point)
|
||
|
|
(list 'width w))))
|
||
|
|
#;(for-each
|
||
|
|
(lambda (twig)
|
||
|
|
(send (cadr twig) grow ndir))
|
||
|
|
twigs)))
|
||
|
|
|
||
|
|
(define/public (get-desc-list)
|
||
|
|
(list
|
||
|
|
(list 'plant-id (send plant get-id))
|
||
|
|
(list 'parent-twig-id parent-twig-id)
|
||
|
|
(list 'point-index parent-twig-point-index)
|
||
|
|
(list 'twig-id id)
|
||
|
|
(list 'type type)
|
||
|
|
(list 'dir dir)
|
||
|
|
(list 'width width)
|
||
|
|
(list 'num-points num-points)
|
||
|
|
(list 'render-type render-type)))
|
||
|
|
|
||
|
|
(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
|
||
|
|
id
|
||
|
|
point-index
|
||
|
|
)))
|
||
|
|
|
||
|
|
(send-message 'new-twig (send twig get-desc-list))
|
||
|
|
(set! twigs (cons (list point-index twig) twigs))
|
||
|
|
twig))
|
||
|
|
|
||
|
|
(define/public (serialise)
|
||
|
|
(append
|
||
|
|
(list (make-object message% 'new-twig (get-desc-list)))
|
||
|
|
(append (map
|
||
|
|
(lambda (point width)
|
||
|
|
(make-object message% 'twig-grow (list
|
||
|
|
(list 'plant-id (send plant get-id))
|
||
|
|
(list 'twig-id id)
|
||
|
|
(list 'point point)
|
||
|
|
(list 'width width))))
|
||
|
|
points widths))
|
||
|
|
(append
|
||
|
|
(map
|
||
|
|
(lambda (twig)
|
||
|
|
(send (cadr twig) serialise))
|
||
|
|
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))
|
||
|
|
(col (vector 1 1 1))
|
||
|
|
(tex "fff"))
|
||
|
|
|
||
|
|
(field
|
||
|
|
(twigs '()) ; a assoc list map of ids to twigs
|
||
|
|
(leader-twig #f) ; the temporary twig controlled by the player
|
||
|
|
(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 (get-col)
|
||
|
|
col)
|
||
|
|
|
||
|
|
(define/public (get-tex)
|
||
|
|
tex)
|
||
|
|
|
||
|
|
(define/public (grow pos)
|
||
|
|
(when leader-twig
|
||
|
|
(send leader-twig grow pos)
|
||
|
|
(when (not (send leader-twig growing?))
|
||
|
|
(send-message 'start-growing (list
|
||
|
|
(list 'plant-id id)
|
||
|
|
(list 'twig-id (send leader-twig get-id))))
|
||
|
|
(set! leader-twig #f))))
|
||
|
|
|
||
|
|
(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)
|
||
|
|
(set! leader-twig twig)
|
||
|
|
(send-message 'grow-seed (list
|
||
|
|
(list 'plant-id id)
|
||
|
|
(list 'amount grow-amount)))
|
||
|
|
(send-message 'new-twig (send twig get-desc-list))
|
||
|
|
(set! twigs (cons-twig twig twigs max-twigs '())))
|
||
|
|
|
||
|
|
(define/public (add-sub-twig ptwig point-index dir)
|
||
|
|
(set! leader-twig (send ptwig add-twig point-index dir))
|
||
|
|
leader-twig)
|
||
|
|
|
||
|
|
(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/public (serialise)
|
||
|
|
(append (list (make-object message% 'new-plant (list
|
||
|
|
(list 'plant-id id)
|
||
|
|
(list 'pos pos)
|
||
|
|
(list 'size size))))
|
||
|
|
(append
|
||
|
|
(map
|
||
|
|
(lambda (twig)
|
||
|
|
(send twig serialise))
|
||
|
|
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 '())
|
||
|
|
(player #f))
|
||
|
|
|
||
|
|
(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)
|
||
|
|
(printf "new player plant added ~a~n" (send plant get-id))
|
||
|
|
(send-message 'player-plant (list
|
||
|
|
(list 'plant-id (send plant get-id))
|
||
|
|
(list 'pos (send plant get-pos))
|
||
|
|
(list 'size (send plant get-size))
|
||
|
|
(list 'col (send plant get-col))
|
||
|
|
(list 'tex (send plant get-tex))))
|
||
|
|
(set! player plant)
|
||
|
|
(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))
|
||
|
|
(list 'col (send plant get-col))
|
||
|
|
(list 'tex (send plant get-tex))))
|
||
|
|
(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)))
|
||
|
|
|
||
|
|
(define/public (serialise)
|
||
|
|
(send player serialise))
|
||
|
|
|
||
|
|
; 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)))
|