;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(define-asm first-loop ()
  (alu (active 0) <- (active 0) add (active 1))
  (jump always 0))

(defun setup-function (name)
  (send *proc* :reset)
  (store-function-into-main-memory name 0)
  (send *proc* :write-pc 0)
  (send *proc* :write-next-pc 0)
  (send *proc* :write-noop-next-bit 1)
  (send *proc* :write-active 1 1))

(define-asm loop3 ()
begin
  (alu (active 0) <- (active 0) add (active 1))
  (jump always foo)
  (alu (active 2) <- (active 2) add (active 3))
  (jump always bar)
foo
  (alu (active 4) <- (active 4) add (active 5))
  (jump always begin)
bar
  (alu (active 6) <- (active 6) add (active 7))
  (jump always foo))

(define-asm ladd ()
  (alu (active 0) <- (active 0) add (active 1))
  (return-xct-next)
  (no-op)
  )

(define-asm call-add ()
  (open)
  (alu (open 0) <- (active 0) set1 (active 0))
  (alu (open 1) <- (active 1) set1 (active 0))
  (call-xct-next ladd)
  (no-op)
  (alu (garbage) <- (open 0) setz (open 0) halt))

(defun load-functions (&rest functions)
  (send *proc* :reset)
  (clear-symbols)
  (let ((adr 0))
    (dolist (f functions)
      (add-symbol f adr)
      (setq adr (store-function-into-main-memory f adr))))
  )

