FoAM/groworld
12
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

butterflies, spiders, pretty twiglets, new pickups

Browse source
This commit is contained in:
Dave Griffiths 2009-09-25 17:19:48 +01:00
parent be2bd4ba1f
commit dca225bc0a
12 changed files with 1083 additions and 287 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
plant-eyes/controller.ss
View file

@ -27,7 +27,8 @@
(seed-return #f)
(seed-return-timer 0)
(seed-return-secs-per-point 3)
(twig-stack '()))
(twig-stack '())
(above-ground #f))
(define/public (set-player-plant s)
(set! pos (send s get-pos))
@ -49,7 +50,6 @@
(define/public (setup)
(lock-camera cam)
(camera-lag 0.2)
(clip 1 300)
(set-camera-transform (mtranslate (vector 0 0 -4))))
; moveme
@ -144,6 +144,16 @@
(set! seed-return #t)
(set! current-point (- (send current-twig get-num-points) 1)))
(cond
((and (not above-ground) (> (vy (vadd player-pos pos)) 0))
(set! above-ground #t)
(send game-view above-ground)
(printf "up~n"))
((and above-ground (< (vy (vadd player-pos pos)) 0))
(set! above-ground #f)
(send game-view below-ground)
(printf "down~n")))
(let* ((side (vnormalise (vcross up fwd)))
(up (vnormalise (vcross fwd side))))

32
plant-eyes/game-modes.ss
View file

@ -13,19 +13,19 @@
(players (list
(make-player-info "plant0000001@fo.am" "plant0000001"
"textures/plant0000001.png" (list-ref (list-ref seed-obs 0) 2)
(vector 0.5 1 0.5))
(vector 0.5 0.5 0.5))
(make-player-info "plant0000002@fo.am" "plant0000002"
"textures/plant0000002.png" (list-ref (list-ref seed-obs 1) 2)
(vector 0.5 1 0))
(vector 0.25 0.25 0.25))
(make-player-info "plant0000003@fo.am" "plant0000003"
"textures/plant0000003.png" (list-ref (list-ref seed-obs 2) 2)
(vector 0 1 0.5))
(vector 0.7 0.7 0.7))
(make-player-info "plant0000004@fo.am" "plant0000004"
"textures/plant0000004.png" (list-ref (list-ref seed-obs 3) 2)
(vector 0.75 1 0.5))
(vector 0.75 0.75 0.75))
(make-player-info "plant0000005@fo.am" "plant0000005"
"textures/plant0000005.png" (list-ref (list-ref seed-obs 4) 2)
(vector 0.5 1 0.75))
(vector 0.1 0.1 0.1))
))
(seeds '())
(clicked -1))
@ -33,6 +33,9 @@
(define/public (get-player-info)
(list-ref players clicked))
(define/public (get-players)
players)
(define/public (setup)
(let ((c 0))
(set! seeds (map
@ -87,15 +90,28 @@
(player #f)
(logic-tick 0.5)) ; time between logic updates
(define/public (setup pi)
(define/public (setup pi players)
(set! cl (make-object client% (player-info-jid pi) (player-info-pass pi)))
(set! player (make-object plant-logic%
(player-info-jid pi)
(player-info-pos pi)
(player-info-col pi)
(player-info-tex pi)))
(player-info-tex pi)
#t))
(send c set-player-plant player)
(send gl add-player player)
; add the other players...
(for-each
(lambda (player)
(when (not (eq? player pi))
(send gl add-plant (make-object plant-logic%
(player-info-jid player)
(player-info-pos player)
(player-info-col player)
(player-info-tex player)))))
players)
(send c setup)
(send gv setup world-list)
(send gl setup world-list)
@ -105,7 +121,7 @@
(when (< tick-time t)
(let ((messages (send gl update)))
(let ((messages (send gl update t d)))
; pass the messages to the network client
(send gv update t d (send cl update messages gl))) ; and the game view

12
plant-eyes/jabberer.ss
View file

@ -1,5 +1,5 @@
#lang scheme/base
(require scheme/class openssl (prefix-in xmpp: "xmpp.ss"))
(require scheme/class); openssl (prefix-in xmpp: "xmpp.ss"))
(provide (all-defined-out))
; a class which wraps the xmpp in a thread and allows messages to be picked up
@ -36,9 +36,9 @@
(define/public (send-msg to msg)
(set! outgoing (append outgoing (list (list to msg)))))
(define (message-handler sz)
(when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz)))
(set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming)))
(define (message-handler sz) 0)
; (when debug-jab (printf "rx <---- ~a ~a~n" (xmpp:message-from sz) (xmpp:message-body sz)))
;(set! incoming (cons (list (xmpp:message-from sz) (xmpp:message-body sz)) incoming)))
(define/public (start)
(set! thr (thread run)))
@ -46,8 +46,8 @@
(define/public (stop)
(kill-thread thr))
(define (run)
(xmpp:with-xmpp-session jid pass
(define (run) 0
#;(xmpp:with-xmpp-session jid pass
(xmpp:set-xmpp-handler 'message message-handler)
(let loop ()
(when debug-netloop (printf ".~n"))

161
plant-eyes/logic.ss
View file

@ -9,7 +9,7 @@
(define start-twig-points 15)
(define start-twig-dist 0.05)
(define start-twig-width 0.1)
(define default-max-twigs 5)
(define default-max-twigs 2)
(define default-scale-factor 1.05)
(define num-pickups 10)
(define pickup-dist-radius 200)
@ -19,6 +19,12 @@
(define start-size 50)
(define max-ornaments 10) ; per twig
(define nutrient-twig-size-increase 2)
(define num-worms 10)
(define num-spiders 10)
(define num-butterflies 10)
(define auto-twig-var 5)
(define auto-time 5)
(define pickup-check-prob 20)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; the base class logic object - all logic side objects can
@ -41,8 +47,8 @@
((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 ((l (inner '() update)) ; and call update on them too.
(define/pubment (update t d) ; need to augement this if we have child logic objects,
(let ((l (inner '() update t d)) ; and call update on them too.
(m messages))
(set! messages '())
(append
@ -51,6 +57,62 @@
(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
(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 (move)
; todo check stones
(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 (and (or (eq? type 'spider) (eq? type 'worm)) (> (vy pos) 0))
(set! pos (vector (vx pos) 0 (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))
(set! next-update (+ time d))
(send-message 'insect-move (list
(list 'insect-id id)
(list 'pos pos)
(list 'duration d)))))
'())
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a twig, which can contain other twigs things.
; (roots and shoots are both twigs)
@ -245,15 +307,15 @@
twigs)
found)))
(define/augment (update)
(define/augment (update t d)
(append
(map
(lambda (ornament)
(send (cadr ornament) update))
(send (cadr ornament) update t d))
ornaments)
(map
(lambda (twig)
(send (cadr twig) update))
(send (cadr twig) update t d))
twigs)))
(super-new)))
@ -323,19 +385,25 @@
(id #f)
(pos (vector 0 0 0))
(col (vector 1 1 1))
(tex "fff"))
(tex "fff")
(is-player #f))
(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
(properties '(flower)) ; 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)
(twig-size start-twig-points))
(twig-size start-twig-points)
(auto-pilot-t 0)
(auto-pilot-d (* (+ 1 (rndf)) auto-time))
(auto-twig #f)
(auto-twig-dir (hsrndvec))
(auto-twig-pos (vector 0 0 0)))
(inherit send-message)
@ -384,6 +452,7 @@
next-ornament-id))
(define/public (check-pickup pickup)
(when (or is-player (random pickup-check-prob)) ; reduce the frequency for non-player plants
(when leader-twig
(send leader-twig check-pickup pickup))
@ -394,7 +463,7 @@
(send (cadr twig) check-pickup pickup))
#f))
#f
twigs))
twigs)))
(define/public (destroy-twig twig)
(send-message 'shrink-twig
@ -461,7 +530,24 @@
(send (cadr twig) serialise))
twigs))))
(define/augment (update)
(define/public (run-auto-pilot t d)
(when (> t auto-pilot-t)
(set! auto-pilot-t (+ t auto-pilot-d))
(when (or (not auto-twig) (not (send auto-twig growing?)))
(set! auto-twig (make-object twig-logic% (vector 0 0 0) 0 this 'root
auto-twig-dir
start-twig-width
twig-size
'ribbon))
(set! auto-twig-dir (hsrndvec))
(set! auto-twig-pos auto-twig-dir)
(add-twig auto-twig))
(set! auto-twig-dir (vmul (vnormalise (vadd auto-twig-dir (vmul (srndvec) auto-twig-var)))
(send auto-twig get-dist)))
(set! auto-twig-pos (vadd auto-twig-pos auto-twig-dir))
(grow auto-twig-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)))
@ -479,7 +565,7 @@
point-index))))))
(map
(lambda (twig)
(send (cadr twig) update))
(send (cadr twig) update t d))
twigs))
(super-new)))
@ -491,7 +577,8 @@
(field
(plants '())
(pickups '())
(player #f))
(player #f)
(insects '()))
(inherit send-message)
@ -503,10 +590,16 @@
(add-pickup (make-object pickup-logic% i (list-ref pickup 0)
(list-ref pickup 2)))
(set! i (+ i 1)))
pickups))))
pickups)
(for ((id (in-range 0 num-worms)))
(add-insect (make-object insect-logic% id (vmul (srndvec) 100) 'worm)))
(for ((id (in-range 0 num-spiders)))
(add-insect (make-object insect-logic% (+ id num-worms) (vmul (srndvec) 100) 'spider)))
(for ((id (in-range 0 num-butterflies)))
(add-insect (make-object insect-logic% (+ id num-worms num-butterflies) (vmul (srndvec) 100) 'butterfly)))
)))
(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))
@ -514,7 +607,12 @@
(list 'col (send plant get-col))
(list 'tex (send plant get-tex))))
(set! player plant)
(set! plants (cons plant plants)))
(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
@ -533,13 +631,33 @@
(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 serialise))
(define/public (run-auto-pilot t d)
(for-each
(lambda (plant)
(when (not (eq? plant player))
(send plant run-auto-pilot t d)))
plants))
; todo - distribute the checking of stuff like
; this to a random selection of pickups/plants
; to distribute the cpu load
(define/augment (update)
(define/augment (update t d)
(run-auto-pilot t d)
(for-each
(lambda (pickup)
(for-each
@ -554,9 +672,14 @@
(not (send pickup picked-up?)))
pickups))
(append
(map
(lambda (plant)
(send plant update))
plants))
(send plant update t d))
plants)
(map
(lambda (insect)
(send insect update t d))
insects)))
(super-new)))

BIN
plant-eyes/meshes/butterfly.blend Normal file
View file

Binary file not shown.

103
plant-eyes/meshes/butterfly.obj Normal file
View file

@ -0,0 +1,103 @@
# Blender3D v245 OBJ File: butterfly.blend
# www.blender3d.org
o butterfly_Mesh
v 0.022483 0.000002 -0.790792
v 0.286519 0.000002 -0.808224
v 0.569586 0.000002 -0.813275
v 1.053234 0.000002 -0.802641
v 1.513902 0.000002 -0.768308
v 1.995211 0.000002 -0.662639
v 2.293338 0.000002 -0.513493
v 2.242126 0.000002 -0.382030
v 2.075995 0.000002 -0.176237
v 1.843004 0.000002 -0.029013
v 1.573859 0.000002 0.086073
v 1.118858 0.000002 0.190916
v 0.741962 0.000002 0.295921
v 0.771135 0.000002 0.497448
v 0.756951 0.000002 0.640671
v 0.596358 0.000002 0.745205
v 0.434684 0.000002 0.768079
v 0.244420 0.000002 0.751611
v 0.089934 0.000002 0.663155
v 0.042516 0.000002 0.533723
v 0.014988 0.000002 0.400845
vt 0.455701 0.993275 0.0
vt 0.243421 1.000000 0.0
vt 0.119179 0.996805 0.0
vt 0.119179 0.996805 0.0
vt 0.003289 0.985782 0.0
vt 0.455701 0.993275 0.0
vt 0.455701 0.993275 0.0
vt 0.003289 0.985782 0.0
vt 0.689145 0.995001 0.0
vt 0.837582 0.995001 0.0
vt 0.003289 0.985782 0.0
vt 0.011719 0.552540 0.0
vt 1.001961 0.943805 0.0
vt 0.837582 0.995001 0.0
vt 0.011719 0.552540 0.0
vt 1.000000 0.810426 0.0
vt 1.001961 0.943805 0.0
vt 0.011719 0.552540 0.0
vt 1.004866 0.699950 0.0
vt 1.000000 0.810426 0.0
vt 0.011719 0.552540 0.0
vt 1.002261 0.585438 0.0
vt 1.004866 0.699950 0.0
vt 0.011719 0.552540 0.0
vt 1.001561 0.484525 0.0
vt 1.002261 0.585438 0.0
vt 0.011719 0.552540 0.0
vt 0.996710 0.400030 0.0
vt 1.001561 0.414213 0.0
vt 0.972656 0.439259 0.0
vt 0.988410 0.279043 0.0
vt 0.996710 0.400030 0.0
vt 0.964844 0.361134 0.0
vt 0.998766 0.161859 0.0
vt 0.992316 0.173574 0.0
vt 0.937500 0.251759 0.0
vt 0.777196 0.206295 0.0
vt 0.600329 0.755609 0.0
vt 0.015625 0.501759 0.0
vt 0.777196 0.206295 0.0
vt 0.007812 0.540821 0.0
vt 0.008176 0.464606 0.0
vt 0.657689 0.072756 0.0
vt 0.777196 0.206295 0.0
vt 0.008176 0.464606 0.0
vt 0.657689 0.072756 0.0
vt 0.008176 0.464606 0.0
vt 0.028988 0.304632 0.0
vt 0.505172 0.010559 0.0
vt 0.657689 0.072756 0.0
vt 0.025082 0.304632 0.0
vt 0.505172 0.010559 0.0
vt 0.021176 0.304632 0.0
vt 0.030388 0.026039 0.0
vt 0.438117 0.003906 0.0
vt 0.665328 0.002746 0.0
vt 0.100701 0.010414 0.0
vn 0.000000 1.000000 -0.000000
usemtl None_butterfly.png
s off
f 4/1/1 3/2/1 2/3/1
f 2/4/1 1/5/1 4/6/1
f 4/7/1 1/8/1 5/9/1
f 5/10/1 1/11/1 21/12/1
f 6/13/1 5/14/1 21/15/1
f 7/16/1 6/17/1 21/18/1
f 8/19/1 7/20/1 21/21/1
f 9/22/1 8/23/1 21/24/1
f 10/25/1 9/26/1 21/27/1
f 11/28/1 10/29/1 21/30/1
f 12/31/1 11/32/1 21/33/1
f 13/34/1 12/35/1 21/36/1
f 14/37/1 13/38/1 21/39/1
f 14/40/1 21/41/1 20/42/1
f 15/43/1 14/44/1 20/45/1
f 15/46/1 20/47/1 19/48/1
f 16/49/1 15/50/1 19/51/1
f 16/52/1 19/53/1 18/54/1
f 17/55/1 16/56/1 18/57/1

69
plant-eyes/meshes/butterfly.svg Normal file
View file

@ -0,0 +1,69 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<!-- Created with Inkscape (http://www.inkscape.org/) -->
<svg
xmlns:dc="http://purl.org/dc/elements/1.1/"
xmlns:cc="http://creativecommons.org/ns#"
xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
xmlns:svg="http://www.w3.org/2000/svg"
xmlns="http://www.w3.org/2000/svg"
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
width="744.09448819"
height="1052.3622047"
id="svg2"
sodipodi:version="0.32"
inkscape:version="0.46"
sodipodi:docname="butterfly.svg"
inkscape:output_extension="org.inkscape.output.svg.inkscape">
<defs
id="defs4">
<inkscape:perspective
sodipodi:type="inkscape:persp3d"
inkscape:vp_x="0 : 526.18109 : 1"
inkscape:vp_y="0 : 1000 : 0"
inkscape:vp_z="744.09448 : 526.18109 : 1"
inkscape:persp3d-origin="372.04724 : 350.78739 : 1"
id="perspective10" />
</defs>
<sodipodi:namedview
id="base"
pagecolor="#ffffff"
bordercolor="#666666"
borderopacity="1.0"
gridtolerance="10000"
guidetolerance="10"
objecttolerance="10"
inkscape:pageopacity="0.0"
inkscape:pageshadow="2"
inkscape:zoom="0.7"
inkscape:cx="375"
inkscape:cy="520"
inkscape:document-units="px"
inkscape:current-layer="layer1"
showgrid="false"
inkscape:window-width="645"
inkscape:window-height="717"
inkscape:window-x="0"
inkscape:window-y="25" />
<metadata
id="metadata7">
<rdf:RDF>
<cc:Work
rdf:about="">
<dc:format>image/svg+xml</dc:format>
<dc:type
rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
</cc:Work>
</rdf:RDF>
</metadata>
<g
inkscape:label="Layer 1"
inkscape:groupmode="layer"
id="layer1">
<path
style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
d="M 235.71428,273.79076 C 254.90915,270.64427 315.96816,269.50504 340,269.50504 C 421.01141,269.11452 444.82891,272.44383 520,278.07647 C 575.79111,290.85363 659.33671,302.82084 668.57143,326.64789 C 671.77064,334.64592 653.15086,364.04446 627.14286,390.93361 C 594.26,410.92531 573.50029,429.10984 531.42857,440.93361 C 482.10711,455.49717 402.32808,466.32873 372.85715,480.93361 C 374.52787,514.27008 385.06319,528.12923 375.71428,546.64789 C 355.38533,569.88117 334.88967,568.45444 314.28571,570.93362 C 292.75817,575.1478 261.00591,565.01549 248.57143,550.93361 C 238.33599,532.98879 239.46617,519.75441 234.28571,500.93361"
id="path2383"
sodipodi:nodetypes="ccccccccccc" />
</g>
</svg>
Side by side

After

Width:  |  Height:  |  Size: 2.7 KiB

3
plant-eyes/plant-eyes.scm
View file

@ -44,6 +44,7 @@
(clear)
(clear-shader-cache)
(clear-texture-cache)
(define mode 'gui)
(define gui (make-object gui-game-mode% (list-ref world-list 0)))
@ -60,7 +61,7 @@
(cond
((eq? mode 'gui)
(when (send gui update (flxtime) (delta))
(send game setup (send gui get-player-info))
(send game setup (send gui get-player-info) (send gui get-players))
(set! mode 'game)))
((eq? mode 'game)
(send game update (flxtime) (delta))))

BIN
plant-eyes/textures/butterfly.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 15 KiB

BIN
plant-eyes/textures/ribbon-twig.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 1.8 KiB

BIN
plant-eyes/textures/root-norm.png
View file

Binary file not shown.
Side by side Swipe Overlay

Before

Width:  |  Height:  |  Size: 398 KiB

After

Width:  |  Height:  |  Size: 88 KiB

700
plant-eyes/view.ss
View file

@ -1,19 +1,22 @@
#lang scheme/base
(require scheme/class fluxus-016/fluxus "sound.ss" "message.ss" "list-utils.ss" "ornament-views.ss")
(require scheme/class fluxus-016/fluxus fluxus-016/shapes "sound.ss" "message.ss" "list-utils.ss" "ornament-views.ss")
(provide (all-defined-out))
; the fluxus code to make things look the way they do
(define debug-messages #f) ; prints out all the messages sent to the renderer
(define (ornament-colour) (vector 0.5 1 0.4))
(define (pickup-colour) (vector 1 1 0.5))
(define (earth-colour) (vector 0.2 0.1 0))
(define (stones-colour) (vmul (earth-colour) (+ 0.5 (* (rndf) 0.5))))
(define (ornament-colour) (vector 0.7 0.7 0.7))
(define (pickup-colour) (vector 1 1 1))
(define (earth-colour) (vector 0.1 0.1 0.1))
(define (dust-colour) (vmul (vector 0.05 0.05 0.05) (* 2 (rndf))))
(define (stones-colour) (vmul (vector 0.5 0.5 0.5) (* (crndf) 0.5)))
(define (alive-colour) (vmul (vector 1 1 1) (+ 0.5 (* (rndf) 0.5))))
(define (worm-colour) (vmul (vector 0.8 0.8 0.8) (+ 0.5 (* (rndf) 0.5))))
(define wire-mode #f)
(define fog-col (earth-colour))
(define fog-strength 0.01)
(define fog-strength 0.1)
(define default-grow-speed 0.5)
(define grow-overshoot 10)
@ -22,6 +25,10 @@
(define fin-grow-prob 200)
(define max-fins-per-twig 5)
(define above-fog-col (vector 1 1 1))
(define above-fog-strength 0.01)
(define ground-change-duration 4)
(define (pre-ripple)
(when (not (pdata-exists? "rip-pref"))
(pdata-copy "p" "rip-pref")))
@ -36,8 +43,260 @@
(vector 0 0 0))))))))))
"p" "rip-pref"))
(define (fract n)
(- n (floor n)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define dust%
(class object%
(field
(rate 1)
(above-ground #f)
(next-p 0)
(root (let ((p (with-state
(colour 0)
(hint-depth-sort)
(texture (load-texture "textures/particle.png"))
(build-particles 1000))))
(with-primitive p
(pdata-map!
(lambda (c)
(vector 0 0 0 0.01))
"c")
(pdata-map!
(lambda (p)
(vmul (srndvec) 100))
"p")
(pdata-map!
(lambda (s)
(let ((s (* 4 (rndf))))
(vector s s s)))
"s")) p))
(emitter (with-state (build-locator)))
(pos (with-primitive root (vtransform (vector 0 0 0) (get-global-transform)))))
(define/public (set-above-ground s)
(set! above-ground s)
(with-primitive root
(colour (if s 1 0))
(pdata-map!
(lambda (c)
(if s (vector 1 1 1 0.01) (vector 0 0 0 0.01)))
"c")))
(define/public (update t d)
(let ((emitter-pos (with-primitive emitter
(identity)
(translate (vmul pos -1)) ; makes the particles relative to the centre of the plant
(concat (get-locked-matrix)) ; which makes the depth sorting work better
(translate (vector 0 0 -10))
(vtransform (vector 0 0 0) (get-transform)))))
(with-primitive root
(for ((i (in-range 0 rate)))
(pdata-set! "p" next-p (vadd emitter-pos (vmul (srndvec) 10)))
(pdata-set! "c" next-p (if above-ground (vector 1 1 1 0.01) (vector 0 0 0 0.01)))
(pdata-set! "s" next-p (let ((s (* 4 (rndf)))) (vector s s s)))
(set! next-p (+ next-p 1)))
(pdata-op "*" "c" 1.04)
(pdata-op "*" "s" 0.995))))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define insect-view%
(class object%
(init-field
(id 0)
(from (vector 0 0 0))
(type 'none))
(field
(to (vector 0 0 0))
(from-dir (vector 1 0 0))
(to-dir (vector 1 0 0))
(time 0)
(tick 1))
(define/public (move pos dur)
(set! from to)
(set! from-dir to-dir)
(set! to pos)
(set! to-dir (vnormalise (vsub from to)))
(set! time 0)
(set! tick dur))
(define/public (update t d)
(set! time (+ time d)))
(define/public (do-tx t d)
(let* ((t (min (/ time tick) 1))
(h (hermite-tangent from to (vmul from-dir 2) (vmul to-dir 2) t)))
(translate (car h))
(concat (maim (vector 0 0 1) (vnormalise (cadr h)))))
(set! time (+ time d)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (add-blendshape key model)
(let ((b (load-primitive model))
(pname (string-append "p" (number->string key))))
(pdata-add pname "v")
(pdata-index-map!
(lambda (i p)
(with-primitive b (pdata-ref "p" i)))
pname)
(destroy b)))
(define (set-blendshape key)
(pdata-copy (string-append "p" (number->string key)) "p"))
(define spider-insect-view%
(class insect-view%
(inherit-field from to from-dir to-dir time tick)
(inherit do-tx)
(field
(root (let ((p (with-state
(hint-unlit)
(colour (vector 0 0 0))
(load-primitive "meshes/spider-1.obj"))))
(with-primitive p
(pdata-copy "p" "p0")
(add-blendshape 1 "meshes/spider-2.obj")
(add-blendshape 2 "meshes/spider-3.obj") p)))
(anim-t 0)
(anim-d (* 0.2 (rndf)))
(blendshape 0))
(define/override (update t d)
(with-primitive root
(when (> anim-t anim-d)
(set! anim-t 0)
(set! blendshape (modulo (+ blendshape 1) 3))
(set-blendshape blendshape))
(identity)
(do-tx t d)
(scale 1))
(set! anim-t (+ anim-t d)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define butterfly-insect-view%
(class insect-view%
(inherit-field from to from-dir to-dir time tick)
(inherit do-tx)
(field
(root (let ((p (build-locator)))
(with-state
(colour (rndvec))
(parent p)
(hint-depth-sort)
(hint-unlit)
(backfacecull 0)
(texture (load-texture "textures/butterfly.png"))
(load-primitive "meshes/butterfly.obj")
(translate (vector 0 0.001 0))
(load-primitive "meshes/butterfly.obj")) p)))
(define/override (update t d)
(with-primitive root
(let ((a (* 90 (rndf))))
(with-primitive (car (get-children))
(rotate (vector 0 0 a)))
(with-primitive (cadr (get-children))
(rotate (vector 0 0 (- a)))))
(identity)
(do-tx t d)
(scale 1))
(set! time (+ time d)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define worm-insect-view%
(class insect-view%
(inherit-field from to from-dir to-dir time tick)
(field
(hidden #t)
(from2 (vector 0 0 0))
(from-dir2 (vector 0 0 0))
(root (let ((p (build-ribbon 20)))
(with-primitive p
(translate (vector 0 0 -0.1))
(hint-depth-sort)
;(hint-unlit)
(colour (worm-colour))
(texture (load-texture "textures/worm.png"))
(let ((width (+ 0.5 (* 0.5 (rndf)))))
(pdata-index-map!
(lambda (i w)
width #;(+ 0.05 (* (abs (sin (* i 0.5))) 0.1)))
"w"))
#;(pdata-map!
(lambda (c)
(vector 1 1 1))
"c"))
p)))
(define/override (move pos dur)
(set! from2 from)
(set! from to)
(set! from-dir2 from-dir)
(set! from-dir to-dir)
(set! to pos)
(set! to-dir (vmul (vsub to from) 5))
(set! time 0)
(set! tick dur))
(define/override (update t d)
(let ((nt (/ time tick))) ; normalise time
(with-primitive root
(pdata-index-map!
(lambda (i p)
(let ((st (- nt (* i 0.05))))
(if (< st 0)
(hermite from2 from (vmul from-dir2 2) (vmul from-dir 2) (+ st 1))
(hermite from to (vmul from-dir 2) (vmul to-dir 2) st))))
"p")))
(set! time (+ time d)))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (build-squiggle x y)
(let ((p (build-ribbon 30))
(x (/ x 10))
(y (/ y 10)))
(with-primitive p
(pdata-index-map!
(lambda (i p)
(vector (cos (/ i x)) (sin (/ i y)) (/ i (pdata-size))))
"p")
(pdata-index-map!
(lambda (i p)
(* 0.1 (sin (* 3.141 (/ i (pdata-size))))))
"w")
(pdata-map!
(lambda (c)
(vector 1 1 1))
"c")
(recalc-bb))
p))
(define pickup-view%
(class object%
(init-field
@ -51,20 +310,17 @@
(translate pos)
(rotate rot)
(colour (pickup-colour))
(shader "shaders/textoon.vert.glsl" "shaders/textoon.frag.glsl")
(emissive (pickup-colour))
(hint-frustum-cull)
(texture (load-texture "textures/wiggle.png"))
(cond
((eq? type 'wiggle) (load-primitive "meshes/pickup.obj"))
((eq? type 'leaf)
(texture (load-texture "textures/leaf.png"))
(load-primitive "meshes/leaf.obj"))
((eq? type 'curly) (load-primitive "meshes/pickup.obj"))
((eq? type 'nutrient) (load-primitive "meshes/nutrient.obj"))
((eq? type 'horn) (load-primitive "meshes/horn.obj"))
((eq? type 'inflatoe) (load-primitive "meshes/inflatoe-full.obj"))
((eq? type 'fork) (load-primitive "meshes/fork.obj"))
((eq? type 'flower) (load-primitive "meshes/flower.obj")))))
(cond ; 0127461816
((eq? type 'wiggle) (build-squiggle 4 2))
((eq? type 'leaf) (build-squiggle 2 4))
((eq? type 'curly) (build-squiggle 4 6))
((eq? type 'nutrient) (build-squiggle 2 2))
((eq? type 'horn) (build-squiggle 3 4))
((eq? type 'inflatoe) (build-squiggle 4 5))
((eq? type 'fork) (build-squiggle 5 2))
((eq? type 'flower) (build-squiggle 4 3)))))
(from pos)
(destination (vector 0 0 0))
(speed 0.05)
@ -73,6 +329,9 @@
(define/public (pick-up)
(destroy root))
(define/public (get-root)
root)
(define/public (move-to s)
(set! t 0)
(set! from pos)
@ -92,6 +351,7 @@
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define twig-view%
(class object%
@ -111,53 +371,30 @@
(col (vector 1 1 1))
(tex "")
(markers '())
(shrink-t 0)
(grow-t -1)
(marker-destroy-t 0)
(grow-speed default-grow-speed)
(shrink-t 0)
(delme #f))
(define/public (get-id)
id)
(define/public (delme?)
delme)
(define/public (get-dir)
dir)
(define/public (set-col! s)
(set! col s))
(define/public (set-tex! s)
(set! tex s))
(define/public (build)
0)
(define/public (get-num-points)
index)
(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 (get-width point-index)
(error "need to overide this"))
(define/public (get-id) id)
(define/public (delme?) delme)
(define/public (get-dir) dir)
(define/public (set-dir! s) (set! dir s))
(define/public (set-col! s) (set! col s))
(define/public (set-tex! s) (set! tex s))
(define/public (get-pos) pos)
(define/public (build) 0)
(define/public (get-num-points) index)
(define/public (get-grow-t) grow-t)
(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 (get-width point-index) (error "need to overide this"))
(define/public (set-grow-speed s) (set! grow-speed s))
(define/public (add-child-twig-id twig-id)
(set! child-twig-ids (cons twig-id child-twig-ids)))
@ -172,17 +409,18 @@
(define/public (start-shrinking)
(set! shrink-t (if (growing?) grow-t (+ num-points grow-overshoot))))
(define/pubment (add-point point width)
(define/pubment (add-point point width make-marker)
(play-sound "snd/event01.wav" point (+ 0.1 (rndf)) 0.3)
(when make-marker
(set! markers (append markers (list (with-state
(parent (get-root))
(translate point)
(scale 0.1)
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
(colour col)
(build-sphere 8 8)))))
(build-sphere 8 8))))))
(inner (void) add-point point width))
(inner (void) add-point point width make-marker))
(define/public (add-ornament point-index property)
(when (< point-index grow-t)
@ -195,11 +433,12 @@
(vnormalise (vsub (get-point point-index) (get-point (- point-index 1))))
col)))
; check above ground
(let ((pos (with-primitive (get-root) (vtransform (vector 0 0 0) (get-global-transform)))))
(if (not (and (send ornament above-ground-only?)
(< (vy (get-point point-index)) 1)))
(< (vy (vadd pos (get-point point-index))) 1)))
; todo - delete existing ornaments here
(set! ornaments (cons (list point-index ornament) ornaments))
(send ornament destroy-ornament))))))
(send ornament destroy-ornament)))))))
(define/pubment (set-excitations! a b)
(for-each
@ -239,16 +478,21 @@
(define ribbon-twig-view%
(class twig-view%
(inherit-field pos radius num-points index col tex)
(inherit-field pos radius num-points index col tex grow-t)
(field
(root 0))
(root 0)
(widths '())
(points '())
(global-growth 0)
(global-growth-time 20))
(define/override (build)
(set! root (let ((p (with-state
(translate pos)
(colour col)
(texture (load-texture tex))
(colour (vmul col 0.2))
(hint-unlit)
(texture (load-texture "textures/ribbon-twig.png"))
(build-ribbon num-points))))
(with-primitive p
(pdata-map!
@ -262,35 +506,124 @@
(define/override (get-root)
root)
(define/override (get-point point-index)
#;(define/override (get-point point-index)
(with-primitive root
(pdata-ref "p" point-index)))
(define/override (get-width point-index)
#;(define/override (get-width point-index)
(with-primitive root
(pdata-ref "w" point-index)))
(define/augment (add-point point width)
(with-primitive root
(define/override (get-point point-index)
(list-ref points point-index))
(define/override (get-width point-index)
(list-ref widths point-index))
(define/augment (add-point point width make-marker)
#;(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
width))
"w"))
"p"))
(set! widths (append widths (list width)))
(set! points (append points (list point)))
(set! index (+ index 1)))
(define/augment (update t d)
0)
(when (and (> grow-t 0) (< grow-t (+ (length points) 10)))
(with-primitive root
(pdata-index-map!
(lambda (i w)
(* (/ global-growth global-growth-time)
(cond ((< i (- grow-t 1))
(list-ref widths i))
((< i grow-t)
(* (list-ref widths i) (fract grow-t)))
(else
0))))
"w")
(pdata-index-map!
(lambda (i p)
(cond ((< i (- grow-t 1))
(list-ref points i))
((equal? i (inexact->exact (floor (+ grow-t 1))))
(vmix
(list-ref points i)
(list-ref points (- i 1)) (fract grow-t)))
(else
(list-ref points i))))
"p")))
(when (< global-growth global-growth-time)
(set! global-growth (+ global-growth d))))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; bunches of ribbon twigs
(define twiglets%
(class object%
(init-field
(par 0))
(field
(twigs '()))
(define/public (build pos dir width length)
(set! twigs (list (build-tree pos dir width length))))
(define (build-tree pos dir width length)
(let ((t (make-object ribbon-twig-view% 0 pos 'ribbon
dir
(* width (+ 0.5 (rndf))) length)))
(send t set-grow-speed 0.1)
(with-state
(parent par)
(send t build))
(let ((m (mrotate (vmul (srndvec) 45)))
(ppos (vector 0 0 0)))
(for ((i (in-range 0 length)))
(let ((dir (vtransform (send t get-dir) m))
(width (if (eq? i (- length 1)) 0 (/ width (+ i 1)))))
(send t set-dir! dir)
(send t add-point ppos width #f)
(set! ppos (vadd ppos (vmul dir (* 5 width)))))))
(send t start-growing)
t))
(define/public (update t d)
(for-each
(lambda (twig)
(send twig update t d)
(when (and
(< (length twigs) 50)
(> (send twig get-num-points) 2)
(zero? (random 20)))
(let ((pi (inexact->exact (floor (send twig get-grow-t)))))
(when (< pi (send twig get-num-points))
(with-state
(translate (vadd (send twig get-pos) (send twig get-point pi)))
(build-sphere 5 5))
(set! twigs (cons
(build-tree
(vadd (send twig get-pos) (send twig get-point pi))
(send twig get-dir)
(/ (send twig get-width pi) 1.4)
(/ (send twig get-num-points) 2))
twigs))))))
twigs))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define fin%
@ -353,10 +686,11 @@
(path '())
(root 0)
(widths '())
(fins '()))
(fins '())
(twiglets '()))
(define/override (build)
(set! profile (build-circle-profile 12 1))
(set! profile (build-circle-points 12 1))
(set! path (build-list num-points (lambda (_) (vector 0 0 0))))
(set! widths (build-list num-points (lambda (_) 1)))
(set! root (let ((p (with-state
@ -364,14 +698,20 @@
(when wire-mode
(hint-none)
(hint-wire))
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
;(shader "shaders/frtrans.vert.glsl" "shaders/frtrans.frag.glsl")
(texture (load-texture tex))
(shader "shaders/twig.vert.glsl" "shaders/twig.frag.glsl")
;(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
(texture (load-texture "textures/cells-1.png"))
(multitexture 1 (load-texture "textures/cells-2.png"))
(multitexture 2 (load-texture "textures/cells-3.png"))
(multitexture 3 (load-texture "textures/root-norm.png"))
(opacity 0.6)
(colour col)
#;(colour (vector 1 1 1))
#;(texture (load-texture "textures/root.png"))
(build-partial-extrusion profile path 3))))
(with-primitive p
(shader-set! (list "Maps" (list 0 1 2) "NormalMap" 3)))
p)))
(define/override (get-root)
@ -388,13 +728,21 @@
((zero? c) (cons s (list-set (cdr l) (- c 1) s)))
(else (cons (car l) (list-set (cdr l) (- c 1) s)))))
(define/augment (add-point point width)
(define/augment (add-point point width make-marker)
(set! path (list-set path index point))
(set! widths (list-set widths index width))
(set! index (+ index 1)))
(define/augment (update t d)
(when (and (zero? (random fin-grow-prob))
(with-primitive root
(shader-set! (list "Time" t))
#;(let ((t (inexact->exact (round (fmod (* 5 t) 3)))))
(cond
((eq? t 0) (texture (load-texture "textures/cells-1.png")))
((eq? t 1) (texture (load-texture "textures/cells-2.png")))
((eq? t 2) (texture (load-texture "textures/cells-3.png"))))))
#;(when (and (zero? (random fin-grow-prob))
(< (length fins) max-fins-per-twig)
(not (growing?))
(> (length path) 1))
@ -409,7 +757,19 @@
(send fin update t d))
fins)
(for-each
(lambda (twiglet)
(send twiglet update t d))
twiglets)
(when (and (not (eq? grow-t -1)) (not (eq? grow-t 999)))
; randomly add twiglets as we are growing
(when (and (zero? (random 400)) (< grow-t num-points))
(printf "~a~n" (length twiglets))
(let ((t (make-object twiglets% (get-root)))
(pi (inexact->exact (floor grow-t))))
(send t build (get-point pi) dir (/ (get-width pi) 2) 20)
(set! twiglets (cons t twiglets))))
(with-primitive root
(partial-extrude grow-t profile path widths (vector 1 0 0) 0.05)))
@ -438,7 +798,8 @@
(pos (vector 0 0 0))
(size 0)
(col (vector 1 1 1))
(tex ""))
(tex "")
(is-player #f))
(field
(twigs '()) ; a assoc list map between ids and twigs stored flat here,
@ -446,27 +807,36 @@
(root (with-state
(translate pos)
(build-locator)))
(seed (with-state
(seed (let ((p (with-state
(parent root)
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
;(shader "shaders/frtrans.vert.glsl" "shaders/frtrans.frag.glsl")
(texture (load-texture tex))
(shader "shaders/twig.vert.glsl" "shaders/twig.frag.glsl")
;(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
(texture (load-texture "textures/cells-1.png"))
(multitexture 1 (load-texture "textures/cells-2.png"))
(multitexture 2 (load-texture "textures/cells-3.png"))
(multitexture 3 (load-texture "textures/root-norm.png"))
(backfacecull 0)
(opacity 0.6)
(opacity 0.75)
(colour col)
(hint-depth-sort)
(scale (* 0.12 size))
(scale (* 0.06 size))
(when wire-mode
(hint-none)
(hint-wire))
;(hint-unlit)
(load-primitive "meshes/seed.obj")))
(load-primitive "meshes/seed.obj"))))
(with-primitive p
(shader-set! (list "Maps" (list 0 1 2) "NormalMap" 3)))
p))
(dust (if is-player (with-state
(parent root)
(make-object dust%)) #f))
(nutrients (let ((p (with-state
(hint-depth-sort)
(hint-unlit)
(parent root)
(blend-mode 'src-alpha 'one)
(texture (load-texture "textures/star.png"))
(texture (load-texture "textures/smoke.png"))
(build-particles 100))))
(with-primitive p
(pdata-add "twig" "f")
@ -487,7 +857,7 @@
"offset")
(pdata-map!
(lambda (c)
(vector 0 (rndf) (rndf)))
(vector 1 1 1))
"c")
(pdata-map!
(lambda (p)
@ -553,7 +923,7 @@
(define/public (add-twig-point twig-id point width)
(when (get-twig twig-id)
(send (get-twig twig-id) add-point point width)))
(send (get-twig twig-id) add-point point width is-player)))
(define/public (start-twig-growing twig-id)
(when (get-twig twig-id)
@ -605,8 +975,24 @@
(vadd p (vmul (vnormalise (vsub (vadd (send twig get-point point) offset) p)) (* speed d)))))))
"p" "twig" "point" "offset" "speed"))))
(define/public (above-ground)
(when dust (send dust set-above-ground #t)))
(define/public (below-ground)
(when dust (send dust set-above-ground #f)))
(define/public (update t d)
(when dust (send dust update t d))
(with-primitive seed
(shader-set! (list "Time" t))
#;(let ((t (inexact->exact (round (fmod (* 5 t) 3)))))
(cond
((eq? t 0) (texture (load-texture "textures/cells-1.png")))
((eq? t 1) (texture (load-texture "textures/cells-2.png")))
((eq? t 2) (texture (load-texture "textures/cells-3.png"))))))
(update-nutrients t d)
(with-primitive seed
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
@ -683,10 +1069,26 @@
(field
(plants '()) ; map of ids -> plants
(pickups '()) ; map of ids -> pickups
(insects '()) ; map of ids -> insects
(camera-dist 1)
(env-root (with-state (scale 1000) (build-locator)))
(root-camera-t 0)
(num-msgs 0)
(floor (let ((p (with-state
(hint-unlit)
(colour 0.2)
(texture (load-texture "textures/stone.png"))
(translate (vector 0 -0.5 0))
(rotate (vector 90 0 0))
(scale 1000)
(backfacecull 0)
(build-seg-plane 10 10))))
(with-primitive p
(pdata-map!
(lambda (t)
(vmul t 10))
"t")) p))
#;(upper-env (with-state
(parent env-root)
(hint-depth-sort)
@ -702,7 +1104,7 @@
(build-env-box "textures/bottom-trans.png" "textures/bottom.png"
"textures/sleft.png" "textures/sright.png"
"textures/sfront.png" "textures/sback.png")))
(upper-env (with-state
#;(upper-env (with-state
(parent env-root)
;(hint-depth-sort)
(hint-unlit)
@ -710,7 +1112,7 @@
(build-env-box "textures/sky-top.png" "textures/floor.png"
"textures/sky-side.png" "textures/sky-side.png"
"textures/sky-side.png" "textures/sky-side.png" #f)))
(lower-env (with-state
#;(lower-env (with-state
(parent env-root)
;(hint-depth-sort)
(hint-unlit)
@ -720,33 +1122,67 @@
"textures/earth-side.png" "textures/earth-side.png"
"textures/earth-side.png" "textures/earth-side.png" #t)))
(stones '()))
(stones '())
(ground-change-t 0)
(going-up #f))
(define/public (setup world-list)
(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 fog-col)
(fog fog-col fog-strength 1 100)
(below-ground)
(set! stones
(map
(lambda (stone)
(let ((p (with-state
(hint-frustum-cull)
(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
;(shader "shaders/toon.vert.glsl" "shaders/toon.frag.glsl")
(colour (stones-colour))
(translate (list-ref stone 2))
(scale (list-ref stone 3))
(rotate (list-ref stone 4))
(texture (load-texture "textures/quartz.png"))
(texture (load-texture "textures/stone.png"))
(load-primitive (list-ref stone 1)))))
(with-primitive p (apply-transform) (recalc-bb)) ; apply the transform to speed up the ray tracing, don't have to tranform the ray into object space
p))
(list-ref world-list 2))))
(define/public (above-ground)
(printf "above-ground~n")
(for-each
(lambda (plant)
(send (cadr plant) above-ground))
plants)
(for-each
(lambda (pickup)
(with-primitive (send (cadr pickup) get-root) (hide 1)))
pickups)
(set! going-up #t)
(set! ground-change-t ground-change-duration))
(define/public (below-ground)
(printf "below-ground~n")
(for-each
(lambda (plant)
(send (cadr plant) below-ground))
plants)
(for-each
(lambda (pickup)
(with-primitive (send (cadr pickup) get-root) (hide 0)))
pickups)
(set! going-up #f)
(set! ground-change-t ground-change-duration))
(define/public (update-ground-change t d)
(when (> ground-change-t 0)
(set! ground-change-t (- ground-change-t d))
(let* ((t (/ ground-change-t ground-change-duration))
(anim-t (if going-up t (- 1 t))))
(clip 1 (lerp 100 500 anim-t))
(clear-colour (vmix fog-col above-fog-col anim-t))
(fog (vmix fog-col above-fog-col anim-t) (lerp 0.04 0.01 anim-t) 1 100))))
(define/public (get-stones)
stones)
@ -775,14 +1211,32 @@
(send (get-plant plant-id) grow-seed amount)))
(define/public (get-pickup pickup-id)
(cadr (assq pickup-id pickups)))
(let ((p (assq pickup-id pickups)))
(if p (cadr p) #f)))
(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 (add-insect insect-id pos type)
(cond
((eq? type 'worm)
(set! insects (cons (list insect-id
(make-object worm-insect-view% insect-id pos type)) insects)))
((eq? type 'spider)
(set! insects (cons (list insect-id
(make-object spider-insect-view% insect-id pos type)) insects)))
((eq? type 'butterfly)
(set! insects (cons (list insect-id
(make-object butterfly-insect-view% insect-id pos type)) insects)))))
(define/public (get-insect insect-id)
(cadr (assq insect-id insects)))
(define/public (pick-up-pickup pickup-id)
(let ((pu (get-pickup pickup-id)))
(when pu
(send (get-pickup pickup-id) pick-up)
(set! pickups (assoc-remove pickup-id pickups)))
(set! pickups (assoc-remove pickup-id pickups)))))
(define/public (add-ornament plant-id twig-id point-index property)
(when (get-plant plant-id)
@ -800,6 +1254,8 @@
(define/public (update t d messages)
(update-ground-change t d)
(for-each
(lambda (plant)
(send (cadr plant) update t d))
@ -810,6 +1266,11 @@
(send (cadr pickup) update t d))
pickups)
(for-each
(lambda (insect)
(send (cadr insect) update t d))
insects)
(when debug-messages
(for-each
(lambda (msg)
@ -818,13 +1279,14 @@
(for-each
(lambda (msg)
(cond
((eq? (send msg get-name) 'player-plant) ; not really any difference now
((eq? (send msg get-name) 'player-plant)
(printf "adding player plant to view ~a~n" (send msg get-data 'plant-id))
(add-plant (make-object plant-view%
(send msg get-data 'plant-id)
(send msg get-data 'pos)
(send msg get-data 'size)
(send msg get-data 'col)
(send msg get-data 'tex))))
(send msg get-data 'tex) #t)))
((eq? (send msg get-name) 'new-plant)
(printf "adding new plant to view ~a~n" (send msg get-data 'plant-id))
@ -835,6 +1297,7 @@
(send msg get-data 'col)
(send msg get-data 'tex))))
((eq? (send msg get-name) 'grow-seed)
(grow-seed (send msg get-data 'plant-id)
(send msg get-data 'amount)))
@ -911,6 +1374,17 @@
(colour (send msg get-data 'amount))))
upper-env))
((eq? (send msg get-name) 'new-insect)
(add-insect
(send msg get-data 'insect-id)
(send msg get-data 'pos)
(send msg get-data 'type)))
((eq? (send msg get-name) 'insect-move)
(send (get-insect (send msg get-data 'insect-id)) move
(send msg get-data 'pos)
(send msg get-data 'duration)))
))
messages))