groworld/flatgarden/flatgarden-mulberry.scm

162 lines
5.2 KiB
Scheme
Raw Normal View History

2009-05-01 20:34:29 +00:00
(clear)
(define current-time 0)
(define fps 25)
(define (time-update) (set! current-time (+ current-time (/ 1 fps))))
(define (delta) (/ 1 fps))
(define (time) current-time)
; try all the rules on this character -
; returns #f if none are matched
(define (lsys-run-rules char rules)
(foldl
(lambda (rule str)
(if str ; if str is not #f
str ; then we have already found a rule, return it
(if (char=? char (string-ref (car rule) 0)) ; check this rule
(cadr rule) ; return the string
#f))) ; no match
#f
rules))
; runs the lsystem rules on every character in a string,
; returns the new string
(define (lsys-search-replace str rules pos result)
(cond
((>= pos (string-length str)) result)
(else
(let ((ret (lsys-run-rules (string-ref str pos) rules)))
(if (string? ret)
(lsys-search-replace str rules (+ pos 1)
(string-append result ret))
(lsys-search-replace str rules (+ pos 1)
(string-append result (string (string-ref str pos)))))))))
; runs the search-replace multiple (n) times on a string
(define (ls-generate n str rules)
(cond
((zero? n) str)
(else
(ls-generate (- n 1)
(lsys-search-replace str rules 0 "") rules))))
; todo: get rid of all these
(define branch-obj (with-state
(translate (vector 0.5 0 0))
(scale (vector 1 0.25 0.25))
(rotate (vector 0 0 90))
(build-plane)))
(with-primitive branch-obj
(hide 1)
(apply-transform))
(define leaf-obj (with-state
(translate (vector 1.9 0 0))
(scale (vector 4 2 2))
(rotate (vector 0 0 90))
(build-plane)))
(with-primitive leaf-obj
(hide 1)
(apply-transform))
(define berry-obj (with-state
(translate (vector 1.0 0 0))
(scale (vector 2 1 1))
(rotate (vector 0 0 90))
(build-plane)))
(with-primitive berry-obj
(hide 1)
(apply-transform))
; builds objects from a string
(define (ls-build root string angle branch-scale)
(let ((parent-stack '(root))
(last-obj root)
(obj-list '())
(rot 0))
(define (make-component src-obj tex)
(let ((obj (with-state
(hint-unlit)
(texture (load-texture tex))
(translate (vector 1 0.01 0))
(rotate (vector 0 0 rot))
(set! rot 0)
(build-copy src-obj))))
(with-primitive obj
(hide 0)
;(apply-transform)
(when (not (zero? last-obj))
(parent last-obj)))
(set! last-obj obj)
(set! obj-list (cons obj obj-list))))
(hint-ignore-depth)
(for-each
(lambda (char)
(cond
((char=? #\F char) (make-component branch-obj "textures/mulberry-branch.png"))
((char=? #\G char) (make-component branch-obj "textures/mulberry-branch.png"))
((char=? #\L char) (make-component leaf-obj "textures/mulberry-leaf.png"))
((char=? #\B char) (make-component berry-obj "textures/mulberry-berry.png"))
((char=? #\+ char)
(set! rot (+ rot angle)))
((char=? #\- char)
(set! rot (- rot angle)))
((char=? #\[ char)
(push)
(set! parent-stack (cons last-obj parent-stack))
(scale (vector branch-scale branch-scale branch-scale))
)
((char=? #\] char)
(pop)
(set! last-obj (car parent-stack))
(set! parent-stack (cdr parent-stack)))))
(string->list string))
obj-list))
(define (animate obj-list)
(time-update)
(let ((c 0))
(for-each
(lambda (objs)
(for-each
(lambda (obj)
(with-primitive obj
(rotate (vmul (vector 0 0 (* 1 (sin (+ c (time))))) (delta))))
(set! c (+ c 20)))
objs))
obj-list)))
(persp)
(hint-depth-sort)
(clear-colour (vector 0.1 0.2 0.2))
(set-camera-transform (mmul
(mrotate (vector 0 0 90))
(mtranslate (vector -17 0 -20))))
(set-ortho-zoom -20)
(clear-texture-cache)
(define trees '())
(colour 1)
(fog (vector 0.1 0.2 0.2) 0.02 1 10)
(for ((i (in-range 0 20)))
(let ((t2 (with-state
(translate (vector 0 (* 20 (crndf)) (- 10 (* 50 (rndf)))))
(build-locator))))
; (set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F")))
(set! trees (cons (ls-build t2 (ls-generate 3 "F"
'(("F" "F[--FL]+F[++FB]-F[--FB]")))
(+ 5 (random 50)) 0.95) trees))))
(every-frame (animate trees))