;***** CODE FOR TAK FOLLOWS ***** (X Y Z)
(define-asm tak ()
  (ALU (GARBAGE) <- (ACTIVE 1) SUB (ACTIVE 0))
  (JUMP LESS-THAN TRUE-BRANCH-7597)
  (ALU (active 0) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
  (RETURN-xct-next)
 (no-op)
TRUE-BRANCH-7597
  (TAIL-RECURSIVE-OPEN)
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 0) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 1) SET-SOURCE-1 (GARBAGE))
  (ALU (OPEN 2) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (no-op)
  (ALU (OPEN 0) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 1) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
  (ALU (OPEN 2) <- (ACTIVE 0) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (no-op)
  (ALU (OPEN 1) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 2) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 0) SET-SOURCE-1 (GARBAGE))
  (ALU (OPEN 2) <- (ACTIVE 1) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (no-op)
  (ALU (OPEN 2) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  (TAIL-RECURSIVE-CALL-xct-next TAK)
 (no-op)
  )


(define-asm tak ()
  (ALU (GARBAGE) <- (ACTIVE 1) SUB (ACTIVE 0))
  (JUMP LESS-THAN TRUE-BRANCH-7597)
  (RETURN-xct-next)
 (ALU (active 0) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
TRUE-BRANCH-7597
  (TAIL-RECURSIVE-OPEN)
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 0) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 1) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (ALU (OPEN 2) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
  (ALU (OPEN 0) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 1) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 2) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (ALU (OPEN 2) <- (ACTIVE 0) SET-SOURCE-1 (GARBAGE))
  (ALU (OPEN 1) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  (OPEN)
  (ALU (OPEN 0) <- (ACTIVE 2) m-a-1 (constant 0))
  (ALU (OPEN 1) <- (ACTIVE 0) SET-SOURCE-1 (GARBAGE))
  (CALL-xct-next TAK)
 (ALU (OPEN 2) <- (ACTIVE 1) SET-SOURCE-1 (GARBAGE))
  (TAIL-RECURSIVE-CALL-xct-next TAK)
 (ALU (OPEN 2) <- (RETURN 0) SET-SOURCE-1 (GARBAGE))
  )

(define-asm tak-driver ()
  (open)
  (alu (open 0) <- (active 0) set-source-1 (garbage))
  (alu (open 1) <- (active 1) set-source-1 (garbage))
  (alu (open 2) <- (active 2) set-source-1 (garbage))
  (call-xct-next tak)
 (no-op)
  (no-op halt))

(defun tak-test (&optional (level 16.))
  (send *proc* :reset)
  (load-functions 'tak 'tak-driver)
  (install-constants)
  (send *proc* :write-next-pc (symbol-lookup 'tak-driver))
  (send *proc* :write-noop-next-bit 1)
  (let ((args (ecase level
		(16. '(8 7 6))
		(15. '(9 7 6))
		(14. '(10. 7 6))
		(13. '(11. 7 6))
		(12-3 '(12. 7 6))
		(12-2 '(5 13. 7))
		(12-1 '(6 6 13.))
		(11. '(7 6 13.))
		(10. '(8 6 13.))
		(9. '(9 6 13.))
		(8 '(10. 6 13.))
		(7-2 '(11. 6 13.))
		(7-1 '(12. 12. 6))
		(6 '(13. 12. 6))
		(5 '(14. 12. 6))
		(4 '(15. 12. 6))
		(3 '(16. 12. 6))
		(2 '(17. 12. 6))
		(1 '(18. 12. 6)))))
    (format t "~&(TAK ~d. ~d. ~d.) => ~d" (car args) (cadr args) (caddr args) (apply #'tak args))
    (mapcar #'(lambda (adr val)
		(send *proc* :write-active adr val))
	    '(0 1 2) args))
  (write-register 'micro:a-sim-inst-counter 0)
  )

;(tak 18. 12. 6)
;                            (15 ENTER TAK: 9 7 6)
;                              (16 ENTER TAK: 8 7 6)
;                                (17 ENTER TAK: 7 7 6)
;                                (17 EXIT TAK: 6)
;                                (17 ENTER TAK: 6 6 8)
;                                (17 EXIT TAK: 8)
;                                (17 ENTER TAK: 5 8 7)
;                                (17 EXIT TAK: 7)
;                                (17 ENTER TAK: 6 8 7)
;                                (17 EXIT TAK: 7)
;                              (16 EXIT TAK: 7)
;                              (16 ENTER TAK: 6 6 9)
;                              (16 EXIT TAK: 9)
;                              (16 ENTER TAK: 5 9 7)
;                              (16 EXIT TAK: 7)
;                              (16 ENTER TAK: 7 9 7)
;                              (16 EXIT TAK: 7)
;                            (15 EXIT TAK: 7)
;                            (15 ENTER TAK: 6 6 10)
;                            (15 EXIT TAK: 10)
;                            (15 ENTER TAK: 5 10 7)
;                            (15 EXIT TAK: 7)
;                            (15 ENTER TAK: 7 10 7)
;                            (15 EXIT TAK: 7)


(defun tak (x y z)
  (cond ((not (< y x))				;xy
	 z)
	(t (tak (tak (1- x) y z)
		(tak (1- y) z x)
		(tak (1- z) x y)))))




(define-asm do-vma ()
  (alu (func vma-start-read) <- (constant #.(array-length *main-memory-array*)) setl (garbage))
  (alu (active 0) <- (func md) setl (garbage))
  (no-op halt))

; (sim-load :functions '(do-vma) :start 'do-vma :args nil)



(define-asm cons-forever ()
  (alu (func md) <- setl (constant #.(- (main-memory-size) 2)) (garbage))
  (alu (func vma-start-write) <- (constant 0) setl (garbage))
loop
  (open)
  (call-xct-next cons)
  (no-op)
  (jump loop)
  (no-op)
  (no-op halt))
;(sim-load :functions '(cons-forever cons) :start 'cons-forever :args nil)



(define-asm test-cons ()
  (alu (active 0) <- (constant 0) setl (garbage))	;this is the current cell
  (alu (active 1) <- (constant 1) setl (garbage))	;this holds the cars

;make the list (4 3 2 1)
loop
  (open)
  (alu (open 0) <- (active 1) setl (garbage))
  (call-xct-next cons)
 (alu (open 1) <- (active 0) setl (garbage))
  (alu (active 0) <- (return 0) setl (garbage))
  (alu (active 1) <- (active 1) add (constant 1))
  (alu (garbage) <- (active 1) sub (constant 5))
  (jump less-than loop)

  (open)
  (call-xct-next cdr)
 (alu (open 0) <- (active 0) setl (garbage))
  (alu (active 0) <- (return 0) setl (garbage))

  (open)
  (call-xct-next cdr)
 (alu (open 0) <- (active 0) setl (garbage))
  (alu (active 0) <- (return 0) setl (garbage))

  (open)
  (call-xct-next car)
 (alu (open 0) <- (active 0) setl (garbage))
  (alu (active 0) <- (return 0) setl (garbage))

  ;active 0 should be 2

  (no-op halt)
  )

; (sim-load :functions '(test-cons cons car cdr) :start 'test-cons :args nil)