ondramaze

(define get-maze
  '(
    (w w w w w w)
    (w 0 w 0 w w)
    (w 0 w 0 0 w)
    (w 0 0 0 w w)
    (w w w w w w)
    )
  )
(define right-hand-rule-prg
  '(
    (procedure start
               ( turn-right
                 (if wall?
                     ( turn-left
                       (if wall?
                           (turn-left
                            (if wall?
                                turn-left
                                step
                                )
                            )
                           step
                           )
                       )
                     step
                     )
                 put-mark
                 start
                 )
               )
    (procedure turn-right (turn-left turn-left turn-left))
    )
  )


(define (get-1d-element arr x)
  (if (zero? x)
      (car arr)
      (get-1d-element (cdr arr) (- x 1))
      ))

(define (get-2d-element arr x y)
  (get-1d-element (get-1d-element arr x) y)
  )

(define (set-1d-element arr x val)
  (if (zero? x)
      (cons val (cdr arr))
      (cons (car arr) (set-1d-element (cdr arr) (- x 1) val))
      ))

(define (set-2d-element arr x y val)
  (if (zero? x)
      (cons (set-1d-element (car arr) y val) (cdr arr))
      (cons (car arr) (set-2d-element (cdr arr) (- x 1) y val))
      ))

(define (decrement-value arr x y)
  (let* ((value (get-2d-element arr x y)))
    (set-2d-element arr x y (- value 1))
    ))

(define (increment-value arr x y)
  (let* ((value (get-2d-element arr x y)))
    (set-2d-element arr x y (+ value 1))
    ))

