;; General Help Functions
(define extract
  (lambda (n pos cnt)
    (remainder (quotient (abs n) (expt 10 pos)) (expt 10 cnt))))

(define sign
  (lambda (num)
    (if (>= num 0) 1 -1)))

(define collapse
  (lambda (max-pos cnt digits) 
    (local ((define C
	      (lambda (cnt index sum-so-far)
		(cond
		  [(zero? cnt) sum-so-far]
		  [else (C (sub1 cnt) (sub1 index)
			  (+ (* sum-so-far 10) (vector-ref digits index)))]))))
      (C cnt max-pos 0))))

(define disassemble
  (lambda (num)
    (let* ([first  (extract num 0 1)]
	   [second (extract num 1 1)]
	   [third  (extract num 2 1)])
      (cond
	((not (zero? first))     ; I format instructions
	 (let ((x (extract num 1 1))
	       (y (extract num 2 6)))
	   (case first
	     ((1)    `(jmpi ,y))
	     ((2)    `(jsr ,x ,y))
	     ((3)    `(bez ,x ,y))
	     ((4)    `(bnez ,x ,y))
	     ((5)    `(blz ,x ,y))
	     ((6)    `(blez ,x ,y))
	     ((7)    `(bgz ,x ,y))
	     ((8)    `(bgez ,x ,y))
	     ((9)    `(ldi ,x ,(if (negative? num) (- 0 y) y)))
	     (else '(unknown)))))
	((not (zero? second))    ; R format instruction
	 (let ([x (extract num 2 1)]
	       [y (extract num 3 1)]
	       [z (extract num 4 1)]
	       [d (extract num 5 1)])
	   (case second
	     ((1)    `(add ,x ,y ,z))
	     ((2)    `(sub ,x ,y ,z))
	     ((3)    `(mul ,x ,y ,z))
	     ((4)    `(div ,x ,y ,z))
	     ((5)    `(mod ,x ,y ,z))
	     ((6)    (if (zero? d)
			 `(ldx ,x ,y ,z)
			 `(ld ,x ,y)))
	     ((7)    (if (zero? d)
			 `(stx ,x ,y ,z)
			 `(st ,x ,y)))
	     ((8)    `(jmpx ,x))
	     ((9)    `(mov ,x ,y))
	     (else '(unknown)))))
	(else                    ; S format instruction
	  (let ((x (extract num 3 1)))
	    (case third
	      ((0)    `(halt))
	      ((1)    `(print ,x))
	      ((2)    `(newline))
	      (else '(unknown)))))))))

(define assemble
  (let* ((check&enc
	   (lambda (sign lop l-register-index)
	     (if (andmap (lambda (x) (<= 0 x MAX-REG-INDEX)) l-register-index)
		 (* sign 
		    (apply + (map (lambda (npos) (* (abs (car npos)) (expt 10 (cadr npos))))
				  lop)))
		 '(*unknown))))
	 (jmpi (lambda (y) (check&enc (sign y)  `((1 0) (0  1) (,y 2)) null)))
	 (jsr  (lambda (x y) (check&enc (sign y)  `((2 0) (,x 1) (,y 2)) (list x))))
	 (bez  (lambda (x y) (check&enc (sign y)  `((3 0) (,x 1) (,y 2)) (list x))))
	 (bnez (lambda (x y) (check&enc (sign y)  `((4 0) (,x 1) (,y 2)) (list x))))
	 (blz  (lambda (x y) (check&enc (sign y)  `((5 0) (,x 1) (,y 2)) (list x))))
	 (blez (lambda (x y) (check&enc (sign y)  `((6 0) (,x 1) (,y 2)) (list x))))
	 (bgz  (lambda (x y) (check&enc (sign y)  `((7 0) (,x 1) (,y 2)) (list x))))
	 (bgez (lambda (x y) (check&enc (sign y)  `((8 0) (,x 1) (,y 2)) (list x))))
	 (ldi  (lambda (x y) (check&enc (sign y)  `((9 0) (,x 1) (,(abs y) 2)) (list x))))
	 (add  (lambda (x y z) (check&enc 1  `((1 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (sub  (lambda (x y z) (check&enc 1  `((2 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (mul  (lambda (x y z) (check&enc 1  `((3 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (div  (lambda (x y z) (check&enc 1  `((4 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (mod  (lambda (x y z) (check&enc 1  `((5 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (ldx  (lambda (x y z) (check&enc 1  `((6 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (ld   (lambda  (x y) (check&enc 1  `((6 1) (,x 2) (,y 3) (1 5)) (list x y))))
	 (stx  (lambda (x y z) (check&enc 1  `((7 1) (,x 2) (,y 3) (,z 4)) (list x y z))))
	 (st   (lambda  (x y) (check&enc 1  `((7 1) (,x 2) (,y 3) (1 5)) (list x y))))
	 (jmpx (lambda (x) (check&enc 1  `((8 1) (,x 2)) (list x))))
	 (mov  (lambda (x y) (check&enc 1  `((9 1) (,x 2) (,y 3)) (list x y))))
	 (halt     (lambda () 0))
	 (print    (lambda (x) (check&enc 1  `((1 2) (,x 3)) (list x))))
	 (newline  (lambda () 200))
	 (data     (lambda (x) x))
	 (defaultf (lambda x '(*unknown)))
	 (check&app (lambda (n ins f) (if (= (length (cdr ins)) n) f defaultf))))
    (lambda (ins)
      (apply (case (car ins)
	       ((jmpi) (check&app 1 ins jmpi))
	       ((jsr)  (check&app 2 ins jsr))
	       ((bez)  (check&app 2 ins bez))
	       ((bnez) (check&app 2 ins bnez))
	       ((blz)  (check&app 2 ins blz))
	       ((blez) (check&app 2 ins blez))
	       ((bgz)  (check&app 2 ins bgz))
	       ((bgez) (check&app 2 ins bgez))
	       ((ldi)  (check&app 2 ins ldi))
	       ((add)  (check&app 3 ins add))
	       ((sub)  (check&app 3 ins sub))
	       ((mul)  (check&app 3 ins mul))
	       ((div)  (check&app 3 ins div))
	       ((mod)  (check&app 3 ins mod))
	       ((ldx)  (check&app 3 ins ldx))
	       ((ld)   (check&app 2 ins ld))
	       ((stx)  (check&app 3 ins stx))
	       ((st)   (check&app 2 ins st))
	       ((jmpx) (check&app 1 ins jmpx))
	       ((mov)  (check&app 2 ins mov))
	       ((halt) (check&app 0 ins halt))
	       ((print)(check&app 1 ins print))
	       ((newline) (check&app 0 ins newline))
	       ((data) (check&app 1 ins data))
	       (else   defaultf))
	     (cdr ins)))))

(define format-address
  (lambda (n width prefix)
    (if (address? n) 
	(let* ((number (abs (if (zero? n) 1 n)))
	       (leader-width
		 (max (- width (add1 (inexact->exact 
				       (floor (/ (log number)
						 (log 10))))))
		      0)))
	  (string-append
	    (make-string leader-width prefix)
	    (format "~s" (abs n))))
	(machine-error  (format"not an address: ~s!" n)))))

(define format-value
  (lambda (n width prefix)
    (let* ((number (abs (if (zero? n) 1 n)))
	   (leader-width
	     (max (- width (add1 (inexact->exact 
				   (floor (/ (log number) (log 10)))))) 0)))
      (string-append
	(if (negative? n) "-" " ")
	(make-string leader-width prefix)
	(format "~s" (abs n))))))

(define reset!
  (lambda ()
    (begin
      (vector-fill! mem-array 0)
      (vector-fill! reg-array 0)
      (set-box! PC 0))))

(define machine-error
  (lambda (astring)
    (begin
      (printf astring)
      (newline)
      (shell))))

(define prompt-read
  (lambda (str)
    (printf str)
    (read)))