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
  21
  22 ;;; Instructions
  23 ;;
  24
  25 (define (make-instr opcode modifier A-mode A-num B-mode B-num))
  26 (define (instr-opcode instr) (list-ref instr 0))
  27 (define (instr-modifier instr) (list-ref instr 1))
  28 (define (instr-A-mode instr) (list-ref instr 2))
  29 (define (instr-A-num instr) (list-ref instr 3))
  30 (define (instr-B-mode instr) (list-ref instr 4))
  31 (define (instr-B-num instr) (list-ref instr 5))
  32
  33
  34 ;;; Players
  35 ;;
  36
  37 (define (make-player name . ptrs)
  38   (cons name ptrs))
  39
  40 (define (player-ptrs player)
  41   (cdr player))
  42
  43 (define (player-name player)
  44   (car player))
  45
  46 (define (player-set-ptrs! player ptrs)
  47   (set-cdr! player ptrs))
  48
  49
  50 ;;; Main loop
  51 ;;
  52
  53 (define (run players step)
  54   (cond
  55    ((> step max-steps) players)      ;Tie between remaining players
  56    ((<= (length players) 1) players) ;There's only one player left who thus wins
  57    (else
  58     (let ((player (car players))
  59           (other-players (cdr players))
  60           (ptrs (player-ptrs player)))
  61       (let ((new-ptrs (execute-instr (car ptrs))))
  62         (if (null? new-ptrs)
  63             (run other-players (+ step 1))
  64             (begin
  65               (player-set-ptrs! (append (cdr ptrs) new-ptrs))
  66               (run (append other-players (list player)) (+ step 1)))))))))
  67
  68 (define (execute-instr ptr)
  69   (let* ((instr (vector-ref core ptr))
  70          (A-operand (eval-operand (instr-A-mode instr) (instr-A-num) ptr))
  71          (B-operand (eval-operand (instr-B-mode instr) (instr-B-num) ptr)))
  72     (case (instr-opcode instr)
  73       ((DAT))
  74       ((MOV))
  75       ((ADD))
  76       ((SUB))
  77       ((MUL))
  78       ((DIV))
  79       ((MOD))
  80       ((JMP))
  81       ((JMN))
  82       ((DJN))
  83       ((SEQ CMP))
  84       ((SNE))
  85       ((SLT))
  86       ((SPL))
  87       ((NOP))
  88       (else
  89        (error "Unrecognised opcode" (instr-opcode instr))))))
  90
  91 (define (eval-operand mode num ptr)
  92   (case mode
  93     ((immediate))
  94     ((direct))
  95     ((indirect-A))
  96     ((indirect-B))
  97     ((pre-indirect-A))
  98     ((pre-indirect-B))
  99     ((post-indirect-A))
 100     ((post-indirect-B))))