#lang racket/gui
(require graphics/turtles)

;;Órdenes LOGO
(define forward draw)
(define fd draw)

(define back (lambda (n) (draw (- n))))
(define bk back)

(define left turn)
(define lt turn)

(define right (lambda (gr) (turn (- gr))))
(define rt right)

(define clearscreen clear)
(define cs clear)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Interpretación à la LOGO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define Base 40)
(define base 25)
(define Altura 20)

(define raiz
  (lambda ()
    (cs)
    (lt 90)
    (move 300)
    (lt 180)
;    (fd 600) (move -600)
    ))
(define linea-base
  (lambda (altura)
    (move (* altura 2))
    ))
(define punto-inicial
  (lambda (lista-signos)
    (let* ((lista-lados
            (map
             (lambda (s)
               (cond
                 ((char=? s #\R) Base)
                 ((char=? s #\L) Base)
                 ((char=? s #\r) base)
                 ((char=? s #\l) base)
                 )
               )
             lista-signos))
           (long-lista-lados (length lista-lados))
           (suma (+ (apply + lista-lados) (* 5 (sub1 long-lista-lados))))
           )
      (/ suma 2)
      )
    ))
(define next-nivel
  (lambda (altura lista-signos)
    (linea-base altura)
    (lt 90)
    (move (- (punto-inicial lista-signos)))
    ))
(define rectangulo
    (lambda (b a)
      (fd b)
      (rt 90)
      (fd a)
      (rt 90)
      (fd b)
      (rt 90)
      (fd a)
      (rt 90)
      ))
(define flecha-d
  (lambda (tamaño)
    (lt 90)
    (move (- (/ Altura 2)))
    (rt 90)
    (move 5)
    (fd (- tamaño 10))
    (rt 15)
    (bk 20)
    (move 20)
    (lt 30)
    (bk 20)
    (move 20)
    (rt 15)
    (move (- (- tamaño 5)))
    (lt 90)
    (move (/ Altura 2))
    (rt 90)
    ))
(define flecha-i
  (lambda (tamaño)
    (move tamaño)
    (rt 90)
    (move (/ Altura 2))
    (rt 90)
    (move 5)
    (fd (- tamaño 10))
    (rt 15)
    (bk 20)
    (move 20)
    (lt 30)
    (bk 20)
    (move 20)
    (rt 15)
    (move 5)
    (rt 90)
    (move (/ Altura 2))
    (rt 90)
    ))

(define dibuja-rectangulos
  (lambda (lista-signos)
    (for-each
     (lambda (char)
       (cond
         ((char=? char #\R) (rectangulo Base Altura) (flecha-d Base) (move (+ 5 Base)))
         ((char=? char #\L) (rectangulo Base Altura) (flecha-i Base) (move (+ 5 Base)))
         ((char=? char #\r) (rectangulo base Altura) (flecha-d base) (move (+ 5 base)))
         ((char=? char #\l) (rectangulo base Altura) (flecha-i base) (move (+ 5 base)))
         (else "error")
         ) )
     lista-signos)
    ))
(define dibuja-nivel
  (lambda (lista-signos)
    (next-nivel Altura lista-signos)
    (dibuja-rectangulos lista-signos)
    (move (- (punto-inicial lista-signos)))
    (rt 90)
    ))
(define interpretacion-ristra
  (lambda (ristra)
    (sleep/yield 1)
    (dibuja-nivel (string->list ristra))
    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Sistema-DOL: Isla de Koch cuadratic
;;1. Hay que contar con un vocabulario
(define vocabulario (list #\R #\L #\r #\l))
;;2. Operación para formar expresiones compuestas
(define-syntax concatenar
  (syntax-rules ()
    [(concatenar x ...)
     (apply string-append
            (map
             (lambda (s)
               (cond
                 ((char? s) (string s))
                 ((string? s) s)
                 (else #f)
                 ))
             (list x ...))
            )
     ]
    ))
;;3. Predicado de tipo
(define-syntax ristra?
  (syntax-rules ()
    [
     (ristra? s)
     (andmap
      (lambda (char)
        (if (member char vocabulario)
            #t
            #f))
      (string->list s))
     ]
    ))
;;4. Reglas de producción
(define regla_R
  (lambda (signo)
    (if (char=? signo #\R)
        (concatenar #\L #\r)
        #f)
    ))
(define regla_L
  (lambda (signo)
    (if (char=? signo #\L)
        (concatenar #\l #\R)
        #f)
    ))
(define regla_r
  (lambda (signo)
    (if (char=? signo #\r)
        (concatenar #\R)
        #f)
    ))
(define regla_l
  (lambda (signo)
    (if (char=? signo #\l)
        (concatenar #\L)
        #f)
    ))
;;5. Se aplica una de las tres reglas
(define aplicar-reglas
  (lambda (char)
    (or
     (regla_R char)
     (regla_L char)
     (regla_r char)
     (regla_l char)
     )
    ))
;;6. Procedimiento auxiliar de transformación
(define transformar
  (lambda (lista-char)
    (if (null? lista-char)
        ""
        (concatenar
         (aplicar-reglas (first lista-char))
         (transformar (rest lista-char))
         )
        )
    ))
;;6. Método de transformación
(define derivacion_1
  (lambda (tesis)
    (if (ristra? tesis)
        (transformar (string->list tesis))
        (printf "~a ha de ser una tesis~n" tesis)
        )
    ))
;;7. Derivación de n aplicaciones
(define derivacion_n
  (lambda (tesis n)
    (let go ((i 0)
             (j n)
             (S tesis)
             )
      (if (= i j)
          S
          (go (add1 i) j (derivacion_1 S))
          )
      )
    ))

(define axioma (string #\R))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Resultado de la interpretación LOGO
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define interpretando
  (lambda (tesis n)
    (turtles)
    (raiz)
    (sleep/yield 1)
    (let go ((i 0)
             (j n)
             (S tesis)
             )
      (if (= i j)
          (move 50)
          (begin
            (printf "~a~n" S)
            (interpretacion-ristra S)
            (go (add1 i) j (derivacion_1 S))
            )
          )
      )
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(interpretando axioma 7)

