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                      (if (null? modifier) "" (conc "." 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 '() 'immediate 0 'immediate 0 '()))
  55
  56
  57 ;;; Memory setup and addressing
  58 ;;
  59
  60 (define core (make-vector core-size '()))
  61
  62 (define (initialize-core)
  63   (let loop ((i 0))
  64     (unless (>= i core-size)
  65       (vector-set! core i (initial-instruction 'copy '()))
  66       (loop (+ i 1)))))
  67
  68 (define (core-dump)
  69   (let loop ((i 0))
  70     (unless (>= i core-size)
  71       ((vector-ref core i) 'print)
  72       (loop (+ i 1)))))
  73
  74 (define (addr+ . args)
  75   (foldl (lambda (a b)
  76            (modulo (+ a b core-size) core-size))
  77          0 args))
  78
  79 ;;; Programmes
  80 ;;
  81
  82 (define (make-prog name instrs offset)
  83   (list name instrs offset))
  84
  85 (define (prog-name prog) (list-ref prog 0))
  86 (define (prog-instrs prog) (list-ref prog 1))
  87 (define (prog-offset prog) (list-ref prog 2))
  88
  89 (define (install-prog prog addr)
  90   (let loop ((ptr addr)
  91              (instrs (prog-instrs prog)))
  92     (unless (null? instrs)
  93       (vector-set! core ptr ((car instrs) 'copy (prog-name prog)))
  94       (loop (addr+ ptr 1) (cdr instrs))))
  95   (make-player (prog-name prog)
  96                (addr+ addr (prog-offset prog))))
  97
  98 (define (can-install-prog? prog-len addr)
  99   (let loop ((ptr addr)
 100              (remaining prog-len))
 101     (if (= remaining 0)
 102         #t
 103         (if (null? ((vector-ref core ptr) 'name))
 104             (loop (addr+ ptr 1)
 105                   (- remaining 1))
 106             #f))))
 107
 108 (define (install-progs progs)
 109   (let loop ((players '())
 110              (progs-left progs))
 111     (if (null? progs-left)
 112         players
 113         (let ((addr (pseudo-random-integer core-size))
 114               (prog (car progs-left)))
 115           (if (can-install-prog? (length (prog-instrs prog)) addr)
 116               (loop (cons (install-prog prog addr) players)
 117                     (cdr progs-left))
 118               (loop players progs-left))))))
 119
 120 (define (make-player name ptr)
 121   (list name ptr))
 122
 123 (define (player-set-ptrs! player ptrs)
 124   (set-cdr! prog-queue ptrs))
 125
 126
 127 ;;; Executive function
 128 ;;
 129
 130 (define (run players step)
 131   (cond
 132    ((> step max-steps) players)      ;Tie between remaining players
 133    ((<= (length players) 1) players) ;There's only one player left who thus wins
 134    (else
 135     (let ((player (car players))
 136           (other-players (cdr players))
 137           (ptrs (player-ptrs player)))
 138       (let ((new-ptrs (execute-instr (car ptrs))))
 139         (if (null? new-ptrs)
 140             (run other-players (+ step 1))
 141             (begin
 142               (player-set-ptrs! (append (cdr ptrs) new-ptrs))
 143               (run (append other-players (list player)) (+ step 1)))))))))
 144
 145 (define (execute-instr ptr)
 146   (let* ((instr (vector-ref core ptr))
 147          (A-pointer (eval-operand (instr-A-mode instr) (instr-A-num) ptr))
 148          (B-pointer (eval-operand (instr-B-mode instr) (instr-B-num) ptr))
 149          (modifier (instr-modifier instr)))
 150     (case (instr-opcode instr)
 151       ((DAT) '()) ;Game over, man, game over!
 152       ((MOV))
 153       ((ADD))
 154       ((SUB))
 155       ((MUL))
 156       ((DIV))
 157       ((MOD))
 158       ((JMP))
 159       ((JMN))
 160       ((DJN))
 161       ((SEQ CMP))
 162       ((SNE))
 163       ((SLT))
 164       ((SPL))
 165       ((NOP))
 166       (else
 167        (error "Unrecognised opcode" (instr-opcode instr))))))
 168
 169 (define (eval-operand mode num ptr)
 170   (addr+ ptr
 171          (case mode
 172            ((immediate) 0)
 173            ((direct) num)
 174            ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num)))))
 175            ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num)))))
 176            ((pre-indirect-A)
 177             (let ((aux-instr (vector-ref core (addr+ ptr num))))
 178               (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr)))
 179               (addr+ num (instr-A-num aux-instr))))
 180            ((pre-indirect-B)
 181             (let ((aux-instr (vector-ref core (addr+ ptr num))))
 182               (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr)))
 183               (addr+ num (instr-B-num aux-instr))))
 184            ((post-indirect-A)
 185             (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 186                    (old-A-num (instr-A-num aux-instr)))
 187               (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr)))
 188               (addr+ num old-A-num)))
 189            ((post-indirect-B)
 190             (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 191                    (old-B-num (instr-B-num aux-instr)))
 192               (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr)))
 193               (addr+ num old-B-num)))
 194            (else
 195             (error "Unrecognized mode" mode)))))