;;; Filename : corewar.lsp

;;; Date     : 95-05-21

;;; Authors  : Leif Lindgren, Joakim Malm and Lars Sundberg at Linköping
;;;            University, Sweden.

;;; Contents : An executive program written in CommonLISP. The program is a so 
;;;            called MARS (Memory Array Redcode Simulator) which is used for 
;;;            running CoreWar programs written in Redcode.




;;;***************************************************************************
;;;                           GLOBAL VARIABLES
;;;***************************************************************************

(setq *MaxProgramLength* 40)           "Max number of REDCODE instructions"
(setq *MaxNumberOfCycles* 15000)       "Max number of cycles for a program" 
(setq *MaxNumberOfTasks* 20)           "Max number of records in the task que"
(setq *CoreSize* 512)                 "The size of the core-memory"

(defconstant *Direct* 1               "Code for the direct mode")
(defconstant *Indirect* 2             "Code for the indirect mode")
(defconstant *Immediate* 0            "Code for the immediate mode")

(defconstant *DAT* 0            "The DATa machine code instuction")
(defconstant *MOV* 1            "The MOVe machine code instuction")
(defconstant *ADD* 2            "The ADD machine code instruction")
(defconstant *SUB* 3            "The SUBstract machine code instruction")
(defconstant *JMP* 4            "The JuMP machine code instruction")
(defconstant *JMZ* 5            "The JuMp if Zero machine code instruction")
(defconstant *JMG* 6            "The JuMp if Greater machine code instruction")
(defconstant *DJZ* 7            "The Decrement and Jump if Zero instr")
(defconstant *CMP* 8            "The CoMPare machine code instruction")
(defconstant *SPL* 9            "The SPLit machinecode instruction")





;;;***************************************************************************
;;;*                             PRIMITIV FUNCTIONS
;;;***************************************************************************


;;;********************** Primitives for CoreCell ****************************
(defstruct 
    ( CoreCell 
     (:constructor CreateCoreCell)
     (:conc-name Read)
     (:copier CopyCoreCell))
  (Opcode 0) (A-mode *Immediate*) (A-data 0) (B-mode *Immediate*) (B-data 0))


(defun WriteOpcode ( CoreCell NewOpcode)
  "CoreCell X Opcode => CoreCell"
  (let ((CC (CopyCoreCell CoreCell)))
    (progn (setf (ReadOpcode CC) NewOpcode) CC)))


(defun WriteA-mode ( CoreCell NewA-mode)
  "CoreCell X A-mode => CoreCell"
  (let ((CC (CopyCoreCell CoreCell)))
    (progn (setf (ReadA-mode CC) NewA-mode) CC)))


(defun WriteA-data ( CoreCell NewA-data)
  "CoreCell X A-data => CoreCell"
  (let ((CC (CopyCoreCell CoreCell)))
    (progn (setf (ReadA-data CC) NewA-data) CC)))


(defun WriteB-mode ( CoreCell NewB-mode)
  "CoreCell X B-mode => CoreCell"
  (let ((CC (CopyCoreCell CoreCell)))
    (progn (setf (ReadB-mode CC) NewB-mode) CC)))


(defun WriteB-data ( CoreCell NewB-data)
  "CoreCell X B-data => CoreCell"
  (let ((CC (CopyCoreCell CoreCell)))
    (progn (setf (ReadB-data CC) NewB-data) CC)))



