140 lines
4.4 KiB
Scheme
140 lines
4.4 KiB
Scheme
(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 'flower "meshes/flower.obj")
|
|
(list 'fork "meshes/fork.obj")
|
|
(list 'horn "meshes/horn.obj")
|
|
(list 'inflatoe "meshes/inflatoe-full.obj")
|
|
(list 'nutrient "meshes/nutrient.obj")
|
|
(list 'nutrient "meshes/nutrient.obj")
|
|
(list 'nutrient "meshes/nutrient.obj")
|
|
(list 'nutrient "meshes/nutrient.obj")
|
|
(list 'nutrient "meshes/nutrient.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 4.5))
|
|
(* 0.3 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))
|
|
2
|
|
(vmul (rndvec) 360) 0))))
|
|
|
|
|
|
(build-list num-stones
|
|
(lambda (_)
|
|
(make-ob 'stone 'stone (choose stone-models)
|
|
(vmul (srndvec) (* 150 area))
|
|
(* size 2 (- 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) (hint-none) (hint-wire) (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)) (* 2 (+ (ob-size ob) (ob-size other))))
|
|
(vadd r (vmul (vnormalise (vsub (ob-pos ob) (ob-pos other))) amount)))
|
|
(else r)))
|
|
(if (eq? (ob-type ob) 'seed)
|
|
(cond ((> (vy (ob-pos ob)) -10)
|
|
(vadd (ob-pos ob) (vector 0 (* amount -10) 0)))
|
|
((< (vy (ob-pos ob)) -50)
|
|
(vadd (ob-pos ob) (vector 0 (* amount 10) 0)))
|
|
(else (ob-pos ob)))
|
|
(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 300 100 1 10))
|
|
(build s)
|
|
|
|
(ortho)
|
|
(set-ortho-zoom -500)
|
|
|
|
(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))
|
|
|
|
|