steerable and navigatorable twigs
This commit is contained in:
Dave Griffiths
parent
b4eef24816
commit
f907549eb4
3 changed files with 195 additions and 389 deletions
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
;#lang scheme/base
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
; hex ornament/groworld game : fluxus version
|
||||
|
||||
(require fluxus-016/drflux)
|
||||
;(require fluxus-016/drflux)
|
||||
(require scheme/class)
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang scheme
|
||||
(require fluxus-016/drflux)
|
||||
;#lang scheme
|
||||
;(require fluxus-016/drflux)
|
||||
|
||||
; extrusion code
|
||||
|
||||
|
|
@ -26,31 +26,20 @@
|
|||
(vmul v 0.5)))))
|
||||
vd))
|
||||
|
||||
(define (extrude-segment index profile path width lv up)
|
||||
(define (extrude-segment index profile path width lv up size)
|
||||
(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))))
|
||||
(mscale (vmul (vector (car width) (car width) (car width)) size))))
|
||||
(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)))
|
||||
(let ((v (extrude-segment index profile path width lv up 1)))
|
||||
(extrude (+ index (length profile)) profile (cdr path) (cdr width) v up)))))
|
||||
|
||||
(define (stitch-face index count profile-size in)
|
||||
|
|
@ -100,83 +89,45 @@
|
|||
(build-tex-coords (length profile) (length path) tex-vscale))
|
||||
p))
|
||||
|
||||
(define (chop-front l n)
|
||||
(define (partial-extrude t profile path width up grow)
|
||||
(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
|
||||
(define (collapse-front)
|
||||
(let ((start (* (floor t) (length profile))))
|
||||
(for ((i (in-range (+ start (* (length profile) 1)) (pdata-size))))
|
||||
(pdata-set! "p" i (pdata-ref "p" start)))))
|
||||
|
||||
(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)))
|
||||
(define (scale-front)
|
||||
(when (> t 1)
|
||||
(let* ((start (* (floor t) (length profile)))
|
||||
(from (list-ref path (- (inexact->exact (floor t)) 1)))
|
||||
(to (list-ref path (+ (inexact->exact (floor t)) 0))))
|
||||
|
||||
(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)
|
||||
(for ((i (in-range start (+ start (length profile)))))
|
||||
(pdata-set! "p" i (vmix to from (- t (floor t))))))))
|
||||
|
||||
; 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 (_ t v g)
|
||||
(cond
|
||||
((< t 1) (with-primitive p (recalc-normals 0)) v)
|
||||
(else
|
||||
(let ((start (* (floor t) (length profile))))
|
||||
(_ (- t 1)
|
||||
(extrude-segment start profile
|
||||
(chop-front path (floor t))
|
||||
(chop-front width (floor t)) v up
|
||||
(if (< g 1)
|
||||
(+ g (* (- t (floor t)) grow))
|
||||
g))
|
||||
(if (< g 1)
|
||||
(+ g grow)
|
||||
1))))))
|
||||
(_ t (vector 0 0 0) 0)
|
||||
(scale-front)
|
||||
(collapse-front))
|
||||
|
||||
(define (build-circle-profile n r)
|
||||
(define (_ n c l)
|
||||
|
|
@ -189,45 +140,46 @@
|
|||
|
||||
(clear)
|
||||
(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 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
|
||||
(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
|
||||
; (hint-wire)
|
||||
(colour (vector 0 0.5 0.5))
|
||||
(wire-colour 0)
|
||||
; (colour (vector 0.5 0.3 0.2))
|
||||
(colour (vector 1 1 1))
|
||||
(specular (vector 1 1 1))
|
||||
(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)
|
||||
(translate (vector 0 0 0))
|
||||
(wire-colour (vector 0 0 1))
|
||||
(hint-none)
|
||||
(hint-wire)
|
||||
; (hint-normal)
|
||||
; (hint-normal)
|
||||
(backfacecull 1)
|
||||
(point-width 5)
|
||||
(build-extrusion profile path width 1 (vector 0 1 0)))
|
||||
|
||||
(define v (vector 0 0 0))
|
||||
(define t 0)
|
||||
|
||||
(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))
|
||||
|
||||
|
||||
(end-framedump)
|
||||
;(start-framedump "ext-" "jpg")
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
;#lang scheme/base
|
||||
;(require fluxus-016/drflux)
|
||||
#lang scheme/base
|
||||
(require fluxus-016/drflux)
|
||||
(require scheme/class)
|
||||
|
||||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
|
@ -35,16 +35,17 @@
|
|||
(define debug-messages #f) ; prints out all the messages sent to the renderer
|
||||
(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 twig-jitter 0.1)
|
||||
(define branch-jitter 0.5)
|
||||
(define max-twig-points 10)
|
||||
(define start-twig-width 0.2)
|
||||
(define max-twig-points 20)
|
||||
(define start-twig-dist 0.3)
|
||||
(define start-twig-width 0.3)
|
||||
(define default-max-twigs 10)
|
||||
(define default-scale-factor 1.05)
|
||||
(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 pickup-dist-radius 20)
|
||||
(define pickup-size 1)
|
||||
|
|
@ -139,7 +140,7 @@
|
|||
(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 1)) ; distance between points
|
||||
(dist start-twig-dist)) ; distance between points
|
||||
|
||||
(field
|
||||
(points '()) ; the 3d points for this twig
|
||||
|
|
@ -181,18 +182,25 @@
|
|||
(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 curly)
|
||||
(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 (vmul dir 1) (vector 0 0 0))
|
||||
(vadd last-point (vmul dir dist)))))
|
||||
|
||||
(cond (curly
|
||||
(set! dir (vmix dir ndir 0.5))
|
||||
|
||||
#;(cond (curly
|
||||
(set! dir (vtransform dir (mrotate curl)))
|
||||
(when (not branch)
|
||||
(set! curl (vmul curl 1.2))
|
||||
|
|
@ -219,7 +227,7 @@
|
|||
dist))))
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(send (cadr twig) grow curly))
|
||||
(send (cadr twig) grow ndir))
|
||||
twigs))
|
||||
|
||||
(define/public (add-twig point-index twig)
|
||||
|
|
@ -369,7 +377,7 @@
|
|||
(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 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
|
||||
(next-twig-id 0)
|
||||
(next-ornament-id 0)
|
||||
|
|
@ -383,12 +391,11 @@
|
|||
(define/public (get-pos)
|
||||
pos)
|
||||
|
||||
(define/public (grow)
|
||||
(let ((curly (list-contains 'curly properties)))
|
||||
(define/public (grow dir)
|
||||
(for-each
|
||||
(lambda (twig)
|
||||
(send twig grow curly))
|
||||
twigs)))
|
||||
(send twig grow dir))
|
||||
twigs))
|
||||
|
||||
(define/public (add-property name)
|
||||
(set! properties (cons name properties)))
|
||||
|
|
@ -457,6 +464,17 @@
|
|||
(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?
|
||||
|
|
@ -711,193 +729,6 @@
|
|||
|
||||
(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%
|
||||
|
|
@ -962,7 +793,6 @@
|
|||
(profile '())
|
||||
(path '())
|
||||
(root 0)
|
||||
(v (vector 0 0 0))
|
||||
(grow-speed default-grow-speed)
|
||||
(anim-t 0)
|
||||
(widths '()))
|
||||
|
|
@ -970,10 +800,16 @@
|
|||
(define/override (build)
|
||||
(set! profile (build-circle-profile 7 1))
|
||||
(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
|
||||
(* radius (- 1 (/ n num-points)))))))
|
||||
(set! widths (build-list num-points (lambda (n) (let ((t (/ 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
|
||||
(backfacecull 1)
|
||||
(backfacecull 0)
|
||||
;(hint-none)
|
||||
;(hint-wire)
|
||||
(translate pos)
|
||||
(texture (load-texture "textures/skin.png"))
|
||||
(opacity 0.6)
|
||||
|
|
@ -995,16 +831,16 @@
|
|||
(else (cons (car l) (list-set (cdr l) (- c 1) s)))))
|
||||
|
||||
(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! anim-t 0)
|
||||
(set! v (partial-extrude-grow root index v profile path widths (vector 1 0 0)))
|
||||
(set! index (+ index 1)))
|
||||
|
||||
(define/augment (update t d)
|
||||
(when (< anim-t 1)
|
||||
(set! v (partial-extrude-grow root (+ (- index 1) anim-t)
|
||||
v profile path widths (vector 1 0 0))))
|
||||
(with-primitive root
|
||||
(partial-extrude (+ (- index 1) anim-t)
|
||||
profile path widths (vector 1 0 0) 0.05)))
|
||||
(set! anim-t (+ anim-t (* d grow-speed))))
|
||||
|
||||
(define/public (get-end-pos)
|
||||
|
|
@ -1043,7 +879,10 @@
|
|||
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)
|
||||
; attach to seed
|
||||
|
|
@ -1144,18 +983,14 @@
|
|||
|
||||
(define game-view%
|
||||
(class object%
|
||||
(init-field
|
||||
(controller #f))
|
||||
|
||||
(field
|
||||
(plants '()) ; map of ids -> plants
|
||||
(pickups '()) ; map of ids -> pickups
|
||||
(player-plant-id #f)
|
||||
(current-twig-id #f)
|
||||
(camera-dist 1)
|
||||
(env-root (with-state (scale 20) (build-locator)))
|
||||
(root-camera-t 0)
|
||||
(upper-env (with-state
|
||||
#;(upper-env (with-state
|
||||
(parent env-root)
|
||||
(hint-depth-sort)
|
||||
(colour 2)
|
||||
|
|
@ -1163,7 +998,7 @@
|
|||
(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
|
||||
#;(lower-env (with-state
|
||||
(parent env-root)
|
||||
(hint-depth-sort)
|
||||
(translate (vector 0 -0.22001 0))
|
||||
|
|
@ -1196,20 +1031,13 @@
|
|||
(fog (vector 0.5 0.3 0.2) 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)
|
||||
(set! plants (cons (list (send plant get-id) plant) plants))
|
||||
(when player (set! player-plant-id (send plant get-id))))
|
||||
(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)
|
||||
(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))
|
||||
|
||||
(define/public (destroy-branch-twig plant-id twig-id)
|
||||
|
|
@ -1219,9 +1047,6 @@
|
|||
(send (get-plant plant-id) add-twig parent-twig-id point-index twig))
|
||||
|
||||
(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))
|
||||
|
||||
(define/public (get-pickup pickup-id)
|
||||
|
|
@ -1249,21 +1074,6 @@
|
|||
(send (cadr pickup) update t d))
|
||||
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
|
||||
(for-each
|
||||
(lambda (msg)
|
||||
|
|
@ -1272,15 +1082,15 @@
|
|||
(for-each
|
||||
(lambda (msg)
|
||||
(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%
|
||||
(send msg get-data 'plant-id)
|
||||
(send msg get-data 'pos)) #t))
|
||||
(send msg get-data 'pos))))
|
||||
|
||||
((eq? (send msg get-name) 'new-plant)
|
||||
(add-plant (make-object plant-view%
|
||||
(send msg get-data 'plant-id)
|
||||
(send msg get-data 'pos)) #f))
|
||||
(send msg get-data 'pos))))
|
||||
|
||||
((eq? (send msg get-name) 'grow-seed)
|
||||
(grow-seed (send msg get-data 'plant-id)
|
||||
|
|
@ -1367,14 +1177,24 @@
|
|||
|
||||
(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))
|
||||
(yaw 0)
|
||||
(player-plant #f))
|
||||
|
||||
(define/public (set-player-plant s)
|
||||
(set! player-plant s))
|
||||
|
||||
(define/public (get-cam-obj)
|
||||
cam)
|
||||
|
|
@ -1395,6 +1215,13 @@
|
|||
(set-camera-transform (mtranslate (vector 0 0 -1))))
|
||||
|
||||
(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 "d") (key-special-pressed 102)) (set! yaw (- yaw 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 (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)))))))
|
||||
|
||||
; 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 tilt 0 0)))))
|
||||
(mrotate (vector tilt 0 0)))))))
|
||||
|
||||
(let* ((side (vnormalise (vcross up fwd)))
|
||||
(up (vnormalise (vcross fwd side))))
|
||||
|
|
@ -1424,9 +1288,9 @@
|
|||
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
(clear)
|
||||
(define c (make-object controller%))
|
||||
(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 gv setup)
|
||||
|
|
@ -1435,14 +1299,14 @@
|
|||
(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)))
|
||||
|
||||
(send gl add-player plant1)
|
||||
(send c set-player-plant plant1)
|
||||
|
||||
(send gl add-plant plant1)
|
||||
(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))
|
||||
|
||||
(define tick-time 0)
|
||||
(define debounce #t)
|
||||
(define debounce-time 0)
|
||||
|
||||
(define pt 0)
|
||||
(define pd 0.02)
|
||||
|
|
@ -1451,21 +1315,11 @@
|
|||
(define (pt-update) (set! pt (+ pt pd)))
|
||||
|
||||
(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))
|
||||
(set! tick-time (+ (pe-time) logic-tick))
|
||||
(send plant1 grow)
|
||||
(send plant2 grow)
|
||||
(send plant1 grow (vmul (send c get-fwd) -1))
|
||||
(send plant2 grow (vector 0 -1 0))
|
||||
(send gv update (pe-time) (pe-delta) (send gl update)))
|
||||
|
||||
(send gv update (pe-time) (pe-delta) '())
|
||||
|
|
|
|||
Loading…
Reference in a new issue