(define (north? state)
  (if (equal? (caddr state) 'north)
      #t
      #f
      )
  )

(define (south? state)
  (if (equal? (caddr state) 'south)
      #t
      #f
      )
  )
(define (west? state)
  (if (equal? (caddr state) 'west)
      #t
      #f
      )
  )
(define (east? state)
  (if (equal? (caddr state) 'east)
      #t
      #f
      )
  )

(define (mark? expr)
  (let* ((state (cadr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (position (get-2d-element maze coordinate-x coordinate-y)))
    (if (and (number? position) (> position 0))
        #t
        #f
        )
    )
  )

(define (wall? expr)
  (let* ((state (cadr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (position (get-2d-element maze coordinate-x coordinate-y))
         (direction (caddr state)))
    (cond
      ((equal? direction 'north)
       (if (equal? 'w (get-2d-element maze (- coordinate-x 1) coordinate-y))
           #t
           #f
           ))
      ((equal? direction 'south)
       (if (equal? 'w (get-2d-element maze (+ coordinate-x 1) coordinate-y))
           #t
           #f
           ))
      ((equal? direction 'east)
       (if (equal? 'w (get-2d-element maze coordinate-x (+ coordinate-y 1)))
           #t
           #f
           ))
      (else (if (equal? 'w (get-2d-element maze coordinate-x (- coordinate-y 1)))
                #t
                #f
                ))
      )))

(define (put-mark expr)
  (let* ((state (cadr expr))
         (log (car expr))
         (limit (caddr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (position (get-2d-element maze coordinate-x coordinate-y))
         (direction (caddr state)))
    (if (number? position)
        (list (append log (list 'put-mark)) (list (increment-value maze coordinate-x coordinate-y) (list coordinate-x coordinate-y) direction) limit)
        expr
        )))

(define (get-mark expr)
  (let* ((state (cadr expr))
         (log (car expr))
         (limit (caddr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (position (get-2d-element maze coordinate-x coordinate-y))
         (direction (caddr state)))
    (if (and (number? position) (> position 0))
        (list (append log (list 'get-mark)) (list (decrement-value maze coordinate-x coordinate-y) (list coordinate-x coordinate-y) direction) limit)
        expr
        )))


(define (turn-left expr)
  (let* ((state (cadr expr))
         (log (car expr))
         (limit (caddr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (direction (caddr state)))
    (cond
      ((north? state) (list (append log (list 'turn-left)) (list maze (list coordinate-x coordinate-y) 'west) limit))
      ((south? state) (list (append log (list 'turn-left)) (list maze (list coordinate-x coordinate-y) 'east) limit))
      ((west? state) (list (append log (list 'turn-left)) (list maze (list coordinate-x coordinate-y) 'south) limit))
      (else  (list (append log (list 'turn-left)) (list maze (list coordinate-x coordinate-y) 'north) limit ))
      ))
  )

(define (step expr)
  (let* ((state (cadr expr))
         (log (car expr))
         (limit (caddr expr))
         (maze (car state))
         (coordinate-x (car (cadr state)))
         (coordinate-y (cadr (cadr state)))
         (direction (caddr state)))
    (if (wall? expr)
        expr
        (cond
          ((north? state) (list (append log (list 'step)) (list maze (list (- coordinate-x 1) coordinate-y) direction) limit))
          ((south? state) (list (append log (list 'step)) (list maze (list (+ coordinate-x 1) coordinate-y) direction) limit))
          ((west? state) (list (append log (list 'step)) (list maze (list coordinate-x (- coordinate-y 1)) direction) limit))
          (else  (list (append log (list 'step)) (list maze (list coordinate-x (+ coordinate-y 1)) direction) limit))
          )

        ))
  )
(define (atom? x)
  (and (not (pair? x))
       (not (null? x))))

(define (is-command? expr program)
  (cond
    ((equal? expr 'turn-left) #t)
    ((equal? expr 'step) #t)
    ((equal? expr 'put-mark) #t)
    ((equal? expr 'get-mark) #t)
    ((is-procedure? expr program) #t)
    (else #f)
    ))

(define (is-form? expr) (list? expr))

(define (is-condition? expr) (and (list? expr) (equal? 'if (car expr))))

(define (is-procedure? expr program)
  (if (and (atom? expr) (not (null? program)))
      (if (equal? expr (cadr (car program)))
          #t
          (is-procedure? expr (cdr program))
          )
      #f
      ))

(define (eval-command expr state program)
  (cond
    ((is-condition? expr) (eval-condition expr state program))
    ((equal? expr 'turn-left) (turn-left state))
    ((equal? expr 'step) (step state))
    ((equal? expr 'put-mark) (put-mark state))
    ((equal? expr 'get-mark) (get-mark state))
    ((is-procedure? expr program) (eval-procedure expr (list (car state) (cadr state) (- (caddr state) 1)) program))
    )
  )

(define (eval-condition expr state program)
  (cond
    ((equal? (cadr expr) 'wall?) (if (wall? state)
                                     (eval-expr state (caddr expr) program)
                                     (eval-expr state (cadddr expr) program)))
    ((equal? (cadr expr) 'mark?) (if (mark? state)
                                     (eval-expr state (caddr expr) program)
                                     (eval-expr state (cadddr expr) program)))
    ((equal? (cadr expr) 'north?) (if (north? state)
                                      (eval-expr state (caddr expr) program)
                                      (eval-expr state (cadddr expr) program)))

    (else display "CHYBA EVAL-CONDITION"))

  )

(define (eval-form expr state program)
  (cond
    ((null? expr) state)
    ((is-condition? expr) (eval-condition expr state program))
    ((is-command? (car expr) program) (eval-form (cdr expr) (eval-command (car expr) state program) program))
    (else (eval-form (cdr expr) (eval-form (car expr) state program) program))
    )
  )

(define (get-procedure expr program)
  (if (equal? expr (cadr (car program)))
      (car program)
      (get-procedure expr (cdr program))
      )
  )
(define (eval-procedure expr state program)
  (display expr)
  (if (> (caddr state) 0)
      (let* ((as (eval-expr state (caddr (get-procedure expr program)) program)))
        (list (car as) (cadr as) (+ (caddr as) 1)))
      state))


(define (eval-expr state expr program)
  (cond ((is-command? expr program) (eval-command expr state program))
        ((is-form? expr)   (eval-form expr state program))
        ((is-procedure? expr program) (eval-procedure expr (list (car state) (cadr state) (- (caddr state) 1))  program))
        (else display "CHYBA EVAL-EXPR"))

  )


(define (simulate state expr program limit)
  (eval-expr (list '() state limit) expr program)
  )