140 lines
4.5 KiB
Scheme
140 lines
4.5 KiB
Scheme
|
(define-struct stones (mesh-list (pos-list #:mutable) size-list rot-list
|
||
|
|
(root #:mutable) (obj-list #:mutable)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (stones->list s)
|
||
|
|
(map list
|
||
|
|
(stones-mesh-list s)
|
||
|
|
(stones-pos-list s)
|
||
|
|
(stones-size-list s)
|
||
|
|
(stones-rot-list s)))
|
||
|
|
|
||
|
|
(define (write-out fn s)
|
||
|
|
(let ((f (open-output-file fn)))
|
||
|
|
(write (stones->list s) f)
|
||
|
|
(close-output-port f)))
|
||
|
|
|
||
|
|
(define (choose l)
|
||
|
|
(list-ref l (random (length l))))
|
||
|
|
|
||
|
|
(define models (list
|
||
|
|
; "meshes/fork.obj"
|
||
|
|
"meshes/stone1.obj"
|
||
|
|
"meshes/stone2.obj"
|
||
|
|
"meshes/stone3.obj"))
|
||
|
|
|
||
|
|
(define (stones-init num area size)
|
||
|
|
(make-stones
|
||
|
|
(append (build-list num
|
||
|
|
(lambda (_)
|
||
|
|
(choose models)))
|
||
|
|
(build-list 5
|
||
|
|
(lambda (_)
|
||
|
|
"meshes/seed.obj")))
|
||
|
|
|
||
|
|
(append
|
||
|
|
(build-list num
|
||
|
|
(lambda (_)
|
||
|
|
(vmul (srndvec) (* size area))))
|
||
|
|
(build-list 5
|
||
|
|
(lambda (_)
|
||
|
|
(vmul (srndvec) (* size area 0.5)))))
|
||
|
|
|
||
|
|
(append
|
||
|
|
(build-list num
|
||
|
|
(lambda (_)
|
||
|
|
(* size (- 1 (expt (rndf) 2)))))
|
||
|
|
(build-list 5
|
||
|
|
(lambda (_)
|
||
|
|
1)))
|
||
|
|
|
||
|
|
(append
|
||
|
|
(build-list num
|
||
|
|
(lambda (_)
|
||
|
|
(vmul (rndvec) 360)))
|
||
|
|
(build-list 5
|
||
|
|
(lambda (_)
|
||
|
|
(vmul (rndvec) 360))))
|
||
|
|
|
||
|
|
0
|
||
|
|
'()))
|
||
|
|
|
||
|
|
(define (stones-build stones)
|
||
|
|
(let* ((root (build-locator))
|
||
|
|
(objs (with-state
|
||
|
|
(parent root)
|
||
|
|
(map
|
||
|
|
(lambda (mesh pos size)
|
||
|
|
(let ((p (with-state
|
||
|
|
(if (string=? mesh "meshes/seed.obj")
|
||
|
|
(colour (vector 0 1 0))
|
||
|
|
(colour (vector 1 0.5 0)))
|
||
|
|
(load-primitive mesh))))
|
||
|
|
0
|
||
|
|
p))
|
||
|
|
(stones-mesh-list stones)
|
||
|
|
(stones-pos-list stones)
|
||
|
|
(stones-size-list stones)))))
|
||
|
|
(set-stones-obj-list! stones objs)
|
||
|
|
(set-stones-root! stones root)
|
||
|
|
stones))
|
||
|
|
|
||
|
|
(define (stones-relax stones amount)
|
||
|
|
(let ((done #t))
|
||
|
|
(set-stones-pos-list! stones
|
||
|
|
(map
|
||
|
|
(lambda (pos size)
|
||
|
|
(foldl
|
||
|
|
(lambda (opos osize r)
|
||
|
|
(cond ((< (vdist pos opos) (* 5 (+ size osize)))
|
||
|
|
(set! done #f)
|
||
|
|
(vadd r (vmul (vnormalise (vsub pos opos)) amount)))
|
||
|
|
(else r)))
|
||
|
|
(if (> (vy pos) 0) (vadd pos (vector 0 (* amount -30) 0)) pos)
|
||
|
|
(stones-pos-list stones)
|
||
|
|
(stones-size-list stones)))
|
||
|
|
(stones-pos-list stones)
|
||
|
|
(stones-size-list stones)))
|
||
|
|
done))
|
||
|
|
|
||
|
|
(define (stones-update stones)
|
||
|
|
(let ((root (build-locator)))
|
||
|
|
(with-state
|
||
|
|
(parent root)
|
||
|
|
(for-each
|
||
|
|
(lambda (obj pos size rot)
|
||
|
|
(with-primitive obj
|
||
|
|
(identity)
|
||
|
|
(translate pos)
|
||
|
|
(rotate rot)
|
||
|
|
(scale size)))
|
||
|
|
(stones-obj-list stones)
|
||
|
|
(stones-pos-list stones)
|
||
|
|
(stones-size-list stones)
|
||
|
|
(stones-rot-list stones)))
|
||
|
|
(set-stones-root! stones root)))
|
||
|
|
|
||
|
|
(clear)
|
||
|
|
(clear-colour 0)
|
||
|
|
(define s (stones-build (stones-init 200 1 10)))
|
||
|
|
|
||
|
|
(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 "stones.txt" s))
|
||
|
|
|
||
|
|
(when (not done)
|
||
|
|
(set! done (stones-relax s 0.1))
|
||
|
|
(stones-update s))
|
||
|
|
(when done (printf "done~n")))
|
||
|
|
|
||
|
|
(every-frame (animate))
|
||
|
|
|
||
|
|
|