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 20)
  14 (define max-steps 10000)
  15
  16
  17 ;;; Instructions
  18 ;;
  19
  20 (define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . args)
  21   (match args
  22     (('copy n) (make-instr opcode modifier A-mode A-num B-mode B-num n))
  23     (('copy-from! other n)
  24      (set! opcode (other 'opcode))
  25      (set! modifier (other 'modifier))
  26      (set! A-mode (other 'A-mode))
  27      (set! A-num (other 'A-num))
  28      (set! B-mode (other 'B-mode))
  29      (set! B-num (other 'B-num))
  30      (set! name n))
  31     (('opcode) opcode)
  32     (('modifier) modifier)
  33     (('A-mode) A-mode)
  34     (('A-num) A-num)
  35     (('B-mode) B-mode)
  36     (('B-num) B-num)
  37     (('name) name)
  38     (('print) (print opcode
  39                      "." modifier
  40                      " " (mode-string A-mode) A-num
  41                      ", " (mode-string B-mode) B-num
  42                      (if (null? name) "" (conc " ; " name))))
  43     (('set-opcode! x n) (set! opcode x) (set! name n))
  44     (('set-modifier! x n) (set! modifier x) (set! name n))
  45     (('set-A-mode! x n) (set! A-mode x) (set! name n))
  46     (('set-A-num! x n) (set! A-num x) (set! name n))
  47     (('set-B-mode! x n) (set! B-mode x) (set! name n))
  48     (('set-B-num! x n) (set! B-num x) (set! name n))))
  49
  50 (define (mode-string mode)
  51    (case mode
  52      ((immediate) "#")
  53      ((direct) "$")
  54      ((indirect-A "*"))
  55      ((indirect-B "@"))
  56      ((pre-indirect-A "{"))
  57      ((pre-indirect-B "<"))
  58      ((post-indirect-A "}"))
  59      ((post-indirect-B ">"))))
  60
  61 (define initial-instruction
  62   (make-instr 'DAT 'F 'immediate 0 'immediate 0 '()))
  63
  64
  65 ;;; Memory setup and addressing
  66 ;;
  67
  68 (define core (make-vector core-size '()))
  69
  70 (define (core-get i)
  71   (vector-ref core i))
  72
  73 (define (core-set! i x)
  74   (vector-set! core i x))
  75
  76 (define (initialize-core)
  77   (let loop ((i 0))
  78     (unless (>= i core-size)
  79       (core-set! i (initial-instruction 'copy '()))
  80       (loop (+ i 1)))))
  81
  82 (define (core-dump)
  83   (let loop ((i 0))
  84     (unless (>= i core-size)
  85       ((core-get i) 'print)
  86       (loop (+ i 1)))))
  87
  88 (define (addr+ . args)
  89   (foldl (lambda (a b)
  90            (modulo (+ a b core-size) core-size))
  91          0 args))
  92
  93 ;;; Programmes
  94 ;;
  95
  96 (define (make-prog name instrs offset)
  97   (list name instrs offset))
  98
  99 (define (prog-name prog) (list-ref prog 0))
 100 (define (prog-instrs prog) (list-ref prog 1))
 101 (define (prog-offset prog) (list-ref prog 2))
 102
 103 (define (install-prog prog addr)
 104   (let loop ((ptr addr)
 105              (instrs (prog-instrs prog)))
 106     (unless (null? instrs)
 107       (core-set! ptr ((car instrs) 'copy (prog-name prog)))
 108       (loop (addr+ ptr 1) (cdr instrs))))
 109   (make-player (prog-name prog)
 110                (addr+ addr (prog-offset prog))))
 111
 112 (define (can-install-prog? prog-len addr)
 113   (let loop ((ptr addr)
 114              (remaining prog-len))
 115     (if (= remaining 0)
 116         #t
 117         (if (null? ((core-get ptr) 'name))
 118             (loop (addr+ ptr 1)
 119                   (- remaining 1))
 120             #f))))
 121
 122 (define (install-progs progs)
 123   (let loop ((players '())
 124              (progs-left progs))
 125     (if (null? progs-left)
 126         players
 127         (let ((addr (pseudo-random-integer core-size))
 128               (prog (car progs-left)))
 129           (if (can-install-prog? (length (prog-instrs prog)) addr)
 130               (loop (cons (install-prog prog addr) players)
 131                     (cdr progs-left))
 132               (loop players progs-left))))))
 133
 134 (define (make-player name ptr)
 135   (list name ptr))
 136
 137 (define (player-name player) (car player))
 138 (define (player-ptrs player) (cdr player))
 139
 140 (define (player-set-ptrs! player ptrs)
 141   (set-cdr! prog-queue ptrs))
 142
 143
 144 ;;; Executive function
 145 ;;
 146
 147 (define (run players step)
 148   (cond
 149    ((> step max-steps) players)      ;Tie between remaining players
 150    ((<= (length players) 1) players) ;There's only one player left who thus wins
 151    (else
 152     (let ((player (car players))
 153           (other-players (cdr players))
 154           (ptrs (player-ptrs player)))
 155       (let ((new-ptrs (execute-instr (car ptrs) (player-name player))))
 156         (if (null? new-ptrs)
 157             (run other-players (+ step 1))
 158             (begin
 159               (player-set-ptrs! (append (cdr ptrs) new-ptrs))
 160               (run (append other-players (list player)) (+ step 1)))))))))
 161
 162 (define (execute-instr ptr name)
 163   (let* ((instr (core-get ptr))
 164          (A-pointer (eval-operand (instr 'A-mode) (instr 'A-num) ptr))
 165          (B-pointer (eval-operand (instr 'B-mode) (instr 'B-num) ptr))
 166          (modifier (instr-modifier instr)))
 167     (case (instr-opcode instr)
 168       ((DAT) '()) ;Game over, man, game over!
 169       ((MOV)
 170        (case modifier
 171          ((A) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'A-num) name))
 172          ((B) ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'B-num) name))
 173          ((AB) ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'A-num) name))
 174          ((BA) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'B-num) name))
 175          ((F) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'A-num) name)
 176               ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'B-num) name))
 177          ((X) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'B-num) name)
 178               ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'A-num) name))
 179          ((I) ((core-get B-pointer) 'copy-from! (core-get A-pointer) name)))
 180        (list (addr+ ptr 1)))
 181       ((ADD)
 182        (case modifier
 183          ((A))
 184          ((B))
 185          ((AB))
 186          ((BA))
 187          ((F))
 188          ((X))))
 189       ((SUB)
 190        (case modifier
 191          ((A))
 192          ((B))
 193          ((AB))
 194          ((BA))
 195          ((F))
 196          ((X))))
 197       ((MUL))
 198       ((DIV))
 199       ((MOD))
 200       ((JMP))
 201       ((JMZ))
 202       ((JMN))
 203       ((DJN))
 204       ((SEQ CMP))
 205       ((SNE))
 206       ((SLT))
 207       ((SPL))
 208       ((NOP) (list (addr+ ptr 1)))
 209       (else
 210        (error "Unrecognised opcode" (instr-opcode instr))))))
 211
 212 (define (eval-operand mode num ptr)
 213   (addr+ ptr
 214          (case mode
 215            ((immediate) 0)
 216            ((direct) num)
 217            ((indirect-A) (addr+ num ((core-get (addr+ ptr num)) 'A-num)))
 218            ((indirect-B) (addr+ num ((core-get (addr+ ptr num)) 'B-num)))
 219            ((pre-indirect-A)
 220             (let ((aux-instr (core-get (addr+ ptr num))))
 221               (instr-set-A-num! aux-instr (addr+ -1 (aux-instr 'A-num)))
 222               (addr+ num (aux-instr 'A-num))))
 223            ((pre-indirect-B)
 224             (let ((aux-instr (core-get (addr+ ptr num))))
 225               (instr-set-B-num! aux-instr (addr+ -1 (aux-instr 'B-num)))
 226               (addr+ num (aux-instr 'B-num))))
 227            ((post-indirect-A)
 228             (let* ((aux-instr (core-get (addr+ ptr num)))
 229                    (old-A-num (aux-instr 'A-num)))
 230               (instr-set-A-num! aux-instr (addr+ 1 (aux-instr 'A-num)))
 231               (addr+ num old-A-num)))
 232            ((post-indirect-B)
 233             (let* ((aux-instr (core-get (addr+ ptr num)))
 234                    (old-B-num (aux-instr 'B-num)))
 235               (instr-set-B-num! aux-instr (addr+ 1 (aux-instr 'B-num)))
 236               (addr+ num old-B-num)))
 237            (else
 238             (error "Unrecognized mode" mode)))))