2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
9 (chicken process context)
16 (define max-steps 10000)
22 (define (make-instr opcode modifier A-mode A-num B-mode B-num)
26 (('modifier) modifier)
31 (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
32 (('set! 'opcode x) (set! opcode x))
33 (('set! 'modifier x) (set! modifier x))
34 (('set! 'A-mode x) (set! A-mode x))
35 (('set! 'A-num x) (set! A-num x))
36 (('set! 'B-mode x) (set! B-mode x))
37 (('set! 'B-num x) (set! B-num x))
39 (set! opcode (other 'opcode))
40 (set! modifier (other 'opcode))
41 (set! A-mode (other 'A-mode))
42 (set! A-num (other 'A-num))
43 (set! B-mode (other 'B-mode))
44 (set! B-num (other 'B-num)))
46 (error "Invalid instr arguments" args)))))
48 (define (mode->string mode)
54 ((pre-indirect-A) "{")
55 ((pre-indirect-B) "<")
56 ((post-indirect-A) "}")
57 ((post-indirect-B) ">")
59 (error "Unknown mode."))))
61 (define (instr->string instr)
64 " " (mode->string A-mode) A-num
65 " " (mode->string B-mode) B-num))
67 (define initial-instruction
68 (make-instr 'DAT 'F 'immediate 0 'immediate 0))
71 ;;; Memory setup and addressing
74 (define (make-core core-size initial-instr)
75 (let ((core-vec (make-vector core-size '()))
76 (names-vec (make-vector core-size '())))
78 (unless (>= i core-size)
79 (vector-set! core-vec i (initial-instr 'copy))
84 ((vector-ref core-vec i) 'set-from! (vector-ref core-vec j))
85 (vector-set! names-vec i n))
86 ((i 'set-from-instr! instr n)
87 ((vector-ref core-vec i) 'set-from! instr)
88 (vector-set! names-vec i n))
90 ((vector-ref core-vec i) 'set! v x)
91 (vector-set! names-vec i n))
92 ((i 'name) (vector-ref names i))
93 ((i v) ((vector-ref core-vec i) v))
96 (unless (>= i core-size)
98 (let ((n (vector-ref names-vec i)))
103 (define (addr+ . args)
105 (modulo (+ a b core-size) core-size))
108 ;;; Programmes and task queues
111 (define (make-prog name instrs offset)
112 (list name instrs offset))
114 (define (prog-name prog) (list-ref prog 0))
115 (define (prog-instrs prog) (list-ref prog 1))
116 (define (prog-offset prog) (list-ref prog 2))
118 (define (install-prog core prog addr)
119 (let loop ((ptr addr)
120 (instrs (prog-instrs prog)))
121 (unless (null? instrs)
122 (core ptr 'set-from-instr! (car instrs) (prog-name prog))
123 (loop (addr+ ptr 1) (cdr instrs))))
124 (make-player (prog-name prog)
125 (addr+ addr (prog-offset prog))))
127 (define (can-install-prog? core prog-len addr)
128 (let loop ((ptr addr)
129 (remaining prog-len))
132 (if (null? (core ptr 'name))
137 (define (install-progs core progs)
138 (let loop ((players '())
140 (if (null? progs-left)
142 (let ((addr (pseudo-random-integer core-size))
143 (prog (car progs-left)))
144 (if (can-install-prog? core (length (prog-instrs prog)) addr)
145 (loop (cons (install-prog core prog addr) players)
147 (loop players progs-left))))))
149 (define (make-queue name ptr)
152 (define (queue-owner queue) (car player))
153 (define (queue-ptrs queue) (cdr queue))
155 (define (queue-set-ptrs! queue ptrs)
156 (set-cdr! queue ptrs))
159 ;;; Executive function
162 (define (run core queues steps-left)
164 ((<= steps-left 0) queues) ;Tie between remaining players
165 ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
167 (let* ((queue (car queues))
168 (remaining-queues (cdr queues))
169 (ptrs (queue-ptrs queues))
170 (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
172 (run other-players (- steps-left 1))
174 (player-set-ptrs! player (append (cdr ptrs) new-ptrs))
175 (run (append other-players (list player)) (- steps-left 1))))))))
177 (define (execute-instr core ptr name)
178 (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
179 (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
180 (modifier (core ptr 'modifier)))
181 (case (core ptr 'opcode)
183 '()) ;Game over, man, game over!
185 (if (eq? modifier 'I)
186 (core B-ptr 'set-from! A-ptr name)
187 (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
188 (list (addr+ ptr 1)))
190 (combine-and-store core A-ptr B-ptr modifier name addr+)
191 (list (addr+ ptr 1)))
193 (combine-and-store core A-ptr B-ptr modifier name
194 (lambda (x y) (addr+ x (- y))))
195 (list (addr+ ptr 1)))
197 (combine-and-store core A-ptr B-ptr modifier name
198 (lambda (x y) (modulo (* (addr+ x core-size)
201 (list (addr+ ptr 1)))
205 (combine-and-store core A-ptr B-ptr modifier name
206 (lambda (x y) (quotient (addr x core-size)
207 (addr y core-size))))
208 (list (addr+ ptr 1)))
209 ((exn arithmetic) '())))
213 (combine-and-store core A-ptr B-ptr modifier name
214 (lambda (x y) (remainder (addr x core-size)
215 (addr y core-size))))
216 (list (addr+ ptr 1)))
217 ((exn arithmetic) '())))
219 (list (addr+ ptr (core A-ptr 'A-num))))
221 (list (addr+ ptr (if (instr-zero? B-ptr modifier #f)
222 ((core-get A-ptr) 'A-num)
225 (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f))
226 ((core-get A-ptr) 'A-num)
229 (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t))
230 ((core-get A-ptr) 'A-num)
233 (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 2 1))))
235 (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 1 2))))
237 (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier <) 2 1))))
239 (list (addr+ ptr 1) (addr+ ptr ((core-get A-ptr) 'A-num))))
241 (list (addr+ ptr 1)))
243 (error "Unrecognised opcode" (instr 'opcode))))))
245 (define (compare-instrs A-ptr B-ptr modifier test)
246 (let ((A-instr (core-get A-ptr))
247 (B-instr (core-get B-ptr)))
249 ((A) (test (A-instr 'A-num) (B-instr 'A-num)))
250 ((B) (test (A-instr 'B-num) (B-instr 'B-num)))
251 ((AB) (test (A-instr 'A-num) (B-instr 'B-num)))
252 ((BA) (test (A-instr 'B-num) (B-instr 'A-num)))
254 (test (A-instr 'A-num) (B-instr 'A-num))
255 (test (A-instr 'B-num) (B-instr 'B-num))))
257 (test (A-instr 'A-num) (B-instr 'B-num))
258 (test (A-instr 'B-num) (B-instr 'A-num))))
262 (eq? (A-instr 'opcode) (B-instr 'opcode))
263 (eq? (A-instr 'modifier) (B-instr 'modifier))
264 (eq? (A-instr 'A-mode) (B-instr 'B-mode))
265 (eq? (A-instr 'B-mode) (B-instr 'A-mode)))
267 (test (A-instr 'A-num) (B-instr 'B-num))
268 (test (A-instr 'B-num) (B-instr 'A-num)))))))
270 (define (instr-zero? ptr modifier decrement)
271 (let ((instr (core-get ptr)))
274 (if decrement (instr 'set-A-num! (addr+ (instr 'A-num) -1)))
275 (= 0 (instr 'A-num)))
277 (if decrement (instr 'set-B-num! (addr+ (instr 'B-num) -1)))
278 (= 0 (instr 'B-num)))
282 (instr 'set-A-num! (addr+ (instr 'A-num) -1))
283 (instr 'set-B-num! (addr+ (instr 'B-num) -1))))
284 (and (= 0 (instr 'A-num))
285 (= 0 (instr 'B-num)))))))
287 (define (combine-and-store core A-ptr B-ptr modifier name f)
289 ((A) (core B-ptr 'set! 'A-num
290 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
291 ((B) (core B-ptr 'set! 'B-num
292 (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
293 ((AB) (core B-ptr 'set! 'B-num
294 (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
295 ((BA) (core B-ptr 'set! 'A-num
296 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
297 ((F I) (core B-ptr 'set! 'A-num
298 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
299 (core B-ptr 'set! 'B-num
300 (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
301 ((X) (core B-ptr 'set! 'A-num
302 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
303 (core B-ptr 'set! 'B-num
304 (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
306 (define (eval-operand core mode num ptr name)
311 ((indirect-A) (addr+ num (core (addr+ ptr num) 'A-num)))
312 ((indirect-B) (addr+ num (core (addr+ ptr num) 'B-num)))
314 (let ((aux-ptr (addr+ ptr num)))
315 (core aux-ptr 'set! 'A-num (addr+ -1 (core aux-ptr 'A-num)) name)
316 (addr+ num (core aux-ptr 'A-num))))
318 (let ((aux-ptr (addr+ ptr num)))
319 (core aux-ptr 'set! 'B-num (addr+ -1 (core aux-ptr 'B-num)) name)
320 (addr+ num (core aux-ptr 'B-num))))
322 (let* ((aux-ptr (addr+ ptr num))
323 (old-A-num (core aux-ptr 'A-num)))
324 (core aux-ptr 'set! 'A-num (addr+ 1 (core aux-ptr 'A-num)) name)
325 (addr+ num old-A-num)))
327 (let* ((aux-ptr (addr+ ptr num))
328 (old-B-num (core aux-ptr 'B-num)))
329 (core aux-ptr 'set! 'B-num (addr+ 1 (core aux-ptr 'B-num)) name)
330 (addr+ num old-B-num)))
332 (error "Unrecognized mode" mode)))))
339 (define addressing-test
341 (make-instr 'DAT 'F 'immediate 42 'immediate 53 'at)
342 (make-instr 'DAT 'F 'immediate 123 'immediate 256 'at)
343 (make-instr 'MOV 'A 'indirect-B 4 'direct 7 'at)
344 (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at)
345 (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at)
346 (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at)
347 (make-instr 'DAT 'F 'immediate -5 'immediate -6 'at)) 2))
350 (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1 'imp)) 0))
353 (make-prog 'dwarf (list
354 (make-instr 'DAT 'F 'immediate 0 'immediate -1 'dwarf)
355 (make-instr 'ADD 'AB 'immediate 5 'direct -1 'dwarf)
356 (make-instr 'MOV 'I 'direct -2 'indirect-B -2 'dwarf)
357 (make-instr 'JMP 'I 'immediate -2 'immediate 0 'dwarf)) 1))
360 (define players (install-progs (list dwarf imp)))