; $Id: rm.scm,v 1.3 2006/10/17 15:57:14 schwicht Exp $
; Implementation of register machines.

; Generalities
; ============

(list-ref '(0 1 2 3) 3)
(make-list 3 8)
(list-tail '(0 1 2 3) 2)

(define (list-head list k)
  (do ((l list (cdr l))
       (n 0 (+ n 1))
       (res '() (cons (car l) res)))
      ((= n k) (reverse res))))

(list-head '(0 1 2 3) 2)

(define (error-object-to-string x)
  (cond
   ((string? x) x)
   ((number? x) (number->string x))
   ((symbol? x) (symbol->string x))
   ((null? x) "Null")
   ((list? x) (string-append
	       "("
	       (error-object-to-string (car x))
	       (apply string-append
		      (map (lambda (y)
			     (string-append " " (error-object-to-string y)))
			   (cdr x)))
	       ")"))
   ((pair? x) (string-append "("
			     (error-object-to-string (car x))
			     " . "
			     (error-object-to-string (cdr x))
			     ")"))
   (else "Unknown error object encountered")))   

(define (myerror . x)
  (do ((l x (cdr l)))
      ((null? l) (newline) (display-comment) (error "Implementation" "sorry"))
    (newline) (display-comment (error-object-to-string (car l)))))

; Instructions
; ============

(define (make-zero-instr j) (list 0 j))
(define zero-instr-to-reg cadr)

(define (zero-instr? x)
  (and (list? x)
       (= 2 (length x))
       (= 0 (car x))
       (integer? (cadr x))
       (not (negative? (cadr x)))))

(define (make-succ-instr j) (list 1 j))
(define succ-instr-to-reg cadr)

(define (succ-instr? x)
  (and (list? x)
       (= 2 (length x))
       (= 1 (car x))
       (integer? (cadr x))
       (not (negative? (cadr x)))))

(define (make-jump-instr j l m n) (list 2 j l m n))
(define jump-instr-to-fst-reg cadr)
(define jump-instr-to-snd-reg caddr)
(define jump-instr-to-true-pc cadddr)
(define (jump-instr-to-false-pc x) (car (cddddr x)))

(define (jump-instr? x)
  (and (list? x)
       (= 5 (length x))
       (= 2 (car x))
       (let ((j0 (list-ref x 1))
	     (j1 (list-ref x 2))
	     (i0 (list-ref x 3))
	     (i1 (list-ref x 4)))
	 (and (integer? j0) (not (negative? j0))
	      (integer? j1) (not (negative? j1))
	      (integer? i0) (not (negative? i0))
	      (integer? i1) (not (negative? i1))))))

(define (jump-instr-to-maxreg x)
  (max (jump-instr-to-fst-reg x)
       (jump-instr-to-snd-reg x) ))

(define (jump-instr-to-maxpc x)
  (max (jump-instr-to-true-pc x)
       (jump-instr-to-false-pc x)))

(define (program-to-maxreg e)
  (if (pair? e)
      (let* ((instr (car e))
	     (rest (cdr e))
	     (prev (program-to-maxreg rest)))
	(cond ((zero-instr? instr)
	       (max prev (zero-instr-to-reg instr)))
	      ((succ-instr? instr)
	       (max prev (succ-instr-to-reg instr)))
	      ((jump-instr? instr)
	       (max prev (jump-instr-to-maxreg instr)))
	      (else 0)))
      0))

(define (maxpc e)
  (if (pair? e)
      (let* ((instr (car e))
	     (rest (cdr e))
	     (prev (maxpc rest)))
	(if (jump-instr? instr)
	    (max prev (jump-instr-to-maxpc instr))
	    prev))
      0))

(define (program-form? e)
  (or (null? e)
      (and (pair? e)
	   (or (zero-instr? (car e))
	       (succ-instr? (car e))
	       (jump-instr? (car e)))
	   (program-form? (cdr e)))))

(define (program? e)
  (and (program-form? e)
       (<= (maxpc e) (length e))))

(define (shift e k)
  (cond ((null? e) e)
	((pair? e)
	 (cons (if (jump-instr? (car e))
		   (shift-jump-instr (car e) k)
		   (car e))
	       (shift (cdr e) k)))
	(else (myerror "Program expected" e))))

(define (shift-jump-instr x k)
  (make-jump-instr (list-ref x 1) (list-ref x 2)
		   (+ k (list-ref x 3)) (+ k (list-ref x 4))))

; Program constructs
; ==================

(define (transfer x y)
  (if (= x y)
      (myerror
       "transfer expects different registers" x y))
  (list (make-zero-instr x)
	(make-jump-instr x y 4 2)
	(make-succ-instr x)
	(make-jump-instr x x 1 1)))

(define (predecessor x y z)
  (list (make-zero-instr x)
	(make-zero-instr z)
	(make-jump-instr x y 8 3)
	(make-succ-instr z)
	(make-jump-instr z y 8 5)
	(make-succ-instr z)
	(make-succ-instr x)
	(make-jump-instr z y 8 5)))

(define (composition e1 e2)
  (append e1 (shift e2 (length e1))))

(define (for i j e) ;note: test that i,x not in e
  (append  
   (list
    (make-zero-instr i)
    (make-jump-instr j i (+ (length e) 4) 2)
    (make-succ-instr i)
    )
   (shift e 3)
   (list
    (make-jump-instr j i (+ (length e) 4) 2))))

(define (while j i e) ;note that i should not be in P
  (append
   (list (make-zero-instr i)
	 (make-jump-instr j i (+ (length e) 3) 2))
   (shift e 2)
   (list (make-jump-instr j i (+ (length e) 3) 2))))

; Tests

(program? (transfer 2 5))
(program? (predecessor 2 5 7))
(program? (composition (transfer 2 5)
		       (predecessor 2 5 7)))
(program? (for 5 3 (transfer 2 5)))
(program? (while 3 5 (transfer 2 5)))

; Transition function
; ===================

(define (make-state e i . regs)
  (cons e (cons i regs)))
(define state-to-program car)
(define state-to-pc cadr)
(define state-to-regs cddr)

(define (state? x)
  (and (list? x)
       (<= 2 (length x))
       (let ((e (car x))
	     (i (cadr x)))
	 (<= i (length e)))))

(define (regs-ref regs j)
  (if (< j (length regs))
      (list-ref regs j)
      0))

(define (regs-zero regs j)
  (if (< j (length regs))
      (append (list-head regs j)
	      (list 0)
	      (list-tail regs (+ 1 j)))
      (append regs (make-list (- j (length regs)) 0))))

; (regs-zero '(2 2 7 5) 9)

(define (regs-succ regs j)
  (if (< j (length regs))
      (append (list-head regs j)
	      (list (+ 1 (list-ref regs j)))
	      (list-tail regs (+ 1 j)))
      (append regs
	      (make-list (- j (length regs)) 0) (list 1))))

; (regs-succ '(2 2 7 5) 9)

(define (tr state)
  (let* ((e (state-to-program state))
	 (i (state-to-pc state))
	 (regs (state-to-regs state)))
    (if (= (length e) i)
	state
	(let* ((e_i (list-ref e i))
	       (instr-type (car e_i)))
	  (cond
	   ((= 0 instr-type)
	    (apply make-state
		   (cons e
			 (cons (+ 1 i)
			       (regs-zero
				regs
				(zero-instr-to-reg
				 e_i))))))
	   ((= 1 instr-type)
	    (apply make-state
		   (cons e
			 (cons (+ 1 i)
			       (regs-succ
				regs
				(succ-instr-to-reg
				 e_i))))))
	   ((= 2 instr-type)
	    (if (= (regs-ref
		    regs
		    (jump-instr-to-fst-reg e_i))
		   (regs-ref
		    regs
		    (jump-instr-to-snd-reg e_i)))
		(apply
		 make-state
		 (cons
		  e (cons (jump-instr-to-true-pc
			   e_i) regs)))
		(apply
		 make-state
		 (cons
		  e (cons (jump-instr-to-false-pc e_i) regs)))))
	   (else (myerror "Instruction expected" e_i)))))))

(define (run timebound e . regs)
  (if (not (and (integer? timebound)
		(positive? timebound)))
      (begin (display "timebound expected")
	     (display timebound) (newline)))
  (newline)
  (do ((state (append (list e 0) regs) (tr state))
       (time timebound (- time 1)))
      ((= 0 time)
       (display "timeout after ")
       (display timebound) (display " steps")
       (newline))
    (display (cadr state))
    (display ": ")
    (display #\tab)
    (display (cddr state)) (newline)))

; Tests

; (run 13 (transfer 2 5) 0 0 3 0 0 2)
; (run 22 (predecessor 1 2 5) 0 0 6)
;  (run 39 (composition (predecessor 1 2 5)
; 		      (transfer 3 1)) 0 0 6)

(define (add j1 j2 l i)
  (composition
   (transfer l j1)
   (for i j2 (list (make-succ-instr l)))))

(run 40 (add 1 2 0 3) 0 4 5)