344 lines
11 KiB
Scheme
344 lines
11 KiB
Scheme
;#lang scheme/base
|
|
;(require fluxus-016/drflux)
|
|
(require scheme/class)
|
|
|
|
|
|
;=====================================================================
|
|
|
|
(clear)
|
|
|
|
(define (build-ring n sr er)
|
|
(let ((p (build-polygons (+ (* n 2) 2) 'triangle-strip)))
|
|
(with-primitive p
|
|
(pdata-index-map!
|
|
(lambda (i p)
|
|
(let ((a (* (/ (quotient i 2) n) (* 2 3.141)))
|
|
(s (* (if (odd? i) sr er) 5)))
|
|
(vector (* (cos a) s) (* (sin a) s) (if (odd? i) 0 5 ))))
|
|
"p")
|
|
|
|
(recalc-normals 1))
|
|
p))
|
|
|
|
(define camera (build-locator))
|
|
|
|
(define twig%
|
|
(class object%
|
|
(init-field
|
|
(size 100)
|
|
(radius 1)
|
|
(speed 0.2))
|
|
(field
|
|
(root (build-locator))
|
|
(child-twigs '())
|
|
(age 0)
|
|
(tx (mident))
|
|
(next-ring-time 0))
|
|
|
|
(define/public (build pos dir)
|
|
(with-primitive root
|
|
(translate pos)
|
|
(cond (dir
|
|
(concat (maim dir (vector 0 0 1)))
|
|
(rotate (vector 0 -90 0)))
|
|
(else (rotate (vmul (crndvec) 20))))))
|
|
|
|
(define/public (update t)
|
|
|
|
(for-each
|
|
(lambda (child)
|
|
(send child update t))
|
|
child-twigs)
|
|
|
|
(when (and (< age size) (< next-ring-time t))
|
|
(set! next-ring-time (+ t speed))
|
|
(let ((p (with-state
|
|
(parent root)
|
|
(hint-depth-sort)
|
|
(colour (vector 0.8 1 0.6))
|
|
(texture (load-texture "textures/skin.png"))
|
|
;(hint-none)
|
|
;(hint-wire)
|
|
(backfacecull 1)
|
|
(let* ((s (- size age))
|
|
(sr (* radius (/ s size)))
|
|
(er (* radius (/ (- s 1) size))))
|
|
(translate (vector 0 0 (* age 5)))
|
|
(when (zero? (random 3))
|
|
(with-state
|
|
(identity)
|
|
(set! child-twigs (cons
|
|
(make-object twig% (/ size 2) sr speed) child-twigs))
|
|
(send (car child-twigs) build (vector 0 0 (* age 5) ) #f)))
|
|
|
|
(build-ring 5 sr er)))))
|
|
(with-primitive camera (parent p)))
|
|
(set! age (+ age 1))))
|
|
|
|
|
|
|
|
|
|
(super-new)))
|
|
|
|
(define pickup%
|
|
(class object%
|
|
(init-field
|
|
(pos (vector 0 0 0)))
|
|
(field
|
|
(col (vmul (rndvec) 0.1))
|
|
(root (let ((p (with-state
|
|
(translate pos)
|
|
(hint-depth-sort)
|
|
(blend-mode 'src-alpha 'one)
|
|
(texture (load-texture "textures/particle.png"))
|
|
(build-particles 20))))
|
|
(with-primitive p
|
|
(pdata-add "vel" "v")
|
|
(pdata-map!
|
|
(lambda (vel)
|
|
(vmul (vector (crndf) (* 2 (rndf)) (crndf)) 0.02))
|
|
"vel")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vector 2 2 2))
|
|
"s")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
col)
|
|
"c"))
|
|
p)))
|
|
|
|
(define/public (get-pos)
|
|
pos)
|
|
|
|
(define/public (update t)
|
|
(with-primitive root
|
|
(pdata-op "+" "p" "vel")
|
|
(pdata-op "*" "c" 0.996)
|
|
(pdata-op "*" "s" 1.005)
|
|
(when (zero? (random 5))
|
|
(let ((reset (random (pdata-size))))
|
|
(pdata-set! "c" reset col)
|
|
(pdata-set! "p" reset (vector 0 0 0))
|
|
(pdata-set! "s" reset (vector 2 2 2))))))
|
|
|
|
(super-new)))
|
|
|
|
(define seed%
|
|
(class object%
|
|
(field
|
|
(twigs '())
|
|
(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)) 90))
|
|
"p")
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(vector 1 1 1))
|
|
"s"))
|
|
p))
|
|
(pickups (build-list 1 (lambda (_)
|
|
(make-object pickup% (vmul (vsub (crndvec) (vector 0 1 0)) 50)))))
|
|
(indicator (let ((p (with-state
|
|
(hint-depth-sort)
|
|
;(blend-mode 'src-alpha 'one )
|
|
(texture (load-texture "textures/particle.png"))
|
|
(build-particles 200))))
|
|
(with-primitive p
|
|
(pdata-add "vel" "v")
|
|
(pdata-map!
|
|
(lambda (vel)
|
|
(srndvec))
|
|
"vel")
|
|
(pdata-map!
|
|
(lambda (c)
|
|
(vector 0 0 0.1))
|
|
"c")
|
|
|
|
(pdata-map!
|
|
(lambda (s)
|
|
(let ((sz (rndf)))
|
|
(vector sz sz sz)))
|
|
"s"))
|
|
p))
|
|
(debounce #t)
|
|
(debounce-time 0)
|
|
(pos (vector 0 0 0))
|
|
(root (with-state
|
|
(scale 5)
|
|
(translate pos)
|
|
(texture (load-texture "textures/skin.png"))
|
|
(backfacecull 0)
|
|
(opacity 0.6)
|
|
(colour (vector 0.8 1 0.6))
|
|
(hint-depth-sort)
|
|
(hint-unlit)
|
|
(load-primitive "meshes/seed.obj"))))
|
|
|
|
(define/public (add-twig dir)
|
|
(let ((t (make-object twig% 10 0.2 2)))
|
|
(set! twigs (cons (with-state
|
|
(colour (vector 0.3 0.8 0.4))
|
|
(send t build (vector 0 0 0) dir) t) twigs))))
|
|
|
|
|
|
(define/public (update t)
|
|
|
|
(let ((closest (foldl
|
|
(lambda (pickup r)
|
|
(if (< (vdist (send pickup get-pos) pos)
|
|
(vdist pos r))
|
|
(send pickup get-pos) r))
|
|
(vector 999 999 999)
|
|
pickups)))
|
|
|
|
(with-primitive indicator
|
|
(pdata-op "+" "p" "vel")
|
|
(when (< (sin (* 2 t)) 0)
|
|
(let ((reset (random (pdata-size))))
|
|
(let ((pos (vmul (vnormalise (vsub closest pos)) 10)))
|
|
(pdata-set! "vel" reset (vadd (vmul (srndvec) 0.01)
|
|
(vmul (vsub closest pos) (* (rndf) 0.01))))
|
|
(pdata-set! "p" reset pos))))))
|
|
|
|
(with-primitive root
|
|
(scale (+ 1 (* 0.001 (sin (* 2 t))))))
|
|
|
|
(when (key-pressed "r") (with-primitive camera (parent 1)))
|
|
|
|
(when (and debounce (key-pressed " "))
|
|
(add-twig (vtransform-rot (vector 0 0 1) (minverse (get-camera-transform))))
|
|
(set! debounce #f)
|
|
(set! debounce-time (+ t 1)))
|
|
|
|
(when (> t debounce-time)
|
|
(set! debounce #t))
|
|
|
|
(for-each
|
|
(lambda (twig)
|
|
(send twig update t))
|
|
twigs)
|
|
(for-each
|
|
(lambda (pickup)
|
|
(send pickup update t))
|
|
pickups))
|
|
|
|
(super-new)))
|
|
|
|
; build world
|
|
|
|
(with-state
|
|
(scale 5 )
|
|
(translate (vector 0 0 0))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/top.png"))
|
|
(translate (vector 0 20 0))
|
|
(rotate (vector 90 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/left.png"))
|
|
(translate (vector 0 0 -20))
|
|
(rotate (vector 0 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/back.png"))
|
|
(translate (vector 20 0 0))
|
|
(rotate (vector 0 90 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/right.png"))
|
|
(translate (vector 0 0 20))
|
|
(rotate (vector 0 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/front.png"))
|
|
(translate (vector -20 0 0))
|
|
(rotate (vector 0 90 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/bottom.png"))
|
|
(opacity 0.8)
|
|
(hint-depth-sort)
|
|
(translate (vector 0 2 0))
|
|
(rotate (vector 90 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
; soil
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/sback.png"))
|
|
(translate (vector 0 -15 -19.99))
|
|
(rotate (vector 0 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/sleft.png"))
|
|
(translate (vector 19.9 -15 0))
|
|
(rotate (vector 0 90 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/sfront.png"))
|
|
(translate (vector 0 -15 19.9))
|
|
(rotate (vector 0 0 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane))
|
|
|
|
(with-state
|
|
(texture (load-texture "textures/sright.png"))
|
|
(translate (vector -19.9 -15 0))
|
|
(rotate (vector 0 90 0))
|
|
(scale 40)
|
|
(hint-unlit)
|
|
(build-plane)))
|
|
|
|
(lock-camera camera)
|
|
(camera-lag 0.05)
|
|
|
|
(define l (make-light 'point 'free))
|
|
(light-diffuse 0 (vector 0 0 0))
|
|
(light-diffuse l (vector 1 1 1))
|
|
(light-position l (vector 10 50 -4))
|
|
|
|
(clear-colour (vector 0.1 0.3 0.2))
|
|
|
|
(fog (vector 0.2 0.5 0.3) 0.01 1 100)
|
|
(define s (make-object seed%))
|
|
|
|
(define t 0)
|
|
|
|
(define (animate)
|
|
(send s update t)
|
|
(set! t (+ t 0.02)))
|
|
|
|
(every-frame (animate))
|
|
|