242 lines
8.1 KiB
Scheme
242 lines
8.1 KiB
Scheme
|
;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
; 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")
|