2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
27 (chicken process-context)
34 (define (make-instr opcode modifier A-mode A-num B-mode B-num)
38 (('modifier) modifier)
43 (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
44 (('set! 'opcode x) (set! opcode x))
45 (('set! 'modifier x) (set! modifier x))
46 (('set! 'A-mode x) (set! A-mode x))
47 (('set! 'A-num x) (set! A-num x))
48 (('set! 'B-mode x) (set! B-mode x))
49 (('set! 'B-num x) (set! B-num x))
51 (set! opcode (other 'opcode))
52 (set! modifier (other 'modifier))
53 (set! A-mode (other 'A-mode))
54 (set! A-num (other 'A-num))
55 (set! B-mode (other 'B-mode))
56 (set! B-num (other 'B-num)))
60 "\t" (mode->string A-mode) A-num
61 ", " (mode->string B-mode) B-num))
63 (error "Invalid instr arguments" args)))))
65 (define (mode->string mode)
71 ((pre-indirect-A) "{")
72 ((pre-indirect-B) "<")
73 ((post-indirect-A) "}")
74 ((post-indirect-B) ">")
76 (error "Unknown mode."))))
79 ;;; Memory setup and addressing
82 (define (make-core core-size initial-instr . set-functions)
83 (let ((core-vec (make-vector core-size '()))
84 (names-vec (make-vector core-size '())))
87 (norm-addr (+ i core-size))
88 (modulo i core-size)))
89 (define (norm-ref v i)
90 (vector-ref v (norm-addr i)))
91 (define (norm-set! v i x)
92 (vector-set! v (norm-addr i)
96 (define (run-set-functions i n)
97 (let loop ((remaining-fns set-functions))
98 (unless (null? remaining-fns)
99 ((car remaining-fns) i n))))
101 (print* i ":\t" ((norm-ref core-vec i) '->string))
102 (let ((n (norm-ref names-vec i)))
107 (unless (>= i core-size)
108 (vector-set! core-vec i (initial-instr 'make-copy))
113 ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j))
114 (norm-set! names-vec i n)
115 (run-set-functions i n))
116 ((i 'set-from-instr! instr n)
117 ((norm-ref core-vec i) 'set-from! instr)
118 (norm-set! names-vec i n)
119 (run-set-functions i n))
121 ((norm-ref core-vec i) 'set! v x)
122 (norm-set! names-vec i n)
123 (run-set-functions i n))
124 ((i 'name) (norm-ref names-vec i))
125 (((? integer? i) v) ((norm-ref core-vec i) v))
126 (('->addr (? integer? i)) (norm-addr i))
136 (('size) core-size)))))
139 ;;; Programmes and task queues
142 (define (make-prog name author instrs offset)
143 (list name author instrs offset))
145 (define (prog-name prog) (list-ref prog 0))
146 (define (prog-author prog) (list-ref prog 1))
147 (define (prog-instrs prog) (list-ref prog 2))
148 (define (prog-offset prog) (list-ref prog 3))
150 (define (install-prog core prog addr)
151 (let loop ((ptr addr)
152 (instrs (prog-instrs prog)))
153 (unless (null? instrs)
154 (core ptr 'set-from-instr! (car instrs) (prog-name prog))
155 (loop (core '->addr (+ ptr 1)) (cdr instrs))))
156 (make-queue (prog-name prog)
157 (core '->addr (+ addr (prog-offset prog)))))
159 (define (can-install-prog? core prog-len addr)
160 (let loop ((ptr addr)
161 (remaining prog-len))
164 (if (null? (core ptr 'name))
165 (loop (core '->addr (+ ptr 1))
169 (define (install-progs core progs)
170 (let loop ((queues '())
172 (if (null? progs-left)
174 (let ((addr (pseudo-random-integer (core 'size)))
175 (prog (car progs-left)))
176 (if (can-install-prog? core (length (prog-instrs prog)) addr)
177 (loop (cons (install-prog core prog addr) queues)
179 (loop queues progs-left))))))
181 (define (make-queue name ptr)
184 (define (queue-owner queue) (car queue))
185 (define (queue-ptrs queue) (cdr queue))
187 (define (queue-set-ptrs! queue ptrs)
188 (set-cdr! queue ptrs))
190 (define (dump-queue queue core)
191 (let loop ((ptrs (queue-ptrs queue)))
193 (core 'dump (car ptrs))
197 (define (prog->string prog)
199 ";name\t" (prog-name prog) "\n"
200 (if (not (null? (prog-author prog)))
201 (conc ";author\t" (prog-author prog) "\n\n")
203 "ORG\t" (prog-offset prog) "\t; Execution offset\n\n"
204 (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog)))))
206 (define (dump-prog prog)
207 (print (prog->string prog)))
209 ;;; Executive function
212 (define (run-mars core queues steps-left)
214 ((<= steps-left 0) queues) ;Tie between remaining players
215 ((null? queues) queues) ;Everyone's dead
217 (let* ((queue (car queues))
218 (remaining-queues (cdr queues))
219 (ptrs (queue-ptrs queue))
220 (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
222 (run-mars core remaining-queues (- steps-left 1))
224 (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
225 (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
227 (define (execute-instr core ptr name)
228 ;; (print ptr "\t" (core ptr '->string) "\t(" name ")")
229 (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
230 (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
231 (modifier (core ptr 'modifier)))
232 (case (core ptr 'opcode)
234 '()) ;Game over, man, game over!
236 (if (eq? modifier 'I)
237 (core B-ptr 'set-from! A-ptr name)
238 (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
239 (list (core '->addr (+ ptr 1))))
241 (combine-and-store core A-ptr B-ptr modifier name +)
242 (list (core '->addr (+ ptr 1))))
244 (combine-and-store core A-ptr B-ptr modifier name -)
245 (list (core '->addr (+ ptr 1))))
247 (combine-and-store core A-ptr B-ptr modifier name *)
248 (list (core '->addr (+ ptr 1))))
252 (combine-and-store core A-ptr B-ptr modifier name quotient)
254 (list (core '->addr (+ ptr 1))))
255 ((exn arithmetic) '())))
259 (combine-and-store core A-ptr B-ptr modifier name modulo)
260 (list (core '->addr (+ ptr 1))))
261 ((exn arithmetic) '())))
263 (list (core '->addr A-ptr)))
265 (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
269 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name))
273 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
277 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
279 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
281 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
283 (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
285 (list (core '->addr (+ ptr 1))))
287 (error "Unrecognised opcode" (core ptr 'opcode))))))
289 (define (compare-instrs core A-ptr B-ptr modifier test)
291 ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
292 ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
293 ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
294 ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
296 (test (core A-ptr 'A-num) (core B-ptr 'A-num))
297 (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
299 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
300 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
304 (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
305 (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
306 (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
307 (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
309 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
310 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
312 (define (instr-zero? core ptr modifier decrement name)
315 (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
316 (= 0 (core ptr 'A-num)))
318 (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
319 (= 0 (core ptr 'B-num)))
323 (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
324 (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
325 (and (= 0 (core ptr 'A-num))
326 (= 0 (core ptr 'B-num))))))
328 (define (combine-and-store core A-ptr B-ptr modifier name f)
330 ((A) (core B-ptr 'set! 'A-num
331 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
332 ((B) (core B-ptr 'set! 'B-num
333 (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
334 ((AB) (core B-ptr 'set! 'B-num
335 (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
336 ((BA) (core B-ptr 'set! 'A-num
337 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
338 ((F I) (core B-ptr 'set! 'A-num
339 (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
340 (core B-ptr 'set! 'B-num
341 (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
342 ((X) (core B-ptr 'set! 'A-num
343 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
344 (core B-ptr 'set! 'B-num
345 (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
347 (define (eval-operand core mode num ptr name)
352 ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
353 ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
355 (let ((aux-ptr (+ ptr num)))
356 (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
357 (+ num (core aux-ptr 'A-num))))
359 (let ((aux-ptr (+ ptr num)))
360 (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
361 (+ num (core aux-ptr 'B-num))))
363 (let* ((aux-ptr (+ ptr num))
364 (old-A-num (core aux-ptr 'A-num)))
365 (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
368 (let* ((aux-ptr (+ ptr num))
369 (old-B-num (core aux-ptr 'B-num)))
370 (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
373 (error "Unrecognized mode" mode)))))))