groworld/flatgarden/flatgarden-mulberry.scm

(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))