#lang scheme

(require "../autocad.ss")
(require (prefix-in s: scheme))

;(require vscheme/autocad)
;;(require (prefix-in s: string))

;;;; Implementation of some L-Systems, described in:
;; http://en.wikipedia.org/wiki/L-system


;; Example 4: Koch curve
;; A variant of the Koch curve which uses only right-angles.
;; variables : F
;; constants : + −
;; start  : F
;; rules  : (F → F+F−F−F+F)
;; Here, F means "draw forward", + means "turn left 90°", and - means "turn right 90°".

(define koch-start "F")
(define koch-rules
  '(("F" . "F+F-F-F+F")))

(define (koch-test)
  (koch-curve 1 5))
(define (koch-curve stride n)
  (let* ([str (apply-rules* koch-rules koch-start n)]
         [len (string-length str)])
    (define (update-p p d c)
      (case c
        [(#\F) (+ p d)]
        [else p]))
    (define (update-d d c)
      (case c
        [(#\+) (v+pol d 0  pi/2)]
        [(#\-) (v+pol d 0 -pi/2)]
        [else d]))
    (define (koch-curve-aux acc p d i)
      (if (= i len)
          (cons p acc)
          (let* ([c (string-ref str i)]
                 [p* (update-p p d c)]
                 [d* (update-d d c)])
          (koch-curve-aux (if (point= p p*)
                              acc
                              (cons p acc)) ;; Don't repeat points
                          p* d*
                          (add1 i)))))
    (make-line (koch-curve-aux (list) origin-2d (vpol stride 0) 0))))


;; Example 6: Sierpinski triangle
;; variables : A B
;; constants : + −
;; start  : A
;; rules  : (A → B−A−B), (B → A+B+A)
;; angle  : 60°
(define sierpinski-start "A")
;;Here, A and B both mean "draw forward", + means "turn left by angle", and
;; − means "turn right by angle". The angle changes sign at each iteration
;; so that the base of the triangular shapes are always in the bottom
;; (they would be in the top and bottom, alternatively, otherwise).

;; Wikipedia doesn't explain it well! The angle must be positive if (even? n),
;; negative otherwise.

(define sierpinski-rules
  '(("A" . "B-A-B")
    ("B" . "A+B+A")))

(define (sierpinski-test)
  (sierpinski-triangle 1 pi/3 10))
(define (sierpinski-triangle stride angle n)
  (let* ([str (apply-rules* sierpinski-rules sierpinski-start n)]
         [len (string-length str)]
         [ang (if (zero? (remainder n 2)) angle (- 0 angle))])
    (define (update-p p d c)
      (case c
        [(#\A #\B) (+ p d)]
        [else p]))
    (define (update-d d c)
      (case c
        [(#\+) (v+pol d 0 ang)]
        [(#\-) (v+pol d 0 (- 0 ang))] ;; XXX: Hmm... How should we treat this... can we curry '- ?
        [else d]))                    ;; What about consistency?
    (define (sierpinski-curve-aux acc p d i)
      (if (= i len)
          (cons p acc)
          (let* ([c (string-ref str i)]
                 [p* (update-p p d c)]
                 [d* (update-d d c)])
            (sierpinski-curve-aux (if (point= p p*)
                                      acc
                                      (cons p acc)) ;; Don't repeat points
                                  p* d*
                                  (add1 i)))))
    (make-line (sierpinski-curve-aux (list) origin-2d (vpol stride 0) 0))))


;; Example 7: Dragon curve
;; The Dragon curve drawn using an L-system.
;; variables : X Y
;; constants : F + −
;; start  : FX
;; rules  : (X → X+YF), (Y → FX-Y)
;; angle  : 90°
(define dragon-start "FX")
(define dragon-rules
  '(("X" . "X+YF")
    ("Y" . "FX-Y")))
;; F means "draw forward", - means "turn left 90°", and + means "turn right 90°".
;; X and Y do not correspond to any drawing action

(define (dragon-test)
  (dragon-curve 1 10))
(define (dragon-curve stride n)
  (let* ([str (apply-rules* dragon-rules dragon-start n)]
         [len (string-length str)])
    (define (update-p p d c)
      (case c
        [(#\F) (+ p d)]
        [else p]))
    (define (update-d d c)
      (case c
        [(#\+) (v+pol d 0  pi/2)]
        [(#\-) (v+pol d 0 -pi/2)]
        [else d]))
    (define (dragon-curve-aux acc p d i)
      (if (= i len)
          (cons p acc)
          (let* ([c (string-ref str i)]
                 [p* (update-p p d c)]
                 [d* (update-d d c)])
          (dragon-curve-aux (if (point= p p*)
                              acc
                              (cons p acc)) ;; Don't repeat points
                          p* d*
                          (add1 i)))))
    (make-line (dragon-curve-aux (list) origin-2d (vpol stride 0) 0))))

;; Example 8: Fractal plant
;; variables : X F
;; constants : + −
;; start  : X
;; rules  : (X → F-[[X]+X]+F[+FX]-X), (F → FF)
;; angle  : 25°

;; (define plant-start "X")
;; (define plant-rules
;;   `(("X" . "F-[[X]+X]+F[+FX]-X")
;;     ("F" . "FF")))

;; (define (plant angle forward-stride n)
;;   (let* ([pos-stack null]
;;          [ang-stack null]
;;          [pts-stack null]
;;          [str (apply-rules* plant-rules plant-start n)]
;;          [len (string-length str)])
;;     (define (plant-aux index)
;;       (if (= index len)
;;           (reverse! pts-stack)
;;        ))
;;     ))




;; General utility functions

;; Apply the rules N times.
(define (apply-rules* rules string n)
  (define (apply-rules*-aux str n)
    (if (zero? n)
        str
        (apply-rules*-aux (apply-rules rules str) (sub1 n))))
  (apply-rules*-aux string n))

;; Apply the rules once.
(define (apply-rules rules string)
  (let ([new ""]
        [length (string-length string)])
    (define (apply-rules-aux index)
        (if (= index length)
            new
            (let* ([c (string-ref string index)]
                   [maybe-rule (assoc (s:string c) rules)])
              (begin
                (if maybe-rule
                    (set! new (string-append new (cdr maybe-rule)))
                    (set! new (string-append new (make-string 1 c))))
                (apply-rules-aux (add1 index))))))
    (apply-rules-aux 0)))



;; Penrose
(define pen-rules
  '(("6" . "81++91----71[-81----61]++")
    ("7" . "+81--91[---61--71]+")
    ("8" . "-61++71[+++81++91]-")
    ("9" . "--81++++61[+91++++71]--71")))
(define pen-start "[7]++[7]++[7]++[7]++[7]")

(define (pen-test) (penrose 1 (/ pi 5) 4))
(define (penrose stride angle n)
  (let* ([str (apply-rules* pen-rules pen-start n)]
         [len (string-length str)]
         [pt-stack (list)]
         [dr-stack (list)])
    (define (update-p p d c)
      (case c
        [(#\1) (+ p d)]
        [(#\[) (set! pt-stack (cons p pt-stack))
               p]
        [(#\]) (let ([p* (first pt-stack)])
                 (set! pt-stack (rest pt-stack))
                 p*)]
        [else p]))
    (define (update-d d c)
      (case c
        [(#\+) (v+pol d 0 angle)]
        [(#\-) (v+pol d 0 angle)]
        [(#\[) (set! dr-stack (cons d dr-stack))
               d]
        [(#\]) (let ([d* (first dr-stack)])
                 (set! dr-stack (rest dr-stack))
                 d*)]
        [else d]))
    (define (pen-aux acc p d i)
      (if (= i len)
          (cons p acc)
          (let* ([c (string-ref str i)]
                 [p* (update-p p d c)]
                 [d* (update-d d c)])
            (if (eqv? c #\])
                (pen-aux (if (> (length (first acc)) 1)
                             (cons (list p*) acc)
                             (cons (list p*) (rest acc)))
                         p* d*
                         (add1 i))
                (pen-aux (cons (if (point= p p*)
                                   (first acc)
                                   (cons p* (first acc))) (rest acc))
                         p* d*
                         (add1 i))))))
    (let ([pts (pen-aux (list (list origin-2d)) origin-2d (vpol stride 0) 0)])
      (apply unite (map make-line (cddr pts))))))