854 lines
28 KiB
Scheme
854 lines
28 KiB
Scheme
;; p l a n t e y e s [ copyright (c) 2009 foam vzw : gpl v3 ]
|
|
|
|
#lang scheme
|
|
(require scheme/class
|
|
fluxus-016/fluxus
|
|
"message.ss"
|
|
"list-utils.ss"
|
|
"path-gen.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 start-twig-points 15)
|
|
(define start-twig-dist 0.05)
|
|
(define start-twig-width 0.1)
|
|
(define default-max-twigs 2)
|
|
(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)
|
|
(define max-ornaments 5) ; per twig
|
|
(define nutrient-twig-size-increase 1)
|
|
(define num-worms 10)
|
|
(define num-spiders 10)
|
|
(define num-butterflies 10)
|
|
(define auto-twig-var 5)
|
|
(define auto-time 10)
|
|
(define pickup-check-prob 10)
|
|
(define max-pickups 120)
|
|
(define insect-send-prob 3)
|
|
|
|
(define update-count 0)
|
|
(define num-checks 0)
|
|
|
|
; moveme
|
|
(define (collide? line objs)
|
|
(foldl
|
|
(lambda (ob r)
|
|
(if r r
|
|
(with-primitive ob
|
|
(cond ((bb/point-intersect? (cadr line) 0)
|
|
(cond
|
|
((not (null? (geo/line-intersect
|
|
(car line) (cadr line))))
|
|
#t)
|
|
(else #f)))
|
|
(else #f)))))
|
|
#f
|
|
objs))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; 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 t d) ; need to augement this if we have child logic objects,
|
|
(set! update-count (+ update-count 1))
|
|
(let ((l (inner '() update t d)) ; and call update on them too.
|
|
(m messages))
|
|
(set! messages '())
|
|
(append
|
|
m
|
|
(flatten l)))) ; the augmented method gets called here
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define insect-logic%
|
|
(class game-logic-object%
|
|
(init-field
|
|
(id 0)
|
|
(pos 0)
|
|
(type 'none)
|
|
(d (if (eq? type 'worm) (+ 20 (* 20 (rndf)))
|
|
(+ 10 (* 2 (rndf))))) ; time to get from one place to another
|
|
(mission-time -1))
|
|
|
|
(field
|
|
(next-update 0)
|
|
(centre (vector 0 0 0)))
|
|
|
|
(inherit send-message)
|
|
|
|
(define/public (get-id)
|
|
id)
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (get-type)
|
|
type)
|
|
|
|
(define/public (set-centre s)
|
|
(set! centre s))
|
|
|
|
(define/public (move-to p)
|
|
(set! mission-time 5)
|
|
(set! pos p))
|
|
|
|
(define (move)
|
|
; todo check stones
|
|
(when (> mission-time 0)
|
|
(set! pos (vadd pos (vmul (hsrndvec) 5))))
|
|
|
|
(when (< mission-time 0)
|
|
(let ((speed (if (eq? type 'worm) 5 50)))
|
|
(if (> (vdist pos centre) 100)
|
|
(set! pos (vadd pos (vmul (vnormalise (vsub centre pos)) speed)))
|
|
(set! pos (vadd pos (vmul (srndvec) speed))))
|
|
;(when (< (vdist pos centre) 12) (move))
|
|
(when (eq? type 'spider)
|
|
(set! pos (vector (vx pos) 0 (vz pos))))
|
|
(when (and (eq? type 'worm) (> (vy pos) -10))
|
|
(set! pos (vector (vx pos) -10 (vz pos))))
|
|
(when (and (eq? type 'butterfly) (< (vy pos) 50))
|
|
(set! pos (vector (vx pos) 50 (vz pos)))))))
|
|
|
|
(define/augment (update time delta)
|
|
(cond ((> time next-update)
|
|
(move)
|
|
; todo: drop stuff
|
|
;(when (zero? (random pickup-drop-probability))
|
|
; (send cell set-pickup! 'default))
|
|
(let ((d (if (> mission-time 0) (/ d 3) d)))
|
|
(set! next-update (+ time d))
|
|
(send-message 'insect-move (list
|
|
(list 'insect-id id)
|
|
(list 'pos pos)
|
|
(list 'duration d))))))
|
|
|
|
(when (> mission-time 0)
|
|
(set! mission-time (- mission-time delta)))
|
|
|
|
'())
|
|
|
|
(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 start-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
|
|
(pickedups '())) ; the pickups we've collected
|
|
|
|
(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-w)
|
|
w)
|
|
|
|
(define/public (get-dir)
|
|
dir)
|
|
|
|
(define/public (get-width)
|
|
width)
|
|
|
|
(define/public (get-width-at-point point-index)
|
|
(list-ref widths point-index))
|
|
|
|
(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 (if (zero? (- num-points 2)) width
|
|
(* width (- 1 (/ (length points) (- num-points 2))))))
|
|
(set! dist (* w 1.5))
|
|
(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))))))
|
|
|
|
(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 (get-ornament point-index)
|
|
(let ((o (assq point-index ornaments)))
|
|
(if o (cadr o) #f)))
|
|
|
|
(define/public (get-random-ornament)
|
|
(if (null? ornaments) #f (cadr (choose ornaments))))
|
|
|
|
(define/public (room-for-new-ornament? point-index)
|
|
(and (not (get-ornament point-index))
|
|
(< (length ornaments) max-ornaments)))
|
|
|
|
(define/public (drop-pickups type game-logic)
|
|
(for-each
|
|
(lambda (ornament)
|
|
(send (cadr ornament) drop-pickup type game-logic))
|
|
ornaments))
|
|
|
|
(define/public (add-ornament point-index ornament)
|
|
(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 (deal-with-pickups)
|
|
(for-each
|
|
(lambda (pu)
|
|
(let ((pickup (car pu))
|
|
(point (cadr pu)))
|
|
(send plant add-property (send pickup get-type))
|
|
(send-message 'pick-up-pickup
|
|
(list
|
|
(list 'pickup-id (send pickup get-id))
|
|
(list 'point point)))))
|
|
pickedups)
|
|
(set! pickedups '()))
|
|
|
|
; adds the ornament if it's close, and checks sub-twigs
|
|
; returns true if it's succeded
|
|
(define/public (check-pickup pickup)
|
|
; check last point in our twig
|
|
(set! num-checks (+ num-checks 1))
|
|
; if we havent found anything yet and it's intersecting
|
|
(cond ((and (not (null? points))
|
|
(< (vdist-sq (vadd (send plant get-pos) (last points))
|
|
(send pickup get-pos))
|
|
100 #;(+ width (send pickup get-size))))
|
|
(set! pickedups (cons (list pickup (- (length points) 1)) pickedups))
|
|
(send pickup pick-up) ; this will remove the pickup for us
|
|
(send-message 'pick-up-highlight
|
|
(list (list 'pickup-id (send pickup get-id))
|
|
(list 'plant-id (send plant get-id))))
|
|
#t)
|
|
(else
|
|
(foldl
|
|
(lambda (twig found)
|
|
(if (not found)
|
|
(send (cadr twig) check-pickup pickup)
|
|
#f))
|
|
#f
|
|
twigs)))
|
|
|
|
; check each point in our twig
|
|
#;(let* ((i -1) (found (foldl
|
|
(lambda (point found)
|
|
(set! i (+ i 1))
|
|
(set! num-checks (+ num-checks 1))
|
|
; if we havent found anything yet and it's intersecting
|
|
(cond ((and (not found) (< (vdist (vadd (send plant get-pos) point)
|
|
(send pickup get-pos))
|
|
10 #;(+ width (send pickup get-size))))
|
|
(set! pickedups (cons (list pickup i) pickedups))
|
|
(send pickup pick-up) ; this will remove the pickup for us
|
|
(send-message 'pick-up-highlight
|
|
(list (list 'pickup-id (send pickup get-id))
|
|
(list 'plant-id (send plant 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 t d)
|
|
(when (and (not (null? pickedups)) (not (growing?)))
|
|
(deal-with-pickups))
|
|
(append
|
|
(map
|
|
(lambda (ornament)
|
|
(send (cadr ornament) update t d))
|
|
ornaments)
|
|
(map
|
|
(lambda (twig)
|
|
(send (cadr twig) update t d))
|
|
twigs)))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
; abilities live on twigs, and can do things.
|
|
; this is the base class for all abilities.
|
|
(define ornaments-above-ground '(flower leaf fork horn))
|
|
(define ornaments-below-ground '(inflatoe))
|
|
|
|
(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)
|
|
|
|
(define/public (get-global-pos)
|
|
(vadd (send plant get-pos) pos))
|
|
|
|
(define/public (drop-pickup type game-logic)
|
|
(when (eq? property 'inflatoe)
|
|
; put a pickup inside of the inflatoe
|
|
(send game-logic add-pickup
|
|
(make-object pickup-logic% (send game-logic new-pickup-id) type
|
|
(vadd (send plant 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
|
|
(game-logic #f)
|
|
(id #f)
|
|
(pos (vector 0 0 0))
|
|
(col (vector 1 1 1))
|
|
(tex "fff")
|
|
(is-player #f)
|
|
(implicit-property #f)
|
|
(shape-params '(0 0)))
|
|
|
|
(field
|
|
(twigs '()) ; a assoc list map of ids to twigs
|
|
(leader-twig #f) ; the temporary twig controlled by the player
|
|
(properties (list 'inflatoe implicit-property)) ; a list of symbols - properties come from pickups
|
|
(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)
|
|
(twig-size start-twig-points)
|
|
(auto-pilot-t 0)
|
|
(auto-pilot-d (* (+ 1 (rndf)) auto-time))
|
|
(auto-twig #f)
|
|
(auto-path-gen (make-object path-gen% (car shape-params) (cadr shape-params))))
|
|
|
|
(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 (get-twig-size)
|
|
twig-size)
|
|
|
|
(define/public (get-shape-params)
|
|
shape-params)
|
|
|
|
(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! twig-size (+ twig-size nutrient-twig-size-increase))
|
|
(when (and (not (eq? name 'nutrient)) (not (list-contains name properties)))
|
|
(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 pickups)
|
|
(when leader-twig
|
|
(for-each
|
|
(lambda (pickup)
|
|
(when (or is-player (zero? (random pickup-check-prob))) ; reduce the frequency for non-player plants
|
|
(when (not (list-contains (send pickup get-type) properties))
|
|
(send leader-twig check-pickup pickup))))
|
|
pickups)))
|
|
|
|
(define/public (destroy-twig twig)
|
|
(send-message 'shrink-twig
|
|
(list (list 'plant-id id)
|
|
(list 'twig-id (send (cadr twig) get-id))))
|
|
(send (cadr twig) drop-pickups implicit-property game-logic)
|
|
#;(send-message 'destroy-branch-twig (list
|
|
(list 'plant-id id)
|
|
(list 'twig-id (send (cadr 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 (destroy-all-twigs)
|
|
(for-each
|
|
(lambda (twig)
|
|
(destroy-twig twig))
|
|
twigs)
|
|
(set! twigs '()))
|
|
|
|
(define/public (get-random-ornament)
|
|
(if (null? twigs) #f (send (cadr (choose twigs)) get-random-ornament)))
|
|
|
|
(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 (list (send twig get-id) 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 (cadr (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 (cadr twig) get-dir)) dir)))
|
|
(if (> d (car l))
|
|
(list d (cadr 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)
|
|
(list 'col col)
|
|
(list 'tex tex))))
|
|
|
|
(append
|
|
(map
|
|
(lambda (twig)
|
|
(send (cadr twig) serialise))
|
|
twigs))))
|
|
|
|
(define/public (run-auto-pilot t d stones)
|
|
(when (or (> t auto-pilot-t) (< (length twigs) 3))
|
|
(set! auto-pilot-t (+ t auto-pilot-d))
|
|
(when (or (not auto-twig) (not (send auto-twig growing?)))
|
|
(let ((auto-twig-dir (hsrndvec)))
|
|
(send auto-path-gen reset auto-twig-dir auto-twig-dir)
|
|
(set! auto-twig (make-object twig-logic% (vector 0 0 0) 0 this 'root
|
|
auto-twig-dir
|
|
start-twig-width
|
|
twig-size
|
|
'extruded)))
|
|
(add-twig auto-twig))
|
|
|
|
(let ((pos (send auto-path-gen get-pos (send auto-twig get-dist))))
|
|
(when (not (collide? pos stones))
|
|
(grow pos)))))
|
|
|
|
(define/augment (update t d)
|
|
; grow a new ornament?
|
|
(when (and (not (null? properties)) (zero? (random ornament-grow-probability)))
|
|
(let ((twig (get-random-twig)))
|
|
(when (and twig (> (send twig get-length) 3) (not (send twig growing?)))
|
|
(let* ((property (choose properties))
|
|
(point-index (+ 1 (random (- (send twig get-length) 2))))
|
|
(pos (vadd pos (send twig get-point point-index))))
|
|
|
|
(when (and (send twig room-for-new-ornament? point-index)
|
|
; check we can grow here
|
|
(and (or (not (list-contains property ornaments-above-ground)) (> (vy pos) 5))
|
|
(or (not (list-contains property ornaments-below-ground)) (< (vy pos) -5))))
|
|
(send twig add-ornament point-index
|
|
(make-object ornament-logic%
|
|
(get-next-ornament-id)
|
|
property
|
|
this
|
|
twig
|
|
point-index)))))))
|
|
;(printf "plant ~a has ~a twigs~n" id (length twigs))
|
|
(map
|
|
(lambda (twig)
|
|
(send (cadr twig) update t d))
|
|
twigs))
|
|
|
|
(super-new)))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define game-logic%
|
|
(class game-logic-object%
|
|
(field
|
|
(plants '())
|
|
(pickups '())
|
|
(player #f)
|
|
(insects '())
|
|
(next-pickup-id 0)
|
|
(next-insect-id 0)
|
|
(stones '()))
|
|
|
|
(inherit send-message)
|
|
|
|
(define/public (set-stones s)
|
|
(set! stones s))
|
|
|
|
(define/public (new-pickup-id)
|
|
(let ((r next-pickup-id))
|
|
(set! next-pickup-id (+ next-pickup-id 1)) r))
|
|
|
|
(define/public (new-insect-id)
|
|
(let ((r next-insect-id))
|
|
(set! next-insect-id (+ next-insect-id 1)) r))
|
|
|
|
(define/public (setup world-list)
|
|
(let ((pickups (list-ref world-list 1)))
|
|
(for-each
|
|
(lambda (pickup)
|
|
(add-pickup (make-object pickup-logic% (new-pickup-id) 'nutrient
|
|
(list-ref pickup 2))))
|
|
pickups)
|
|
(for ((id (in-range 0 num-worms)))
|
|
(add-insect (make-object insect-logic% (new-insect-id) (vmul (vsub (srndvec) (vector 0 1 0)) 100) 'worm)))
|
|
(for ((id (in-range 0 num-spiders)))
|
|
(add-insect (make-object insect-logic% (new-insect-id) (vmul (vsub (srndvec) (vector 0 1 0)) 100) 'spider)))
|
|
(for ((id (in-range 0 num-butterflies)))
|
|
(add-insect (make-object insect-logic% (new-insect-id) (vmul (srndvec) 100) 'butterfly)))
|
|
))
|
|
|
|
(define/public (clear)
|
|
(for-each
|
|
(lambda (plant)
|
|
(send plant destroy-all-twigs))
|
|
plants))
|
|
|
|
(define/public (add-player plant)
|
|
(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))
|
|
(list 'curve (car (send plant get-shape-params)))
|
|
(list 'corner (cadr (send plant get-shape-params)))))
|
|
(set! player plant)
|
|
(set! plants (cons plant plants))
|
|
|
|
(for-each
|
|
(lambda (insect)
|
|
(send insect set-centre (send plant get-pos)))
|
|
insects))
|
|
|
|
(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))
|
|
(list 'curve (car (send plant get-shape-params)))
|
|
(list 'corner (cadr (send plant get-shape-params)))))
|
|
(set! plants (cons plant plants)))
|
|
|
|
(define/public (add-pickup pickup)
|
|
(when (< (length pickups) max-pickups)
|
|
(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 (add-insect insect)
|
|
(send-message 'new-insect (list
|
|
(list 'insect-id (send insect get-id))
|
|
(list 'pos (send insect get-pos))
|
|
(list 'type (send insect get-type))))
|
|
(send insect set-centre (send player get-pos))
|
|
(set! insects (cons insect insects)))
|
|
|
|
(define/public (serialise)
|
|
; send player-plant serialise I think...
|
|
0)
|
|
|
|
(define/public (insect-send)
|
|
(let ((ornament (send (choose plants) get-random-ornament)))
|
|
(when (and ornament
|
|
(not (eq? (send ornament get-property) 'inflatoe))
|
|
#;(or (eq? (send ornament get-property) 'flower)
|
|
(eq? (send ornament get-property) 'horn)))
|
|
(let ((insect (choose insects)))
|
|
(when (eq? (send insect get-type) 'butterfly)
|
|
(send insect move-to (send ornament get-global-pos)))))))
|
|
|
|
(define/public (run-auto-pilot t d)
|
|
(for-each
|
|
(lambda (plant)
|
|
(when (not (eq? plant player))
|
|
(send plant run-auto-pilot t d stones)))
|
|
plants))
|
|
|
|
|
|
; todo - distribute the checking of stuff like
|
|
; this to a random selection of pickups/plants
|
|
; to distribute the cpu load
|
|
(define/augment (update t d)
|
|
|
|
(printf "num updates ~a~n" update-count)
|
|
(printf "num pickups ~a~n" (length pickups))
|
|
(printf "num checks ~a~n" num-checks)
|
|
(set! update-count 0)
|
|
(set! num-checks 0)
|
|
|
|
(run-auto-pilot t d)
|
|
|
|
(when (zero? (random insect-send-prob))
|
|
(insect-send))
|
|
|
|
(for-each
|
|
(lambda (plant)
|
|
(send plant check-pickup pickups))
|
|
plants)
|
|
|
|
; remove the pickups that have been 'picked up'
|
|
(set! pickups (filter
|
|
(lambda (pickup)
|
|
(not (send pickup picked-up?)))
|
|
pickups))
|
|
|
|
(append
|
|
(map
|
|
(lambda (plant)
|
|
(send plant update t d))
|
|
plants)
|
|
(map
|
|
(lambda (insect)
|
|
(send insect update t d))
|
|
insects)))
|
|
|
|
(super-new)))
|