2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
14 (define max-steps 10000)
20 (define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . 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))
32 (('modifier) modifier)
38 (('print) (print opcode
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))))
50 (define (mode-string mode)
56 ((pre-indirect-A "{"))
57 ((pre-indirect-B "<"))
58 ((post-indirect-A "}"))
59 ((post-indirect-B ">"))))
61 (define initial-instruction
62 (make-instr 'DAT 'F 'immediate 0 'immediate 0 '()))
65 ;;; Memory setup and addressing
68 (define core (make-vector core-size '()))
73 (define (core-set! i x)
74 (vector-set! core i x))
76 (define (initialize-core)
78 (unless (>= i core-size)
79 (core-set! i (initial-instruction 'copy '()))
84 (unless (>= i core-size)
88 (define (addr+ . args)
90 (modulo (+ a b core-size) core-size))
96 (define (make-prog name instrs offset)
97 (list name instrs offset))
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))
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))))
112 (define (can-install-prog? prog-len addr)
113 (let loop ((ptr addr)
114 (remaining prog-len))
117 (if (null? ((core-get ptr) 'name))
122 (define (install-progs progs)
123 (let loop ((players '())
125 (if (null? progs-left)
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)
132 (loop players progs-left))))))
134 (define (make-player name ptr)
137 (define (player-name player) (car player))
138 (define (player-ptrs player) (cdr player))
140 (define (player-set-ptrs! player ptrs)
141 (set-cdr! prog-queue ptrs))
144 ;;; Executive function
147 (define (run players step)
149 ((> step max-steps) players) ;Tie between remaining players
150 ((<= (length players) 1) players) ;There's only one player left who thus wins
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))))
157 (run other-players (+ step 1))
159 (player-set-ptrs! (append (cdr ptrs) new-ptrs))
160 (run (append other-players (list player)) (+ step 1)))))))))
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!
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)))
208 ((NOP) (list (addr+ ptr 1)))
210 (error "Unrecognised opcode" (instr-opcode instr))))))
212 (define (eval-operand mode num ptr)
217 ((indirect-A) (addr+ num ((core-get (addr+ ptr num)) 'A-num)))
218 ((indirect-B) (addr+ num ((core-get (addr+ ptr num)) 'B-num)))
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))))
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))))
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)))
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)))
238 (error "Unrecognized mode" mode)))))