;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
; slightly more advanced lsystem for
; interactive growth. 
;
; doing away with strings.
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct token (char gen age id (root #:mutable)))

(define nxt-id 0)

(define (token-gid) 
    (set! nxt-id (+ nxt-id 1))
    nxt-id)

(define (reset-token-gid)
    (set! nxt-id 0))

(define (token-eq? a b)
    (eq? (token-char a) (token-char b)))

(define (token-copy a gen)
    (make-token (token-char a) gen (token-age a) (token-gid) 0))

(define (make-token-list str)
    (map
        (lambda (char)
            (make-token char 0 0 0 0))
        (string->list str)))

(define (copy-token-list str gen)
    (map 
        (lambda (token)
            (token-copy token gen))
        str))

(define (print-token-list tl)
    (for-each
        (lambda (token)
            (printf "(~a ~a ~a)" (token-char token) (token-gen token) (token-age token)))
        tl)
    (newline))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct ls-rule (from to))

; make a rule from a char and a string
(define (make-rule from to)
    (when (not (char? from)) (error ""))
    (make-ls-rule
        (make-token from 0 0 0 0)
        (make-token-list to)))

; convert a list of strings into a list of rules
(define (make-rule-list l)
    (map
        (lambda (r)
            (make-rule (string-ref (car r) 0) (cadr r)))
        l))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct plant ((rules #:mutable) 
        axiom
        angle
        branch-scale
        (str #:mutable) 
        (gen #:mutable) 
        (root #:mutable)
        (components #:mutable)))

(define (build-plant root angle branch-scale rules)
    (make-plant (make-rule-list rules) (make-token-list "FA")
        angle branch-scale '() 0 root '()))

(define (plant-clear plant)
    (set-plant-gen! plant 0)
    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
    (set-plant-components! plant '()))

(define (plant-update plant time)
        
    (when (> (inexact->exact (floor time)) (plant-gen plant))
        (when (< time (plant-gen plant)) (plant-clear plant))
        (set-plant-gen! plant (inexact->exact (floor time)))        
        (destroy (plant-root plant))
        (set-plant-root! plant (build-locator))        
        (reset-token-gid)
        (plant-generate plant)        
        ; (plant-print plant)        
        (set-plant-components! plant (build-components plant (plant-root plant) 
                (plant-angle plant) (plant-branch-scale plant))))
    
    (components-update (plant-components plant) time))

(define (plant-print plant)
    (print-token-list (plant-str plant)))

(define (plant-add-to-rule plant n char)
    (let ((c 0))
        (set-plant-rules! plant 
            (map 
                (lambda (rule)
                    (set! c (+ c 1))
                    (if (eq? (- c 1) n)
                        (make-ls-rule (ls-rule-from rule)
                            (append (ls-rule-to rule) 
                                (list (make-token char -1 (plant-gen plant) 0))))
                        rule))
                (plant-rules plant)))))

; try all the rules on this token - returns #f if none are matched
(define (plant-run-rules plant token gen)
    (foldl
        (lambda (rule str)
            (if str ; if str is not #f
                str ; then we have already found a rule, return it
                (if (token-eq? token (ls-rule-from rule)) ; check this rule
                    (copy-token-list (ls-rule-to rule) gen) ; return the result
                    #f))) ; no match
        #f
        (plant-rules plant)))

; runs the lsystem rules on every token in a list, returns the new list
(define (plant-search-replace plant pos result gen)
    (cond 
        ((>= pos (length (plant-str plant))) result)
        (else
            (let ((ret (plant-run-rules plant (list-ref (plant-str plant) pos) gen)))
                (if (list? ret)
                    (plant-search-replace plant (+ pos 1) (append result ret) gen)
                    (plant-search-replace plant (+ pos 1) 
                        (append result (list (list-ref (plant-str plant) pos))) gen))))))

(define (plant-generate plant)
    ; reset the string
    (set-plant-str! plant (copy-token-list (plant-axiom plant) 0))
    (for ((i (in-range 0 (plant-gen plant))))
        (set-plant-str! plant (plant-search-replace plant 0 '() (+ i 1)))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define-struct component (type root t rot sc id))

(define (components-update components time)
    (for-each
        (lambda (component)
            (let ((t (- time (component-t component))))
                (with-primitive (component-root component)
                    (identity)
                    (translate (vector 1 0 0))        
                    
                    (rotate (vector 0 (+ (* 5 (sin (+ (component-id component) 
                        (* 3 time))))) 0))
                    
                    (if (< t 1)
                        (rotate (vector 0 (* t (component-rot component)) 0))                        
                        (rotate (vector 0 (component-rot component) 0)))
                    
                    (scale (component-sc component))
                    (when (< t 1) (scale (vector t 1 1))))))
        components))

; builds objects from a list of tokens
(define (build-components plant root angle branch-scale)
    (let ((parent-stack '(root))
            (last-obj root)
            (rot 0)
            (sc 1)
            (sc-stack '(1))
            (rot-stack '(0))
            (o (with-state                    
                    (rotate (vector 90 0 0))
                    (translate (vector 0.5 0 0))
                    (scale (vector 1 0.1 0.1))
                    (build-plane))))
        
        
        (define (build-obj-component token)
            (let ((obj (with-state
                            (hint-unlit)
                            (build-copy o))))
                (with-primitive obj
                    (hide 0)
                    (when (not (zero? last-obj))
                        (parent last-obj)))
                (set! last-obj obj)
                (make-component (token-char token) obj (token-gen token) 
                    rot sc (token-id token))))
        
        (with-primitive o
            (hide 1)
            (apply-transform))   
        
        (foldl
            (lambda (token ret)
                (let ((char (token-char token)))
                    (cond 
                        ((char=? #\F char) 
                            (let ((r (build-obj-component token)))
                                (set! rot 0)
                                (cons r ret)))
                        ((char=? #\+ char) (set! rot (+ rot angle)) ret)
                        ((char=? #\- char) (set! rot (- rot angle)) ret)
                        ((char=? #\[ char)
                                (set! parent-stack (cons last-obj parent-stack))
                                (set! sc-stack (cons sc sc-stack))
                                (set! sc (* sc branch-scale))
                                (set! rot-stack (cons rot rot-stack))
                                ret)
                            ((char=? #\] char)
                            (set! last-obj (car parent-stack))                        
                            (set! parent-stack (cdr parent-stack))
                            (set! sc (car sc-stack))                        
                            (set! sc-stack (cdr sc-stack))
                            (set! rot (car rot-stack))                        
                            (set! rot-stack (cdr rot-stack))
                            ret)
                        (else ret))))
            '()
            (plant-str plant))))

;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(clear)

(define root (build-locator))

;(define p (build-plant root 30 0.96 '(("A" "[+FB][-FB]") ("B" "F[+AF]A"))))
(define p (build-plant root 30 0.96 '(("A" "F[++A][F-A]"))))

(define t 0)

(define (animate)
    (let ((t (fmod (* 1 t) 10)))
        (plant-update p t))
    (set! t (+ t 0.01)))

(every-frame (animate))

(start-framedump "gro" "jpg")