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