;;;*********************** Primitives for TaskQue ***************************
(defun CreateTaskQue ()
  " => TaskQue"
  '())


(defun PopTask ()
  " => adress (or NIL)"
  (cond
   ((= CurrentPlayer 1)
    (if (eq TaskQueProg1 '()) nil
      (let ((Adress (first TaskQueProg1)))
	(setq TaskQueProg1 (rest TaskqueProg1))
	Adress)))
   ((= CurrentPlayer 2)
    (if (eq TaskQueProg2 '()) nil
    (let ((Adress (first TaskQueProg2)))
      (setq TaskQueProg2 (rest TaskQueProg2))
      Adress)))))


(defun PushTask (Adress)
  "adress => T or NIL"
  (cond
   ((= CurrentPlayer 1)
    (if (>= (list-length TaskQueProg1) *MaxNumberOfTasks*)
	nil
      (progn (setq TaskQueProg1 (append TaskQueProg1 (list Adress))) t) ))
   ((= CurrentPlayer 2)
    (if (>= (list-length TaskQueProg2) *MaxNumberOfTasks*)
	nil
      (progn (setq TaskQueProg2 (append TaskQueProg2 (list Adress))) t) ))))



;;;***************** Primitives for CoreArray ********************************
(defun CreateCoreArray ()
  " => T"
  (setq CoreArray (make-array *CoreSize* :initial-element (CreateCoreCell))))

(defun ReadCoreCell (Adress)
  "adress => CoreCell"
  (aref CoreArray Adress))

(defun WriteCoreCell (Adress CoreCell)
  "adress X CoreCell => T or NIL"
  (if (> Adress *CoreSize* ) nil
    (progn (setf (aref CoreArray Adress) CoreCell) (shell (format nil "~ad93joama/pink/projekt/c/corewarg ~d ~d ~d" '~ 1 Adress (+ CurrentPlayer 5))) )))



;;;********************** Primitives for Adress ******************************
(defun IncAdress (adress number)
  "adress x integer -> adress"
  (+mod adress number))

(defun DecAdress (adress number)
  "adress x integer -> adress"
  (-mod adress number))





;;;**************************************************************************
;;;                                     FUNCTIONS
;;;**************************************************************************

(defun +mod (&rest numbers)
  "integer X integer X ... X integer => integer"
  ;; Performs addition modulo *CoreSize*
  (labels ((add (numbers)
	     (if (endp numbers)
		 0
	       (+ (first numbers) (add (rest numbers))))))
    (mod (add numbers) *CoreSize*)))


(defun -mod (&rest numbers)
  "integer X integer X ... X integer => integer"
  ;; Performs subtraction modulo *CoreSize*
  (labels ((sub (numbers)
	     (if (endp numbers)
		 0
	       (- (first numbers) (sub (rest numbers))))))
    (mod (sub numbers) *CoreSize*)))



;;;********************* Adress evaluating functions ************************
(defun EvalDirect (data adress)
  "data x adress -> adress"
  (+mod  data adress))

(defun EvalIndirect (data adress)
  "data x adress -> adress"
  (let ((nextcell (ReadCoreCell (EvalDirect data adress ))))
    (+mod adress data (ReadB-data nextcell)) ))
    

(defun EvalToAdress (mode data adress)
  "mode x data x adress -> adress or NIL if failure" 
  (cond
   ((eq mode *indirect*)
    (EvalIndirect data adress))
   ((eq mode *Direct*)
    (EvalDirect data adress))
   (t nil)))



;;;************* Functions that execute the machinecode instructions ********
(defun CoreMOV (corecell adress)
  "corecell x adress -> t or nil"
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (B-mode (ReadB-mode corecell))
	 (B-data (ReadB-data corecell))
	 (newadress (EvalToAdress B-mode B-data adress))
	 (newcell (let ((adress/? (EvalToAdress A-mode A-data adress)))
		      (if (eq adress/? nil)
			  (if (eq newadress nil)
			      nil
			    (WriteB-data (ReadCoreCell newadress) A-data))
			(ReadCoreCell adress/?)) )))
    (progn (PushTask (IncAdress adress 1))
	   (if (or (eq newadress nil) (eq newcell nil))
	       nil
	     (WriteCoreCell newadress newcell)) )))
			

(defun CoreJMP (corecell adress)
  "corecell x adress -> t or nil"
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (newadress (EvalToAdress A-mode A-data adress)))
    (if (eq newadress nil)
	(progn (PushTask (IncAdress adress 1)) nil)
      (progn (PushTask newadress) t))))


(defun CoreADD/SUB (corecell adress fn)
  "corecell x adress x fn -> t or nil"
  ;; fn is supposed to add or subtract
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (B-mode (ReadB-mode corecell))
	 (B-data (ReadB-data corecell))
	 (newadress (EvalToAdress B-mode B-data adress))
	 (newcell (let ((adress/? (EvalToAdress A-mode A-data adress)))
		    (if (eq newadress nil)
			nil
		      (let* ((Bcell (ReadCoreCell newadress))
			     (BA-data (ReadA-data Bcell))
			     (BB-data (ReadB-data Bcell)))
			(if (eq adress/? nil)
			    (WriteB-data Bcell (funcall fn BB-data A-data))
			  (let* ((Acell (ReadCoreCell adress/?))
				 (AA-data (ReadA-data Acell))
				 (AB-data (ReadB-data Acell)))
			    (WriteA-data 
			     (WriteB-data Bcell (funcall fn AB-data BB-data)) 
			     (funcall fn AA-data BA-data)) )))))))
    (progn (PushTask (IncAdress adress 1))
	   (if (eq newadress nil)
	       nil
	     (WriteCoreCell newadress newcell)))))

(defun CoreAdd (corecell adress)
  "corecell adress -> t or nil"
  (CoreAdd/SUB corecell adress '+mod))

(defun CoreSUB (corecell adress)
  "corecell adress -> t or nil"
  (CoreADD/SUB corecell adress '-mod))
			     
  
(defun CoreJMP-test(corecell adress fn)
  "corecell x adress x fn -> t or nil"
  ;; fn is supposed to compare a number to zero, eg >,<,= etc
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (B-mode (ReadB-mode corecell))
	 (B-data (ReadB-data corecell))
	 (newadress (EvalToAdress A-mode A-data adress))
	 (value (let ((tmpadress (EvalToAdress B-mode B-data adress)))
		  (if (eq tmpadress nil)
		      B-data
		    (ReadB-data (ReadCoreCell tmpadress))))))
    (if (and newadress (funcall fn value 0))
	(progn (PushTask newadress) t)
      (progn (PushTask (IncAdress adress 1)) nil) )))

(defun CoreJMZ (corecell adress)
  "corecell x adress -> t or nil"
  (CoreJMP-test corecell adress '=))

(defun CoreJMG (corecell adress)
  "corecell x adress -> t or nil"
  (CoreJMP-test corecell adress '>))

(defun CoreCMP (corecell adress)
  "corecell x adress -> t or nil"
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (B-mode (ReadB-mode corecell))
	 (B-data (ReadB-data corecell))
	 (Badress (EvalToAdress B-mode B-data adress))
	 (Bcell  (if Badress (ReadCoreCell Badress) nil))
	 (BB-data (if Badress (ReadB-data Bcell) nil))
	 (cmp?    (if (eq Badress nil) 
		      nil
		    (let ((tmpadress (EvalToAdress A-mode A-data adress)))
		      (if (eq tmpadress nil)
			  (eq A-data BB-data)
			(let ((tmpcell (ReadCoreCell tmpadress)))
			  (eq tmpcell Bcell) )))) ))
    (if cmp?
	(progn (PushTask (IncAdress adress 2)) t)
      (progn (PushTask (IncAdress adress 1)) nil))))
			       
			
(defun CoreDJZ (corecell adress)
  "corecell x adress -> t or nil"
  (labels ((decrement (corecell adress)
	     (let* ((B-mode (ReadB-mode corecell))
		    (B-data (ReadB-data corecell))
		    (adress/? (EvalToAdress B-mode B-data adress)))
	       (if (eq adress/? nil)
		   (WriteCoreCell adress (WriteB-data corecell (-mod B-data 1)))
		 (let* ((newCell (ReadCoreCell adress/?))
			(newData (ReadB-data newCell)))
		   (WriteCoreCell adress/? (WriteB-data newCell (-mod newData 1))))))))
    (progn (decrement corecell adress)
	   (let ((newcell (ReadCoreCell adress)))
	     (CoreJMP-test newcell adress '=))) ))

(defun CoreSPL (corecell adress)
  "corecell x adress ->t or nil"
  (let* ((A-mode (ReadA-mode corecell))
	 (A-data (ReadA-data corecell))
	 (newadress (EvalToAdress A-mode A-data adress)))
    (progn (PushTask (IncAdress adress 1))
	   (if newadress 
	       (PushTask newadress)
	     nil))))



;;;**************************** Compile function ****************************
(defun CompileToList (filename)
  "assembler file => list with machinecode"
  (let ((codelist '())
        (linecounter 0))
    (catch 'ErrorOccurrence
      (with-open-file (infile (translate-logical-pathname filename)
		       :direction :input)
	(labels (
		 (MyError () 
		   (Format t "~%Error at line ~a in program ~a. Empty lines not counted." 
			   linecounter CurrentPlayer)
		   (throw 'ErrorOccurrence nil))
		 (AddArgumentToCodelist (arg) 
		   (if (listp arg)
		       (setq codelist (append codelist arg))
		     (setq codelist (append codelist (list *Direct* arg)))))
		 (ReadTwoArgs (instruction)
		   (setq codelist (append codelist (list instruction)))
		   (AddArgumentToCodelist (ReadArgument))
		   (AddArgumentToCodelist (ReadArgument)))
		 (ReadA-arg (instruction)
		   (setq codelist (append codelist (list instruction)))
		   (AddArgumentToCodelist (ReadArgument))
		   (AddArgumentToCodelist 0))
		 (ReadB-arg (instruction)
		   (setq codelist (append codelist (list instruction)))
		   (AddArgumentToCodelist 0)
		   (AddArgumentToCodelist (ReadArgument)))
		 (ReadArgument ()
		   (let* ((nextchar (peek-char t infile)))
		       (cond ((equal nextchar #\@) 
			      (read-char infile)
			      (list *Indirect* (ReadData)))
			     ((equal nextchar #\#)
			      (read-char infile)
			      (list *Immediate* (ReadData)))
			     ((equal nextchar #\$)
			      (read-char infile)
			      (list *Direct* (ReadData)))
			     (t (ReadData)))))
		 (ReadData ()
		   (let ((newdata (read infile nil '==eof==)))
		     (if (numberp newdata) newdata (MyError)))))
	  (loop
	    (setq linecounter (1+ linecounter))
	    (let ((InObject (read infile nil '==eof==)))
	      (cond ((equal InObject 'DAT) (ReadTwoArgs *dat*))
		    ((equal InObject 'MOV) (ReadTwoArgs *mov*))
		    ((equal InObject 'ADD) (ReadTwoArgs *add*))
		    ((equal InObject 'SUB) (ReadTwoArgs *sub*))
		    ((equal InObject 'JMP) (ReadA-arg *jmp*))    
		    ((equal InObject 'JMZ) (ReadTwoArgs *jmz*))
		    ((equal InObject 'JMG) (ReadTwoArgs *jmg*))    
		    ((equal InObject 'DJZ) (ReadTwoArgs *djz*))    
		    ((equal InObject 'CMP) (ReadTwoArgs *cmp*))
		    ((equal InObject 'SPL) (ReadA-arg *spl*))
		    ((equal InObject '==eof==) (return codelist)) 
		    (t (if (equal #\Newline (peek-char nil infile)) 
			   t
			   (read-line infile)))))))))))



;;;****** Function for placing a machinecode program in the CoreArray *******
(defun PlaceProgramInMemory (adress codelist)
  "adress X codelist (list with machinecode) => T or NIL"
  (cond ((> (/ (length codelist) 5) *MaxProgramLength* )
	 (progn
	   (format t "~%Program ~a is too long." CurrentPlayer)
	   NIL))
	((endp codelist) t)
	(t (WriteCoreCell 
	    adress
	    (CreateCoreCell :opcode (first codelist)
			    :A-mode (second codelist)
			    :A-data (third codelist)
			    :B-mode (fourth codelist)
			    :B-data (fifth codelist)))
	   (PlaceProgramInMemory
	    (+mod (IncAdress adress 1))
	    (nthcdr 5 codelist)))))




;;;************************ Main function ***********************************
(defun CoreWar (file1 file2)
  " => "
  (let ((CurrentCycle 1))
    (progn (CreateCoreArray)
	   (setq CurrentPlayer 1)
	   (shell (format nil "~ad93joama/pink/projekt/c/corewarg ~d ~d " '~ 0 *CoreSize*))
	   (PlaceProgramInMemory 0 (CompileToList file1))
	   (setq TaskQueProg1 (CreateTaskQue))
	   (PushTask 0)
	   (Setq CurrentPlayer 2)
	   (let ((other-adress 
		  (+ *MaxProgramLength* 
		     (random (- *CoreSize* (* 2 *MaxProgramLength*)))) ))
	     (Progn (PlaceProgramInMemory other-adress (CompileToList file2))
		    (setq TaskQueProg2 (CreateTaskQue))
		    (PushTask other-adress)
		    (values)))
	   (loop
	     (if (= CurrentPlayer 1) 
		 (setq CurrentPlayer 2)
	       (setq CurrentPlayer 1))
	     (setq CurrentAdress (PopTask))
	     (if (or (equal CurrentAdress nil) 
		     (= CurrentCycle (+ 1 *MaxNumberOfCycles*)))
		 (return))
	     (let* ((CurrentCell (ReadCoreCell CurrentAdress))
		    (CurrentOpCode (ReadOpCode CurrentCell)))
	       (Cond 
		((= CurrentOpCode *MOV*) (CoreMOV CurrentCell CurrentAdress))
		((= CurrentOpCode *ADD*) (CoreADD CurrentCell CurrentAdress))
		((= CurrentOpCode *SUB*) (CoreSUB CurrentCell CurrentAdress))
		((= CurrentOpCode *JMP*) (CoreJMP CurrentCell CurrentAdress))
		((= CurrentOpCode *JMZ*) (CoreJMZ CurrentCell CurrentAdress))
		((= CurrentOpCode *JMG*) (CoreJMG CurrentCell CurrentAdress))
		((= CurrentOpCode *DJZ*) (CoreDJZ CurrentCell CurrentAdress))
		((= CurrentOpCode *CMP*) (CoreCMP CurrentCell CurrentAdress))
		((= CurrentOpCode *SPL*) (CoreSPL CurrentCell CurrentAdress))
		( t nil)) )
	     (if (= CurrentPlayer 1)
		 ;;(format t "~%Cycle:~7a Address p1:~7a"CurrentCycle CurrentAdress)
	       (progn
		 ;;(format t "Address p2:~7a" CurrentAdress)
		 (setq CurrentCycle (+ CurrentCycle 1)))))
	   (if (> CurrentCycle *MaxNumberOfCycles*)
	       (progn 
		 (format t "~%The match was a tie.")
		 (values))
	     (progn
	       (format t "~%The loser is number ~a" CurrentPlayer)
	       (values))))))