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

steerable and navigatorable twigs

Browse source
This commit is contained in:
Dave Griffiths 2009-07-09 12:52:56 +01:00
parent b4eef24816
commit f907549eb4
3 changed files with 195 additions and 389 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
hex-ornament/hex-ornament.scm
View file

@ -1,8 +1,8 @@
#lang scheme/base ;#lang scheme/base
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; hex ornament/groworld game : fluxus version ; hex ornament/groworld game : fluxus version
(require fluxus-016/drflux) ;(require fluxus-016/drflux)
(require scheme/class) (require scheme/class)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

184
plant-eyes/extrude.scm
View file

@ -1,5 +1,5 @@
#lang scheme ;#lang scheme
(require fluxus-016/drflux) ;(require fluxus-016/drflux)
; extrusion code ; extrusion code
@ -26,31 +26,20 @@
(vmul v 0.5))))) (vmul v 0.5)))))
vd)) vd))
(define (extrude-segment index profile path width lv up) (define (extrude-segment index profile path width lv up size)
(cond ((not (null? path)) (cond ((not (null? path))
(let ((v (path-vector (zero? index) path lv))) (let ((v (path-vector (zero? index) path lv)))
(draw-profile index (transform-profile profile (draw-profile index (transform-profile profile
(mmul (mmul
(maim v up) (maim v up)
(mrotate (vector 0 90 0)) (mrotate (vector 0 90 0))
(mscale (vector (car width) (car width) (car width))))) (mscale (vmul (vector (car width) (car width) (car width)) size))))
(car path))
v))))
(define (extrude-segment-grow index profile path width lv up t)
(cond ((not (null? path))
(let ((v (path-vector (zero? index) path lv)))
(draw-profile index (transform-profile profile
(mmul
(maim v up)
(mrotate (vector 0 90 0))
(mscale (vmul (vector (car width) (car width) (car width)) t))))
(car path)) (car path))
v)))) v))))
(define (extrude index profile path width lv up) (define (extrude index profile path width lv up)
(cond ((not (null? path)) (cond ((not (null? path))
(let ((v (extrude-segment index profile path width lv up))) (let ((v (extrude-segment index profile path width lv up 1)))
(extrude (+ index (length profile)) profile (cdr path) (cdr width) v up))))) (extrude (+ index (length profile)) profile (cdr path) (cdr width) v up)))))
(define (stitch-face index count profile-size in) (define (stitch-face index count profile-size in)
@ -76,11 +65,11 @@
in))))) in)))))
(define (build-tex-coords profile-size path-size vscale) (define (build-tex-coords profile-size path-size vscale)
(pdata-index-map! (pdata-index-map!
(lambda (i t) (lambda (i t)
(vector (* vscale (/ (quotient i profile-size) path-size)) (vector (* vscale (/ (quotient i profile-size) path-size))
(/ (modulo i profile-size) profile-size) 0)) (/ (modulo i profile-size) profile-size) 0))
"t")) "t"))
(define (build-extrusion profile path width tex-vscale up) (define (build-extrusion profile path width tex-vscale up)
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list))) (let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
@ -100,83 +89,45 @@
(build-tex-coords (length profile) (length path) tex-vscale)) (build-tex-coords (length profile) (length path) tex-vscale))
p)) p))
(define (chop-front l n) (define (partial-extrude t profile path width up grow)
(cond ((null? l) l) (define (chop-front l n)
(else (cond ((null? l) l)
(if (zero? n) (cons (car l) (chop-front (cdr l) n)) (else
(chop-front (cdr l) (- n 1)))))) (if (zero? n) (cons (car l) (chop-front (cdr l) n))
(chop-front (cdr l) (- n 1))))))
(define (partial-extrude p t v profile path width up)
(with-primitive p 0 (define (collapse-front)
(let ((start (* (floor t) (length profile))))
(let* ((T (floor t)) (for ((i (in-range (+ start (* (length profile) 1)) (pdata-size))))
(t (- t T)) (pdata-set! "p" i (pdata-ref "p" start)))))
(seg-len (length profile))
(start (* T seg-len)) (define (scale-front)
(end (* (length path) seg-len)) (when (> t 1)
(v (extrude-segment start profile (let* ((start (* (floor t) (length profile)))
(chop-front path T) (from (list-ref path (- (inexact->exact (floor t)) 1)))
(chop-front width T) v up))) (to (list-ref path (+ (inexact->exact (floor t)) 0))))
(when (< T (- (length path) 1)) (for ((i (in-range start (+ start (length profile)))))
; extrude the next segment (pdata-set! "p" i (vmix to from (- t (floor t))))))))
(extrude-segment (+ start seg-len) profile
(chop-front path (+ T 1)) (define (_ t v g)
(chop-front width (+ T 1)) v up) (cond
((< t 1) (with-primitive p (recalc-normals 0)) v)
; and now blend it back by using both segments to t (else
(for ((i (in-range (+ start seg-len) (let ((start (* (floor t) (length profile))))
(+ start (* 2 seg-len))))) (_ (- t 1)
(extrude-segment start profile
(pdata-set! "p" i (vmix (pdata-ref "p" i) (chop-front path (floor t))
(pdata-ref "p" (- i seg-len)) (chop-front width (floor t)) v up
(if (< g 1)
t))) (+ g (* (- t (floor t)) grow))
g))
(if (< g 1)
(+ g grow)
; collapse the yet un-extruded part into the last vert 1))))))
(for ((i (in-range (+ start (* seg-len 2)) end))) (_ t (vector 0 0 0) 0)
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start))))) (scale-front)
(collapse-front))
(recalc-normals 0)
v)))
(define (partial-extrude-grow p t v profile path width up)
(with-primitive p 0
(let* ((T (floor t))
(t (- t T))
(seg-len (length profile))
(start (* T seg-len))
(end (* (length path) seg-len))
(v (extrude-segment-grow start profile
(chop-front path T)
(chop-front width T) v up t)))
(when (< T (- (length path) 1))
; extrude the next segment
(extrude-segment-grow (+ start seg-len) profile
(chop-front path (+ T 1))
(chop-front width (+ T 1)) v up 0)
; and now blend it back by using both segments to t
(for ((i (in-range (+ start seg-len)
(+ start (* 2 seg-len)))))
(pdata-set! "p" i (vmix (pdata-ref "p" i)
(pdata-ref "p" (- i seg-len))
t)))
; collapse the yet un-extruded part into the last vert
(for ((i (in-range (+ start (* seg-len 2)) end)))
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start)))))
(recalc-normals 0)
v)))
(define (build-circle-profile n r) (define (build-circle-profile n r)
(define (_ n c l) (define (_ n c l)
@ -189,45 +140,46 @@
(clear) (clear)
(clear-colour 0.5) (clear-colour 0.5)
(define l (make-light 'point 'free))
(light-diffuse 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 50 50 0))
(light-specular l (vector 1 1 1))
(define profile (build-circle-profile 12 0.5)) (define profile (build-circle-profile 12 0.5))
(define width (build-list 100 (define width (build-list 100
(lambda (n) (* 0.5 (+ 1 (sin (* 0.3 n))))))) (lambda (n) (* n 0.01 (+ 1.5 (cos (* 0.5 n)))))))
(define path (build-list 100 (define path (build-list 100
(lambda (n) (vmul (vector (sin (* 0.05 n)) 0 (cos (* 0.05 n))) (+ 0.5 (* 0.2 n)))))) (lambda (n) (vmul (vector (sin (* 0.2 n)) 0 (cos (* 0.2 n))) (* 0.05 n)))))
(define p (with-state (define p (with-state
; (hint-wire) (wire-colour 0)
(colour (vector 0 0.5 0.5)) ; (colour (vector 0.5 0.3 0.2))
(colour (vector 1 1 1))
(specular (vector 1 1 1)) (specular (vector 1 1 1))
(shinyness 20) (shinyness 20)
(build-partial-extrusion profile path 1))) (hint-wire)
(texture (load-texture "textures/root.png"))
(build-partial-extrusion profile path 10)))
(with-state #;(with-state
(wire-opacity 0.4) (wire-opacity 0.4)
(translate (vector 0 0 0)) (translate (vector 0 0 0))
(wire-colour (vector 0 0 1)) (wire-colour (vector 0 0 1))
(hint-none) (hint-none)
(hint-wire) (hint-wire)
; (hint-normal) ; (hint-normal)
(backfacecull 1) (backfacecull 1)
(point-width 5) (point-width 5)
(build-extrusion profile path width 1 (vector 0 1 0))) (build-extrusion profile path width 1 (vector 0 1 0)))
(define v (vector 0 0 0)) (define t 0)
(define (animate) (define (animate)
(set! v (partial-extrude-grow p (fmod (* 2 (flxtime)) (length path)) v profile path width (vector 0 1 0)))) (with-primitive p
(partial-extrude
(* (* 0.5 (+ 1 (sin (* 0.2 t)))) (length path))
profile path width (vector 0 1 0) 0.05)
(set! t (+ t 0.01))))
(every-frame (animate)) (every-frame (animate))
(end-framedump)
;(start-framedump "ext-" "jpg")

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

@ -1,5 +1,5 @@
;#lang scheme/base #lang scheme/base
;(require fluxus-016/drflux) (require fluxus-016/drflux)
(require scheme/class) (require scheme/class)
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@ -35,16 +35,17 @@
(define debug-messages #f) ; prints out all the messages sent to the renderer (define debug-messages #f) ; prints out all the messages sent to the renderer
(define logic-tick 1) ; time between logic updates (define logic-tick 1) ; time between logic updates
(define branch-probability 2) ; as in one in branch-probability chance (define branch-probability 6) ; as in one in branch-probability chance
(define branch-width-reduction 0.5) (define branch-width-reduction 0.5)
(define twig-jitter 0.1) (define twig-jitter 0.1)
(define branch-jitter 0.5) (define branch-jitter 0.5)
(define max-twig-points 10) (define max-twig-points 20)
(define start-twig-width 0.2) (define start-twig-dist 0.3)
(define start-twig-width 0.3)
(define default-max-twigs 10) (define default-max-twigs 10)
(define default-scale-factor 1.05) (define default-scale-factor 1.05)
(define default-grow-speed 1) (define default-grow-speed 1)
(define root-camera-time (* default-max-twigs logic-tick)) (define root-camera-time (* max-twig-points logic-tick))
(define num-pickups 10) (define num-pickups 10)
(define pickup-dist-radius 20) (define pickup-dist-radius 20)
(define pickup-size 1) (define pickup-size 1)
@ -139,7 +140,7 @@
(width 0) ; the width of this root (width 0) ; the width of this root
(num-points max-twig-points) ; number of points in this twig (num-points max-twig-points) ; number of points in this twig
(render-type 'extruded) ; the way to tell the view to render this twig (render-type 'extruded) ; the way to tell the view to render this twig
(dist 1)) ; distance between points (dist start-twig-dist)) ; distance between points
(field (field
(points '()) ; the 3d points for this twig (points '()) ; the 3d points for this twig
@ -167,7 +168,7 @@
width) width)
(define/public (get-num-points) (define/public (get-num-points)
num-points) num-points)
(define/public (get-render-type) (define/public (get-render-type)
render-type) render-type)
@ -181,18 +182,25 @@
(define/public (get-length) (define/public (get-length)
(length points)) (length points))
(define/public (get-end-pos)
(if (not (null? points))
(list-ref points (- (get-length) 1))
#f))
(define/public (scale a) (define/public (scale a)
(set! width (* width a)) (set! width (* width a))
(set! dist (* dist a))) (set! dist (* dist a)))
(define/public (grow curly) (define/public (grow ndir)
(when (< (length points) num-points) (when (< (length points) num-points)
(let ((new-point (if (zero? (length points)) (let ((new-point (if (zero? (length points))
; first point should be at edge of the seed if we are a branch ; first point should be at edge of the seed if we are a branch
(if branch (vmul dir 1) (vector 0 0 0)) (if branch (vmul dir 1) (vector 0 0 0))
(vadd last-point (vmul dir dist))))) (vadd last-point (vmul dir dist)))))
(cond (curly (set! dir (vmix dir ndir 0.5))
#;(cond (curly
(set! dir (vtransform dir (mrotate curl))) (set! dir (vtransform dir (mrotate curl)))
(when (not branch) (when (not branch)
(set! curl (vmul curl 1.2)) (set! curl (vmul curl 1.2))
@ -219,7 +227,7 @@
dist)))) dist))))
(for-each (for-each
(lambda (twig) (lambda (twig)
(send (cadr twig) grow curly)) (send (cadr twig) grow ndir))
twigs)) twigs))
(define/public (add-twig point-index twig) (define/public (add-twig point-index twig)
@ -369,7 +377,7 @@
(twigs '()) ; a assoc list map of ages to twigs (twigs '()) ; a assoc list map of ages to twigs
(properties '()) ; a list of symbols - properties come from pickups (properties '()) ; a list of symbols - properties come from pickups
(ornaments '()) ; map of ids to ornaments on the plant (ornaments '()) ; map of ids to ornaments on the plant
(size 1) ; the age of this plant (size 5) ; the age of this plant
(max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first (max-twigs default-max-twigs) ; the maximum twigs allowed at any time - oldest removed first
(next-twig-id 0) (next-twig-id 0)
(next-ornament-id 0) (next-ornament-id 0)
@ -383,12 +391,11 @@
(define/public (get-pos) (define/public (get-pos)
pos) pos)
(define/public (grow) (define/public (grow dir)
(let ((curly (list-contains 'curly properties)))
(for-each (for-each
(lambda (twig) (lambda (twig)
(send twig grow curly)) (send twig grow dir))
twigs))) twigs))
(define/public (add-property name) (define/public (add-property name)
(set! properties (cons name properties))) (set! properties (cons name properties)))
@ -456,6 +463,17 @@
(if (not (null? twigs)) (if (not (null? twigs))
(send (choose twigs) get-random-twig) (send (choose twigs) get-random-twig)
#f)) #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) (define/augment (update)
@ -711,193 +729,6 @@
(super-new))) (super-new)))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; extrusion code
(define (draw-profile index profile offset)
(cond ((not (null? profile))
(pdata-set! "p" index (vadd (car profile) offset))
(draw-profile (+ index 1) (cdr profile) offset))))
(define (transform-profile profile m)
(cond
((null? profile) '())
(else
(cons (vtransform (car profile) m)
(transform-profile (cdr profile) m)))))
; figures out the vector for rotation of the profile
(define (path-vector first-segment path lv)
(let* ((v (if (null? (cdr path)) ; last segment?
lv ; use the last vector used
(vsub (cadr path) (car path)))) ; use the next point
(vd (if first-segment v ; first segment?
(vadd (vmul lv 0.5) ; blend with the last vector
(vmul v 0.5)))))
vd))
(define (extrude-segment index profile path width lv up)
(cond ((not (null? path))
(let ((v (path-vector (zero? index) path lv)))
(draw-profile index (transform-profile profile
(mmul
(maim v up)
(mrotate (vector 0 90 0))
(mscale (vector (car width) (car width) (car width)))))
(car path))
v))))
(define (extrude-segment-grow index profile path width lv up t)
(cond ((not (null? path))
(let ((v (path-vector (zero? index) path lv)))
(draw-profile index (transform-profile profile
(mmul
(maim v up)
(mrotate (vector 0 90 0))
(mscale (vmul (vector (car width) (car width) (car width)) t))))
(car path))
v))))
(define (extrude index profile path width lv up)
(cond ((not (null? path))
(let ((v (extrude-segment index profile path width lv up)))
(extrude (+ index (length profile)) profile (cdr path) (cdr width) v up)))))
(define (stitch-face index count profile-size in)
(cond
((eq? 1 count)
(append in (list (+ (- index profile-size) 1) index (+ index profile-size)
(+ (- index profile-size) 1 profile-size))))
(else
(append
(list (+ index 1) index
(+ index profile-size) (+ index profile-size 1))
(stitch-face (+ index 1) (- count 1) profile-size in)))))
(define (stitch-indices index profile-size path-size in)
(cond
((eq? 1 path-size) in)
(else
(append
(stitch-face index profile-size profile-size '())
(stitch-indices (+ index profile-size)
profile-size
(- path-size 1)
in)))))
(define (build-tex-coords profile-size path-size vscale)
(pdata-index-map!
(lambda (i t)
(vector (* vscale (/ (quotient i profile-size) path-size))
(/ (modulo i profile-size) profile-size) 0))
"t"))
(define (build-extrusion profile path width tex-vscale up)
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
(with-primitive p
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
(build-tex-coords (length profile) (length path) tex-vscale)
(extrude 0 profile path width (vector 0 0 0) up)
(recalc-normals 0))
p))
; partial extrusions are for animating
(define (build-partial-extrusion profile path tex-vscale)
(let ((p (build-polygons (* (length profile) (length path)) 'quad-list)))
(with-primitive p
(poly-set-index (stitch-indices 0 (length profile) (length path) '()))
(build-tex-coords (length profile) (length path) tex-vscale))
p))
(define (chop-front l n)
(cond ((null? l) l)
(else
(if (zero? n) (cons (car l) (chop-front (cdr l) n))
(chop-front (cdr l) (- n 1))))))
(define (partial-extrude p t v profile path width up)
(with-primitive p 0
(let* ((T (floor t))
(t (- t T))
(seg-len (length profile))
(start (* T seg-len))
(end (* (length path) seg-len))
(v (extrude-segment start profile
(chop-front path T)
(chop-front width T) v up)))
(when (< T (- (length path) 1))
; extrude the next segment
(extrude-segment (+ start seg-len) profile
(chop-front path (+ T 1))
(chop-front width (+ T 1)) v up)
; and now blend it back by using both segments to t
(for ((i (in-range (+ start seg-len)
(+ start (* 2 seg-len)))))
(pdata-set! "p" i (vmix (pdata-ref "p" i)
(pdata-ref "p" (- i seg-len))
t)))
; collapse the yet un-extruded part into the last vert
(for ((i (in-range (+ start (* seg-len 2)) end)))
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start)))))
(recalc-normals 0)
v)))
(define (partial-extrude-grow p t v profile path width up)
(with-primitive p 0
(let* ((T (floor t))
(t (- t T))
(seg-len (length profile))
(start (* T seg-len))
(end (* (length path) seg-len))
(v (extrude-segment-grow start profile
(chop-front path T)
(chop-front width T) v up t)))
(when (< T (- (length path) 1))
; extrude the next segment
(extrude-segment-grow (+ start seg-len) profile
(chop-front path (+ T 1))
(chop-front width (+ T 1)) v up 0)
; and now blend it back by using both segments to t
(for ((i (in-range (+ start seg-len)
(+ start (* 2 seg-len)))))
(pdata-set! "p" i (vmix (pdata-ref "p" i)
(pdata-ref "p" (- i seg-len))
t)))
; collapse the yet un-extruded part into the last vert
(for ((i (in-range (+ start (* seg-len 2)) end)))
(pdata-set! "p" i (pdata-ref "p" (+ seg-len start)))))
(recalc-normals 0)
v)))
(define (build-circle-profile n r)
(define (_ n c l)
(cond ((zero? c) l)
(else
(let ((a (* (/ c n) (* 2 3.141))))
(_ n (- c 1)
(cons (vmul (vector (sin a) (cos a) 0) r) l))))))
(_ n n '()))
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define ribbon-twig-view% (define ribbon-twig-view%
@ -962,7 +793,6 @@
(profile '()) (profile '())
(path '()) (path '())
(root 0) (root 0)
(v (vector 0 0 0))
(grow-speed default-grow-speed) (grow-speed default-grow-speed)
(anim-t 0) (anim-t 0)
(widths '())) (widths '()))
@ -970,10 +800,16 @@
(define/override (build) (define/override (build)
(set! profile (build-circle-profile 7 1)) (set! profile (build-circle-profile 7 1))
(set! path (build-list num-points (lambda (n) (vector 0 0 0)))) (set! path (build-list num-points (lambda (n) (vector 0 0 0))))
(set! widths (build-list num-points (lambda (n) (if (eq? n (- num-points 1)) 0 (set! widths (build-list num-points (lambda (n) (let ((t (/ n num-points)))
(* radius (- 1 (/ n num-points))))))) (if (eq? n (- num-points 1)) 0
(* radius
(if (zero? t) 1
(+ (* t 0.5)
(* (- (/ 1 t) 1) 0.1)))))))))
(set! root (let ((p (with-state (set! root (let ((p (with-state
(backfacecull 1) (backfacecull 0)
;(hint-none)
;(hint-wire)
(translate pos) (translate pos)
(texture (load-texture "textures/skin.png")) (texture (load-texture "textures/skin.png"))
(opacity 0.6) (opacity 0.6)
@ -995,16 +831,16 @@
(else (cons (car l) (list-set (cdr l) (- c 1) s))))) (else (cons (car l) (list-set (cdr l) (- c 1) s)))))
(define/augment (grow point) (define/augment (grow point)
(when (zero? index) (set! path (list-set path index point))) #;(when (zero? index) (set! path (list-set path index point)))
(set! path (list-set path (+ index 1) point)) (set! path (list-set path (+ index 1) point))
(set! anim-t 0) (set! anim-t 0)
(set! v (partial-extrude-grow root index v profile path widths (vector 1 0 0)))
(set! index (+ index 1))) (set! index (+ index 1)))
(define/augment (update t d) (define/augment (update t d)
(when (< anim-t 1) (when (< anim-t 1)
(set! v (partial-extrude-grow root (+ (- index 1) anim-t) (with-primitive root
v profile path widths (vector 1 0 0)))) (partial-extrude (+ (- index 1) anim-t)
profile path widths (vector 1 0 0) 0.05)))
(set! anim-t (+ anim-t (* d grow-speed)))) (set! anim-t (+ anim-t (* d grow-speed))))
(define/public (get-end-pos) (define/public (get-end-pos)
@ -1043,7 +879,10 @@
id) id)
(define/public (get-twig twig-id) (define/public (get-twig twig-id)
(cadr (assq twig-id twigs))) (let ((l (assq twig-id twigs)))
(if l
(cadr (assq twig-id twigs))
#f)))
(define/public (add-branch-twig twig) (define/public (add-branch-twig twig)
; attach to seed ; attach to seed
@ -1144,18 +983,14 @@
(define game-view% (define game-view%
(class object% (class object%
(init-field
(controller #f))
(field (field
(plants '()) ; map of ids -> plants (plants '()) ; map of ids -> plants
(pickups '()) ; map of ids -> pickups (pickups '()) ; map of ids -> pickups
(player-plant-id #f)
(current-twig-id #f)
(camera-dist 1) (camera-dist 1)
(env-root (with-state (scale 20) (build-locator))) (env-root (with-state (scale 20) (build-locator)))
(root-camera-t 0) (root-camera-t 0)
(upper-env (with-state #;(upper-env (with-state
(parent env-root) (parent env-root)
(hint-depth-sort) (hint-depth-sort)
(colour 2) (colour 2)
@ -1163,7 +998,7 @@
(build-env-box "textures/top.png" "textures/bottom-trans.png" (build-env-box "textures/top.png" "textures/bottom-trans.png"
"textures/left.png" "textures/right.png" "textures/left.png" "textures/right.png"
"textures/front.png" "textures/back.png"))) "textures/front.png" "textures/back.png")))
(lower-env (with-state #;(lower-env (with-state
(parent env-root) (parent env-root)
(hint-depth-sort) (hint-depth-sort)
(translate (vector 0 -0.22001 0)) (translate (vector 0 -0.22001 0))
@ -1195,21 +1030,14 @@
(fog (vector 0.5 0.3 0.2) 0.02 1 100) (fog (vector 0.5 0.3 0.2) 0.02 1 100)
#;(fog (vector 0.2 0.5 0.3) 0.02 1 100)) #;(fog (vector 0.2 0.5 0.3) 0.02 1 100))
(define/public (get-player)
(get-plant player-plant-id))
(define/public (add-plant plant player) (define/public (add-plant plant)
(set! plants (cons (list (send plant get-id) plant) plants)) (set! plants (cons (list (send plant get-id) plant) plants)))
(when player (set! player-plant-id (send plant get-id))))
(define/public (get-plant plant-id) (define/public (get-plant plant-id)
(cadr (assq plant-id plants))) (cadr (assq plant-id plants)))
(define/public (add-branch-twig plant-id twig) (define/public (add-branch-twig plant-id twig)
(when (eq? plant-id player-plant-id)
(set! current-twig-id (send twig get-id))
(set! root-camera-t 0))
(send (get-plant plant-id) add-branch-twig twig)) (send (get-plant plant-id) add-branch-twig twig))
(define/public (destroy-branch-twig plant-id twig-id) (define/public (destroy-branch-twig plant-id twig-id)
@ -1218,10 +1046,7 @@
(define/public (add-twig plant-id parent-twig-id point-index twig) (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)) (send (get-plant plant-id) add-twig parent-twig-id point-index twig))
(define/public (grow-seed plant-id amount) (define/public (grow-seed plant-id amount)
(when (eq? plant-id player-plant-id)
(set! camera-dist (* camera-dist amount))
(with-primitive env-root (scale amount)))
(send (get-plant plant-id) grow-seed amount)) (send (get-plant plant-id) grow-seed amount))
(define/public (get-pickup pickup-id) (define/public (get-pickup pickup-id)
@ -1249,21 +1074,6 @@
(send (cadr pickup) update t d)) (send (cadr pickup) update t d))
pickups) pickups)
(if current-twig-id
(let ((twig (send (get-player) get-twig current-twig-id)))
(send controller set-pos (vadd (send twig get-end-pos)
(vmul (send twig get-dir) (* camera-dist -2))
(vcross (send twig get-dir) (vector 0 1 0)))))
(send controller set-pos (vector 0 0 0)))
(when (> root-camera-t root-camera-time)
;(set-camera-position (vector 0 0 (- camera-dist)))
(set! current-twig-id #f))
(set! root-camera-t (+ root-camera-t d))
(when debug-messages (when debug-messages
(for-each (for-each
(lambda (msg) (lambda (msg)
@ -1272,15 +1082,15 @@
(for-each (for-each
(lambda (msg) (lambda (msg)
(cond (cond
((eq? (send msg get-name) 'player-plant) ((eq? (send msg get-name) 'player-plant) ; not really any difference now
(add-plant (make-object plant-view% (add-plant (make-object plant-view%
(send msg get-data 'plant-id) (send msg get-data 'plant-id)
(send msg get-data 'pos)) #t)) (send msg get-data 'pos))))
((eq? (send msg get-name) 'new-plant) ((eq? (send msg get-name) 'new-plant)
(add-plant (make-object plant-view% (add-plant (make-object plant-view%
(send msg get-data 'plant-id) (send msg get-data 'plant-id)
(send msg get-data 'pos)) #f)) (send msg get-data 'pos))))
((eq? (send msg get-name) 'grow-seed) ((eq? (send msg get-name) 'grow-seed)
(grow-seed (send msg get-data 'plant-id) (grow-seed (send msg get-data 'plant-id)
@ -1366,15 +1176,25 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define controller% (define controller%
(class object% (class object%
(init-field
(game-view #f))
(field (field
(fwd (vector 0 0 1)) (fwd (vector 0 0 1))
(up (vector 0 1 0)) (up (vector 0 1 0))
(pos (vector 0 0 0)) (pos (vector 0 0 0))
(mtx (mident)) (mtx (mident))
(cam (build-locator)) (cam (build-locator))
(current-twig #f)
(current-twig-growing #f)
(current-point 0)
(tilt 0) (tilt 0)
(yaw 0)) (yaw 0)
(player-plant #f))
(define/public (set-player-plant s)
(set! player-plant s))
(define/public (get-cam-obj) (define/public (get-cam-obj)
cam) cam)
@ -1395,6 +1215,13 @@
(set-camera-transform (mtranslate (vector 0 0 -1)))) (set-camera-transform (mtranslate (vector 0 0 -1))))
(define/public (update) (define/public (update)
(when (key-pressed-this-frame " ")
(set! current-twig (make-object twig-logic% 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 1))) (when (or (key-pressed "a") (key-special-pressed 100)) (set! yaw (+ yaw 1)))
(when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 1))) (when (or (key-pressed "d") (key-special-pressed 102)) (set! yaw (- yaw 1)))
(when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 1))) (when (or (key-pressed "w") (key-special-pressed 101)) (set! tilt (+ tilt 1)))
@ -1404,10 +1231,47 @@
(when (> tilt 88) (set! tilt 88)) (when (> tilt 88) (set! tilt 88))
(when (< tilt -88) (set! tilt -88)) (when (< tilt -88) (set! tilt -88))
(set! fwd (vtransform (vector 0 0 1) (when (key-pressed-this-frame "q")
(mmul (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)))))))
; 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 (vnormalise (vsub (send current-twig get-point (- current-point 1))
pos)))))
(else
(when current-twig-growing
(set-camera-transform (mtranslate (vector 0 0 0)))
(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) 5)))))
(when (eq? (send current-twig get-num-points)
(send current-twig get-length))
(set! current-twig-growing #f)
(set! current-twig #f)))
; get camera fwd vector from key-presses
(set! fwd (vtransform (vector 0 0 1)
(mmul
(mrotate (vector 0 yaw 0)) (mrotate (vector 0 yaw 0))
(mrotate (vector tilt 0 0))))) (mrotate (vector tilt 0 0)))))))
(let* ((side (vnormalise (vcross up fwd))) (let* ((side (vnormalise (vcross up fwd)))
(up (vnormalise (vcross fwd side)))) (up (vnormalise (vcross fwd side))))
@ -1424,9 +1288,9 @@
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(clear) (clear)
(define c (make-object controller%))
(define gl (make-object game-logic%)) (define gl (make-object game-logic%))
(define gv (make-object game-view% c)) (define gv (make-object game-view%))
(define c (make-object controller% gv))
(send c setup) (send c setup)
(send gv setup) (send gv setup)
@ -1435,14 +1299,14 @@
(define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0))) (define plant1 (make-object plant-logic% "dave@fo.am" (vector 0 0 0)))
(define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 9))) (define plant2 (make-object plant-logic% "plant00001@fo.am" (vector 0 0 9)))
(send gl add-player plant1) (send c set-player-plant plant1)
(send gl add-plant plant1)
(send gl add-plant plant2) (send gl add-plant plant2)
(send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon)) (send plant2 add-twig (make-object twig-logic% 0 plant2 'root (vector 0 -1 0) start-twig-width 10 'ribbon))
(define tick-time 0) (define tick-time 0)
(define debounce #t)
(define debounce-time 0)
(define pt 0) (define pt 0)
(define pd 0.02) (define pd 0.02)
@ -1451,21 +1315,11 @@
(define (pt-update) (set! pt (+ pt pd))) (define (pt-update) (set! pt (+ pt pd)))
(define (animate) (define (animate)
(when (and debounce (key-pressed " "))
(send plant1 add-twig (make-object twig-logic% 0 plant1 'root
(vmul (send c get-fwd) -1)
start-twig-width max-twig-points 'extruded))
(set! tick-time 0)
(set! debounce #f)
(set! debounce-time (+ (pe-time) 0.2)))
(when (> (pe-time) debounce-time)
(set! debounce #t))
(when (< tick-time (pe-time)) (when (< tick-time (pe-time))
(set! tick-time (+ (pe-time) logic-tick)) (set! tick-time (+ (pe-time) logic-tick))
(send plant1 grow) (send plant1 grow (vmul (send c get-fwd) -1))
(send plant2 grow) (send plant2 grow (vector 0 -1 0))
(send gv update (pe-time) (pe-delta) (send gl update))) (send gv update (pe-time) (pe-delta) (send gl update)))
(send gv update (pe-time) (pe-delta) '()) (send gv update (pe-time) (pe-delta) '())