;;; ;;; An implementation of the Memory Array Redcode Simulator (MARS) ;;; (import (chicken io) (chicken string) matchable) ;;; Constants ;; (define core-size 8000) (define max-steps 10000) ;;; Memory setup ;; (define core (make-vector core-size '())) ;;; Instructions ;; (define (make-instr opcode modifier A-mode A-num B-mode B-num)) (define (instr-opcode instr) (list-ref instr 0)) (define (instr-modifier instr) (list-ref instr 1)) (define (instr-A-mode instr) (list-ref instr 2)) (define (instr-A-num instr) (list-ref instr 3)) (define (instr-B-mode instr) (list-ref instr 4)) (define (instr-B-num instr) (list-ref instr 5)) ;;; Players ;; (define (make-player name . ptrs) (cons name ptrs)) (define (player-ptrs player) (cdr player)) (define (player-name player) (car player)) (define (player-set-ptrs! player ptrs) (set-cdr! player ptrs)) ;;; Main loop ;; (define (run players step) (cond ((> step max-steps) players) ;Tie between remaining players ((<= (length players) 1) players) ;There's only one player left who thus wins (else (let ((player (car players)) (other-players (cdr players)) (ptrs (player-ptrs player))) (let ((new-ptrs (execute-instr (car ptrs)))) (if (null? new-ptrs) (run other-players (+ step 1)) (begin (player-set-ptrs! (append (cdr ptrs) new-ptrs)) (run (append other-players (list player)) (+ step 1))))))))) (define (execute-instr ptr) (let* ((instr (vector-ref core ptr)) (A-pointer (eval-operand (instr-A-mode instr) (instr-A-num) ptr)) (B-pointer (eval-operand (instr-B-mode instr) (instr-B-num) ptr))) (case (instr-opcode instr) ((DAT)) ((MOV)) ((ADD)) ((SUB)) ((MUL)) ((DIV)) ((MOD)) ((JMP)) ((JMN)) ((DJN)) ((SEQ CMP)) ((SNE)) ((SLT)) ((SPL)) ((NOP)) (else (error "Unrecognised opcode" (instr-opcode instr)))))) (define (eval-operand mode num ptr) (case mode ((immediate) 0) ((direct) num) ((indirect-A) (+ num (instr-A-num (vector-ref core (+ ptr num))))) ((indirect-B) (+ num (instr-B-num (vector-ref core (+ ptr num))))) ((pre-indirect-A) (let ((aux-instr (vector-ref core (+ ptr num)))) (instr-set-A-num! aux-instr (- 1 (instr-A-num aux-instr))) (+ num (instr-A-num aux-instr)))) ((pre-indirect-B) (let ((aux-instr (vector-ref core (+ ptr num)))) (instr-set-B-num! aux-instr (- 1 (instr-B-num aux-instr))) (+ num (instr-B-num aux-instr)))) ((post-indirect-A) (let* ((aux-instr (vector-ref core (+ ptr num))) (old-A-num (instr-A-num aux-instr))) (instr-set-A-num! aux-instr (+ 1 (instr-A-num aux-instr))) (+ num old-A-num))) ((post-indirect-B) (let* ((aux-instr (vector-ref core (+ ptr num))) (old-B-num (instr-B-num aux-instr))) (instr-set-B-num! aux-instr (+ 1 (instr-B-num aux-instr))) (+ num old-B-num))) (else (error "Unrecognized mode" mode))))