#lang racket
(require (planet "main.rkt" ("samsergey" "rewrite.plt" 1 0))
         rackunit)

;;;=============================================================
;;; The definition of a functional type Tape,
;;; representing infinite tape with O(1) operations:
;;; put, get, shift-right and shift-left.
;;;=============================================================

(struct Tape (the-left-part      ; i-1 i-2 i-3 ...
              the-current-record ; i
              the-right-part))   ; i+1 i+2 i+3 ...

;; The tape in initial state
(define/. initial-tape 
  (cons h t) --> (Tape '() h t))

;; shift caret to the right
(define (snoc a b) (cons b a))
(define/. shift-right
  (Tape '() '() (cons h t)) --> (Tape '() h t)            ; left end
  (Tape  l x '())           --> (Tape (snoc l x) '() '()) ; right end
  (Tape  l x (cons h t))    --> (Tape (snoc l x) h t))    ; general case

;;  shift caret to the left
(define/. flip-tape 
  (Tape l x r) --> (Tape r x l))

(define shift-left 
  (compose flip-tape shift-right flip-tape))

;; access to the current record on the tape
(define/. get 
  (Tape _ v _) --> v)

(define/. put 
  '() t --> t            
  v (Tape l _ r) --> (Tape l v r))

;; List representation of the tape (≤ O(n)).
;; A tape is shown as (... a b c (d) e f g ...)
;; where (d) marks the current position of the caret.
(define (revappend a b) 
  (foldl cons b a))
(define/. show-tape
  (Tape '() '() '()) --> '() 
  (Tape l '() r) --> (revappend l (cons '() r)) 
  (Tape l v r) --> (revappend l (cons (list v) r)))


;;;=============================================================
;;; The Turing Machine interpreter
;;;
;;; The machine is defined by a program -- a set of rules:
;;;
;;;                 '(S1 v1) --> '(S2 v2 d)
;;;
;;; where S1 and v1 -- are current state and record on the tape,
;;;       S2 and v2 -- are new state and record,
;;;       d ∈ {'r 'l 'p} -- is a caret shift direction.
;;;=============================================================

;; interpretation of output triple for a given tape
(define/. interprete
  (list S v 'r) tape --> (list S (shift-right (put v tape))) 
  (list S v 'l) tape --> (list S (shift-left  (put v tape))) 
  (list S v 'p) tape --> (list S              (put v tape))  
  (list S _)    tape --> (list S                     tape))

;; Running the program.
;; The initial state is set to 'Start.
;; The initial tape is given as a list of records.
;; The initial position is the leftmost symbol of initial record.
(define (run-turing prog t0 verbose)
  ((replace-repeated
    `(,S ,T) --> (begin
                   (when verbose (printf "~a\t~a\n" S (show-tape T)))
                   (interprete (prog `(,S ,(get T))) T)))
   (list 'Start (initial-tape t0))))

;; A syntax for definition of a Turing-Machines.
;; Transforms to a function which accepts a list of initial
;; tape records as input and returns the tape after stopping.
(define-syntax-rule (Turing-Machine prog ...)
  (λ (l #:verbose? (verbose #t))
    (when verbose (displayln "STATE\tTAPE"))
    ((/. (list _ t) --> (flatten (show-tape t))) 
     (run-turing (replace prog ...) l verbose))))

;;;=============================================================
;;; Examples
;;;=============================================================

(define ADD1
  ; adds 1 to a binary number
  (Turing-Machine
   '(Start 1) --> '(Start 1 r) 
   '(Start 0) --> '(Start 0 r) 
   '(Start ()) --> '(Add () l) 
   '(Add 0) --> '(End 1 p) 
   '(Add 1) --> '(Add 0 l) 
   '(Add ()) --> '(End 1 p)))

; to see this machine in work run the commands
 (ADD1 '(1 0 1 1 1 1))
 (ADD1 (ADD1 '(1 1 0)))

(check-equal? (ADD1 '(1 0 1) #:verbose? #f)  '(1 1 0))
(check-equal? (ADD1 '(0) #:verbose? #f)      '(1))
(check-equal? (ADD1 '(1) #:verbose? #f)      '(1 0))
(check-equal? (ADD1 '(1 1 1)  #:verbose? #f) '(1 0 0 0))

; Here we cheat and use patterns to save lines of code.
; In classical Turing machine program we need to consider
; all possible symbols for all states.
(define ADDER
  ; adds unary numbers
  (Turing-Machine
   '(Start 1) --> '(Drag * r) 
   '(Start +) --> '(Start + r) 
   '(Start =) --> '(End = p) 
   '(Drag ()) --> '(Return 1 l) 
   `(Drag ,x) --> `(Drag ,x r) 
   '(Return *) --> '(Start 1 r) 
   `(Return ,x) --> `(Return ,x l)))

; to see this machine in work run the command
; (ADDER '(1 1 + 1 1 1 =))

(check-equal? (ADDER '(1 + 1 =)  #:verbose? #f)         '(1 + 1 = 1 1))
(check-equal? (ADDER '(1 1 + 1 1 1 =)  #:verbose? #f)   '(1 1 + 1 1 1 = 1 1 1 1 1))
(check-equal? (ADDER '(1 1 + 1 + 1 1 =)  #:verbose? #f) '(1 1 + 1 + 1 1 = 1 1 1 1 1))
(check-equal? (ADDER '(1 1 =)  #:verbose? #f)           '(1 1 = 1 1))