333 lines
12 KiB
Scheme
333 lines
12 KiB
Scheme
(define max-tokens 1000)
|
|
(define additive-growth #t)
|
|
|
|
(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" (token-char 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)
|
|
base-root
|
|
(components #:mutable)
|
|
(anim-time #:mutable)
|
|
(col #:mutable)))
|
|
|
|
(define (build-plant axiom angle branch-scale rules)
|
|
(let ((base-root (build-locator)))
|
|
(with-state
|
|
(parent base-root)
|
|
(make-plant (make-rule-list rules) (make-token-list axiom)
|
|
angle branch-scale (make-token-list axiom) 0 (build-locator)
|
|
base-root '() (time) (vector 1 1 1)))))
|
|
|
|
(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-inc-gen plant)
|
|
(set-plant-anim-time! plant (time))
|
|
(set-plant-gen! plant (+ (plant-gen plant) 1))
|
|
(destroy (plant-root plant))
|
|
(with-state
|
|
(parent (plant-base-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))))
|
|
|
|
(define (plant-update plant time)
|
|
(components-update plant (plant-components plant) time))
|
|
|
|
(define (plant-print plant)
|
|
(print-token-list (plant-str plant)))
|
|
|
|
(define (plant-add-to-rule plant n s)
|
|
(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)
|
|
(map
|
|
(lambda (char)
|
|
(make-token char -1 (plant-gen plant) 0 0))
|
|
(string->list s))))
|
|
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 (and (token-eq? token (ls-rule-from rule)) ; check this rule
|
|
(< (length (plant-str plant)) max-tokens))
|
|
(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)
|
|
(when (< (length (plant-str plant)) max-tokens)
|
|
; (print-token-list (plant-str plant))
|
|
(cond (additive-growth
|
|
(set-plant-str! plant (plant-search-replace plant 0
|
|
'() (plant-gen plant))))
|
|
(else
|
|
; 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 gen rot sc id))
|
|
|
|
(define (components-update plant components time)
|
|
(for-each
|
|
(lambda (component)
|
|
(let ((growing (eq? (plant-gen plant) (component-gen component)))
|
|
(t (- time (plant-anim-time plant))))
|
|
(with-primitive (component-root component)
|
|
(identity)
|
|
(translate (vector 1 0 0))
|
|
|
|
(rotate (vector 0 (+ (* 0.5 (sin (+ (component-id component)
|
|
(* 3 time))))) 0))
|
|
|
|
(if (and growing (< t 1))
|
|
(rotate (vector 0 (* t (component-rot component)) 0))
|
|
(rotate (vector 0 (component-rot component) 0)))
|
|
|
|
(scale (component-sc component))
|
|
(when (and growing (< 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))
|
|
(bo (with-state
|
|
(rotate (vector 90 0 0))
|
|
(translate (vector 0.5 0 0))
|
|
(scale (vector 1.1 0.1 0.1))
|
|
(build-plane)))
|
|
(lo (with-state
|
|
(rotate (vector 90 0 0))
|
|
(translate (vector 0.5 0 0))
|
|
(build-plane))))
|
|
|
|
|
|
(define (build-obj-component token)
|
|
(let ((obj (with-state
|
|
(colour (plant-col plant))
|
|
(hint-ignore-depth)
|
|
#;(cond
|
|
((char=? #\F (token-char token))
|
|
(texture (load-texture "textures/branch-a.png")))
|
|
((char=? #\G (token-char token))
|
|
(texture (load-texture "textures/branch-b.png")))
|
|
((char=? #\L (token-char token))
|
|
(texture (load-texture "textures/leaf-a.png")))
|
|
((char=? #\M (token-char token))
|
|
(texture (load-texture "textures/leaf-b.png"))))
|
|
(hint-unlit)
|
|
(cond ((or (char=? #\F (token-char token))
|
|
(char=? #\G (token-char token)))
|
|
(build-copy bo))
|
|
((or (char=? #\L (token-char token))
|
|
(char=? #\M (token-char token)))
|
|
(build-copy lo))))))
|
|
(with-primitive obj
|
|
(hide 0)
|
|
(when (not (zero? last-obj))
|
|
(parent last-obj)))
|
|
(set! last-obj obj)
|
|
(make-component (token-char token) obj
|
|
; (if (> (token-age token) (token-gen token))
|
|
; (+ (token-age token) 1)
|
|
(token-gen token);)
|
|
rot sc (token-id token))))
|
|
|
|
(with-primitive bo
|
|
(hide 1)
|
|
(pdata-set! "t" 0 (vector 0 0 0))
|
|
(pdata-set! "t" 1 (vector 0 1 0))
|
|
(pdata-set! "t" 2 (vector 1 1 0))
|
|
(pdata-set! "t" 3 (vector 1 0 0))
|
|
(apply-transform))
|
|
|
|
(with-primitive lo
|
|
(hide 1)
|
|
(pdata-set! "t" 0 (vector 1 1 0))
|
|
(pdata-set! "t" 1 (vector 1 0 0))
|
|
(pdata-set! "t" 2 (vector 0 0 0))
|
|
(pdata-set! "t" 3 (vector 0 1 0))
|
|
(apply-transform))
|
|
|
|
(foldl
|
|
(lambda (token ret)
|
|
(let ((char (token-char token)))
|
|
(cond
|
|
((or (char=? #\F char) (char=? #\G char) (char=? #\L char) (char=? #\M 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))))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(define (choose l)
|
|
(list-ref l (random (length l))))
|
|
|
|
(define (build-foliage count rules)
|
|
(build-list count
|
|
(lambda (_)
|
|
(with-state
|
|
(translate (vector 0 (+ 0 (* (rndf) 10)) (* 15 (crndf))))
|
|
(build-plant "FA" (* 40 (crndf)) 0.96 (choose rules))))))
|
|
|
|
|
|
(define (foliage-grow foliage)
|
|
(for-each
|
|
(lambda (plant)
|
|
(for ((i (in-range 2 (random 10))))
|
|
(set-plant-col! plant (vmul (vector 0 0.6 0.6) (rndf)))
|
|
(plant-inc-gen plant)))
|
|
foliage))
|
|
|
|
(define (foliage-update foliage time)
|
|
(for-each
|
|
(lambda (plant)
|
|
(plant-update plant time))
|
|
foliage))
|
|
|
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
|
|
(clear)
|
|
(clear-colour (vector 0 0.3 0.2))
|
|
(set-camera-transform (mmul (mtranslate (vector 0 -5 -10))
|
|
(mrotate (vector 90 -90 180))))
|
|
|
|
(with-state
|
|
(hint-unlit)
|
|
(colour (vector 0 0.2 0.1))
|
|
(scale 100)
|
|
(rotate (vector 0 90 0))
|
|
(build-plane))
|
|
|
|
(define rules '(("A" "F-[+F+F+FA]+F[+F-F-FA]-F[-F-FA]")))
|
|
(define p (build-plant "A" 34 0.96 rules))
|
|
(set-plant-col! p (vector 0.5 1 0.5))
|
|
|
|
(define t (time))
|
|
|
|
(define (animate)
|
|
|
|
(when (> (time) t)
|
|
(set! t (+ t 1))
|
|
(plant-inc-gen p))
|
|
|
|
(when (> (plant-gen p) 10)
|
|
(plant-clear p)
|
|
(set-plant-rules! p (make-rule-list rules)))
|
|
|
|
(plant-update p (time)))
|
|
|
|
(every-frame (animate))
|