144 lines
4.8 KiB
Scheme
144 lines
4.8 KiB
Scheme
(clear)
|
|
|
|
(define texture-loc "/home/dave/flotsam/groworld/game-prototypes/flatgarden/textures/")
|
|
|
|
; 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.5 0.5))
|
|
(rotate (vector 0 0 90))
|
|
(build-plane)))
|
|
|
|
(with-primitive branch-obj
|
|
(hide 1)
|
|
(apply-transform))
|
|
|
|
(define leaf-obj (with-state
|
|
(translate (vector 0.5 0 0))
|
|
; (scale (vector 1 0.5 0.5))
|
|
(rotate (vector 0 0 -90))
|
|
(build-plane)))
|
|
|
|
(with-primitive leaf-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 (string-append texture-loc "branch-a.png")))
|
|
((char=? #\G char) (make-component branch-obj (string-append texture-loc "branch-b.png")))
|
|
((char=? #\L char) (make-component leaf-obj (string-append texture-loc "leaf-a.png")))
|
|
((char=? #\B char) (make-component leaf-obj (string-append texture-loc "leaf-b.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)
|
|
(let ((c 0))
|
|
(for-each
|
|
(lambda (objs)
|
|
(for-each
|
|
(lambda (obj)
|
|
(with-primitive obj
|
|
(rotate (vector 0 0 (* 0.1 (sin (+ c (time)))))))
|
|
(set! c (+ c 20)))
|
|
objs))
|
|
obj-list)))
|
|
|
|
|
|
(ortho)
|
|
(clear-colour (vector 0 0 0))
|
|
(set-camera-transform (mmul
|
|
(mrotate (vector 0 0 90))
|
|
(mtranslate (vector -9 0 -10))))
|
|
(set-ortho-zoom -10)
|
|
(clear-texture-cache)
|
|
|
|
(define trees '())
|
|
|
|
(colour 1)
|
|
|
|
(for ((i (in-range 0 5)))
|
|
(let ((t2 (with-state
|
|
(translate (vector 0 (* 20 (crndf)) (rndf)))
|
|
(build-locator))))
|
|
(set! trees (cons (ls-build t2 (ls-generate 3 "F" '(("F" "G-[-F+G+FB]+F[+F-G-FL]-F")))
|
|
(+ 10 (random 20)) 0.9) trees))))
|
|
|
|
|
|
(every-frame (animate trees))
|