groworld/plant-eyes/world-build.scm

(define-struct ob (type subtype mesh (pos #:mutable) size rot (root #:mutable)))

(define stone-models (list 
        ;    "meshes/fork.obj"
        "meshes/stone1.obj"
        "meshes/stone2.obj"
        "meshes/stone3.obj"))

(define pickup-models (list
        (list 'leaf "meshes/leaf.obj")
        (list 'horn "meshes/horn.obj")
		(list 'inflatoe "meshes/inflatoe-full.obj")))

(define (extract-list t l)
    (foldl
        (lambda (ob l)
            (if (eq? (ob-type ob) t)
                (cons (list
                        (ob-subtype ob)
                        (ob-mesh ob)
                        (ob-pos ob)
                        (ob-size ob)
                        (ob-rot ob)) l) l))
        '()
        l))

(define (write-out fn s)
    (let ((f (open-output-file fn)))
        (write (extract-list 'seed s) f)
        (write (extract-list 'pickup s) f)
        (write (extract-list 'stone s) f)
        (close-output-port f)))

(define (choose l)
    (list-ref l (random (length l))))


(define (init num-seeds num-pickups num-stones area size)
    (append
        (build-list num-seeds 
            (lambda (_)
                (make-ob 'seed 'seed "meshes/seed.obj"
                    (vmul (srndvec) (* size area 0.5)) 
                    (* 0.12 50)
                    (vmul (rndvec) 0) 0)))
        
        (build-list num-pickups 
            (lambda (_)
                (let ((pickup (choose pickup-models)))
                (make-ob 'pickup (car pickup) (cadr pickup)
                    (vmul (srndvec) (* 150 area))
                    0.5
                    (vmul (rndvec) 360) 0))))
        
        
        (build-list num-stones 
            (lambda (_)
                (make-ob 'stone 'stone (choose stone-models)
                    (vmul (srndvec) area)
                    (* size (- 1 (expt (rndf) 2)))
                    (vmul (rndvec) 360) 0)))))


(define (build l)
    (for-each
        (lambda (ob)
            (set-ob-root! ob (with-state
                    (cond 
                        ((eq? (ob-type ob) 'seed) (colour (vector 0 1 0)))
                        ((eq? (ob-type ob) 'pickup) (backfacecull 0) (hint-unlit) (colour (vector 1 1 0)))
                        ((eq? (ob-type ob) 'stone) (colour (vector 1 0.5 0))))
                    (load-primitive (ob-mesh ob))))
            (when (eq? (ob-type ob) 'stone) (with-primitive (ob-root ob) (hide 1))))
        l))

(define (relax l amount)
    (for-each
        (lambda (ob)
            (set-ob-pos! ob (foldl
                    (lambda (other r)
                        (cond ((< (vdist (ob-pos ob) (ob-pos other)) (* 5 (+ (ob-size ob) (ob-size other))))
                                (vadd r (vmul (vnormalise (vsub (ob-pos ob) (ob-pos other))) amount)))
                            (else r)))
                    (cond ((> (vy (ob-pos ob)) 0)
                        (vadd (ob-pos ob) (vector 0 (* amount -30) 0)))
                        (else (ob-pos ob)))
                    l)))
        l))

(define (update l)
    (for-each
        (lambda (ob)
            (with-primitive (ob-root ob)
                (identity)                        
                (translate (ob-pos ob))
                (rotate (ob-rot ob))
                (scale (ob-size ob))))
        l))


(clear)
(clear-colour 0)
(define s (init 5 200 200 1 10))
(build s)

(define l (make-light 'spot 'free))
(light-diffuse 0 (vector 0 0 0))
(light-specular 0 (vector 0 0 0))
(light-diffuse l (vector 1 1 1))
(light-position l (vector 0 1000 0))
(light-specular l (vector 0.1 0.1 0.1))

(define done #f)

(define (animate)
    (when (key-pressed "s") (write-out "world.txt" s))
    (relax s 0.1)
    (update s))

(every-frame (animate))