groworld/fpp/fpp.scm

(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)))
                        (vector (* (cos a) s) (* (sin a) s) (if (odd? i) 0 1))))
                "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)

            (for-each 
                (lambda (child)
                    (send child update))
                child-twigs)

            (when (and (< age size) (< next-ring-time (time)))
                (set! next-ring-time (+ (time) 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))
                        (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) #f)))
                        
                        (build-ring 5 sr er)))))
                    (with-primitive camera (parent p)))
                (set! age (+ age 1))))

          
        
        
        (super-new)))


(define seed%
    (class object%
        (field 
            (twigs '())
            (debounce #t)
            (debounce-time 0)
            (root (with-state
                (translate (vector 0 -0.25 0))
                (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)
            
            (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 (+ (time) 1)))
            
            (when (> (time) debounce-time)
                (set! debounce #t)) 
            
            (for-each 
                (lambda (twig)
                    (send twig update))
                twigs))
        
        (super-new)))

; build world

(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.03   1 100) 
(define s (make-object seed%))

(every-frame (send s update))