mars.scm

   1 ;;;
   2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
   3 ;;;
   4
   5 (import (chicken io)
   6         (chicken string)
   7         (chicken random)
   8         matchable)
   9
  10 ;;; Constants
  11 ;;
  12
  13 (define core-size 8000)
  14 (define max-steps 10000)
  15
  16
  17 ;;; Instructions
  18 ;;
  19
  20 (define ((blah x y) . args)
  21   (match args
  22     (('x q) (+ x q) q)
  23     (('y q) y)))
  24
  25 (define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . args)
  26   (match args
  27     (('copy n) (make-instr opcode modifier A-mode A-num B-mode B-num n))
  28     (('opcode) opcode)
  29     (('modifier) modifier)
  30     (('A-mode) A-mode)
  31     (('A-num) A-num)
  32     (('B-mode) B-mode)
  33     (('B-num) B-num)
  34     (('name) name)
  35     (('print) (print opcode
  36                      (if (null? modifier) "" (concat "." modifier))
  37                      " " (mode-string A-mode) A-num
  38                      ", " (mode-string B-mode) B-num
  39                      (if (null? name) "" (concat " ; " name))))
  40     (('set-opcode! x n) (set! opcode x) (set! name n))
  41     (('set-modifier! x n) (set! modifier x) (set! name n))
  42     (('set-A-mode! x n) (set! A-mode x) (set! name n))
  43     (('set-A-num! x n) (set! A-num x) (set! name n))
  44     (('set-B-mode! x n) (set! B-mode x) (set! name n))
  45     (('set-B-num! x n) (set! B-num x) (set! name n))))
  46
  47 (define (mode-string mode)
  48    (case mode
  49      ((immediate) "#")
  50      ((direct) "")
  51      ((indirect-A "*"))
  52      ((indirect-B "@"))
  53      ((pre-indirect-A "{"))
  54      ((pre-indirect-B "<"))
  55      ((post-indirect-A "}"))
  56      ((post-indirect-B ">"))))
  57
  58 (define initial-instruction
  59   (make-instr 'DAT '() 'immediate 0 'immediate 0 '()))
  60
  61 ;;; Memory setup and addressing
  62 ;;
  63
  64 (define core (make-vector core-size '()))
  65
  66 (define (initialize-core)
  67   (let loop ((i 0))
  68     (unless (< i core-size)
  69       (vector-set! core i (initial-instruction 'copy '()))
  70       (loop (+ i 1)))))
  71
  72 (define (addr+ . args)
  73   (foldl (lambda (a b)
  74            (modulo (+ a b core-size) core-size))
  75          0 args))
  76
  77 ;;; Programmes
  78 ;;
  79
  80 (define (make-prog name instrs offset)
  81   (list name instructions offset))
  82
  83 (define (prog-name prog) (list-ref prog 0))
  84 (define (prog-instrs prog) (list-ref prog 1))
  85 (define (prog-offset prog) (list-ref prog 2))
  86
  87 (define (install-prog prog addr)
  88   (let loop ((ptr addr)
  89              (instrs (prog-instrs prog)))
  90     (unless (null? instrs)
  91       (vector-set! core ptr (instr-copy (car instrs)))
  92       (loop (addr+ ptr 1) (cdr instrs))))
  93   (make-player (prog-name prog)
  94                (addr+ addr (prog-offset prog))))
  95
  96 (define (can-install-prog? prog-len addr)
  97   (let loop ((ptr addr)
  98              (remaining prog-len))
  99     (if (= remaining 0)
 100         #t
 101         (if ((vector-ref core ptr) 'name)
 102             #f
 103             (loop (addr+ ptr 1)
 104                   (- remaining 1))))))
 105
 106 (define (install-progs progs)
 107   (let loop ((players '())
 108              (progs-left progs))
 109     (if (null? progs-left)
 110         players
 111         (let ((addr (pseudo-random-integer core-size))
 112               (prog (car progs-left)))
 113           (if (can-install-prog? (length (prog-instrs prog)) addr)
 114               (loop (cons (install-prog prog addr) players)
 115                     (cdr progs-left))
 116               (loop players progs-left))))))
 117
 118 (define (make-player name ptr)
 119   (list name ptr))
 120
 121 (define (player-set-ptrs! player ptrs)
 122   (set-cdr! prog-queue ptrs))
 123
 124
 125 ;;; Executive function
 126 ;;
 127
 128 (define (run players step)
 129   (cond
 130    ((> step max-steps) players)      ;Tie between remaining players
 131    ((<= (length players) 1) players) ;There's only one player left who thus wins
 132    (else
 133     (let ((player (car players))
 134           (other-players (cdr players))
 135           (ptrs (player-ptrs player)))
 136       (let ((new-ptrs (execute-instr (car ptrs))))
 137         (if (null? new-ptrs)
 138             (run other-players (+ step 1))
 139             (begin
 140               (player-set-ptrs! (append (cdr ptrs) new-ptrs))
 141               (run (append other-players (list player)) (+ step 1)))))))))
 142
 143 (define (execute-instr ptr)
 144   (let* ((instr (vector-ref core ptr))
 145          (A-pointer (eval-operand (instr-A-mode instr) (instr-A-num) ptr))
 146          (B-pointer (eval-operand (instr-B-mode instr) (instr-B-num) ptr))
 147          (modifier (instr-modifier instr)))
 148     (case (instr-opcode instr)
 149       ((DAT) '()) ;Game over, man, game over!
 150       ((MOV))
 151       ((ADD))
 152       ((SUB))
 153       ((MUL))
 154       ((DIV))
 155       ((MOD))
 156       ((JMP))
 157       ((JMN))
 158       ((DJN))
 159       ((SEQ CMP))
 160       ((SNE))
 161       ((SLT))
 162       ((SPL))
 163       ((NOP))
 164       (else
 165        (error "Unrecognised opcode" (instr-opcode instr))))))
 166
 167 (define (eval-operand mode num ptr)
 168   (addr+ ptr
 169          (case mode
 170            ((immediate) 0)
 171            ((direct) num)
 172            ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num)))))
 173            ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num)))))
 174            ((pre-indirect-A)
 175             (let ((aux-instr (vector-ref core (addr+ ptr num))))
 176               (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr)))
 177               (addr+ num (instr-A-num aux-instr))))
 178            ((pre-indirect-B)
 179             (let ((aux-instr (vector-ref core (addr+ ptr num))))
 180               (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr)))
 181               (addr+ num (instr-B-num aux-instr))))
 182            ((post-indirect-A)
 183             (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 184                    (old-A-num (instr-A-num aux-instr)))
 185               (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr)))
 186               (addr+ num old-A-num)))
 187            ((post-indirect-B)
 188             (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 189                    (old-B-num (instr-B-num aux-instr)))
 190               (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr)))
 191               (addr+ num old-B-num)))
 192            (else
 193             (error "Unrecognized mode" mode)))))