broke apart the source, added jabberer and xmpp
This commit is contained in:
Dave Griffiths
parent
fb334fe4eb
commit
cb7915058c
12 changed files with 1901 additions and 1305 deletions
|
|
@ -142,5 +142,4 @@
|
|||
(set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F")))
|
||||
(+ 10 (random 20)) 0.9) trees))))
|
||||
|
||||
(start-framedump "wind" "jpg")
|
||||
(every-frame (animate trees))
|
||||
|
|
|
|||
125
plant-eyes/controller.ss
Normal file
125
plant-eyes/controller.ss
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class fluxus-016/drflux "logic.ss" "view.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
; reads input events and tells the logic side what to do
|
||||
|
||||
(define controller%
|
||||
(class object%
|
||||
(init-field
|
||||
(game-view #f))
|
||||
|
||||
(field
|
||||
(fwd (vector 0 0 1))
|
||||
(up (vector 0 1 0))
|
||||
(pos (vector 0 0 0))
|
||||
(mtx (mident))
|
||||
(cam (build-locator))
|
||||
(current-twig #f)
|
||||
(current-twig-growing #f)
|
||||
(current-point 0)
|
||||
(tilt 0)
|
||||
(yaw 0)
|
||||
(player-plant #f))
|
||||
|
||||
(define/public (set-player-plant s)
|
||||
(set! player-plant s))
|
||||
|
||||
(define/public (get-cam-obj)
|
||||
cam)
|
||||
|
||||
(define/public (set-pos s)
|
||||
(set! pos s))
|
||||
|
||||
(define/public (set-fwd s)
|
||||
(set! fwd s))
|
||||
|
||||
(define/public (get-fwd)
|
||||
fwd)
|
||||
|
||||
(define/public (setup)
|
||||
(lock-camera cam)
|
||||
(camera-lag 0.2)
|
||||
(clip 1 1000)
|
||||
(set-camera-transform (mtranslate (vector 0 0 -4))))
|
||||
|
||||
(define/public (update)
|
||||
(when (key-pressed-this-frame " ")
|
||||
(cond ((and current-twig (not current-twig-growing))
|
||||
(let ((new-twig (send current-twig add-twig current-point
|
||||
(vector 0 1 0) #;(vsub (send current-twig get-point current-point)
|
||||
(send current-twig get-point (- current-point 1))))))
|
||||
(set! current-twig-growing #t)
|
||||
(set! current-twig new-twig)))
|
||||
(else
|
||||
(set! current-twig (make-object twig-logic% (vector 0 0 0) 0 player-plant 'root
|
||||
(vmul fwd -1)
|
||||
start-twig-width max-twig-points 'extruded))
|
||||
(send player-plant add-twig current-twig)
|
||||
(set! current-twig-growing #t))))
|
||||
|
||||
(when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 2)))
|
||||
(when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 2)))
|
||||
(when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 2)))
|
||||
(when (or (key-pressed "s") (key-special-pressed 103)) (set! tilt (- tilt 2)))
|
||||
|
||||
; clamp tilt to prevent gimbal lock
|
||||
(when (> tilt 88) (set! tilt 88))
|
||||
(when (< tilt -88) (set! tilt -88))
|
||||
|
||||
(when (not current-twig-growing)
|
||||
(when (key-pressed-this-frame "q")
|
||||
(cond ((not current-twig)
|
||||
(set! current-twig (send player-plant get-twig-from-dir (vmul fwd -1)))
|
||||
(set! current-point 2))
|
||||
(else
|
||||
(when (< current-point (- (send current-twig get-num-points) 1))
|
||||
(set! current-point (+ current-point 1))))))
|
||||
|
||||
(when (key-pressed-this-frame "z")
|
||||
(cond (current-twig
|
||||
(set! current-point (- current-point 1))
|
||||
(when (< current-point 2)
|
||||
(set! current-twig #f)
|
||||
(set! pos (vector 0 0 0))
|
||||
#;(set-camera-transform (mtranslate (vector 0 0 -1))))))))
|
||||
|
||||
; get camera fwd vector from key-presses
|
||||
(set! fwd (vtransform (vector 0 0 1)
|
||||
(mmul
|
||||
(mrotate (vector 0 yaw 0))
|
||||
(mrotate (vector tilt 0 0)))))
|
||||
|
||||
|
||||
; if we are on a twig not growing
|
||||
(cond ((and current-twig (not current-twig-growing))
|
||||
(set! pos (send current-twig get-point current-point))
|
||||
#;(when (> current-point 0)
|
||||
(set! fwd (vmix fwd (vnormalise (vsub (send current-twig get-point
|
||||
(- current-point 1))
|
||||
pos)) 0.5))))
|
||||
|
||||
(else
|
||||
(when current-twig-growing
|
||||
(let ((twig-view (send (send game-view get-plant (send player-plant get-id))
|
||||
get-twig (send current-twig get-id))))
|
||||
(when twig-view
|
||||
(set! pos (vsub (send twig-view get-end-pos)
|
||||
(vmul (send current-twig get-dir) 1)))))
|
||||
(when (eq? (send current-twig get-num-points)
|
||||
(send current-twig get-length))
|
||||
(set! current-twig-growing #f)
|
||||
(set! current-point (- (send current-twig get-num-points) 1))))))
|
||||
|
||||
|
||||
(let* ((side (vnormalise (vcross up fwd)))
|
||||
(up (vnormalise (vcross fwd side))))
|
||||
|
||||
(with-primitive cam
|
||||
(identity)
|
||||
(concat (vector (vx side) (vy side) (vz side) 0
|
||||
(vx up) (vy up) (vz up) 0
|
||||
(vx fwd) (vy fwd) (vz fwd) 0
|
||||
(vx pos) (vy pos) (vz pos) 1)))))
|
||||
|
||||
(super-new)))
|
||||
63
plant-eyes/jabberer.ss
Normal file
63
plant-eyes/jabberer.ss
Normal file
|
|
@ -0,0 +1,63 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class fluxus-016/drflux 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
|
||||
; and sent by the game
|
||||
|
||||
(define debug-netloop #f)
|
||||
|
||||
(define jabberer%
|
||||
(class object%
|
||||
(init-field
|
||||
(jid "none@nowhere")
|
||||
(pass "xxxx"))
|
||||
|
||||
(field
|
||||
(incoming '())
|
||||
(outgoing '())
|
||||
(thr 0)
|
||||
(debug-jab #f))
|
||||
|
||||
(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" (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)))
|
||||
|
||||
(define/public (stop)
|
||||
(kill-thread thr))
|
||||
|
||||
(define (run)
|
||||
(xmpp:with-xmpp-session jid pass
|
||||
(xmpp:set-xmpp-handler 'message message-handler)
|
||||
(let loop ()
|
||||
(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 (xmpp:message (car msg) (cadr msg))))
|
||||
outgoing)
|
||||
(set! outgoing '()))
|
||||
(sleep 0.5)
|
||||
(loop))))
|
||||
(super-new)))
|
||||
20
plant-eyes/list-utils.ss
Normal file
20
plant-eyes/list-utils.ss
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
#lang scheme/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (assoc-remove k l)
|
||||
(cond
|
||||
((null? l) '())
|
||||
((eq? (car (car l)) k)
|
||||
(assoc-remove k (cdr l)))
|
||||
(else
|
||||
(cons (car l) (assoc-remove k (cdr l))))))
|
||||
|
||||
(define (choose l)
|
||||
(list-ref l (random (length l))))
|
||||
|
||||
(define (list-contains k l)
|
||||
(cond
|
||||
((null? l) #f)
|
||||
((eq? (car l) k) #t)
|
||||
(else (list-contains k (cdr l)))))
|
||||
|
||||
499
plant-eyes/logic.ss
Normal file
499
plant-eyes/logic.ss
Normal file
|
|
@ -0,0 +1,499 @@
|
|||
#lang scheme
|
||||
(require scheme/class fluxus-016/drflux "message.ss" "list-utils.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define branch-probability 6) ; as in one in branch-probability chance
|
||||
(define branch-width-reduction 0.5)
|
||||
(define twig-jitter 0.1)
|
||||
(define branch-jitter 0.5)
|
||||
(define max-twig-points 30)
|
||||
(define start-twig-dist 0.05)
|
||||
(define start-twig-width 0.2)
|
||||
(define default-max-twigs 10)
|
||||
(define default-scale-factor 1.05)
|
||||
(define num-pickups 10)
|
||||
(define pickup-dist-radius 200)
|
||||
(define pickup-size 1)
|
||||
(define ornament-grow-probability 4)
|
||||
(define curl-amount 40)
|
||||
(define start-size 50)
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; the base class logic object - all logic side objects can
|
||||
; send messages to the render side at any time by calling add-message
|
||||
; this takes care of the propagation of information. (not just oo fetish, I hope)
|
||||
(define game-logic-object%
|
||||
(class object%
|
||||
(field
|
||||
(messages '())
|
||||
(children '()))
|
||||
|
||||
(define/public (send-message name data)
|
||||
(set! messages (cons (make-object message% name data) messages)))
|
||||
|
||||
; convert a list of lists in to just a single list - needed to convert
|
||||
; the update lists into one big list of messages
|
||||
(define (flatten l)
|
||||
(cond
|
||||
((null? l) '())
|
||||
((list? (car l)) (append (flatten (car l)) (flatten (cdr l))))
|
||||
(else (cons (car l) (flatten (cdr l))))))
|
||||
|
||||
(define/pubment (update) ; need to augement this if we have child logic objects,
|
||||
(let ((m messages)) ; and call update on them too.
|
||||
(set! messages '())
|
||||
(append
|
||||
m
|
||||
(flatten (inner '() update))))) ; the augmented method gets called here
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; a twig, which can contain other twigs things.
|
||||
; (roots and shoots are both twigs)
|
||||
(define twig-logic%
|
||||
(class game-logic-object%
|
||||
(init-field
|
||||
(last-point (vector 0 0 0))
|
||||
(id #f) ; our id (for matching up with the renderer geometry)
|
||||
(plant #f) ; the plant we belong to
|
||||
(type 'root) ; or 'shoot
|
||||
(dir (vector 0 1 0)) ; the general direction we are pointing in
|
||||
(width 0) ; the width of this root
|
||||
(num-points max-twig-points) ; number of points in this twig
|
||||
(render-type 'extruded) ; the way to tell the view to render this twig
|
||||
(dist start-twig-dist)) ; distance between points
|
||||
|
||||
(field
|
||||
(points '()) ; the 3d points for this twig
|
||||
(widths '())
|
||||
(twigs '()) ; children are stored with the point number they are connected to.
|
||||
(ornaments '()) ; the things attached to this twig, an assoc list with point index
|
||||
(branch #f) ; are we a main branch twig?
|
||||
(w 0) ; the width of this segment
|
||||
(curl (vmul (crndvec) curl-amount))) ; the angles to turn each point, if curly
|
||||
|
||||
(inherit send-message)
|
||||
|
||||
(define/public (set-pos s)
|
||||
(set! last-point s))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (set-id! s)
|
||||
(set! id s))
|
||||
|
||||
(define/public (get-type)
|
||||
type)
|
||||
|
||||
(define/public (get-dir)
|
||||
dir)
|
||||
|
||||
(define/public (get-width)
|
||||
width)
|
||||
|
||||
(define/public (get-num-points)
|
||||
num-points)
|
||||
|
||||
(define/public (get-render-type)
|
||||
render-type)
|
||||
|
||||
(define/public (set-branch! s)
|
||||
(set! branch s))
|
||||
|
||||
(define/public (get-point point-index)
|
||||
(list-ref points point-index))
|
||||
|
||||
(define/public (get-length)
|
||||
(length points))
|
||||
|
||||
(define/public (get-end-pos)
|
||||
(if (not (null? points))
|
||||
(list-ref points (- (get-length) 1))
|
||||
#f))
|
||||
|
||||
(define/public (scale a)
|
||||
(set! width (* width a))
|
||||
(set! dist (* dist a)))
|
||||
|
||||
(define/public (grow ndir)
|
||||
(when (< (length points) num-points)
|
||||
(let ((new-point (if (zero? (length points))
|
||||
; first point should be at edge of the seed if we are a branch
|
||||
(if branch (vadd last-point (vmul dir dist))
|
||||
last-point)
|
||||
(vadd last-point (vmul dir dist)))))
|
||||
|
||||
(set! dir ndir)
|
||||
(set! w (* width (- 1 (/ (length points) num-points))))
|
||||
|
||||
(set! last-point new-point)
|
||||
(set! points (append points (list new-point)))
|
||||
(set! widths (append widths (list w)))
|
||||
(send-message 'twig-grow (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'twig-id id)
|
||||
(list 'point new-point)
|
||||
(list 'width w)))
|
||||
#;(when (and (> (length points) 1) (> num-points 1)
|
||||
(zero? (random branch-probability)))
|
||||
(add-twig (- (length points) 1) (vadd dir (vmul (srndvec) branch-jitter))))))
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(send (cadr twig) grow ndir))
|
||||
twigs))
|
||||
|
||||
(define/public (add-twig point-index dir)
|
||||
(let ((twig (make-object twig-logic%
|
||||
(get-point point-index)
|
||||
(send plant get-next-twig-id)
|
||||
plant
|
||||
type
|
||||
dir
|
||||
(list-ref widths point-index)
|
||||
(quotient num-points 2)
|
||||
render-type
|
||||
dist)))
|
||||
|
||||
(send-message 'new-twig (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'parent-twig-id id)
|
||||
(list 'point-index point-index)
|
||||
(list 'twig-id (send twig get-id))
|
||||
(list 'type (send twig get-type))
|
||||
(list 'dir (send twig get-dir))
|
||||
(list 'width (send twig get-width))
|
||||
(list 'num-points (send twig get-num-points))
|
||||
(list 'render-type (send twig get-render-type))
|
||||
))
|
||||
(set! twigs (cons (list point-index twig) twigs))
|
||||
twig))
|
||||
|
||||
(define/public (get-twig point-index)
|
||||
(cadr (assq point-index twigs)))
|
||||
|
||||
(define/public (get-random-twig)
|
||||
(if (or (null? twigs) (zero? (random 10)))
|
||||
this
|
||||
(send (cadr (choose twigs)) get-random-twig)))
|
||||
|
||||
(define/public (add-ornament point-index ornament)
|
||||
; todo - check max ornaments
|
||||
(send-message 'new-ornament
|
||||
(list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'twig-id id)
|
||||
(list 'point-index point-index)
|
||||
(list 'property (send ornament get-property))))
|
||||
(set! ornaments (cons (list point-index ornament) ornaments)))
|
||||
|
||||
(define/public (get-ornament point-index)
|
||||
(cadr (assq point-index ornaments)))
|
||||
|
||||
; adds the ornament if it's close, and checks sub-twigs
|
||||
; returns true if it's succeded
|
||||
(define/public (check-pickup pickup)
|
||||
; check each point in our twig
|
||||
(let* ((i -1) (found (foldl
|
||||
(lambda (point found)
|
||||
(set! i (+ i 1))
|
||||
; if we havent found anything yet and it's intersecting
|
||||
(cond ((and (not found) (< (vdist point (send pickup get-pos))
|
||||
(+ width (send pickup get-size))))
|
||||
(send plant add-property (send pickup get-type))
|
||||
(send pickup pick-up) ; this will remove the pickup for us
|
||||
(send-message 'pick-up-pickup
|
||||
(list
|
||||
(list 'pickup-id (send pickup get-id))))
|
||||
#t)
|
||||
(else #f)))
|
||||
#f
|
||||
points)))
|
||||
; now check each sub-twig
|
||||
(if (not found)
|
||||
(foldl
|
||||
(lambda (twig found)
|
||||
(if (not found)
|
||||
(send (cadr twig) check-pickup pickup)
|
||||
#f))
|
||||
#f
|
||||
twigs)
|
||||
found)))
|
||||
|
||||
(define/augment (update)
|
||||
(append
|
||||
(map
|
||||
(lambda (ornament)
|
||||
(send (cadr ornament) update))
|
||||
ornaments)
|
||||
(map
|
||||
(lambda (twig)
|
||||
(send (cadr twig) update))
|
||||
twigs)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; abilities live on twigs, and can do things.
|
||||
; this is the base class for all abilities.
|
||||
(define ornament-logic%
|
||||
(class game-logic-object%
|
||||
(init-field
|
||||
(id -1)
|
||||
(property 'none)
|
||||
(plant #f) ; the plant we belong to
|
||||
(twig #f) ; the twig we are on
|
||||
(point-index -1)) ; the index to the point on our twig
|
||||
|
||||
(field
|
||||
(pos (send twig get-point point-index))) ; figure out the position here
|
||||
|
||||
(define/public (get-property)
|
||||
property)
|
||||
|
||||
(define/public (get-pos)
|
||||
pos)
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; pickups map to abilities, and live out in space
|
||||
; this is the base class for all pickups.
|
||||
(define pickup-logic%
|
||||
(class game-logic-object%
|
||||
(init-field
|
||||
(id -1)
|
||||
(type 'none)
|
||||
(pos (vector 0 0 0)))
|
||||
|
||||
(field
|
||||
(size pickup-size)
|
||||
(picked-up #f))
|
||||
|
||||
(define/public (picked-up?)
|
||||
picked-up)
|
||||
|
||||
(define/public (pick-up)
|
||||
(set! picked-up #t))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-type)
|
||||
type)
|
||||
|
||||
(define/public (get-pos)
|
||||
pos)
|
||||
|
||||
(define/public (get-size)
|
||||
size)
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define plant-logic%
|
||||
(class game-logic-object%
|
||||
(init-field
|
||||
(id #f)
|
||||
(pos (vector 0 0 0)))
|
||||
|
||||
(field
|
||||
(twigs '()) ; a assoc list map of ages to twigs
|
||||
(properties '()) ; 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))
|
||||
|
||||
(inherit send-message)
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-pos)
|
||||
pos)
|
||||
|
||||
(define/public (get-size)
|
||||
size)
|
||||
|
||||
(define/public (grow dir)
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(send twig grow dir))
|
||||
twigs))
|
||||
|
||||
(define/public (add-property name)
|
||||
(set! properties (cons name properties)))
|
||||
|
||||
; we need to maintain our list of twig ids here, for this plant
|
||||
(define/public (get-next-twig-id)
|
||||
(let ((id next-twig-id))
|
||||
(set! next-twig-id (+ next-twig-id 1))
|
||||
next-twig-id))
|
||||
|
||||
; we need to maintain our list of ornament ids here, for this plant
|
||||
(define/public (get-next-ornament-id)
|
||||
(let ((id next-ornament-id))
|
||||
(set! next-ornament-id (+ next-ornament-id 1))
|
||||
next-ornament-id))
|
||||
|
||||
(define/public (check-pickup pickup)
|
||||
(foldl
|
||||
(lambda (twig found)
|
||||
(if (not found)
|
||||
(send twig check-pickup pickup)
|
||||
#f))
|
||||
#f
|
||||
twigs))
|
||||
|
||||
(define/public (destroy-twig twig)
|
||||
(send-message 'destroy-branch-twig (list
|
||||
(list 'plant-id id)
|
||||
(list 'twig-id (send twig get-id))
|
||||
)))
|
||||
|
||||
; a util to keep a fixed size list of twigs, calling destroy twig when needed.
|
||||
(define (cons-twig thing in count out)
|
||||
(cond
|
||||
((null? in)
|
||||
(cons thing out))
|
||||
((zero? count)
|
||||
(destroy-twig (car in))
|
||||
(cons thing out))
|
||||
(else (cons-twig thing (cdr in) (- count 1) (append out (list (car in)))))))
|
||||
|
||||
(define/public (add-twig twig)
|
||||
(send twig set-id! (get-next-twig-id))
|
||||
(set! size (* size grow-amount))
|
||||
(send twig scale size)
|
||||
(send twig set-branch! #t)
|
||||
(send twig set-pos pos)
|
||||
|
||||
(send-message 'grow-seed (list
|
||||
(list 'plant-id id)
|
||||
(list 'amount grow-amount)))
|
||||
(send-message 'new-branch-twig (list
|
||||
(list 'plant-id id)
|
||||
(list 'twig-id (send twig get-id))
|
||||
(list 'type (send twig get-type))
|
||||
(list 'dir (send twig get-dir))
|
||||
(list 'width (send twig get-width))
|
||||
(list 'num-points (send twig get-num-points))
|
||||
(list 'render-type (send twig get-render-type))
|
||||
))
|
||||
|
||||
(set! twigs (cons-twig twig twigs max-twigs '())))
|
||||
|
||||
|
||||
(define/public (get-random-twig)
|
||||
(if (not (null? twigs))
|
||||
(send (choose twigs) get-random-twig)
|
||||
#f))
|
||||
|
||||
(define/public (get-twig-from-dir dir)
|
||||
(let ((dir (vnormalise dir)))
|
||||
(cadr (foldl
|
||||
(lambda (twig l)
|
||||
(let ((d (vdot (vnormalise (send twig get-dir)) dir)))
|
||||
(if (> d (car l))
|
||||
(list d twig)
|
||||
l)))
|
||||
(list -99 #f)
|
||||
twigs))))
|
||||
|
||||
|
||||
(define/augment (update)
|
||||
; grow a new ornament?
|
||||
(when (and (not (null? properties)) (zero? (random ornament-grow-probability)))
|
||||
(let ((twig (get-random-twig)))
|
||||
(when twig
|
||||
(let
|
||||
((property (choose properties))
|
||||
(point-index (random (send twig get-length))))
|
||||
|
||||
(when (not (eq? property 'curly))
|
||||
(send twig add-ornament point-index
|
||||
(cond
|
||||
((or
|
||||
(eq? property 'leaf)
|
||||
(eq? property 'wiggle))
|
||||
(make-object ornament-logic%
|
||||
(get-next-ornament-id)
|
||||
property
|
||||
this
|
||||
twig
|
||||
point-index))
|
||||
(else
|
||||
(error "property not understood " property)))))))))
|
||||
(map
|
||||
(lambda (twig)
|
||||
(send twig update))
|
||||
twigs))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define game-logic%
|
||||
(class game-logic-object%
|
||||
(field
|
||||
(plants '())
|
||||
(pickups '()))
|
||||
|
||||
(inherit send-message)
|
||||
|
||||
(define/public (setup)
|
||||
(for ((i (in-range 0 num-pickups)))
|
||||
(add-pickup (make-object pickup-logic% i (choose (list 'leaf 'curly 'wiggle))
|
||||
(vmul (srndvec) pickup-dist-radius)))))
|
||||
|
||||
(define/public (add-player plant)
|
||||
(send-message 'player-plant (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'pos (send plant get-pos))))
|
||||
(set! plants (cons plant plants)))
|
||||
|
||||
(define/public (add-plant plant)
|
||||
(send-message 'new-plant (list
|
||||
(list 'plant-id (send plant get-id))
|
||||
(list 'pos (send plant get-pos))
|
||||
(list 'size (send plant get-size))))
|
||||
(set! plants (cons plant plants)))
|
||||
|
||||
(define/public (add-pickup pickup)
|
||||
(send-message 'new-pickup
|
||||
(list
|
||||
(list 'pickup-id (send pickup get-id))
|
||||
(list 'type (send pickup get-type))
|
||||
(list 'pos (send pickup get-pos))))
|
||||
(set! pickups (cons pickup pickups)))
|
||||
|
||||
|
||||
; todo - distribute the checking of stuff like
|
||||
; this to a random selection of pickups/plants
|
||||
; to distribute the cpu load
|
||||
(define/augment (update)
|
||||
(for-each
|
||||
(lambda (pickup)
|
||||
(for-each
|
||||
(lambda (plant)
|
||||
(send plant check-pickup pickup))
|
||||
plants))
|
||||
pickups)
|
||||
|
||||
; remove the pickups that have been 'picked up'
|
||||
(set! pickups (filter
|
||||
(lambda (pickup)
|
||||
(not (send pickup picked-up?)))
|
||||
pickups))
|
||||
|
||||
(map
|
||||
(lambda (plant)
|
||||
(send plant update))
|
||||
plants))
|
||||
|
||||
(super-new)))
|
||||
24
plant-eyes/message.ss
Normal file
24
plant-eyes/message.ss
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class)
|
||||
(provide (all-defined-out))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; a message for sending betwixt logic and view side
|
||||
(define message%
|
||||
(class object%
|
||||
(init-field
|
||||
(name 'none) ; a symbol denoting the type of the message
|
||||
(data '())) ; should be an assoc list map of name to values, eg:
|
||||
; '((name "archibold") (age 53))
|
||||
; shouldn't put logic objects in here - 'raw' data only
|
||||
|
||||
(define/public (get-name)
|
||||
name)
|
||||
|
||||
(define/public (get-data arg-name)
|
||||
(cadr (assoc arg-name data)))
|
||||
|
||||
(define/public (print)
|
||||
(printf "msg: ~a ~a~n" name data))
|
||||
|
||||
(super-new)))
|
||||
41
plant-eyes/ornament-view.ss
Normal file
41
plant-eyes/ornament-view.ss
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
#lang scheme
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define ornament-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(pos (vector 0 0 0))
|
||||
(property 'none)
|
||||
(time 0))
|
||||
|
||||
(field
|
||||
(rot (vmul (rndvec) 360))
|
||||
(root (with-state
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(scale 0.01)
|
||||
(cond
|
||||
((eq? property 'wiggle)
|
||||
; (opacity 1)
|
||||
(hint-depth-sort)
|
||||
(colour (vector 0.5 0.0 0.0))
|
||||
(load-primitive "meshes/wiggle.obj"))
|
||||
((eq? property 'leaf)
|
||||
(colour (vector 0.8 1 0.6))
|
||||
(texture (load-texture "textures/leaf2.png"))
|
||||
(load-primitive "meshes/leaf.obj"))
|
||||
(else (error ""))))))
|
||||
|
||||
(define/public (update t d)
|
||||
(when (< time 1)
|
||||
(with-primitive root
|
||||
(identity)
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(scale (* 0.2 time)))
|
||||
(set! time (+ time (* 0.1 d)))))
|
||||
|
||||
(super-new)))
|
||||
49
plant-eyes/pickup-view.ss
Normal file
49
plant-eyes/pickup-view.ss
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class fluxus-016/drflux "common.ss" "message.ss" "list-utils.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define pickup-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(id -1)
|
||||
(type 'none)
|
||||
(pos (vector 0 0 0)))
|
||||
|
||||
(field
|
||||
(rot (vmul (rndvec) 360))
|
||||
(root (with-state
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(colour (pickup-colour))
|
||||
(scale 0.3)
|
||||
(texture
|
||||
(cond
|
||||
((eq? type 'wiggle) (load-texture "textures/wiggle.png"))
|
||||
((eq? type 'leaf) (load-texture "textures/leaf.png"))
|
||||
((eq? type 'curly) (load-texture "textures/curl.png"))))
|
||||
(load-primitive "meshes/pickup.obj")))
|
||||
(from pos)
|
||||
(destination (vector 0 0 0))
|
||||
(speed 0.05)
|
||||
(t -1))
|
||||
|
||||
(define/public (pick-up)
|
||||
(destroy root))
|
||||
|
||||
(define/public (move-to s)
|
||||
(set! t 0)
|
||||
(set! from pos)
|
||||
(set! destination s))
|
||||
|
||||
(define/public (update t d)
|
||||
(with-primitive root
|
||||
(rotate (vector (* d 10) 0 0)))
|
||||
#;(when (and (>= t 0) (< t 1))
|
||||
(set! pos (vadd pos (vmul (vsub destination from) speed)))
|
||||
(with-primitive root
|
||||
(identity)
|
||||
(translate pos)
|
||||
(rotate rot))
|
||||
(set! t (+ t speed))))
|
||||
|
||||
(super-new)))
|
||||
File diff suppressed because it is too large
Load diff
649
plant-eyes/view.ss
Normal file
649
plant-eyes/view.ss
Normal file
|
|
@ -0,0 +1,649 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class fluxus-016/drflux "message.ss" "list-utils.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 audio-on #f)
|
||||
|
||||
(define (ornament-colour) (vector 0.5 1 0.4))
|
||||
(define (pickup-colour) (vector 1 1 1))
|
||||
(define (earth-colour) (vector 0.2 0.1 0))
|
||||
|
||||
(define wire-mode #f)
|
||||
(define fog-col (earth-colour))
|
||||
(define fog-strength 0.001)
|
||||
(define max-ornaments 2) ; per twig
|
||||
(define default-grow-speed 2)
|
||||
|
||||
(when audio-on (oa-start)) ;; start openAL audio
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define ornament-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(pos (vector 0 0 0))
|
||||
(property 'none)
|
||||
(time 0))
|
||||
|
||||
(field
|
||||
(rot (vmul (rndvec) 360))
|
||||
(root (with-state
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(scale 0.01)
|
||||
(cond
|
||||
((eq? property 'wiggle)
|
||||
; (opacity 1)
|
||||
(hint-depth-sort)
|
||||
(colour (vector 0.5 0.0 0.0))
|
||||
(load-primitive "meshes/wiggle.obj"))
|
||||
((eq? property 'leaf)
|
||||
(colour (vector 0.8 1 0.6))
|
||||
(texture (load-texture "textures/leaf2.png"))
|
||||
(load-primitive "meshes/leaf.obj"))
|
||||
(else (error ""))))))
|
||||
|
||||
(define/public (update t d)
|
||||
(when (< time 1)
|
||||
(with-primitive root
|
||||
(identity)
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(scale (* 0.2 time)))
|
||||
(set! time (+ time (* 0.1 d)))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define pickup-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(id -1)
|
||||
(type 'none)
|
||||
(pos (vector 0 0 0)))
|
||||
|
||||
(field
|
||||
(rot (vmul (rndvec) 360))
|
||||
(root (with-state
|
||||
(translate pos)
|
||||
(rotate rot)
|
||||
(colour (pickup-colour))
|
||||
(scale 0.3)
|
||||
(texture
|
||||
(cond
|
||||
((eq? type 'wiggle) (load-texture "textures/wiggle.png"))
|
||||
((eq? type 'leaf) (load-texture "textures/leaf.png"))
|
||||
((eq? type 'curly) (load-texture "textures/curl.png"))))
|
||||
(load-primitive "meshes/pickup.obj")))
|
||||
(from pos)
|
||||
(destination (vector 0 0 0))
|
||||
(speed 0.05)
|
||||
(t -1))
|
||||
|
||||
(define/public (pick-up)
|
||||
(destroy root))
|
||||
|
||||
(define/public (move-to s)
|
||||
(set! t 0)
|
||||
(set! from pos)
|
||||
(set! destination s))
|
||||
|
||||
(define/public (update t d)
|
||||
(with-primitive root
|
||||
(rotate (vector (* d 10) 0 0)))
|
||||
#;(when (and (>= t 0) (< t 1))
|
||||
(set! pos (vadd pos (vmul (vsub destination from) speed)))
|
||||
(with-primitive root
|
||||
(identity)
|
||||
(translate pos)
|
||||
(rotate rot))
|
||||
(set! t (+ t speed))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define twig-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(id 0)
|
||||
(pos (vector 0 0 0))
|
||||
(type 'none)
|
||||
(dir (vector 0 1 0))
|
||||
(radius 1)
|
||||
(num-points 0))
|
||||
|
||||
(field
|
||||
(index 0)
|
||||
(parent-twig-id -1)
|
||||
(child-twig-ids '())
|
||||
(ornaments '()))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-dir)
|
||||
dir)
|
||||
|
||||
(define/public (build)
|
||||
0)
|
||||
|
||||
(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 (add-child-twig-id twig-id)
|
||||
(set! child-twig-ids (cons twig-id child-twig-ids)))
|
||||
|
||||
(define/pubment (grow point width)
|
||||
(when audio-on (let ((growing-noise (oa-load-sample (fullpath "snd/event01.wav"))))
|
||||
(oa-play growing-noise (vector 0 0 0) (rndf) 0.3)))
|
||||
(inner (void) grow point width))
|
||||
|
||||
(define/public (add-ornament point-index property)
|
||||
(when (< (length ornaments) max-ornaments)
|
||||
(with-state
|
||||
(parent (get-root))
|
||||
; todo - different ornament-view objects per property needed?
|
||||
; todo - delete existing ornaments here
|
||||
(set! ornaments (cons (list point-index
|
||||
(make-object ornament-view%
|
||||
(get-point point-index)
|
||||
property))
|
||||
ornaments)))))
|
||||
|
||||
(define/pubment (update t d)
|
||||
(for-each
|
||||
(lambda (ornament)
|
||||
(send (cadr ornament) update t d))
|
||||
ornaments)
|
||||
|
||||
(inner (void) update t d))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define ribbon-twig-view%
|
||||
(class twig-view%
|
||||
|
||||
(inherit-field pos radius num-points index)
|
||||
|
||||
(field
|
||||
(root 0))
|
||||
|
||||
(define/override (build)
|
||||
(set! root (let ((p (with-state
|
||||
(translate pos)
|
||||
(colour (vector 0.8 1 0.6))
|
||||
(texture (load-texture "textures/root.png"))
|
||||
(build-ribbon num-points))))
|
||||
(with-primitive p
|
||||
(pdata-map!
|
||||
(lambda (w)
|
||||
0)
|
||||
"w")
|
||||
(pdata-set! "w" 0 radius))
|
||||
p)))
|
||||
|
||||
|
||||
(define/override (get-root)
|
||||
root)
|
||||
|
||||
(define/override (get-point point-index)
|
||||
(with-primitive root
|
||||
(pdata-ref "p" point-index)))
|
||||
|
||||
(define/augment (grow point width)
|
||||
(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"))
|
||||
(set! index (+ index 1)))
|
||||
|
||||
(define/augment (update t d)
|
||||
0)
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define extruded-twig-view%
|
||||
(class twig-view%
|
||||
|
||||
(inherit-field index radius num-points pos dir)
|
||||
|
||||
(field
|
||||
(profile '())
|
||||
(path '())
|
||||
(root 0)
|
||||
(grow-speed default-grow-speed)
|
||||
(anim-t 0)
|
||||
(widths '()))
|
||||
|
||||
(define/override (build)
|
||||
(set! profile (build-circle-profile 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
|
||||
(backfacecull 0)
|
||||
(when wire-mode
|
||||
(hint-none)
|
||||
(hint-wire))
|
||||
(texture (load-texture "textures/root2.png"))
|
||||
;(opacity 0.6)
|
||||
(colour (vmul (vector 0.8 1 0.6) 2))
|
||||
#;(colour (vector 1 1 1))
|
||||
#;(texture (load-texture "textures/root.png"))
|
||||
(build-partial-extrusion profile path 3))))
|
||||
p)))
|
||||
|
||||
(define/override (get-root)
|
||||
root)
|
||||
|
||||
(define/override (get-point point-index)
|
||||
(list-ref path point-index))
|
||||
|
||||
(define (list-set l c s)
|
||||
(cond ((null? l) '())
|
||||
((zero? c) (cons s (list-set (cdr l) (- c 1) s)))
|
||||
(else (cons (car l) (list-set (cdr l) (- c 1) s)))))
|
||||
|
||||
(define/augment (grow point width)
|
||||
(set! path (list-set path index point))
|
||||
(set! widths (list-set widths index width))
|
||||
(set! anim-t 0)
|
||||
(set! index (+ index 1)))
|
||||
|
||||
(define/augment (update t d)
|
||||
(when (< anim-t 1)
|
||||
(with-primitive root
|
||||
(partial-extrude (+ (- index 2) anim-t)
|
||||
profile path widths (vector 1 0 0) 0.05)))
|
||||
(set! anim-t (+ anim-t (* d grow-speed))))
|
||||
|
||||
(define/public (get-end-pos)
|
||||
(with-primitive root (pdata-ref "p" (- (* index (length profile)) 1))))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define plant-view%
|
||||
(class object%
|
||||
|
||||
(init-field
|
||||
(id "none")
|
||||
(pos (vector 0 0 0))
|
||||
(size 0))
|
||||
|
||||
(field
|
||||
(twigs '()) ; a assoc list map between ids and twigs stored flat here,
|
||||
; for fast access, but prims heirachically in the scenegraph
|
||||
(root (with-state
|
||||
(translate pos)
|
||||
(build-locator)))
|
||||
(seed (with-state
|
||||
(parent root)
|
||||
(texture (load-texture "textures/root2.png"))
|
||||
(backfacecull 0)
|
||||
(opacity 0.6)
|
||||
(colour (vector 0.8 1 0.6))
|
||||
(hint-depth-sort)
|
||||
(scale (* 0.12 size))
|
||||
(when wire-mode
|
||||
(hint-none)
|
||||
(hint-wire))
|
||||
;(hint-unlit)
|
||||
(load-primitive "meshes/seed.obj"))))
|
||||
|
||||
(define/public (get-id)
|
||||
id)
|
||||
|
||||
(define/public (get-twig twig-id)
|
||||
(let ((l (assq twig-id twigs)))
|
||||
(if l
|
||||
(cadr (assq twig-id twigs))
|
||||
#f)))
|
||||
|
||||
(define/public (add-branch-twig twig)
|
||||
; attach to seed
|
||||
(with-primitive (send twig get-root)
|
||||
(parent root))
|
||||
(send twig build)
|
||||
(set! twigs (cons (list (send twig get-id) twig) twigs)))
|
||||
|
||||
(define/public (destroy-branch-twig twig-id)
|
||||
(for-each
|
||||
(lambda (twig-id)
|
||||
(destroy-branch-twig twig-id))
|
||||
(send (get-twig twig-id) get-child-twig-ids))
|
||||
(send (get-twig twig-id) destroy-twig)
|
||||
(set! twigs (assoc-remove twig-id twigs)))
|
||||
|
||||
(define/public (add-twig parent-twig-id point-index twig)
|
||||
(let ((ptwig (get-twig parent-twig-id)))
|
||||
; attach to parent twig
|
||||
(send twig set-pos! (send ptwig get-point point-index))
|
||||
(send twig build)
|
||||
(with-primitive (send twig get-root)
|
||||
(parent (send ptwig get-root)))
|
||||
|
||||
|
||||
; tell the twigs about this relationship (might turn out to be overkill)
|
||||
(send ptwig add-child-twig-id (send twig get-id))
|
||||
(send twig set-parent-twig-id parent-twig-id)
|
||||
|
||||
(set! twigs (cons (list (send twig get-id) twig) twigs))))
|
||||
|
||||
(define/public (grow-twig twig-id point width)
|
||||
(send (get-twig twig-id) grow point width))
|
||||
|
||||
(define/public (grow-seed amount)
|
||||
(with-primitive seed (scale amount)))
|
||||
|
||||
(define/public (add-ornament twig-id point-index property)
|
||||
(send (get-twig twig-id) add-ornament point-index property))
|
||||
|
||||
(define/public (update t d)
|
||||
|
||||
(with-primitive seed
|
||||
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
|
||||
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(send (cadr twig) update t d))
|
||||
twigs))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define (build-env-box top bottom left right front back lower)
|
||||
(let ((p (build-locator)))
|
||||
(with-state
|
||||
(parent p)
|
||||
(hint-unlit)
|
||||
|
||||
(let ((t (with-state
|
||||
(texture (load-texture top))
|
||||
(translate (vector 0 0.5 0))
|
||||
(rotate (vector 90 0 0))
|
||||
(build-plane))))
|
||||
(when lower (with-primitive t
|
||||
(pdata-map!
|
||||
(lambda (t)
|
||||
(vmul t 10))
|
||||
"t"))))
|
||||
|
||||
(with-state
|
||||
(texture (load-texture left))
|
||||
(translate (vector 0 0 -0.5))
|
||||
(rotate (vector 0 0 0))
|
||||
(build-plane))
|
||||
|
||||
(with-state
|
||||
(texture (load-texture back))
|
||||
(translate (vector 0.5 0 0))
|
||||
(rotate (vector 0 90 0))
|
||||
(build-plane))
|
||||
|
||||
(with-state
|
||||
(texture (load-texture right))
|
||||
(translate (vector 0 0 0.5))
|
||||
(rotate (vector 0 0 0))
|
||||
(build-plane))
|
||||
|
||||
(with-state
|
||||
(texture (load-texture front))
|
||||
(translate (vector -0.5 0 0))
|
||||
(rotate (vector 0 90 0))
|
||||
(build-plane))
|
||||
|
||||
(when lower
|
||||
(with-state
|
||||
(texture (load-texture bottom))
|
||||
(translate (vector 0 -0.5 0))
|
||||
(rotate (vector 90 0 0))
|
||||
(build-plane)))
|
||||
|
||||
p)))
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(define game-view%
|
||||
(class object%
|
||||
|
||||
(field
|
||||
(plants '()) ; map of ids -> plants
|
||||
(pickups '()) ; map of ids -> pickups
|
||||
(camera-dist 1)
|
||||
(env-root (with-state (scale 1000) (build-locator)))
|
||||
(root-camera-t 0)
|
||||
#;(upper-env (with-state
|
||||
(parent env-root)
|
||||
(hint-depth-sort)
|
||||
(colour 2)
|
||||
(translate (vector 0 0.28 0))
|
||||
(build-env-box "textures/top.png" "textures/bottom-trans.png"
|
||||
"textures/left.png" "textures/right.png"
|
||||
"textures/front.png" "textures/back.png")))
|
||||
#;(lower-env (with-state
|
||||
(parent env-root)
|
||||
(hint-depth-sort)
|
||||
(translate (vector 0 -0.22001 0))
|
||||
(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
|
||||
(parent env-root)
|
||||
;(hint-depth-sort)
|
||||
(hint-unlit)
|
||||
(translate (vector 0 0.28 0))
|
||||
(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
|
||||
(parent env-root)
|
||||
;(hint-depth-sort)
|
||||
(hint-unlit)
|
||||
(colour (earth-colour))
|
||||
(translate (vector 0 -0.22001 0))
|
||||
(build-env-box "textures/floor.png" "textures/earth-bottom.png"
|
||||
"textures/earth-side.png" "textures/earth-side.png"
|
||||
"textures/earth-side.png" "textures/earth-side.png" #t)))
|
||||
(nutrients (let ((p (with-state
|
||||
(hint-depth-sort)
|
||||
(texture (load-texture "textures/particle.png"))
|
||||
(build-particles 5000))))
|
||||
(with-primitive p
|
||||
(pdata-map!
|
||||
(lambda (p)
|
||||
(vmul (vadd (crndvec) (vector 0 -1 0)) 900))
|
||||
"p")
|
||||
(pdata-map!
|
||||
(lambda (s)
|
||||
(vector 1 1 1))
|
||||
"s"))
|
||||
p)))
|
||||
|
||||
(define/public (setup)
|
||||
(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)
|
||||
(clip 0.5 10000)
|
||||
(fog fog-col fog-strength 1 100))
|
||||
|
||||
(define/public (add-plant plant)
|
||||
(set! plants (cons (list (send plant get-id) plant) plants)))
|
||||
|
||||
(define/public (get-plant plant-id)
|
||||
(cadr (assq plant-id plants)))
|
||||
|
||||
(define/public (add-branch-twig plant-id twig)
|
||||
(send (get-plant plant-id) add-branch-twig twig))
|
||||
|
||||
(define/public (destroy-branch-twig plant-id twig-id)
|
||||
(send (get-plant plant-id) destroy-branch-twig twig-id))
|
||||
|
||||
(define/public (add-twig plant-id parent-twig-id point-index twig)
|
||||
(send (get-plant plant-id) add-twig parent-twig-id point-index twig))
|
||||
|
||||
(define/public (grow-seed plant-id amount)
|
||||
(send (get-plant plant-id) grow-seed amount))
|
||||
|
||||
(define/public (get-pickup pickup-id)
|
||||
(cadr (assq pickup-id pickups)))
|
||||
|
||||
(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 (pick-up-pickup pickup-id)
|
||||
(send (get-pickup pickup-id) pick-up)
|
||||
(set! pickups (assoc-remove pickup-id pickups)))
|
||||
|
||||
(define/public (add-ornament plant-id twig-id point-index property)
|
||||
(send (get-plant plant-id) add-ornament twig-id point-index property))
|
||||
|
||||
(define/public (update t d messages)
|
||||
|
||||
(for-each
|
||||
(lambda (plant)
|
||||
(send (cadr plant) update t d))
|
||||
plants)
|
||||
|
||||
(for-each
|
||||
(lambda (pickup)
|
||||
(send (cadr pickup) update t d))
|
||||
pickups)
|
||||
|
||||
(when debug-messages
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(send msg print))
|
||||
messages))
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
(cond
|
||||
((eq? (send msg get-name) 'player-plant) ; not really any difference now
|
||||
(add-plant (make-object plant-view%
|
||||
(send msg get-data 'plant-id)
|
||||
(send msg get-data 'pos)
|
||||
(send msg get-data 'size))))
|
||||
|
||||
((eq? (send msg get-name) 'new-plant)
|
||||
(add-plant (make-object plant-view%
|
||||
(send msg get-data 'plant-id)
|
||||
(send msg get-data 'pos))))
|
||||
|
||||
((eq? (send msg get-name) 'grow-seed)
|
||||
(grow-seed (send msg get-data 'plant-id)
|
||||
(send msg get-data 'amount)))
|
||||
|
||||
((eq? (send msg get-name) 'destroy-branch-twig)
|
||||
(destroy-branch-twig (send msg get-data 'plant-id) (send msg get-data 'twig-id)))
|
||||
|
||||
((eq? (send msg get-name) 'new-branch-twig)
|
||||
(add-branch-twig (send msg get-data 'plant-id)
|
||||
(cond
|
||||
((eq? (send msg get-data 'render-type) 'ribbon)
|
||||
(make-object ribbon-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0)
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points)))
|
||||
|
||||
((eq? (send msg get-data 'render-type) 'extruded)
|
||||
(make-object extruded-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0)
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points))))))
|
||||
|
||||
((eq? (send msg get-name) 'new-twig)
|
||||
(add-twig (send msg get-data 'plant-id)
|
||||
(send msg get-data 'parent-twig-id)
|
||||
(send msg get-data 'point-index)
|
||||
(cond
|
||||
((eq? (send msg get-data 'render-type) 'ribbon)
|
||||
(make-object ribbon-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0) ; will be filled in by add-twig
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points)))
|
||||
|
||||
((eq? (send msg get-data 'render-type) 'extruded)
|
||||
(make-object extruded-twig-view%
|
||||
(send msg get-data 'twig-id)
|
||||
(vector 0 0 0) ; will be filled in by add-twig
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'dir)
|
||||
(send msg get-data 'width)
|
||||
(send msg get-data 'num-points))))))
|
||||
|
||||
((eq? (send msg get-name) 'twig-grow)
|
||||
(send (get-plant (send msg get-data 'plant-id)) grow-twig
|
||||
(send msg get-data 'twig-id)
|
||||
(send msg get-data 'point)
|
||||
(send msg get-data 'width)))
|
||||
|
||||
((eq? (send msg get-name) 'new-pickup)
|
||||
(add-pickup
|
||||
(send msg get-data 'pickup-id)
|
||||
(send msg get-data 'type)
|
||||
(send msg get-data 'pos)))
|
||||
|
||||
((eq? (send msg get-name) 'pick-up-pickup)
|
||||
(pick-up-pickup
|
||||
(send msg get-data 'pickup-id)))
|
||||
|
||||
((eq? (send msg get-name) 'new-ornament)
|
||||
(add-ornament
|
||||
(send msg get-data 'plant-id)
|
||||
(send msg get-data 'twig-id)
|
||||
(send msg get-data 'point-index)
|
||||
(send msg get-data 'property)))
|
||||
|
||||
))
|
||||
messages))
|
||||
|
||||
|
||||
|
||||
|
||||
(super-new)))
|
||||
421
plant-eyes/xmpp.ss
Normal file
421
plant-eyes/xmpp.ss
Normal file
|
|
@ -0,0 +1,421 @@
|
|||
;;; A basic XMPP library which should conform to RFCs 3920 and 3921
|
||||
;;;
|
||||
;;; Copyright (C) 2009 FoAM vzw.
|
||||
;;;
|
||||
;;; This package is free software: you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;; License as published by the Free Software Foundation, either
|
||||
;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;;
|
||||
;;; You can find a copy of the GNU Lesser General Public License at
|
||||
;;; http://www.gnu.org/licenses/lgpl-3.0.html.
|
||||
;;;
|
||||
;;; Authors
|
||||
;;;
|
||||
;;; nik gaffney <nik@fo.am>
|
||||
;;;
|
||||
;;; Requirements
|
||||
;;;
|
||||
;;; PLT for now. TLS requires a version of PLT > 4.1.5.3
|
||||
;;;
|
||||
;;; Commentary
|
||||
;;;
|
||||
;;; Still a long way from implementing even a minimal subset of XMPP
|
||||
;;;
|
||||
;;; features implemented
|
||||
;;; - plaintext sessions on port 5222
|
||||
;;; - "old sytle" ssl sessions on port 5223 (default)
|
||||
;;; - authenticate using an existing account
|
||||
;;; - send messages (rfc 3921 sec.4)
|
||||
;;; - send presence (rfc 3921 sec.5)
|
||||
;;; - parse (some) xml reponses from server
|
||||
;;; - handlers for responses
|
||||
;;; - basic roster handling (rfc 3921 sec.7)
|
||||
;;;
|
||||
;;; features to implement
|
||||
;;; - account creation
|
||||
;;; - managing subscriptions & rosters (rfc 3921 sec.6 & 8)
|
||||
;;; - error handling for rosters (rfc 3921 sec.7)
|
||||
;;; - plaintext/tls/sasl negotiation (rfc 3920 sec.5 & 6)
|
||||
;;; - encrypted connections using tls on port 5222
|
||||
;;; - correct namespaces in sxml
|
||||
;;; - message types
|
||||
;;; - maintain session ids
|
||||
;;; - maintain threads
|
||||
;;; - error handling
|
||||
;;; - events
|
||||
;;; - [...]
|
||||
;;; - rfc 3920
|
||||
;;; - rfc 3921
|
||||
;;;
|
||||
;;; bugs and/or improvements
|
||||
;;; - start & stop functions for multiple sessions
|
||||
;;; - pubsub (XEP-0060) & group chats (XEP-0045)
|
||||
;;; - 'send' using call/cc & parameterize'd i/o ports
|
||||
;;; - coroutines for sasl negotiation
|
||||
;;; - read-async & repsonse-handler
|
||||
;;; - ssax:xml->sxml or lazy:xml->sxml
|
||||
;;; - default handlers
|
||||
;;; - syntax for defining sxpath based handlers
|
||||
;;; - improve parsing
|
||||
;;; - chatbot exmples
|
||||
;;;
|
||||
|
||||
(module xmpp scheme
|
||||
|
||||
(require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
|
||||
(require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
|
||||
(require mzlib/os) ;; hostname
|
||||
(require scheme/tcp) ;; networking
|
||||
(require openssl) ;; ssl/tls
|
||||
(require srfi/13) ;; jid decoding
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
;;;; ; ;; ;
|
||||
;;
|
||||
;; debugging
|
||||
;;
|
||||
;;;; ; ;
|
||||
|
||||
(define debug? #t)
|
||||
|
||||
(define debugf
|
||||
(case-lambda
|
||||
((str) (when debug? (printf str)))
|
||||
((str . dir) (when debug? (apply printf (cons str dir))))))
|
||||
|
||||
;;;;;;;;;;; ; ;;;; ; ;;; ; ; ;; ;
|
||||
;;
|
||||
;; networking
|
||||
;;
|
||||
;;;;;; ;; ;; ; ; ; ;
|
||||
|
||||
(define port 5222)
|
||||
(define ssl-port 5223)
|
||||
|
||||
(define (open-connection machine port handler)
|
||||
(let-values (((in out)
|
||||
(tcp-connect machine port)))
|
||||
(handler in out)
|
||||
(close-output-port out)
|
||||
(close-input-port in)))
|
||||
|
||||
(define (open-ssl-connection machine port handler)
|
||||
(let-values (((in out)
|
||||
(ssl-connect machine port 'tls)))
|
||||
(handler in out)
|
||||
(close-output-port out)
|
||||
(close-input-port in)))
|
||||
|
||||
(define (read-async in)
|
||||
(bytes->string/utf-8 (list->bytes (read-async-bytes in))))
|
||||
|
||||
(define (read-async-bytes in)
|
||||
(let ((bstr '()))
|
||||
(when (sync/timeout 0 in)
|
||||
(set! bstr (cons (read-byte in) (read-async-bytes in)))) bstr))
|
||||
|
||||
(define ssxml srl:sxml->xml-noindent)
|
||||
|
||||
;;;;;; ; ; ; ; ;; ;;;;;; ;
|
||||
;;
|
||||
;; XMPP stanzas
|
||||
;;
|
||||
;;;;;;;;;; ;;; ; ;; ; ;
|
||||
|
||||
;; intialization
|
||||
(define (xmpp-stream host)
|
||||
(string-append "<?xml version='1.0'?>" ;; version='1.0' is a MUST for SASL on 5222 but NOT for ssl on 5223
|
||||
"<stream:stream xmlns:stream='http://etherx.jabber.org/streams' to='"
|
||||
host
|
||||
"' xmlns='jabber:client' >"))
|
||||
|
||||
;; authentication
|
||||
(define (xmpp-auth username password resource)
|
||||
(ssxml `(iq (@ (type "set") (id "auth"))
|
||||
(query (@ (xmlns "jabber:iq:auth"))
|
||||
(username ,username)
|
||||
(password ,password)
|
||||
(resource ,resource)))))
|
||||
|
||||
(define (xmpp-session host)
|
||||
(ssxml `(iq (@ (to ,host) (type "set") (id "session"))
|
||||
(session (@ (xmlns "urn:ietf:params:xml:ns:xmpp-session"))))))
|
||||
|
||||
;; messages
|
||||
(define (message to body)
|
||||
(ssxml `(message (@ (to ,to)) (body ,body))))
|
||||
|
||||
;; presence
|
||||
(define (presence #:from (from "")
|
||||
#:to (to "")
|
||||
#:type (type "")
|
||||
#:show (show "")
|
||||
#:status (status ""))
|
||||
(cond ((not (string=? status ""))
|
||||
(ssxml `(presence (@ (type "probe")) (status ,status))))
|
||||
((string=? type "") "<presence/>")
|
||||
(else (ssxml `(presence (@ (type ,type)))))))
|
||||
|
||||
;; queries
|
||||
(define (iq body
|
||||
#:from (from "")
|
||||
#:to (to "")
|
||||
#:type (type "")
|
||||
#:id (id ""))
|
||||
(ssxml `(iq (@ (to ,to) (type ,type) ,body))))
|
||||
|
||||
;; curried stanza disection (sxml stanza -> string)
|
||||
(define ((sxpath-element xpath (ns "")) stanza)
|
||||
(let ((node ((sxpath xpath (list (cons 'ns ns))) stanza)))
|
||||
(if (empty? node) "" (car node))))
|
||||
|
||||
;; message
|
||||
(define message-from (sxpath-element "message/@from/text()"))
|
||||
(define message-to (sxpath-element "message/@to/text()"))
|
||||
(define message-id (sxpath-element "message/@id/text()"))
|
||||
(define message-type (sxpath-element "message/@type/text()"))
|
||||
(define message-body (sxpath-element "message/body/text()"))
|
||||
(define message-subject (sxpath-element "message/subject/text()"))
|
||||
|
||||
;; info/query
|
||||
(define iq-type (sxpath-element "iq/@type/text()"))
|
||||
(define iq-id (sxpath-element "iq/@id/text()"))
|
||||
(define iq-error-type (sxpath-element "iq/error/@type/text()"))
|
||||
(define iq-error-text (sxpath-element "iq/error/text()"))
|
||||
(define iq-error (sxpath-element "iq/error"))
|
||||
|
||||
;; presence
|
||||
(define presence-show (sxpath-element "presence/show/text()"))
|
||||
(define presence-from (sxpath-element "presence/@from/text()"))
|
||||
(define presence-status (sxpath-element "presence/status/text()"))
|
||||
|
||||
|
||||
;;;;;;;;;; ; ; ; ;; ;
|
||||
;;
|
||||
;; rosters
|
||||
;;
|
||||
;;;;;; ; ;; ;
|
||||
|
||||
;; request the roster from server
|
||||
(define (request-roster from)
|
||||
(ssxml `(iq (@ (from ,from) (type "get") (id "roster_1"))
|
||||
(query (@ (xmlns "jabber:iq:roster"))))))
|
||||
|
||||
;; add an item to the roster
|
||||
(define (add-to-roster from jid name group)
|
||||
(ssxml `(iq (@ (from ,from) (type "set") (id "roster_2"))
|
||||
(query (@ (xmlns "jabber:iq:roster"))
|
||||
(item (@ (jid ,jid) (name ,name))
|
||||
(group ,group))))))
|
||||
|
||||
;; update an item in the roster
|
||||
(define (update-roster from jid name group)
|
||||
(ssxml `(iq (@ (from ,from) (type "set") (id "roster_3"))
|
||||
(query (@ (xmlns "jabber:iq:roster"))
|
||||
(item (@ (jid ,jid) (name ,name))
|
||||
(group ,group))))))
|
||||
|
||||
;; remove an item from the roster
|
||||
(define (remove-from-roster from jid)
|
||||
(ssxml `(iq (@ (from ,from) (type "set") (id "roster_4"))
|
||||
(query (@ (xmlns "jabber:iq:roster"))
|
||||
(item (@ (jid ,jid) (subscription "remove")))))))
|
||||
|
||||
|
||||
;;;;; ; ; ;; ; ;
|
||||
;;
|
||||
;; in-band registration
|
||||
;;
|
||||
;;;;;; ;; ;; ;
|
||||
|
||||
(define (reg1)
|
||||
(ssxml `(iq (@ (type "get") (id "reg1"))
|
||||
(query (@ (xmlns "jabber:iq:register"))))))
|
||||
|
||||
;;;; ;; ; ;;; ;
|
||||
;;
|
||||
;; tls & sasl
|
||||
;; - http://xmpp.org/rfcs/rfc3920.html#tls
|
||||
;; - http://xmpp.org/rfcs/rfc3920.html#sasl
|
||||
;;
|
||||
;;;; ;;
|
||||
|
||||
(define session->tls? #f) ;; changes state when a tls proceed is recived
|
||||
|
||||
;; moved to xmpp-sasl until it 'works'
|
||||
|
||||
|
||||
;;;;;;;;; ; ;; ; ; ;; ;; ; ;
|
||||
;;
|
||||
;; parsing & message/iq/error handlers
|
||||
;; - minimal parsing
|
||||
;; - handlers match on a tag (eg. 'message)
|
||||
;; - handlers are called with a single relevant xmpp stanza
|
||||
;;
|
||||
;;;;;; ;; ; ; ;; ;
|
||||
|
||||
(define xmpp-handlers (make-hash)) ;; a hash of tags and functions (possibly extend to using sxpaths and multiple handlers)
|
||||
|
||||
(define (set-xmpp-handler type fcn)
|
||||
(dict-set! xmpp-handlers type fcn))
|
||||
|
||||
(define (remove-xmpp-handler type fcn)
|
||||
(dict-remove! xmpp-handlers type fcn))
|
||||
|
||||
(define (run-xmpp-handler type sz)
|
||||
(let ((fcn (dict-ref xmpp-handlers type #f)))
|
||||
(when fcn (begin
|
||||
(debugf "attempting to run handler ~a.~%" fcn)
|
||||
(fcn sz)))))
|
||||
|
||||
;; no real parsing yet. dispatches any received xml stanzas as sxml
|
||||
|
||||
(define (parse-xmpp-response str)
|
||||
(when (> (string-length str) 0)
|
||||
(let ((sz (ssax:xml->sxml (open-input-string (clean str)) '())))
|
||||
;;(let ((sz (lazy:xml->sxml (open-input-string str) '())))
|
||||
(cond
|
||||
((equal? '(null) (cadr sz))
|
||||
(newline))
|
||||
((equal? 'message (caadr sz))
|
||||
(run-xmpp-handler 'message sz))
|
||||
((equal? 'iq (caadr sz))
|
||||
(run-xmpp-handler 'iq sz))
|
||||
((equal? 'presence (caadr sz))
|
||||
(run-xmpp-handler 'presence sz))
|
||||
(else (run-xmpp-handler 'other sz))))))
|
||||
|
||||
;; example handlers to print stanzas or their contents
|
||||
(define (print-message sz)
|
||||
(printf "a ~a message from ~a which says '~a.'~%" (message-type sz) (message-from sz) (message-body sz)))
|
||||
|
||||
(define (print-iq sz)
|
||||
(printf "an iq response of type '~a' with id '~a.'~%" (iq-type sz) (iq-id sz)))
|
||||
|
||||
(define (print-presence sz)
|
||||
(printf " p-r-e-s-e-n-e-c--> ~a is ~a" (presence-from sz) (presence-status)))
|
||||
|
||||
(define (print-stanza sz)
|
||||
(printf "? ?? -> ~%~a~%" sz))
|
||||
|
||||
;; handler to print roster
|
||||
|
||||
(define (roster-jids sz)
|
||||
((sxpath "iq/ns:query/ns:item/@jid/text()" '(( ns . "jabber:iq:roster"))) sz))
|
||||
|
||||
(define (roster-items sz)
|
||||
((sxpath-element "iq/ns:query/ns:item" '(( ns . "jabber:iq:roster"))) sz))
|
||||
|
||||
(define (print-roster sz)
|
||||
(when (and (string=? (iq-type sz) "result")
|
||||
(string=? (iq-id sz) "roster_1"))
|
||||
(printf "~a~%" (roster-jids sz))))
|
||||
|
||||
;; QND hack to filter out anything not a message, iq or presence
|
||||
(define (clean str)
|
||||
(let ((test (substring str 0 3)))
|
||||
(cond ((string-ci=? test "<me") str)
|
||||
((string-ci=? test "<iq") str)
|
||||
((string-ci=? test "<pr") str)
|
||||
((string-ci=? test "<ur") str)
|
||||
(else
|
||||
(debugf "~%recieved: ~a ~%parsed as <null/>~%~%" str)
|
||||
"<null/>"))))
|
||||
|
||||
|
||||
;; response handler
|
||||
(define (xmpp-response-handler in)
|
||||
(thread (lambda ()
|
||||
(let loop ()
|
||||
(parse-xmpp-response (read-async in))
|
||||
(sleep 0.1) ;; slight delay to avoid a tight loop
|
||||
(loop)))))
|
||||
|
||||
;; jid splicing (assuming the jid is in the format user@host/resource)
|
||||
(define (jid-user jid)
|
||||
(string-take jid (string-index jid #\@)))
|
||||
|
||||
(define (jid-host jid)
|
||||
(let* ((s (string-take-right jid (- (string-length jid) (string-index jid #\@) 1)))
|
||||
(v (string-index s #\/)))
|
||||
(if v (string-take s v) s )))
|
||||
|
||||
(define (jid-resource jid)
|
||||
(let ((r (jid-resource-0 jid)))
|
||||
(if (void? r) (gethostname) r)))
|
||||
|
||||
(define (jid-resource-0 jid)
|
||||
(let ((v (string-index jid #\/)))
|
||||
(when v (string-take-right jid (- (string-length jid) v 1)))))
|
||||
|
||||
|
||||
;;;; ;; ; ; ;; ;; ;;;; ;
|
||||
;;
|
||||
;; interfaces
|
||||
;;
|
||||
;;;;; ;; ;;;; ; ;; ;
|
||||
|
||||
(define xmpp-in-port (make-parameter #f))
|
||||
(define xmpp-out-port (make-parameter #F))
|
||||
|
||||
(define (send str)
|
||||
(debugf "sending: ~a ~%~%" str)
|
||||
(let* ((p-out (xmpp-out-port))
|
||||
(out (if p-out p-out xmpp-out-port-v)))
|
||||
(fprintf out "~A~%" str) (flush-output out)))
|
||||
|
||||
(define-syntax with-xmpp-session
|
||||
(syntax-rules ()
|
||||
((_ jid pass form . forms)
|
||||
(let ((host (jid-host jid))
|
||||
(user (jid-user jid))
|
||||
(resource (jid-resource jid)))
|
||||
(let-values (((in out)
|
||||
(ssl-connect host ssl-port 'tls)))
|
||||
;;(tcp-connect host port)))
|
||||
(parameterize ((xmpp-in-port in)
|
||||
(xmpp-out-port out))
|
||||
(file-stream-buffer-mode out 'line)
|
||||
(xmpp-response-handler in)
|
||||
(send (xmpp-stream host))
|
||||
(send (xmpp-session host))
|
||||
;(starttls in out)
|
||||
(send (xmpp-auth user pass resource))
|
||||
(send (presence))
|
||||
(begin form . forms)
|
||||
(close-output-port out)
|
||||
(close-input-port in)))))))
|
||||
|
||||
;; NOTE: this will only work with a single connection to a host, however multiple sessions to that host may be possible
|
||||
(define xmpp-in-port-v (current-input-port))
|
||||
(define xmpp-out-port-v (current-output-port))
|
||||
|
||||
(define (start-xmpp-session jid pass)
|
||||
(let ((host (jid-host jid))
|
||||
(user (jid-user jid))
|
||||
(resource (jid-resource jid)))
|
||||
(let-values (((in out)
|
||||
(ssl-connect host ssl-port 'tls)))
|
||||
;;(tcp-connect host port)))
|
||||
(set! xmpp-in-port-v in)
|
||||
(set! xmpp-out-port-v out)
|
||||
(file-stream-buffer-mode out 'line)
|
||||
(xmpp-response-handler in)
|
||||
(send (xmpp-stream host))
|
||||
(send (xmpp-session host))
|
||||
;;(starttls in out)
|
||||
(send (xmpp-auth user pass resource))
|
||||
(send (presence)))))
|
||||
|
||||
(define (close-xmpp-session)
|
||||
(close-output-port xmpp-out-port-v)
|
||||
(close-input-port xmpp-in-port-v))
|
||||
|
||||
) ;; end module
|
||||
|
|
@ -67,7 +67,7 @@
|
|||
(cond
|
||||
(ret (cdr ret))
|
||||
(else
|
||||
(let* ((tex (load-primitive (string-append "plant-2/comp-cp-" id ".png")))
|
||||
(let* ((tex (load-primitive (string-append "plant-1/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)
|
||||
|
|
@ -85,7 +85,7 @@
|
|||
(let ((root (with-state
|
||||
(translate (vector 0 0.5 0))
|
||||
(hint-ignore-depth)
|
||||
(texture (load-texture (string-append "plant-2/comp-" id ".png")))
|
||||
(texture (load-texture (string-append "plant-1/comp-" id ".png")))
|
||||
(build-plane))))
|
||||
(with-primitive root (apply-transform))
|
||||
(make-component root '())))
|
||||
|
|
@ -93,7 +93,7 @@
|
|||
(let* ((connection-list (get-connection-list id))
|
||||
(root (with-state
|
||||
(translate (vector 0 0.5 0))
|
||||
(texture (load-texture (string-append "plant-2/comp-" id ".png")))
|
||||
(texture (load-texture (string-append "plant-1/comp-" id ".png")))
|
||||
(build-plane)))
|
||||
(comp (make-component root
|
||||
(map
|
||||
|
|
@ -127,9 +127,9 @@
|
|||
(cond
|
||||
((eq? num-children 0) (list (choose (list "3" "4" "8" "9")) (list)))
|
||||
((eq? num-children 1) (list "1-1" (list (make-random-plant (+ depth 1)))))
|
||||
((eq? num-children 2) (list (string-append "2-" (choose (list "1" "2" "6" "10" "13" "16"))) (list (make-random-plant (+ depth 1))
|
||||
((eq? num-children 2) (list (string-append "2-" (choose (list "1"))) (list (make-random-plant (+ depth 1))
|
||||
(make-random-plant (+ depth 1)))))
|
||||
((eq? num-children 3) (list (string-append "3-" (choose (list "7")))
|
||||
((eq? num-children 3) (list (string-append "3-" (choose (list "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))
|
||||
|
|
|
|||
Loading…
Reference in a new issue