;;;
;;; An implementation of the Memory Array Redcode Simulator (MARS)
;;;

(import (chicken io)
        (chicken string)
        (chicken random)
        matchable)

;;; Constants
;;

(define core-size 20)
(define max-steps 10000)


;;; Instructions
;;

(define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . args)
  (match args
    (('copy n) (make-instr opcode modifier A-mode A-num B-mode B-num n))
    (('opcode) opcode)
    (('modifier) modifier)
    (('A-mode) A-mode)
    (('A-num) A-num)
    (('B-mode) B-mode)
    (('B-num) B-num)
    (('name) name)
    (('print) (print opcode
                     "." modifier
                     " " (mode-string A-mode) A-num
                     ", " (mode-string B-mode) B-num
                     (if (null? name) "" (conc " ; " name))))
    (('set-opcode! x n) (set! opcode x) (set! name n))
    (('set-modifier! x n) (set! modifier x) (set! name n))
    (('set-A-mode! x n) (set! A-mode x) (set! name n))
    (('set-A-num! x n) (set! A-num x) (set! name n))
    (('set-B-mode! x n) (set! B-mode x) (set! name n))
    (('set-B-num! x n) (set! B-num x) (set! name n))))

(define (mode-string mode)
   (case mode
     ((immediate) "#")
     ((direct) "$")
     ((indirect-A "*"))
     ((indirect-B "@"))
     ((pre-indirect-A "{"))
     ((pre-indirect-B "<"))
     ((post-indirect-A "}"))
     ((post-indirect-B ">"))))

(define initial-instruction
  (make-instr 'DAT 'F 'immediate 0 'immediate 0 '()))


;;; Memory setup and addressing
;;

(define core (make-vector core-size '()))

(define (core-get i)
  (vector-ref core i))

(define (core-set! i x)
  (vector-set! core i x))

(define (initialize-core)
  (let loop ((i 0))
    (unless (>= i core-size)
      (core-set! i (initial-instruction 'copy '()))
      (loop (+ i 1)))))

(define (core-dump)
  (let loop ((i 0))
    (unless (>= i core-size)
      ((core-get i) 'print)
      (loop (+ i 1)))))

(define (addr+ . args)
  (foldl (lambda (a b)
           (modulo (+ a b core-size) core-size))
         0 args))

;;; Programmes
;;

(define (make-prog name instrs offset)
  (list name instrs offset))

(define (prog-name prog) (list-ref prog 0))
(define (prog-instrs prog) (list-ref prog 1))
(define (prog-offset prog) (list-ref prog 2))

(define (install-prog prog addr)
  (let loop ((ptr addr)
             (instrs (prog-instrs prog)))
    (unless (null? instrs)
      (core-set! ptr ((car instrs) 'copy (prog-name prog)))
      (loop (addr+ ptr 1) (cdr instrs))))
  (make-player (prog-name prog)
               (addr+ addr (prog-offset prog))))

(define (can-install-prog? prog-len addr)
  (let loop ((ptr addr)
             (remaining prog-len))
    (if (= remaining 0)
        #t
        (if (null? ((core-get ptr) 'name))
            (loop (addr+ ptr 1)
                  (- remaining 1))
            #f))))

(define (install-progs progs)
  (let loop ((players '())
             (progs-left progs))
    (if (null? progs-left)
        players
        (let ((addr (pseudo-random-integer core-size))
              (prog (car progs-left)))
          (if (can-install-prog? (length (prog-instrs prog)) addr)
              (loop (cons (install-prog prog addr) players)
                    (cdr progs-left))
              (loop players progs-left))))))

(define (make-player name ptr)
  (list name ptr))

(define (player-set-ptrs! player ptrs)
  (set-cdr! prog-queue ptrs))


;;; Executive function
;;

(define (run players step)
  (cond
   ((> step max-steps) players)      ;Tie between remaining players
   ((<= (length players) 1) players) ;There's only one player left who thus wins
   (else
    (let ((player (car players))
          (other-players (cdr players))
          (ptrs (player-ptrs player)))
      (let ((new-ptrs (execute-instr (car ptrs))))
        (if (null? new-ptrs)
            (run other-players (+ step 1))
            (begin
              (player-set-ptrs! (append (cdr ptrs) new-ptrs))
              (run (append other-players (list player)) (+ step 1)))))))))

(define (execute-instr ptr)
  (let* ((instr (core-get ptr))
         (A-pointer (eval-operand (instr 'A-mode) (instr 'A-num) ptr))
         (B-pointer (eval-operand (instr 'B-mode) (instr 'B-num) ptr))
         (modifier (instr-modifier instr)))
    (case (instr-opcode instr)
      ((DAT) '()) ;Game over, man, game over!
      ((MOV)
       (case modifier
         ((A))
         ((B))
         ((AB))
         ((BA))
         ((F))
         ((X))))
      ((ADD)
       (case modifier
         ((A))
         ((B))
         ((AB))
         ((BA))
         ((F))
         ((X))))
      ((SUB)
       (case modifier
         ((A))
         ((B))
         ((AB))
         ((BA))
         ((F))
         ((X))))
      ((MUL))
      ((DIV))
      ((MOD))
      ((JMP))
      ((JMZ))
      ((JMN))
      ((DJN))
      ((SEQ CMP))
      ((SNE))
      ((SLT))
      ((SPL))
      ((NOP) (list (addr+ ptr 1)))
      (else
       (error "Unrecognised opcode" (instr-opcode instr))))))

(define (eval-operand mode num ptr)
  (addr+ ptr
         (case mode
           ((immediate) 0)
           ((direct) num)
           ((indirect-A) (addr+ num ((core-get (addr+ ptr num)) 'A-num)))
           ((indirect-B) (addr+ num ((core-get (addr+ ptr num)) 'B-num)))
           ((pre-indirect-A)
            (let ((aux-instr (core-get (addr+ ptr num))))
              (instr-set-A-num! aux-instr (addr+ -1 (aux-instr 'A-num)))
              (addr+ num (aux-instr 'A-num))))
           ((pre-indirect-B)
            (let ((aux-instr (core-get (addr+ ptr num))))
              (instr-set-B-num! aux-instr (addr+ -1 (aux-instr 'B-num)))
              (addr+ num (aux-instr 'B-num))))
           ((post-indirect-A)
            (let* ((aux-instr (core-get (addr+ ptr num)))
                   (old-A-num (aux-instr 'A-num)))
              (instr-set-A-num! aux-instr (addr+ 1 (aux-instr 'A-num)))
              (addr+ num old-A-num)))
           ((post-indirect-B)
            (let* ((aux-instr (core-get (addr+ ptr num)))
                   (old-B-num (aux-instr 'B-num)))
              (instr-set-B-num! aux-instr (addr+ 1 (aux-instr 'B-num)))
              (addr+ num old-B-num)))
           (else
            (error "Unrecognized mode" mode)))))