From 09bfbe366cacf50bfd059a322cf5e84c135066b6 Mon Sep 17 00:00:00 2001 From: Dave Griffiths Date: Fri, 24 Apr 2009 11:52:00 +0100 Subject: [PATCH] xmpp works, tidied up visually and internally --- hayfever/hayfever2.scm | 742 ++++++++++++++++++++++------------------- hayfever/xmpp-dave.ss | 6 +- 2 files changed, 407 insertions(+), 341 deletions(-) diff --git a/hayfever/hayfever2.scm b/hayfever/hayfever2.scm index e6474f4..95a8f6e 100644 --- a/hayfever/hayfever2.scm +++ b/hayfever/hayfever2.scm @@ -1,26 +1,38 @@ +;#lang scheme ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +; h a y f e v e r +;(require fluxus-016/drflux) (require scheme/class) (require mzlib/string) (require openssl) - (require "xmpp-dave.ss") ;(require (prefix-in xmpp: (planet zzkt/xmpp))) (define plant2 #f) ;(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 pass "plant0000003") (define jto "plant0000002@fo.am") (when plant2 - (set! jid "plant0000002@fo.am") - (set! pass "plant0000002") - (set! jto "plant0000003@fo.am")) + (set! jid "plant0000002@fo.am") + (set! pass "plant0000002") + (set! jto "plant0000003@fo.am")) (printf "I am ~a~n" jid) +(when deterministic + (flxseed 1) + (random-seed 2)) + + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; pixel primitive things for getting connection points @@ -109,7 +121,10 @@ (cond ((null? children) (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) (texture (load-texture (string-append "textures/comp-" id ".png"))) (build-plane)))) @@ -119,7 +134,7 @@ (root (with-state (hint-depth-sort) (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"))) (build-plane))) (comp (make-component root col @@ -158,13 +173,10 @@ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; utils for building random plants -(define (choose l) - (list-ref l (random (length l)))) - (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)))))) + ((< depth 1) (choose (list 2 3))) + (else (choose (list 0 1 2 3)))))) (cond ((eq? num-children 0) (list (choose (list "11")) (list))) ((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1))))) @@ -193,19 +205,19 @@ (entity-list '()) (id 0) (pollen 0) - (my-id 0)) + (my-id "")) (define/public (init) (set! pollen (with-state (translate (vector 0 0 0.2)) (texture (load-texture "textures/pollen.png")) - (build-particles 100))) + (build-particles pollen-particles))) (with-primitive pollen (pdata-map! (lambda (p) - (vmul (srndvec) 5)) + (vmul (vector (crndf) (crndf) 0) 5)) "p") (pdata-map! (lambda (c) @@ -224,16 +236,23 @@ my-id) (define/public (make-my-plant) + + (when deterministic + (flxseed 3) + (random-seed 10) ; 2 5 + ) + + (let* ((pos (vector (* (crndf) 5) 0 0.1)) (col (hsv->rgb (vector (rndf) 0.8 1))) (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)))) (define/public (get-entity id) (foldl (lambda (entity ret) - (if (eq? (send entity get-id) id) + (if (string=? (send entity get-id) id) entity ret)) #f @@ -252,11 +271,22 @@ (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))) + (define/public (destroy-entity id) (set! entity-list (filter (lambda (entity) - (cond ((eq? (send entity get-id) id) + (cond ((string=? (send entity get-id) id) (send entity destroy-me) #f) (else #t))) @@ -280,14 +310,14 @@ (define (animate-pollen) (pdata-map! (lambda (p) - (let* ((pp (vadd (vmul p 1) (vector 0 (- (time)) 0))) + (let* ((pp (vadd (vmul p 1) (vector 0 (- (flxtime)) 0))) (v (cond - ((< (vy p) 0) (vmul (vector (crndf) 1 (crndf)) 0.1)) - ((> (vmag p) 8) (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) - (- (noise (+ (vx pp) 393.2) (vy pp) (vz pp)) 0.5)))))) + ((< (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)))))) (vadd (vadd p (vmul v 0.2)) (vmul (srndvec) 0.01)))) "p")) @@ -302,7 +332,8 @@ (let ((c (random (pdata-size))) (cc (vmul col 1))) (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)))))) (define/public (suck-pollen pos size) @@ -369,7 +400,7 @@ (colour col) (hint-unlit) (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! flower-list (component-leaves root-component)))) @@ -378,28 +409,28 @@ (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)))) - (when (key-special-pressed 102) + (when (key-special-pressed-this-frame 102) (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 101) + (when (key-special-pressed-this-frame 101) (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 103) + (when (key-special-pressed-this-frame 103) (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)))) + (vadd c1 c2)) (vector 0 0 0) colours) (length colours)))) (set-component-col! flower (vadd (vmul (component-col flower) 0.9) @@ -416,7 +447,7 @@ (set-component-col! flower col) (with-primitive (component-root flower) (colour (component-col flower))))) - + (define/public (update world) 0 #;(with-primitive root @@ -430,7 +461,7 @@ (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 1))) + 0.2 10))) (define/public (suck world flower) (let ((pos (vtransform (vector 0 0 0) @@ -448,201 +479,212 @@ ; * 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) - (printf "<---- ~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 () - (when (not (null? outgoing)) - (for-each - (lambda (msg) - (printf "----> ~a ~a~n" (car msg) (cadr msg)) + (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 () + (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))) + outgoing) + (set! outgoing '())) + (sleep 0.5) + (loop)))) + (super-new))) (define network-dispatch% - (class object% - - (field - (waiting #f) - (wait-till 0) - (jab (make-object jabberer%)) - (send-to jto)) - - (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 ((command (list-ref (cadr msg) 0)) - (args (cdr (cadr msg)))) - (cond - ((string=? command "join-game") - (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)) - (printf "~a~n" (join-end 7 args "")) - (send world set-entity (string->number (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 (string->number (list-ref args 0))) flower-update - (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 (string->number (list-ref args 0)))) - - ((string=? command "spray") - ; (printf "destroy plant message recieved...~n") - (let ((e (send world get-entity (string->number (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))))))))) - (send jab get-incoming)) - (send jab clear-incoming)) - - (define/public (join-game world) - (send jab start) - (send jab send-msg send-to "join-game") - (set! wait-till (+ (time) 2)) - (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)))) + (class object% - (send jab send-msg send-to (string-append "plant " (number->string (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 " (number->string id))) - (send world destroy-entity id)) - - (define/public (spray world id flower type) - (send jab send-msg send-to (string-append "spray " - (number->string 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 " - (number->string 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 (time))) - (set! waiting #f) - (send world make-my-plant) - (update-plant world)) - (dispatch world)) - - (super-new))) + (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))) @@ -685,144 +727,168 @@ (with-state (backfacecull 0) (hint-depth-sort) -; (hint-unlit) + ; (hint-unlit) (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" - )))) + "textures/bgplant-1.png" + "textures/bgplant-2.png" + ;"textures/bgplant-3.png" + "textures/bgplant-4.png" + "textures/bgplant-5.png" + "textures/bgplant-6.png" + )))) (let ((o (build-copy obj))) (with-primitive o (hide 0))) -; (load-primitive "meshes/freeplant.obj") -)) + ; (load-primitive "meshes/freeplant.obj") + )) (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)) + (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))))))) + ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (clear) -(clear-colour (vmul (vector 0.4 0.5 0.9) 0.2)) -(fog (vector 0.4 0.5 0.9) 0.01 1 100) +(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 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 set-root (with-state + (scale 2) + (rotate (vector 0 -100 0)) + (build-locator))) -(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) - (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-base.png" "telly-0.obj") - (load-model "telly-base2.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")) - -(define terrain (with-state - (texture (load-texture "textures/ground-base.png")) - (load-primitive "meshes/ground.obj"))) - - -;(define grassmap (load-primitive "textures/set-grass.png")) - -(define (tx->pi tx) - (+ (vy tx) (* (vx tx) (pixels-width)))) - -(define flower-obj (load-primitive "meshes/freeplant.obj")) - -(with-primitive flower-obj - (pdata-map! - (lambda (n p) - (vnormalise p)) - "n" "p") - (hide 1)) - -(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) - (build-flower (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))) (vector 0 1 0) - flower-obj)))) - 1)) - -(define 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))) -) - -;---------------------------------------- +(when (not minimal-mode) + (with-state + (parent set-root) + (build-set))) (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 n (make-object network-dispatch%)) +(send n start) + (send n join-game w) (define (animate) diff --git a/hayfever/xmpp-dave.ss b/hayfever/xmpp-dave.ss index 37e2090..1187eff 100644 --- a/hayfever/xmpp-dave.ss +++ b/hayfever/xmpp-dave.ss @@ -258,14 +258,14 @@ ((string-ci=? test "~%~%" str)) + ;(display (format "~%recieved: ~a ~%parsed as ~%~%" str)) "")))) ;; response handler (define (xmpp-response-handler in) (thread (lambda () - (let loop () + (let loop () (parse-xmpp-response (read-async in)) (sleep 0.1) ;; slight delay to avoid a tight loop (loop))))) @@ -298,7 +298,7 @@ (define xmpp-out-port (make-parameter (current-output-port))) (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))) (defmacro with-xmpp-session (jid pass . body)