;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/icfp2006/RCS/icfp2006.lisp,v 395.1 2008/04/20 17:25:51 gene Exp $
;;;

(setq *random-state* (make-random-state t))

(defpackage "COM.CYBERTIGGYR.GENE.ICFP2006"
  (:use "COMMON-LISP")
  (:import-from "CYBERTIGGYR-TEST" "DEFTEST" "RUN"))
(in-package "COM.CYBERTIGGYR.GENE.ICFP2006")

(defvar *um-input* *terminal-io*
  "The universal machine reads from this.")

(defvar *um-output* *standard-output*
  "The universal machine writes to this.")

(defvar *um-log* nil
  "The execution, debug, trace log goes here.")

(defconstant PLATTER-RANGE (expt 2 32))

(defconstant PLATTER-MAXIMUM-VALUE (1- PLATTER-RANGE))

(deftype platter ()
  "This is what we'd call a WORD in the sandstone CPU."
  '(unsigned-byte 32))

(defun read-platter (strm)
  "Consume & return the next PLATTER value from the binary
input stream.  If the stream has only part of a platter
value, you get an error.  If the stream is already at its
end, doesn't have even a part of a platter, you get STRM."
  (let ((b0 (read-byte strm nil strm)))
    (if (eq b0 strm)
	strm                            ; end of input
      ;; else
      (+ (ash b0 24)
	 (ash (read-byte strm) 16)
	 (ash (read-byte strm) 8)
	 (read-byte strm)))))

(defun platter-op (platter)
  "Return the OPeration part of a platter value.  The operation
is always the high four bits.  We conver them from a number
into a symbol."
  (declare (type platter platter))
  (case (ash platter -28)
    (0 :conditional-move)
    (1 :array-index)
    (2 :array-amendment)
    (3 :addition)
    (4 :multiplication)
    (5 :division)
    (6 :nand)
    (7 :halt)
    (8 :allocation)
    (9 :abandonment)
    (10 :output)
    (11 :input)
    (12 :load-program)
    (13 :orthography)
    (otherwise
     (format t "~&~A: warning: Decoding an instruction of x~X." 'platter-op
	     platter)
     (format t "  Assuming it's :NOP.")
     :nop)))
  
(defun platter-a (platter)
  "Return the A register part of a platter value.  The A
register is a number, 0 through 7."
  (declare (type platter platter))
  (mod (ash platter -6) 8))

(defun platter-b (platter)
  "Return the B register part of a platter value.  The B
register is a number, 0 through 7."
  (declare (type platter platter))
  (mod (ash platter -3) 8))

(defun platter-c (platter)
  "Return the C register part of a platter value.  The C
register is a number, 0 through 7."
  (declare (type platter platter))
  (mod platter 8))

(defun platter-orthor (platter)
  "Return the orthography REGISTER from an instruction."
  (declare (type platter platter))
  (mod (ash platter -25) 8))

(defun platter-orthov (platter)
  "Return the orthography LITERAL from an instruction."
  (declare (type platter platter))
  (mod platter (expt 2 25)))

(defun decode (platter)
  "Decode a platter value into an instruction.  Return the
instruction as a list.  The list always has five elements.
They are: OPeration, A register, B register, C register,
ORTHO register, & ORTHO value."
  (declare (type platter platter))
  (list (platter-op platter)
	(platter-a platter)
	(platter-b platter)
	(platter-c platter)
	(platter-orthor platter)
	(platter-orthov platter)))

(defun load-scroll (pathname)
  "Load an entire scroll into memory.  Return its contents in
a vector of platter values.  If there is any problem at all,
you get an error."
  (with-open-file (strm pathname :element-type '(unsigned-byte 8))
    (if (zerop (mod (file-length strm) 4))
	(let* ((count (/ (file-length strm) 4))
	       (a (make-array count :element-type 'platter
			      :fill-pointer nil :adjustable nil)))
	  (dotimes (i count)
	    (setf (aref a i) (read-platter strm)))
	  a)
      ;; else
      (error "~A: The file's length in octets should be divisible by 4."
	     'load-scroll))))

(defvar *is-halted* nil)
(defvar *clock* 0)
(defvar *reg* (make-array 8 :element-type 'platter :initial-element 0
			  :adjustable nil :fill-pointer nil))
(proclaim '(type (simple-array platter (8)) *reg*))
(defvar *finger* 0)
(proclaim '(type platter *finger*))
(defvar *tape* (make-array 1 :adjustable nil :fill-pointer nil
			   :initial-element nil))
(defvar *unused-tapes* ())

(defun setup-um (scrollname)
  (setq *is-halted* nil
	*clock* 0
	*finger* 0)
  (dotimes (i (length *tape*)) (setf (aref *tape* i) nil))
  (setf (aref *tape* 0) (load-scroll scrollname))
  (dotimes (i (length *reg*)) (setf (aref *reg* i) 0)))

(defun um-tapen (n)
  "Return tape number N.  If there is no such tape, you
get NIL."
  (declare (type platter n))
  (assert (< n (length *tape*)))
  (aref *tape* n))

(defun um-platter (tapen offset)
  "Return the platter value at OFFSET of tape N.  If
the tape does not exist, you get an error."
  (aref (um-tapen tapen) offset))

(defun set-um-platter (tapen offset value)
  (declare (type platter value))
  (setf (aref (um-tapen tapen) offset) value))

(defun um-reg (n)
  "Return the value in a register.  0 <= REG < 8."
  (aref *reg* n))

(defun set-um-reg (n value)
  (declare (type platter n value))
  (setf (aref *reg* n) value))

(defun fetch ()
  "Return the platter value that the finger indicates.
Increment *FINGER* & *CLOCK*."
  (let ((x (um-platter 0 *finger*)))
    (declare (type platter x))
    (incf *finger*)
    (incf *clock*)
    x))

(defun um-conditional-move (a b c)
  (unless (zerop (um-reg c))
    (set-um-reg a (um-reg b))))

(defun um-array-index (a b c)
  (set-um-reg a (um-platter (um-reg b) (um-reg c))))

(defun um-array-amendment (a b c)
  (set-um-platter (um-reg a) (um-reg b) (um-reg c)))

(defun um-addition (a b c)
  (set-um-reg a (mod (+ (um-reg b) (um-reg c))
		     PLATTER-RANGE)))

(defun um-multiplication (a b c)
  (set-um-reg a (mod (* (um-reg b) (um-reg c))
		     PLATTER-RANGE)))

(defun um-division (a b c)
  (set-um-reg a (floor (/ (um-reg b) (um-reg c)))))

(defun um-nand (a b c)
  (let* ((valc (um-reg c))
	 (valb (um-reg b))
	 (vala (mod (boole boole-nand valb valc) PLATTER-RANGE)))
    (set-um-reg a vala)))

(defun um-halt () (setq *is-halted* t))

(defun unused-tape-number ()
  "Return a tape number which is not currently used."
  (when (endp *unused-tapes*)
    (let ((n (length *tape*)))
      (setq *tape* (adjust-array *tape* (* 2 n)))
      (loop for i from n while (< i (length *tape*)) do
	    (setf (aref *tape* i) nil)
	    (push i *unused-tapes*))))
  (pop *unused-tapes*))

(defun um-allocation (b c)
  (let ((n (unused-tape-number)))
    (declare (type fixnum n))
    (setf (aref *tape* n) (make-array (um-reg c)
				      :element-type 'platter
				      :adjustable nil
				      :fill-pointer nil
				      :initial-element 0))
    (set-um-reg b n)))

(defun um-abandonment (c)
  (assert (not (zerop (um-reg c))))     ; Can't free tape 0.
  (assert (um-tapen (um-reg c)))        ; Mustn't free an unused tape.
  (setf (aref *tape* (um-reg c)) nil)
  (push (um-reg c) *unused-tapes*))

(defun um-output (c)
  (let ((ascii (um-reg c)))
    (declare (type platter ascii))
    (assert (<= 0 ascii 255))
    (if (<= 0 ascii 127)
	(write-char (code-char ascii) *um-output*)
      ;; Else, it's not realy an ASCII character, so we
      ;; write something else.
      (format *um-output* "#x~2,'0X" ascii))
    (force-output *um-output*)))

(defun um-input (c)
  (format *um-log* " INPUT") (force-output *um-log*)
  (let ((char (read-char *um-input*)))
    (format *um-log* " ~S" char)
    (force-output *um-log*)
    (set-um-reg c (char-code char))))

(defun um-load-program (b c)
  (setf *finger* (um-reg c))
  (unless (zerop (um-reg b))
    (setf (aref *tape* 0) (copy-seq (aref *tape* (um-reg b))))))

(defun um-orthography (orthor literal)
  (set-um-reg orthor literal))

(defun execute (op a b c orthor literal)
  (ecase op
    (:conditional-move (um-conditional-move a b c))
    (:array-index (um-array-index a b c))
    (:array-amendment (um-array-amendment a b c))
    (:addition (um-addition a b c))
    (:multiplication (um-multiplication a b c))
    (:division (um-division a b c))
    (:nand (um-nand a b c))
    (:halt (um-halt))
    (:allocation (um-allocation b c))
    (:abandonment (um-abandonment c))
    (:output (um-output c))
    (:input (um-input c))
    (:load-program (um-load-program b c))
    (:orthography (um-orthography orthor literal))))
  
(defun spin ()
  (format *um-log* "~%~%~%*** ~A begins ***" 'spin)
  (loop until *is-halted* do
	(apply #'execute (decode (fetch))))
  (format *um-log* "~&*** ~A ends ***" 'spin)
  (force-output *um-log*))
  	
;;; --- end of file ---