;; Copyright 2005 Matthieu Lemerre. Covered by the GNU GPL.

;; TODO: * Use GOOPS to overload write instead of using method triple-print.
;;       * Extend to non-deterministic machines.


;; Doubly linked list type definition.

(use-modules (srfi srfi-9))

(define-record-type :triple
  (make-triple previous value next)
  triple?
  (previous previous set-previous!)
  (next next set-next!)
  (value value set-value!))

(define (triple-cons a b)
  (set-previous! b a)
  (set-next! a b)
  a)

(define triple-nil (gensym))

(define (triple-null? triple)
  (eq? triple triple-nil))

(define (doubly-linked-list list)
  (if (null? list)
      triple-nil
      (let my-doubly-linked-list ((my-list list))
	(if (null? (cdr my-list))
	    (make-triple triple-nil (car my-list) triple-nil)
	    (let ((triple-cdr (my-doubly-linked-list (cdr my-list)))
		  (triple-car (make-triple triple-nil (car my-list) triple-nil)))
	      (triple-cons triple-car triple-cdr))))))

(doubly-linked-list '(a))

(define (triple-next-or-new triple new-symbol)
  (let ((next-triple (next triple)))
    (if (triple-null? next-triple)
	(next (triple-cons triple (make-triple triple-nil new-symbol triple-nil)))
	next-triple)))

(define (triple-previous-or-new triple new-symbol)
  (let ((previous-triple (previous triple)))
    (if (triple-null? previous-triple)
	(triple-cons (make-triple triple-nil new-symbol triple-nil) triple)
	previous-triple)))


;; We could do a map or something like this.
(define (triple-print triple)
  (if (triple-null? triple)
      (display "#d()# ")
      
      (begin
	;; Print the left part
	(let print-left ((left-triple (previous triple)))
	  (if (triple-null? left-triple)
	      (display "d#(")
	      (begin (print-left (previous left-triple))
		     (write (value left-triple))
		     (display " "))))
	;; Print the current value
	(display "|")
	(write (value triple))
	(display "|")
	;; Print the right part
	(let print-right ((right-triple (next triple)))
	  (if (triple-null? right-triple)
	      (display ")# ")
	      (begin (display " ") 
		     (write (value right-triple))
		     (print-right (next right-triple))))))))


  (triple-print (next (doubly-linked-list '(a b c))))
  (triple-print (doubly-linked-list '(a b c)))


  (let ((t (doubly-linked-list '(a))))
    (triple-print (triple-next-or-new t #f))
    (triple-print t))
;(value (doubly-linked-list '(a b c)))

;(doubly-linked-list '())



;; 1ere etape: machine deterministe avec bande infinie a droite et pas a gauche.

;(let ((plus-un (turing-machine :type determinist
;			       :states '(e1 e2 e3)
;			       :initial e1
;			       :final e2
;			       :transitions '((e1 e2))
;			       ))))


(define *turing-machine*
  (make-record-type "turing-machine" '(initial finals transitions)))

(define make-turing-machine
  (record-constructor *turing-machine*))


(define turing-machine-transitions
  (record-accessor *turing-machine* 'transitions))

(define turing-machine-initial
  (record-accessor *turing-machine* 'initial))

(define turing-machine-finals
  (record-accessor *turing-machine* 'finals))

(define find-transition
  ;; Find the transition corresponding to the current state.
  (lambda (machine current-state current-symbol)
    (let ((transition (assoc (list current-state current-symbol)
			     (turing-machine-transitions machine))))
      (if transition
	  (cadr transition)
	  (error "No transition found" current-state current-symbol)))))

(define (change-tape current-tape symbol-to-write deplacement)
  (set-value! current-tape symbol-to-write)
  (let ((new-tape (cond ((eq? deplacement '=>) (triple-next-or-new current-tape #f))
			((eq? deplacement '<=) (triple-previous-or-new current-tape #f))
			  (else (error "Deplacement isn't correct")))))
    new-tape))

(let* ((word '(a b c))
       (wordb word))
  (set-car! wordb 'd)
  word)


(use-modules (srfi srfi-1)) 		;first etc

;; Word is a list of symbols
(define (apply-machine machine word)
  (let ((total-tape (doubly-linked-list word)))
    (let make-step ((current-tape total-tape)
		    (current-state (turing-machine-initial machine)))
      (display "Current tape: ")
      (triple-print current-tape)
      (newline)
      (let* ((current-symbol (value current-tape))
	     (transition (find-transition machine current-state current-symbol))
	     (next-state (first transition)) ;; XXX: change this for non deterministic machines.
	     (symbol-to-write (second transition))
	     (deplacement (third transition))
	     (next-tape (change-tape current-tape symbol-to-write deplacement)))
	(if (eq? next-state 'ef)
	    total-tape
	    (make-step next-tape next-state))))))


;; Example uses.

(define plus-one
  (make-turing-machine 'e0
		       '(ef)
		       '(((e0 0) (e0 0 =>))
			 ((e0 1) (e0 1 =>))
			 ((e0 #f) (e1 #f <=))
		       
			 ((e1 1) (e1 0 <=))
			 ((e1 0) (ef 1 =>))
			 ((e1 #f) (ef 1 =>)))))


(triple-print (apply-machine plus-one '(1 0 1))) ;;Returns d#(|1| 1 0 #f)#.