groworld/hayfever/hayfever2.scm

911 lines
34 KiB
Scheme
Raw Normal View History

;#lang scheme
2009-04-06 20:15:28 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; h a y f e v e r
2009-04-06 20:15:28 +00:00
;(require fluxus-016/drflux)
2009-04-06 20:15:28 +00:00
(require scheme/class)
(require mzlib/string)
(require openssl)
(require "xmpp-dave.ss")
2009-04-21 08:59:14 +00:00
;(require (prefix-in xmpp: (planet zzkt/xmpp)))
(define plant2 #f)
;(set! plant2 #t)
(define debug-jab #t)
2009-04-28 08:42:21 +00:00
(define debug-netloop #f)
(define pollen-particles 300)
(define max-pollen-radius 12)
2009-04-28 08:42:21 +00:00
(define suck-pollen-radius 8)
(define deterministic #t)
(define minimal-mode #f)
2009-04-21 08:59:14 +00:00
(define jid "plant0000003@fo.am")
(define pass "plant0000003")
(define jto "plant0000002@fo.am")
(when plant2
(set! jid "plant0000002@fo.am")
(set! pass "plant0000002")
(set! jto "plant0000003@fo.am"))
2009-04-21 08:59:14 +00:00
(printf "I am ~a~n" jid)
2009-04-06 20:15:28 +00:00
(when deterministic
(flxseed 1)
(random-seed 2))
2009-04-06 20:15:28 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pixel primitive things for getting connection points
; converts a 2D vector into an angle, with some dodgy dave maths
(define (2dvec->angle x y)
(let ((q (/ 3.141 2)))
(when (zero? y) (set! y 0.0001))
(cond
((>= y 0)
(fmod (* (+ q q q (- q (atan (/ x y)))) 57.2957795) 360))
(else
(fmod (* (+ q (- q (atan (/ x y)))) 57.2957795) 360)))))
(define (i->pos i)
(vector (modulo i (pixels-width))
(quotient i (pixels-width)) 0))
(define (pos->i pos)
(+ (* (round (vy pos)) (pixels-width)) (round (vx pos))))
(define (pixels-ref name pos)
(pdata-ref name (pos->i pos)))
(define (pixels-set! name pos s)
(pdata-set! name (pos->i pos) s))
(define (search i)
(cond
((eq? i (pdata-size)) i)
((< (vr (pdata-ref "c" i)) 0.5) i)
(else (search (+ i 1)))))
(define (flood pos tc av)
(define (rec-flood pos)
(pixels-set! "c" pos (vector 1 0 1))
(set! tc (+ tc 1))
(set! av (vadd av pos))
(when (< (vr (pixels-ref "c" (vadd pos (vector -1 0 0)))) 0.5)
(rec-flood (vadd pos (vector -1 0 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 1 0 0)))) 0.5)
(rec-flood (vadd pos (vector 1 0 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 1 0)))) 0.5)
(rec-flood (vadd pos (vector 0 1 0))))
(when (< (vr (pixels-ref "c" (vadd pos (vector 0 -1 0)))) 0.5)
(rec-flood (vadd pos (vector 0 -1 0)))))
(rec-flood pos)
(vmul av (/ 1 tc)))
(define (find-centroids pos l)
(let ((i (search pos)))
(cond ((eq? i (pdata-size)) l)
(else
(find-centroids i
(cons (flood (i->pos i) 0 (vector 0 0 0)) l))))))
(define (convert-to-pos l)
(map
(lambda (cp)
(vector (- (- (/ (vx cp) (pixels-width)) 0.5))
(/ (vy cp) (pixels-height)) 0))
l))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a cache for the connection points - should save this out
(define connection-cache '())
(define (get-connection-list id)
(let ((ret (assoc id connection-cache)))
(cond
(ret (cdr ret))
(else
(let* ((tex (load-primitive (string-append "textures/comp-cp-" id ".png")))
(connections (with-primitive tex (convert-to-pos (find-centroids 0 '())))))
(set! connection-cache (cons (cons id connections) connection-cache))
(destroy tex)
connections)))))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; a plant component
(define-struct component (root (col #:mutable) children))
(define (build-component id col children)
(cond
((null? children)
(let ((root (with-state
(translate (vector 0 0.5 (* 0.01 (rndf))))
(hint-none)
(hint-solid)
(hint-unlit)
2009-04-06 20:15:28 +00:00
(hint-depth-sort)
(texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane))))
(make-component root col '())))
(else
(let* ((connection-list (get-connection-list id))
(root (with-state
(hint-depth-sort)
(translate (vector 0 0.5 (* 0.01 (rndf))))
; (rotate (vector 0 0 90))
2009-04-06 20:15:28 +00:00
(texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane)))
(comp (make-component root col
(map
(lambda (child connection)
(with-state
(parent root)
(translate (vadd connection (vector 0 0 (* 0.01 (rndf)))))
(rotate (vector 0 0 (2dvec->angle
(vx connection) (- (vy connection) 0.5))))
(rotate (vector 0 0 0))
(build-component (car child) col (cadr child))))
children
connection-list))))
(with-primitive root (apply-transform))
comp))))
(define (random-leaf component)
(cond
((null? (component-children component)) component)
(else (random-leaf (choose (component-children component))))))
(define (component-leaves component)
(cond
((null? (component-children component)) (list component))
(else
(foldl
(lambda (child r)
(append (component-leaves child) r))
'()
(component-children component)))))
(define (component-print component)
(printf "~a~n" (component-children component)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; utils for building random plants
(define (make-random-plant depth)
(let ((num-children (cond ((> depth 2) 0)
((< depth 1) (choose (list 2 3)))
(else (choose (list 0 1 2 3))))))
2009-04-06 20:15:28 +00:00
(cond
((eq? num-children 0) (list (choose (list "11")) (list)))
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
((eq? num-children 2) (list "2-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)))))
((eq? num-children 3) (list "3-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1)))))
((eq? num-children 4) (list "4-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)))))
((eq? num-children 5) (list "5-1" (list (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))
(make-random-plant (+ depth 1)) (make-random-plant (+ depth 1))))))))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; the world things live in
(define world%
(class object%
(init-field (size 1))
(field
(root 0)
(entity-list '())
(id 0)
(pollen 0)
(my-id ""))
2009-04-06 20:15:28 +00:00
(define/public (init)
(set! pollen (with-state
(translate (vector 0 0 0.2))
(texture (load-texture "textures/pollen.png"))
(build-particles pollen-particles)))
2009-04-06 20:15:28 +00:00
(with-primitive pollen
(pdata-map!
(lambda (p)
(vmul (vector (crndf) (crndf) 0) 5))
2009-04-06 20:15:28 +00:00
"p")
(pdata-map!
(lambda (c)
(vector (rndf) (rndf) (rndf) 0.5))
"c")
(pdata-map!
(lambda (c)
(let ((s (* 0.2 (grndf))))
(vector s s 1)))
"s")))
2009-04-06 20:15:28 +00:00
(define/public (get-entity-list)
entity-list)
(define/public (get-my-id)
my-id)
(define/public (make-my-plant)
(when deterministic
(flxseed 3)
(random-seed 1) ; 2 5
)
(let* ((pos (vector -4 #;(* (crndf) 5) 0 0.1))
2009-04-06 20:15:28 +00:00
(col (hsv->rgb (vector (rndf) 0.8 1)))
(desc (list (make-random-plant 0))))
(set! my-id jid)
(set-entity my-id (make-object plant% pos col desc)))
(let* ((pos (vector 4 #;(* (crndf) 5) 0 0.1))
(col (hsv->rgb (vector (rndf) 0.8 1)))
(desc (list (make-random-plant 0))))
(set-entity "other" (make-object plant% pos col desc))))
2009-04-06 20:15:28 +00:00
(define/public (get-entity id)
(foldl
(lambda (entity ret)
(if (string=? (send entity get-id) id)
2009-04-06 20:15:28 +00:00
entity
ret))
#f
entity-list))
(define/public (choose)
(list-ref entity-list (random (length entity-list))))
(define/public (set-entity id entity)
; if it already exists, destroy it
; (do we want to do this all the time?)
(when (get-entity id)
(destroy-entity id))
(send entity set-id! id)
(set! entity-list (cons entity entity-list)))
(define/public (destroy-all-but-me)
(set! entity-list
(filter
(lambda (entity)
(cond ((not (string=? (send entity get-id) my-id))
(send entity destroy-me)
#f)
(else #t)))
entity-list)))
2009-04-06 20:15:28 +00:00
(define/public (destroy-entity id)
(set! entity-list
(filter
(lambda (entity)
(cond ((string=? (send entity get-id) id)
2009-04-06 20:15:28 +00:00
(send entity destroy-me)
#f)
(else #t)))
entity-list)))
(define/public (update network)
(with-primitive pollen
(animate-pollen))
; update my plant with player input
(when (get-entity my-id)
(send (get-entity my-id) player-update this network))
(for-each
(lambda (entity)
(send entity update this))
entity-list))
; pollen stuff
(define (animate-pollen)
(pdata-map!
(lambda (p)
(let* ((pp (vadd (vmul p 1) (vector 0 (- (flxtime)) 0)))
(v (cond
((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1))
((> (vmag p) max-pollen-radius) (vmul p -0.1))
(else
(vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5)
(- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5)
0 #;(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5))))))
2009-04-06 20:15:28 +00:00
(vadd (vadd p (vmul v 0.2))
(vmul (srndvec) 0.01))))
2009-04-06 20:15:28 +00:00
"p"))
(define (cirndvec)
(let ((o (srndvec)))
(vector (vx o) (vy o) 0)))
(define/public (puff-pollen pos col size np)
(with-primitive pollen
(for ((i (in-range 0 np)))
(let ((c (random (pdata-size)))
(cc (vmul col 1)))
(pdata-set! "p" c (vadd (vmul (cirndvec) size)
(vadd (vector (vx pos) (vy pos) 0)
(vector 0 0 (+ 0.2 (* (rndf) 0.01))))))
2009-04-06 20:15:28 +00:00
(pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
(define/public (suck-pollen pos size)
(with-primitive pollen
(pdata-index-fold
(lambda (i p c r)
2009-04-28 08:42:21 +00:00
(cond ((< (vdist pos p) 0.5)
2009-04-06 20:15:28 +00:00
(pdata-set! "p" i (vector -1000 0 0))
(cons c r))
((< (vdist pos p) size)
(pdata-set! "p" i (vadd p
(vmul (vnormalise (vsub pos p)) 0.1)))
r)
(else r)))
'()
"p" "c")))
(super-new)
(init)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; the entity base class
(define entity%
(class object%
(init-field (id 0))
(define/public (get-id)
id)
(define/public (set-id! s)
(set! id s))
(super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; finally, a plant...
(define plant%
(class entity%
(init-field
(pos (vector 0 0 0))
(col (vector 1 1 1))
(plant-desc '())
(flower-list '())
(current-flower 0))
(field
(root-component 0)
(spray-t 0))
(define/public (get-pos)
pos)
(define/public (get-col)
col)
(define/public (get-desc)
plant-desc)
(define/public (init)
(with-state
;(parent (send world get-root))
(colour col)
(hint-unlit)
(translate pos)
;(printf "building from:~a~n" plant-desc)
2009-04-06 20:15:28 +00:00
(set! root-component (build-component "1-1" col plant-desc))
(set! flower-list (component-leaves root-component))))
(define/public (destroy-me)
(destroy (component-root root-component)))
(define/public (player-update world network)
(when (key-special-pressed-this-frame 100)
2009-04-06 20:15:28 +00:00
(set! current-flower (modulo (+ current-flower 1) (length flower-list))))
(when (key-special-pressed-this-frame 102)
2009-04-06 20:15:28 +00:00
(set! current-flower (modulo (- current-flower 1) (length flower-list))))
; bit odd, have to go through network to tell other clients to
; spray, and need to get the id of the player plant from the world...
(when (key-special-pressed-this-frame 101)
2009-04-06 20:15:28 +00:00
(send network spray world (send world get-my-id) current-flower 0))
(let ((flower (list-ref flower-list current-flower)))
(with-primitive (component-root flower)
(when (key-special-pressed-this-frame 103)
2009-04-06 20:15:28 +00:00
(rotate (vector 0 0 20))
(let ((colours (suck world current-flower)))
(when (not (zero? (length colours)))
(let
((av-col (vdiv (foldl (lambda (c1 c2)
(vadd c1 c2)) (vector 0 0 0) colours) (length colours))))
2009-04-06 20:15:28 +00:00
(set-component-col! flower
(vadd (vmul (component-col flower) 0.9)
(vmul av-col 0.1)))
(send network flower-update world (send world get-my-id)
current-flower (component-col flower))))))
(rotate (vector 0 0 2)))))
(define/public (flower-update flower col)
(let ((flower (list-ref flower-list flower)))
(set-component-col! flower col)
(with-primitive (component-root flower)
(colour (component-col flower)))))
2009-04-06 20:15:28 +00:00
(define/public (update world)
0
#;(with-primitive root
(colour col)
(when (> spray-t 1)
(set! spray-t (* spray-t 0.9))
(colour spray-t))))
(define/public (spray world flower type)
(let ((pos (vtransform (vector 0 0 0)
(with-primitive (component-root (list-ref flower-list flower))
(get-global-transform)))))
(send world puff-pollen pos (component-col (list-ref flower-list flower))
0.2 10)))
2009-04-06 20:15:28 +00:00
(define/public (suck world flower)
(let ((pos (vtransform (vector 0 0 0)
(with-primitive (component-root (list-ref flower-list flower))
(get-global-transform)))))
2009-04-28 08:42:21 +00:00
(send world suck-pollen pos suck-pollen-radius)))
2009-04-06 20:15:28 +00:00
(super-new)
(init)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; things changed in xmpp
; * removed printf
; * renamed send to xmpp-send
(define jabberer%
(class object%
(field
(incoming '())
(outgoing '())
(thr 0))
(define/public (get-incoming)
incoming)
(define/public (clear-incoming)
(set! incoming '()))
(define/public (msg-waiting?)
(not (null? incoming)))
(define/public (get-msg)
(let ((msg (car incoming)))
(set! incoming (cdr incoming))
msg))
(define/public (send-msg to msg)
(set! outgoing (cons (list to msg) outgoing)))
(define (message-handler sz)
(when debug-jab (printf "rx <---- ~a ~a~n" (message-from sz) (message-body sz)))
(set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
(define/public (start)
(set! thr (thread run)))
(define/public (stop)
(kill-thread thr))
(define (run)
(with-xmpp-session jid pass
(set-xmpp-handler 'message message-handler)
(let loop ()
2009-04-28 08:42:21 +00:00
(when debug-netloop (printf ".~n"))
(when (not (null? outgoing))
(for-each
(lambda (msg)
(when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
(xmpp-send (message (car msg) (cadr msg))))
outgoing)
(set! outgoing '()))
(sleep 0.5)
(loop))))
(super-new)))
2009-04-06 20:15:28 +00:00
(define network-dispatch%
(class object%
(field
(waiting #f)
(wait-till 0)
(jab (make-object jabberer%))
(send-to jto))
(define/public (start)
(send jab start))
(define (stringify l)
(cond
((null? l) l)
((symbol? (car l))
(cons (symbol->string (car l))
(stringify (cdr l))))
((number? (car l))
(cons (number->string (car l))
(stringify (cdr l))))
((vector? (car l))
(cons (car l)
(stringify (cdr l))))
((list? (car l))
(cons (stringify (car l)) (stringify (cdr l))))
(else (error "oops"))))
(define (split-string str)
(let* ((l (string->list str))
(cur "")
(r (reverse (foldl
(lambda (c l)
(cond
((char=? #\ c)
(let ((r (cons cur l)))
(set! cur "")
r))
(else
(set! cur (string-append cur (string c)))
l)))
'()
l))))
(if (not (string=? cur ""))
(append r (list cur))
r)))
(define (join-end n l s)
(cond
((null? l) s)
((not (zero? n)) (join-end (- n 1) (cdr l) s))
(else
(join-end n (cdr l) (string-append s " " (car l))))))
(define (dispatch world)
(for-each
(lambda (msg)
(let* ((chopped (split-string (cadr msg)))
(command (list-ref chopped 0))
(args (cdr chopped)))
(cond
((string=? command "ping")
(printf "pong~n"))
((string=? command "join-game")
(send world destroy-all-but-me)
(printf "a new plant has joined the game~n")
; send a plant update for the new player
(update-plant world) )
((string=? command "plant")
(printf "add plant message recieved : ~a~n" (list-ref args 0))
(send world set-entity (list-ref args 0) (make-object plant%
(vector (string->number (list-ref args 1))
(string->number (list-ref args 2))
(string->number (list-ref args 3)))
(vector (string->number (list-ref args 4))
(string->number (list-ref args 5))
(string->number (list-ref args 6)))
(stringify (eval-string (join-end 7 args ""))))))
((string=? command "flower")
;(printf "flower change msg recieved~n")
(send (send world get-entity (list-ref args 0)) flower-update
(string->number (list-ref args 1)) (vector (string->number (list-ref args 2))
(string->number (list-ref args 3))
(string->number (list-ref args 4)))))
((string=? command "destroy-plant")
(printf "destroy plant message recieved...~n")
(send world destroy-entity (list-ref args 0)))
((string=? command "spray")
; (printf "destroy plant message recieved...~n")
(let ((e (send world get-entity (list-ref args 0))))
; it's possible to get spray events before the
; plant has been created...
(when e
(send e spray world (string->number (list-ref args 1))
(string->number (list-ref args 2))))))
(else
(printf "unknown command ~a ~n" command)))))
(send jab get-incoming))
(send jab clear-incoming))
(define/public (join-game world)
(printf "ping~n")
(send jab send-msg send-to "ping")
(send jab send-msg send-to "join-game ")
(set! wait-till (+ (flxtime) 5))
(set! waiting #t))
(define/public (update-plant world)
(let* ((my-plant (send world get-entity (send world get-my-id)))
(pos (send my-plant get-pos))
(col (send my-plant get-col))
(desc-str (format "'~a" (send my-plant get-desc))))
(send jab send-msg send-to (string-append "plant " (send world get-my-id) " "
(number->string (vx pos)) " "
(number->string (vy pos)) " "
(number->string (vz pos)) " "
(number->string (vx col)) " "
(number->string (vy col)) " "
(number->string (vz col)) " "
desc-str))))
(define/public (destroy-plant world id)
(send jab send-msg send-to (string-append "destroy-plant " id))
(send world destroy-entity id))
(define/public (spray world id flower type)
(send jab send-msg send-to (string-append "spray "
id " "
(number->string flower) " "
(number->string type))) " "
(send (send world get-entity id) spray world flower type))
(define/public (flower-update world id flower col)
(send jab send-msg send-to (string-append "flower "
id " "
(number->string flower) " "
(number->string (vx col)) " "
(number->string (vy col)) " "
(number->string (vz col))))
(send (send world get-entity id) flower-update flower col))
(define/public (update world)
; wait for all other players to register their plants
(when (and waiting (< wait-till (flxtime)))
(set! waiting #f)
(send world make-my-plant)
(update-plant world))
(dispatch world))
(super-new)))
2009-04-06 20:15:28 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; things needed for the set
(define (build-shells obj count dist col)
(when (not (zero? count))
(with-state
(parent obj)
(colour col)
(let ((shell (build-copy obj)))
(with-primitive shell
(pdata-map!
(lambda (p n)
(vadd p (vmul (vector 0 1 0) dist)))
"p" "n"))
(build-shells shell (- count 1) dist (vmul col 1))))))
(define (build-shrub p n)
(with-state
(translate p)
(colour (vector 0.5 0.7 0.4))
(let ((shrub (build-ribbon (+ (random 10) 2))))
(with-primitive shrub
(pdata-index-map!
(lambda (i p)
(let ((j (* 0.2 (* i 0.2))))
(vector (* (crndf) j) (* i 0.2) (* (crndf) j))))
"p")
(pdata-index-map!
(lambda (i w)
(* (/ 1 (+ i 1)) 0.2))
"w")))))
2009-04-08 15:30:17 +00:00
(define (choose l)
(list-ref l (random (length l))))
(define (build-flower p n obj)
(with-state
(backfacecull 0)
(hint-depth-sort)
; (hint-unlit)
2009-04-08 15:30:17 +00:00
(translate p)
(rotate (vector 0 (random 360) 0))
(scale (+ 1 (* (rndf) 1.5)))
(texture (load-texture (choose (list
"textures/bgplant-1.png"
"textures/bgplant-2.png"
;"textures/bgplant-3.png"
"textures/bgplant-4.png"
"textures/bgplant-5.png"
"textures/bgplant-6.png"
))))
2009-04-08 15:30:17 +00:00
(let ((o (build-copy obj)))
(with-primitive o (hide 0)))
; (load-primitive "meshes/freeplant.obj")
))
2009-04-08 15:30:17 +00:00
(define (load-model tex obj)
(with-state
(texture (load-texture (string-append "textures/" tex)))
(load-primitive (string-append "meshes/" obj))))
(define (build-set)
(with-state
(let ((l (make-light 'spot 'free)))
(light-diffuse 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 0 10 0))
(light-direction l (vector 0 -1 0))
(light-spot-angle l 55)
(light-spot-exponent l 1))
2009-04-08 15:30:17 +00:00
(let ((l2 (make-light 'point 'free)))
(light-position l2 (vector 0 20 0))
(light-diffuse l2 (vector 0.4 0.9 0.5)))
(with-state
(backfacecull 0)
(hint-depth-sort)
(hint-unlit)
(texture-params 0 '(wrap-s repeat wrap-t repeat))
(load-model "bgplant-1.png" "plant-0.obj")
(load-model "bgplant-1.png" "plant-1.obj")
(load-model "bgplant-1.png" "plant-2.obj")
(load-model "bgplant-1.png" "plant-3.obj")
(load-model "bgplant-1.png" "plant-4.obj")
(load-model "bgplant-1.png" "plant-5.obj")
(load-model "bgplant-1.png" "plant-6.obj")
; (load-model "bgplant-2.png" "plant-7.obj")
)
(with-state
(backfacecull 0)
(load-model "car-base.png" "car.obj")
(load-model "car-base.png" "car-2.obj")
(load-model "telly-base.png" "telly-2.obj"))
(with-state
(load-model "telly-base2.png" "telly-0.obj")
(load-model "telly-base.png" "telly-1.obj")
(load-model "telly-base.png" "telly-2.obj")
(load-model "telly-base.png" "telly-3.obj")
(load-model "telly-base.png" "telly-4.obj"))
(with-state
(load-model "washer-base.png" "washer-0.obj")
(load-model "washer-base.png" "washer-1.obj")
(load-model "washer-base.png" "washer-2.obj")
(load-model "washer-base.png" "washer-3.obj"))
(let ((terrain (with-state
(texture (load-texture "textures/ground-base.png"))
(load-primitive "meshes/ground.obj")))
(flower-obj (load-primitive "meshes/freeplant.obj")))
;(define grassmap (load-primitive "textures/set-grass.png"))
#;(define (tx->pi tx)
(+ (vy tx) (* (vx tx) (pixels-width))))
(with-primitive flower-obj
(pdata-map!
(lambda (n p)
(vnormalise p))
"n" "p")
(hide 1))
(with-state
(backfacecull 0)
(hint-depth-sort)
(hint-unlit)
(translate (vector -15 2 10))
(scale 15)
(texture (load-texture "textures/bgplant-1.png"))
(let ((o (build-copy flower-obj)))
(with-primitive o (hide 0))))
(with-primitive terrain
(poly-for-each-tri-sample
(lambda (indices bary)
(let ((tc (vadd
(vmul (pdata-ref "t" (list-ref indices 0)) (vx bary))
(vmul (pdata-ref "t" (list-ref indices 1)) (vy bary))
(vmul (pdata-ref "t" (list-ref indices 2)) (vz bary)))))
(when (zero? (random 2)) #;(> (va (with-primitive grassmap (pdata-ref "c" (tx->pi tc)))) 0.5)
(let ((pos (vadd
(vmul (pdata-ref "p" (list-ref indices 0)) (vx bary))
(vmul (pdata-ref "p" (list-ref indices 1)) (vy bary))
(vmul (pdata-ref "p" (list-ref indices 2)) (vz bary)))))
(when (> (vmag pos) 3)
(build-flower pos (vector 0 1 0) flower-obj))))))
1))
(let ((shell0 (build-copy terrain)))
(with-primitive shell0
(pdata-copy "t" "t1")
(pdata-map!
(lambda (t)
(vmul t 4))
"t"))
(with-state
(multitexture 0 (load-texture "textures/shell.png"))
; (multitexture 1 (load-texture "textures/ground-grassmap.png"))
(build-shells shell0 4 0.05 (vector 1 0.5 1)))))))
2009-04-06 20:15:28 +00:00
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear)
(clear-colour (vmul (vector 0.4 0.9 0.5) 0.2))
(fog (vector 0.4 0.9 0.5) 0.01 1 100)
(define set-root (with-state
(scale 2)
(rotate (vector 0 -100 0))
(build-locator)))
(when (not minimal-mode)
(with-state
(parent set-root)
(build-set)))
2009-04-06 20:15:28 +00:00
(hint-depth-sort)
(define camera (build-locator))
(with-primitive camera
(translate (vector 0 5 0)))
(lock-camera camera)
2009-04-06 20:15:28 +00:00
(define w (make-object world% 1))
(define n (make-object network-dispatch%))
(send n start)
2009-04-06 20:15:28 +00:00
(send n join-game w)
(define (animate)
(send n update w)
2009-04-24 11:58:25 +00:00
(send w update n)
2009-04-28 08:42:21 +00:00
(sleep 0.01))
2009-04-06 20:15:28 +00:00
(every-frame (animate))