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

xmpp works, tidied up visually and internally

Browse source
This commit is contained in:
Dave Griffiths 2009-04-24 11:52:00 +01:00
parent 9cc1c0e204
commit 09bfbe366c
2 changed files with 407 additions and 341 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

248
hayfever/hayfever2.scm
View file

@ -1,15 +1,22 @@
;#lang scheme
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; h a y f e v e r
;(require fluxus-016/drflux)
(require scheme/class) (require scheme/class)
(require mzlib/string) (require mzlib/string)
(require openssl) (require openssl)
(require "xmpp-dave.ss") (require "xmpp-dave.ss")
;(require (prefix-in xmpp: (planet zzkt/xmpp))) ;(require (prefix-in xmpp: (planet zzkt/xmpp)))
(define plant2 #f) (define plant2 #f)
;(set! plant2 #t) ;(set! plant2 #t)
(define debug-jab #t)
(define pollen-particles 300)
(define max-pollen-radius 12)
(define deterministic #f)
(define minimal-mode #f)
(define jid "plant0000003@fo.am") (define jid "plant0000003@fo.am")
(define pass "plant0000003") (define pass "plant0000003")
(define jto "plant0000002@fo.am") (define jto "plant0000002@fo.am")
@ -21,6 +28,11 @@
(printf "I am ~a~n" jid) (printf "I am ~a~n" jid)
(when deterministic
(flxseed 1)
(random-seed 2))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; pixel primitive things for getting connection points ; pixel primitive things for getting connection points
@ -109,7 +121,10 @@
(cond (cond
((null? children) ((null? children)
(let ((root (with-state (let ((root (with-state
(translate (vector 0 0.5 (* 0.1 (rndf)))) (translate (vector 0 0.5 (* 0.01 (rndf))))
(hint-none)
(hint-solid)
(hint-unlit)
(hint-depth-sort) (hint-depth-sort)
(texture (load-texture (string-append "textures/comp-" id ".png"))) (texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane)))) (build-plane))))
@ -119,7 +134,7 @@
(root (with-state (root (with-state
(hint-depth-sort) (hint-depth-sort)
(translate (vector 0 0.5 (* 0.01 (rndf)))) (translate (vector 0 0.5 (* 0.01 (rndf))))
; (rotate (vector 0 0 90)) ; (rotate (vector 0 0 90))
(texture (load-texture (string-append "textures/comp-" id ".png"))) (texture (load-texture (string-append "textures/comp-" id ".png")))
(build-plane))) (build-plane)))
(comp (make-component root col (comp (make-component root col
@ -158,9 +173,6 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; utils for building random plants ; utils for building random plants
(define (choose l)
(list-ref l (random (length l))))
(define (make-random-plant depth) (define (make-random-plant depth)
(let ((num-children (cond ((> depth 2) 0) (let ((num-children (cond ((> depth 2) 0)
((< depth 1) (choose (list 2 3))) ((< depth 1) (choose (list 2 3)))
@ -193,19 +205,19 @@
(entity-list '()) (entity-list '())
(id 0) (id 0)
(pollen 0) (pollen 0)
(my-id 0)) (my-id ""))
(define/public (init) (define/public (init)
(set! pollen (with-state (set! pollen (with-state
(translate (vector 0 0 0.2)) (translate (vector 0 0 0.2))
(texture (load-texture "textures/pollen.png")) (texture (load-texture "textures/pollen.png"))
(build-particles 100))) (build-particles pollen-particles)))
(with-primitive pollen (with-primitive pollen
(pdata-map! (pdata-map!
(lambda (p) (lambda (p)
(vmul (srndvec) 5)) (vmul (vector (crndf) (crndf) 0) 5))
"p") "p")
(pdata-map! (pdata-map!
(lambda (c) (lambda (c)
@ -224,16 +236,23 @@
my-id) my-id)
(define/public (make-my-plant) (define/public (make-my-plant)
(when deterministic
(flxseed 3)
(random-seed 10) ; 2 5
)
(let* ((pos (vector (* (crndf) 5) 0 0.1)) (let* ((pos (vector (* (crndf) 5) 0 0.1))
(col (hsv->rgb (vector (rndf) 0.8 1))) (col (hsv->rgb (vector (rndf) 0.8 1)))
(desc (list (make-random-plant 0)))) (desc (list (make-random-plant 0))))
(set! my-id (length entity-list)) (set! my-id jid)
(set-entity my-id (make-object plant% pos col desc)))) (set-entity my-id (make-object plant% pos col desc))))
(define/public (get-entity id) (define/public (get-entity id)
(foldl (foldl
(lambda (entity ret) (lambda (entity ret)
(if (eq? (send entity get-id) id) (if (string=? (send entity get-id) id)
entity entity
ret)) ret))
#f #f
@ -252,11 +271,22 @@
(send entity set-id! id) (send entity set-id! id)
(set! entity-list (cons entity entity-list))) (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)))
(define/public (destroy-entity id) (define/public (destroy-entity id)
(set! entity-list (set! entity-list
(filter (filter
(lambda (entity) (lambda (entity)
(cond ((eq? (send entity get-id) id) (cond ((string=? (send entity get-id) id)
(send entity destroy-me) (send entity destroy-me)
#f) #f)
(else #t))) (else #t)))
@ -280,14 +310,14 @@
(define (animate-pollen) (define (animate-pollen)
(pdata-map! (pdata-map!
(lambda (p) (lambda (p)
(let* ((pp (vadd (vmul p 1) (vector 0 (- (time)) 0))) (let* ((pp (vadd (vmul p 1) (vector 0 (- (flxtime)) 0)))
(v (cond (v (cond
((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1)) ((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1))
((> (vmag p) 8) (vmul p -0.1)) ((> (vmag p) max-pollen-radius) (vmul p -0.1))
(else (else
(vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5) (vector (- (noise (vx pp) (vy pp) (vz pp)) 0.5)
(- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5) (- (noise (vx pp) (+ (vy pp) 112.3) (vz pp)) 0.5)
(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5)))))) 0 #;(- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5))))))
(vadd (vadd p (vmul v 0.2)) (vadd (vadd p (vmul v 0.2))
(vmul (srndvec) 0.01)))) (vmul (srndvec) 0.01))))
"p")) "p"))
@ -302,7 +332,8 @@
(let ((c (random (pdata-size))) (let ((c (random (pdata-size)))
(cc (vmul col 1))) (cc (vmul col 1)))
(pdata-set! "p" c (vadd (vmul (cirndvec) size) (pdata-set! "p" c (vadd (vmul (cirndvec) size)
(vadd pos (vector 0 0 (+ 0.2 (* (rndf) 0.01)))))) (vadd (vector (vx pos) (vy pos) 0)
(vector 0 0 (+ 0.2 (* (rndf) 0.01))))))
(pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5)))))) (pdata-set! "c" c (vector (vx cc) (vy cc) (vz cc) 0.5))))))
(define/public (suck-pollen pos size) (define/public (suck-pollen pos size)
@ -369,7 +400,7 @@
(colour col) (colour col)
(hint-unlit) (hint-unlit)
(translate pos) (translate pos)
(printf "building from:~a~n" plant-desc) ;(printf "building from:~a~n" plant-desc)
(set! root-component (build-component "1-1" col plant-desc)) (set! root-component (build-component "1-1" col plant-desc))
(set! flower-list (component-leaves root-component)))) (set! flower-list (component-leaves root-component))))
@ -378,22 +409,22 @@
(define/public (player-update world network) (define/public (player-update world network)
(when (key-special-pressed 100) (when (key-special-pressed-this-frame 100)
(set! current-flower (modulo (+ current-flower 1) (length flower-list)))) (set! current-flower (modulo (+ current-flower 1) (length flower-list))))
(when (key-special-pressed 102) (when (key-special-pressed-this-frame 102)
(set! current-flower (modulo (- current-flower 1) (length flower-list)))) (set! current-flower (modulo (- current-flower 1) (length flower-list))))
; bit odd, have to go through network to tell other clients to ; 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... ; spray, and need to get the id of the player plant from the world...
(when (key-special-pressed 101) (when (key-special-pressed-this-frame 101)
(send network spray world (send world get-my-id) current-flower 0)) (send network spray world (send world get-my-id) current-flower 0))
(let ((flower (list-ref flower-list current-flower))) (let ((flower (list-ref flower-list current-flower)))
(with-primitive (component-root flower) (with-primitive (component-root flower)
(when (key-special-pressed 103) (when (key-special-pressed-this-frame 103)
(rotate (vector 0 0 20)) (rotate (vector 0 0 20))
(let ((colours (suck world current-flower))) (let ((colours (suck world current-flower)))
(when (not (zero? (length colours))) (when (not (zero? (length colours)))
@ -430,7 +461,7 @@
(with-primitive (component-root (list-ref flower-list flower)) (with-primitive (component-root (list-ref flower-list flower))
(get-global-transform))))) (get-global-transform)))))
(send world puff-pollen pos (component-col (list-ref flower-list flower)) (send world puff-pollen pos (component-col (list-ref flower-list flower))
0.2 1))) 0.2 10)))
(define/public (suck world flower) (define/public (suck world flower)
(let ((pos (vtransform (vector 0 0 0) (let ((pos (vtransform (vector 0 0 0)
@ -472,7 +503,7 @@
(set! outgoing (cons (list to msg) outgoing))) (set! outgoing (cons (list to msg) outgoing)))
(define (message-handler sz) (define (message-handler sz)
(printf "<---- ~a ~a~n" (message-from sz) (message-body 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))) (set! incoming (cons (list (message-from sz) (message-body sz)) incoming)))
(define/public (start) (define/public (start)
@ -488,7 +519,7 @@
(when (not (null? outgoing)) (when (not (null? outgoing))
(for-each (for-each
(lambda (msg) (lambda (msg)
(printf "----> ~a ~a~n" (car msg) (cadr msg)) (when debug-jab (printf "tx ----> ~a ~a~n" (car msg) (cadr msg)))
(xmpp-send (message (car msg) (cadr msg)))) (xmpp-send (message (car msg) (cadr msg))))
outgoing) outgoing)
(set! outgoing '())) (set! outgoing '()))
@ -505,6 +536,10 @@
(jab (make-object jabberer%)) (jab (make-object jabberer%))
(send-to jto)) (send-to jto))
(define/public (start)
(send jab start))
(define (stringify l) (define (stringify l)
(cond (cond
((null? l) l) ((null? l) l)
@ -550,18 +585,22 @@
(define (dispatch world) (define (dispatch world)
(for-each (for-each
(lambda (msg) (lambda (msg)
(let ((command (list-ref (cadr msg) 0)) (let* ((chopped (split-string (cadr msg)))
(args (cdr (cadr msg)))) (command (list-ref chopped 0))
(args (cdr chopped)))
(cond (cond
((string=? command "ping")
(printf "pong~n"))
((string=? command "join-game") ((string=? command "join-game")
(send world destroy-all-but-me)
(printf "a new plant has joined the game~n") (printf "a new plant has joined the game~n")
; send a plant update for the new player ; send a plant update for the new player
(update-plant world) ) (update-plant world) )
((string=? command "plant") ((string=? command "plant")
(printf "add plant message recieved : ~a~n" (list-ref args 0)) (printf "add plant message recieved : ~a~n" (list-ref args 0))
(printf "~a~n" (join-end 7 args "")) (send world set-entity (list-ref args 0) (make-object plant%
(send world set-entity (string->number (list-ref args 0)) (make-object plant%
(vector (string->number (list-ref args 1)) (vector (string->number (list-ref args 1))
(string->number (list-ref args 2)) (string->number (list-ref args 2))
(string->number (list-ref args 3))) (string->number (list-ref args 3)))
@ -572,30 +611,33 @@
((string=? command "flower") ((string=? command "flower")
;(printf "flower change msg recieved~n") ;(printf "flower change msg recieved~n")
(send (send world get-entity (string->number (list-ref args 0))) flower-update (send (send world get-entity (list-ref args 0)) flower-update
(list-ref args 1) (vector (string->number (list-ref args 2)) (string->number (list-ref args 1)) (vector (string->number (list-ref args 2))
(string->number (list-ref args 3)) (string->number (list-ref args 3))
(string->number (list-ref args 4))))) (string->number (list-ref args 4)))))
((string=? command "destroy-plant") ((string=? command "destroy-plant")
(printf "destroy plant message recieved...~n") (printf "destroy plant message recieved...~n")
(send world destroy-entity (string->number (list-ref args 0)))) (send world destroy-entity (list-ref args 0)))
((string=? command "spray") ((string=? command "spray")
; (printf "destroy plant message recieved...~n") ; (printf "destroy plant message recieved...~n")
(let ((e (send world get-entity (string->number (list-ref args 0))))) (let ((e (send world get-entity (list-ref args 0))))
; it's possible to get spray events before the ; it's possible to get spray events before the
; plant has been created... ; plant has been created...
(when e (when e
(send e spray world (string->number (list-ref args 1)) (send e spray world (string->number (list-ref args 1))
(string->number (list-ref args 2))))))))) (string->number (list-ref args 2))))))
(else
(printf "unknown command ~a ~n" command)))))
(send jab get-incoming)) (send jab get-incoming))
(send jab clear-incoming)) (send jab clear-incoming))
(define/public (join-game world) (define/public (join-game world)
(send jab start) (printf "ping~n")
(send jab send-msg send-to "join-game") (send jab send-msg send-to "ping")
(set! wait-till (+ (time) 2)) (send jab send-msg send-to "join-game ")
(set! wait-till (+ (flxtime) 5))
(set! waiting #t)) (set! waiting #t))
(define/public (update-plant world) (define/public (update-plant world)
@ -604,7 +646,7 @@
(col (send my-plant get-col)) (col (send my-plant get-col))
(desc-str (format "'~a" (send my-plant get-desc)))) (desc-str (format "'~a" (send my-plant get-desc))))
(send jab send-msg send-to (string-append "plant " (number->string (send world get-my-id)) " " (send jab send-msg send-to (string-append "plant " (send world get-my-id) " "
(number->string (vx pos)) " " (number->string (vx pos)) " "
(number->string (vy pos)) " " (number->string (vy pos)) " "
(number->string (vz pos)) " " (number->string (vz pos)) " "
@ -614,19 +656,19 @@
desc-str)))) desc-str))))
(define/public (destroy-plant world id) (define/public (destroy-plant world id)
(send jab send-msg send-to (string-append "destroy-plant " (number->string id))) (send jab send-msg send-to (string-append "destroy-plant " id))
(send world destroy-entity id)) (send world destroy-entity id))
(define/public (spray world id flower type) (define/public (spray world id flower type)
(send jab send-msg send-to (string-append "spray " (send jab send-msg send-to (string-append "spray "
(number->string id) " " id " "
(number->string flower) " " (number->string flower) " "
(number->string type))) " " (number->string type))) " "
(send (send world get-entity id) spray world flower type)) (send (send world get-entity id) spray world flower type))
(define/public (flower-update world id flower col) (define/public (flower-update world id flower col)
(send jab send-msg send-to (string-append "flower " (send jab send-msg send-to (string-append "flower "
(number->string id) " " id " "
(number->string flower) " " (number->string flower) " "
(number->string (vx col)) " " (number->string (vx col)) " "
(number->string (vy col)) " " (number->string (vy col)) " "
@ -636,7 +678,7 @@
(define/public (update world) (define/public (update world)
; wait for all other players to register their plants ; wait for all other players to register their plants
(when (and waiting (< wait-till (time))) (when (and waiting (< wait-till (flxtime)))
(set! waiting #f) (set! waiting #f)
(send world make-my-plant) (send world make-my-plant)
(update-plant world)) (update-plant world))
@ -685,52 +727,43 @@
(with-state (with-state
(backfacecull 0) (backfacecull 0)
(hint-depth-sort) (hint-depth-sort)
; (hint-unlit) ; (hint-unlit)
(translate p) (translate p)
(rotate (vector 0 (random 360) 0)) (rotate (vector 0 (random 360) 0))
(scale (+ 1 (* (rndf) 1.5))) (scale (+ 1 (* (rndf) 1.5)))
(texture (load-texture (choose (list (texture (load-texture (choose (list
"textures/bgplant-1.png" "textures/bgplant-1.png"
"textures/bgplant-2.png" "textures/bgplant-2.png"
"textures/bgplant-3.png" ;"textures/bgplant-3.png"
"textures/bgplant-4.png" "textures/bgplant-4.png"
"textures/bgplant-5.png" "textures/bgplant-5.png"
"textures/bgplant-6.png" "textures/bgplant-6.png"
)))) ))))
(let ((o (build-copy obj))) (let ((o (build-copy obj)))
(with-primitive o (hide 0))) (with-primitive o (hide 0)))
; (load-primitive "meshes/freeplant.obj") ; (load-primitive "meshes/freeplant.obj")
)) ))
(define (load-model tex obj) (define (load-model tex obj)
(with-state (with-state
(texture (load-texture (string-append "textures/" tex))) (texture (load-texture (string-append "textures/" tex)))
(load-primitive (string-append "meshes/" obj)))) (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))
(clear) (let ((l2 (make-light 'point 'free)))
(light-position l2 (vector 0 20 0))
(light-diffuse l2 (vector 0.4 0.9 0.5)))
(clear-colour (vmul (vector 0.4 0.5 0.9) 0.2)) (with-state
(fog (vector 0.4 0.5 0.9) 0.01 1 100)
#;(
(define l (make-light 'spot 'free))
(light-diffuse 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 0 5 0))
(light-direction l (vector 0 -1 0))
(light-spot-angle l 55)
(light-spot-exponent l 1)
(define l2 (make-light 'point 'free))
(light-position l2 (vector 0 10 0))
(light-diffuse l2 (vector 0.4 0.5 0.9))
(clear-texture-cache)
(clear-geometry-cache)
(with-state
(backfacecull 0) (backfacecull 0)
(hint-depth-sort) (hint-depth-sort)
(hint-unlit) (hint-unlit)
@ -742,51 +775,61 @@
(load-model "bgplant-1.png" "plant-4.obj") (load-model "bgplant-1.png" "plant-4.obj")
(load-model "bgplant-1.png" "plant-5.obj") (load-model "bgplant-1.png" "plant-5.obj")
(load-model "bgplant-1.png" "plant-6.obj") (load-model "bgplant-1.png" "plant-6.obj")
; (load-model "bgplant-2.png" "plant-7.obj") ; (load-model "bgplant-2.png" "plant-7.obj")
) )
(with-state
(with-state
(backfacecull 0) (backfacecull 0)
(load-model "car-base.png" "car.obj") (load-model "car-base.png" "car.obj")
(load-model "car-base.png" "car-2.obj") (load-model "car-base.png" "car-2.obj")
(load-model "telly-base.png" "telly-2.obj")) (load-model "telly-base.png" "telly-2.obj"))
(with-state (with-state
(load-model "telly-base.png" "telly-0.obj") (load-model "telly-base2.png" "telly-0.obj")
(load-model "telly-base2.png" "telly-1.obj") (load-model "telly-base.png" "telly-1.obj")
(load-model "telly-base.png" "telly-2.obj") (load-model "telly-base.png" "telly-2.obj")
(load-model "telly-base.png" "telly-3.obj") (load-model "telly-base.png" "telly-3.obj")
(load-model "telly-base.png" "telly-4.obj")) (load-model "telly-base.png" "telly-4.obj"))
(with-state (with-state
(load-model "washer-base.png" "washer-0.obj") (load-model "washer-base.png" "washer-0.obj")
(load-model "washer-base.png" "washer-1.obj") (load-model "washer-base.png" "washer-1.obj")
(load-model "washer-base.png" "washer-2.obj") (load-model "washer-base.png" "washer-2.obj")
(load-model "washer-base.png" "washer-3.obj")) (load-model "washer-base.png" "washer-3.obj"))
(define terrain (with-state (let ((terrain (with-state
(texture (load-texture "textures/ground-base.png")) (texture (load-texture "textures/ground-base.png"))
(load-primitive "meshes/ground.obj"))) (load-primitive "meshes/ground.obj")))
(flower-obj (load-primitive "meshes/freeplant.obj")))
;(define grassmap (load-primitive "textures/set-grass.png"))
;(define grassmap (load-primitive "textures/set-grass.png")) #;(define (tx->pi tx)
(define (tx->pi tx)
(+ (vy tx) (* (vx tx) (pixels-width)))) (+ (vy tx) (* (vx tx) (pixels-width))))
(define flower-obj (load-primitive "meshes/freeplant.obj"))
(with-primitive flower-obj (with-primitive flower-obj
(pdata-map! (pdata-map!
(lambda (n p) (lambda (n p)
(vnormalise p)) (vnormalise p))
"n" "p") "n" "p")
(hide 1)) (hide 1))
(with-primitive terrain
(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 (poly-for-each-tri-sample
(lambda (indices bary) (lambda (indices bary)
(let ((tc (vadd (let ((tc (vadd
@ -794,35 +837,58 @@
(vmul (pdata-ref "t" (list-ref indices 1)) (vy bary)) (vmul (pdata-ref "t" (list-ref indices 1)) (vy bary))
(vmul (pdata-ref "t" (list-ref indices 2)) (vz 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) (when (zero? (random 2)) #;(> (va (with-primitive grassmap (pdata-ref "c" (tx->pi tc)))) 0.5)
(build-flower (vadd (let ((pos (vadd
(vmul (pdata-ref "p" (list-ref indices 0)) (vx bary)) (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 1)) (vy bary))
(vmul (pdata-ref "p" (list-ref indices 2)) (vz bary))) (vector 0 1 0) (vmul (pdata-ref "p" (list-ref indices 2)) (vz bary)))))
flower-obj)))) (when (> (vmag pos) 3)
(build-flower pos (vector 0 1 0) flower-obj))))))
1)) 1))
(define shell0 (build-copy terrain)) (let ((shell0 (build-copy terrain)))
(with-primitive shell0 (with-primitive shell0
(pdata-copy "t" "t1") (pdata-copy "t" "t1")
(pdata-map! (pdata-map!
(lambda (t) (lambda (t)
(vmul t 4)) (vmul t 4))
"t")) "t"))
(with-state (with-state
(multitexture 0 (load-texture "textures/shell.png")) (multitexture 0 (load-texture "textures/shell.png"))
; (multitexture 1 (load-texture "textures/ground-grassmap.png")) ; (multitexture 1 (load-texture "textures/ground-grassmap.png"))
(build-shells shell0 4 0.05 (vector 1 0.5 1))) (build-shells shell0 4 0.05 (vector 1 0.5 1)))))))
)
;---------------------------------------- ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(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)))
(hint-depth-sort) (hint-depth-sort)
(define camera (build-locator))
(with-primitive camera
(translate (vector 0 5 0)))
(lock-camera camera)
(define w (make-object world% 1)) (define w (make-object world% 1))
(define n (make-object network-dispatch%)) (define n (make-object network-dispatch%))
(send n start)
(send n join-game w) (send n join-game w)
(define (animate) (define (animate)

4
hayfever/xmpp-dave.ss
View file

@ -258,7 +258,7 @@
((string-ci=? test "<pr") str) ((string-ci=? test "<pr") str)
((string-ci=? test "<ur") str) ((string-ci=? test "<ur") str)
(else (else
(display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str)) ;(display (format "~%recieved: ~a ~%parsed as <null/>~%~%" str))
"<null/>")))) "<null/>"))))
@ -298,7 +298,7 @@
(define xmpp-out-port (make-parameter (current-output-port))) (define xmpp-out-port (make-parameter (current-output-port)))
(define (xmpp-send str) (define (xmpp-send str)
(printf "sending iO: ~a ~%~%" str) ;(printf "sending iO: ~a ~%~%" str)
(fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port))) (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
(defmacro with-xmpp-session (jid pass . body) (defmacro with-xmpp-session (jid pass . body)