;;; ;;; An implementation of the Memory Array Redcode Simulator (MARS) ;;; (module mars (make-instr make-prog prog-name prog-instrs prog-offset prog->string dump-prog install-progs make-queue queue-owner queue-ptrs dump-queue make-core run-mars) (import scheme (chicken base) (chicken io) (chicken string) (chicken random) (chicken condition) (chicken process-context) matchable) ;;; Instructions ;; (define (make-instr opcode modifier A-mode A-num B-mode B-num) (lambda args (match args (('opcode) opcode) (('modifier) modifier) (('A-mode) A-mode) (('A-num) A-num) (('B-mode) B-mode) (('B-num) B-num) (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num)) (('set! 'opcode x) (set! opcode x)) (('set! 'modifier x) (set! modifier x)) (('set! 'A-mode x) (set! A-mode x)) (('set! 'A-num x) (set! A-num x)) (('set! 'B-mode x) (set! B-mode x)) (('set! 'B-num x) (set! B-num x)) (('set-from! other) (set! opcode (other 'opcode)) (set! modifier (other 'modifier)) (set! A-mode (other 'A-mode)) (set! A-num (other 'A-num)) (set! B-mode (other 'B-mode)) (set! B-num (other 'B-num))) (('->string) (conc opcode "." modifier "\t" (mode->string A-mode) A-num ", " (mode->string B-mode) B-num)) (else (error "Invalid instr arguments" args))))) (define (mode->string mode) (case mode ((immediate) "#") ((direct) "$") ((indirect-A) "*") ((indirect-B) "@") ((pre-indirect-A) "{") ((pre-indirect-B) "<") ((post-indirect-A) "}") ((post-indirect-B) ">") (else (error "Unknown mode.")))) ;;; Memory setup and addressing ;; (define (make-core core-size initial-instr . set-functions) (let ((core-vec (make-vector core-size '())) (names-vec (make-vector core-size '()))) (define (norm-addr i) (if (< i 0) (norm-addr (+ i core-size)) (modulo i core-size))) (define (norm-ref v i) (vector-ref v (norm-addr i))) (define (norm-set! v i x) (vector-set! v (norm-addr i) (if (integer? x) (norm-addr x) x))) (define (run-set-functions i n) (let loop ((remaining-fns set-functions)) (unless (null? remaining-fns) ((car remaining-fns) i n)))) (define (dump i) (print* i ":\t" ((norm-ref core-vec i) '->string)) (let ((n (norm-ref names-vec i))) (unless (null? n) (print* "\t;" n))) (print)) (let loop ((i 0)) (unless (>= i core-size) (vector-set! core-vec i (initial-instr 'make-copy)) (loop (+ i 1)))) (lambda args (match args ((i 'set-from! j n) ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j)) (norm-set! names-vec i n) (run-set-functions i n)) ((i 'set-from-instr! instr n) ((norm-ref core-vec i) 'set-from! instr) (norm-set! names-vec i n) (run-set-functions i n)) ((i 'set! v x n) ((norm-ref core-vec i) 'set! v x) (norm-set! names-vec i n) (run-set-functions i n)) ((i 'name) (norm-ref names-vec i)) (((? integer? i) v) ((norm-ref core-vec i) v)) (('->addr (? integer? i)) (norm-addr i)) (('dump i) (let ((i1 (- i 4)) (i2 (+ i 4))) (let loop ((idx i1)) (unless (> idx i2) (if (= idx i) (print* "*")) (dump idx) (loop (+ idx 1)))))) (('size) core-size))))) ;;; Programmes and task queues ;; (define (make-prog name author instrs offset) (list name author instrs offset)) (define (prog-name prog) (list-ref prog 0)) (define (prog-author prog) (list-ref prog 1)) (define (prog-instrs prog) (list-ref prog 2)) (define (prog-offset prog) (list-ref prog 3)) (define (install-prog core prog addr) (let loop ((ptr addr) (instrs (prog-instrs prog))) (unless (null? instrs) (core ptr 'set-from-instr! (car instrs) (prog-name prog)) (loop (core '->addr (+ ptr 1)) (cdr instrs)))) (make-queue (prog-name prog) (core '->addr (+ addr (prog-offset prog))))) (define (can-install-prog? core prog-len addr) (let loop ((ptr addr) (remaining prog-len)) (if (= remaining 0) #t (if (null? (core ptr 'name)) (loop (core '->addr (+ ptr 1)) (- remaining 1)) #f)))) (define (install-progs core progs) (let loop ((queues '()) (progs-left progs)) (if (null? progs-left) queues (let ((addr (pseudo-random-integer (core 'size))) (prog (car progs-left))) (if (can-install-prog? core (length (prog-instrs prog)) addr) (loop (cons (install-prog core prog addr) queues) (cdr progs-left)) (loop queues progs-left)))))) (define (make-queue name ptr) (list name ptr)) (define (queue-owner queue) (car queue)) (define (queue-ptrs queue) (cdr queue)) (define (queue-set-ptrs! queue ptrs) (set-cdr! queue ptrs)) (define (dump-queue queue core) (let loop ((ptrs (queue-ptrs queue))) (unless (null? ptrs) (core 'dump (car ptrs)) (print) (loop (cdr ptrs))))) (define (prog->string prog) (conc ";redcode\n\n" ";name\t" (prog-name prog) "\n" (if (not (null? (prog-author prog))) (conc ";author\t" (prog-author prog) "\n\n") "\n") "ORG\t" (prog-offset prog) "\t; Execution offset\n\n" (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog))))) (define (dump-prog prog) (print (prog->string prog))) ;;; Executive function ;; (define (run-mars core queues steps-left) (cond ((<= steps-left 0) queues) ;Tie between remaining players ((null? queues) queues) ;Everyone's dead (else (let* ((queue (car queues)) (remaining-queues (cdr queues)) (ptrs (queue-ptrs queue)) (new-ptrs (execute-instr core (car ptrs) (queue-owner queue)))) (if (null? new-ptrs) (run-mars core remaining-queues (- steps-left 1)) (begin (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs)) (run-mars core (append remaining-queues (list queue)) (- steps-left 1)))))))) (define (execute-instr core ptr name) ;; (print ptr "\t" (core ptr '->string) "\t(" name ")") (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name)) (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name)) (modifier (core ptr 'modifier))) (case (core ptr 'opcode) ((DAT) '()) ;Game over, man, game over! ((MOV) (if (eq? modifier 'I) (core B-ptr 'set-from! A-ptr name) (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y))) (list (core '->addr (+ ptr 1)))) ((ADD) (combine-and-store core A-ptr B-ptr modifier name +) (list (core '->addr (+ ptr 1)))) ((SUB) (combine-and-store core A-ptr B-ptr modifier name -) (list (core '->addr (+ ptr 1)))) ((MUL) (combine-and-store core A-ptr B-ptr modifier name *) (list (core '->addr (+ ptr 1)))) ((DIV) (condition-case (begin (combine-and-store core A-ptr B-ptr modifier name quotient) (list (core '->addr (+ ptr 1)))) ((exn arithmetic) '()))) ((MOD) (condition-case (begin (combine-and-store core A-ptr B-ptr modifier name modulo) (list (core '->addr (+ ptr 1)))) ((exn arithmetic) '()))) ((JMP) (list (core '->addr A-ptr))) ((JMZ) (list (core '->addr (if (instr-zero? core B-ptr modifier #f name) A-ptr (+ ptr 1))))) ((JMN) (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name)) A-ptr (+ ptr 1))))) ((DJN) (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name)) A-ptr (+ ptr 1))))) ((SEQ CMP) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1))))) ((SNE) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2))))) ((SLT) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1))))) ((SPL) (list (core '->addr (+ ptr 1) (core '->addr A-ptr)))) ((NOP) (list (core '->addr (+ ptr 1)))) (else (error "Unrecognised opcode" (core ptr 'opcode)))))) (define (compare-instrs core A-ptr B-ptr modifier test) (case modifier ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num))) ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num))) ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num))) ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num))) ((F) (and (test (core A-ptr 'A-num) (core B-ptr 'A-num)) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))) ((X) (and (test (core A-ptr 'A-num) (core B-ptr 'B-num)) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))) ((I) (and (if (eq? test =) (and (eq? (core A-ptr 'opcode) (core B-ptr 'opcode)) (eq? (core A-ptr 'modifier) (core B-ptr 'modifier)) (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode)) (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode))) #t) (test (core A-ptr 'A-num) (core B-ptr 'B-num)) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))))) (define (instr-zero? core ptr modifier decrement name) (case modifier ((A AB) (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)) (= 0 (core ptr 'A-num))) ((A AB) (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)) (= 0 (core ptr 'B-num))) ((X I F) (if decrement (begin (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name) (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))) (and (= 0 (core ptr 'A-num)) (= 0 (core ptr 'B-num)))))) (define (combine-and-store core A-ptr B-ptr modifier name f) (case modifier ((A) (core B-ptr 'set! 'A-num (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)) ((B) (core B-ptr 'set! 'B-num (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name)) ((AB) (core B-ptr 'set! 'B-num (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name)) ((BA) (core B-ptr 'set! 'A-num (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)) ((F I) (core B-ptr 'set! 'A-num (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name) (core B-ptr 'set! 'B-num (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name)) ((X) (core B-ptr 'set! 'A-num (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name) (core B-ptr 'set! 'B-num (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name)))) (define (eval-operand core mode num ptr name) (core '->addr (+ ptr (case mode ((immediate) 0) ((direct) num) ((indirect-A) (+ num (core (+ ptr num) 'A-num))) ((indirect-B) (+ num (core (+ ptr num) 'B-num))) ((pre-indirect-A) (let ((aux-ptr (+ ptr num))) (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name) (+ num (core aux-ptr 'A-num)))) ((pre-indirect-B) (let ((aux-ptr (+ ptr num))) (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name) (+ num (core aux-ptr 'B-num)))) ((post-indirect-A) (let* ((aux-ptr (+ ptr num)) (old-A-num (core aux-ptr 'A-num))) (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name) (+ num old-A-num))) ((post-indirect-B) (let* ((aux-ptr (+ ptr num)) (old-B-num (core aux-ptr 'B-num))) (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name) (+ num old-B-num))) (else (error "Unrecognized mode" mode)))))))