mars.scm

   1 ;;;
   2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
   3 ;;;
   4
   5 (import (chicken io)
   6         (chicken string)
   7         matchable)
   8
   9 ;;; Constants
  10 ;;
  11
  12 (define core-size 8000)
  13 (define max-steps 10000)
  14
  15
  16 ;;; Memory setup
  17 ;;
  18
  19 (define core (make-vector core-size '()))
  20 (define (addr+ . args)
  21   (foldl (lambda (a b)
  22            (modulo (+ a b core-size) core-size))
  23          0 args))
  24
  25 ;;; Instructions
  26 ;;
  27
  28 (define (make-instr opcode modifier A-mode A-num B-mode B-num))
  29 (define (instr-opcode instr) (list-ref instr 0))
  30 (define (instr-modifier instr) (list-ref instr 1))
  31 (define (instr-A-mode instr) (list-ref instr 2))
  32 (define (instr-A-num instr) (list-ref instr 3))
  33 (define (instr-B-mode instr) (list-ref instr 4))
  34 (define (instr-B-num instr) (list-ref instr 5))
  35
  36
  37 ;;; Players
  38 ;;
  39
  40 (define (make-player name . ptrs)
  41   (cons name ptrs))
  42
  43 (define (player-ptrs player)
  44   (cdr player))
  45
  46 (define (player-name player)
  47   (car player))
  48
  49 (define (player-set-ptrs! player ptrs)
  50   (set-cdr! player ptrs))
  51
  52
  53 ;;; Main loop
  54 ;;
  55
  56 (define (run players step)
  57   (cond
  58    ((> step max-steps) players)      ;Tie between remaining players
  59    ((<= (length players) 1) players) ;There's only one player left who thus wins
  60    (else
  61     (let ((player (car players))
  62           (other-players (cdr players))
  63           (ptrs (player-ptrs player)))
  64       (let ((new-ptrs (execute-instr (car ptrs))))
  65         (if (null? new-ptrs)
  66             (run other-players (+ step 1))
  67             (begin
  68               (player-set-ptrs! (append (cdr ptrs) new-ptrs))
  69               (run (append other-players (list player)) (+ step 1)))))))))
  70
  71 (define (execute-instr ptr)
  72   (let* ((instr (vector-ref core ptr))
  73          (A-pointer (eval-operand (instr-A-mode instr) (instr-A-num) ptr))
  74          (B-pointer (eval-operand (instr-B-mode instr) (instr-B-num) ptr))
  75          (modifier (instr-modifier instr)))
  76     (case (instr-opcode instr)
  77       ((DAT) '()) ;Game over, man, game over!
  78       ((MOV))
  79       ((ADD))
  80       ((SUB))
  81       ((MUL))
  82       ((DIV))
  83       ((MOD))
  84       ((JMP))
  85       ((JMN))
  86       ((DJN))
  87       ((SEQ CMP))
  88       ((SNE))
  89       ((SLT))
  90       ((SPL))
  91       ((NOP))
  92       (else
  93        (error "Unrecognised opcode" (instr-opcode instr))))))
  94
  95 (define (eval-operand mode num ptr)
  96   (case mode
  97     ((immediate) 0)
  98     ((direct) num)
  99     ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num)))))
 100     ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num)))))
 101     ((pre-indirect-A)
 102      (let ((aux-instr (vector-ref core (addr+ ptr num))))
 103        (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr)))
 104        (addr+ num (instr-A-num aux-instr))))
 105     ((pre-indirect-B)
 106      (let ((aux-instr (vector-ref core (addr+ ptr num))))
 107        (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr)))
 108        (addr+ num (instr-B-num aux-instr))))
 109     ((post-indirect-A)
 110      (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 111             (old-A-num (instr-A-num aux-instr)))
 112        (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr)))
 113        (addr+ num old-A-num)))
 114     ((post-indirect-B)
 115      (let* ((aux-instr (vector-ref core (addr+ ptr num)))
 116             (old-B-num (instr-B-num aux-instr)))
 117        (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr)))
 118        (addr+ num old-B-num)))
 119     (else
 120      (error "Unrecognized mode" mode))))