X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=mars.scm;h=5ea1fbac5e0a4cbcdf07dc25f5997645664526b9;hp=57e3e13e3f77809ca51d491c4682e1b5afcc0282;hb=943e709157da251d669a5a5e59f470a1d6672f79;hpb=c30656b58f082be264e382d0da5866c4c04a10f7 diff --git a/mars.scm b/mars.scm index 57e3e13..5ea1fba 100644 --- a/mars.scm +++ b/mars.scm @@ -2,62 +2,194 @@ ;;; An implementation of the Memory Array Redcode Simulator (MARS) ;;; +(import (chicken io) + (chicken string) + (chicken random) + matchable) + ;;; Constants ;; -(define core-size 8000) +(define core-size 20) (define max-steps 10000) -;;; Memory setup +;;; Instructions ;; -(define core (make-vector core-size '())) - - -;;; Instructions +(define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . args) + (match args + (('copy n) (make-instr opcode modifier A-mode A-num B-mode B-num n)) + (('opcode) opcode) + (('modifier) modifier) + (('A-mode) A-mode) + (('A-num) A-num) + (('B-mode) B-mode) + (('B-num) B-num) + (('name) name) + (('print) (print opcode + (if (null? modifier) "" (conc "." modifier)) + " " (mode-string A-mode) A-num + ", " (mode-string B-mode) B-num + (if (null? name) "" (conc " ; " name)))) + (('set-opcode! x n) (set! opcode x) (set! name n)) + (('set-modifier! x n) (set! modifier x) (set! name n)) + (('set-A-mode! x n) (set! A-mode x) (set! name n)) + (('set-A-num! x n) (set! A-num x) (set! name n)) + (('set-B-mode! x n) (set! B-mode x) (set! name n)) + (('set-B-num! x n) (set! B-num x) (set! name n)))) + +(define (mode-string mode) + (case mode + ((immediate) "#") + ((direct) "") + ((indirect-A "*")) + ((indirect-B "@")) + ((pre-indirect-A "{")) + ((pre-indirect-B "<")) + ((post-indirect-A "}")) + ((post-indirect-B ">")))) + +(define initial-instruction + (make-instr 'DAT '() 'immediate 0 'immediate 0 '())) + + +;;; Memory setup and addressing ;; -(define (make-instr opcode modifier addrA modeA addrB modeB)) +(define core (make-vector core-size '())) +(define (initialize-core) + (let loop ((i 0)) + (unless (>= i core-size) + (vector-set! core i (initial-instruction 'copy '())) + (loop (+ i 1))))) -;;; Players -;; +(define (core-dump) + (let loop ((i 0)) + (unless (>= i core-size) + ((vector-ref core i) 'print) + (loop (+ i 1))))) -(define (make-player name . ptrs) - (cons name ptrs)) +(define (addr+ . args) + (foldl (lambda (a b) + (modulo (+ a b core-size) core-size)) + 0 args)) -(define (player-ptrs player) - (cdr player)) +;;; Programmes +;; -(define (player-name player) - (car player)) +(define (make-prog name instrs offset) + (list name instrs offset)) + +(define (prog-name prog) (list-ref prog 0)) +(define (prog-instrs prog) (list-ref prog 1)) +(define (prog-offset prog) (list-ref prog 2)) + +(define (install-prog prog addr) + (let loop ((ptr addr) + (instrs (prog-instrs prog))) + (unless (null? instrs) + (vector-set! core ptr ((car instrs) 'copy (prog-name prog))) + (loop (addr+ ptr 1) (cdr instrs)))) + (make-player (prog-name prog) + (addr+ addr (prog-offset prog)))) + +(define (can-install-prog? prog-len addr) + (let loop ((ptr addr) + (remaining prog-len)) + (if (= remaining 0) + #t + (if (null? ((vector-ref core ptr) 'name)) + (loop (addr+ ptr 1) + (- remaining 1)) + #f)))) + +(define (install-progs progs) + (let loop ((players '()) + (progs-left progs)) + (if (null? progs-left) + players + (let ((addr (pseudo-random-integer core-size)) + (prog (car progs-left))) + (if (can-install-prog? (length (prog-instrs prog)) addr) + (loop (cons (install-prog prog addr) players) + (cdr progs-left)) + (loop players progs-left)))))) + +(define (make-player name ptr) + (list name ptr)) (define (player-set-ptrs! player ptrs) - (set-cdr! player ptrs)) + (set-cdr! prog-queue ptrs)) -;;; Main loop +;;; Executive function ;; -(define (list-rot l) - (if (> (length l) 1) - (append (cdr l) (list (car l))) - l)) - -(define (run playerA playerB step) +(define (run players step) (cond - ((> step max-steps) 'tie) - ((null? (player-ptrs playerA) playerB)) - ((null? (player-ptrs playerB) playerA)) + ((> step max-steps) players) ;Tie between remaining players + ((<= (length players) 1) players) ;There's only one player left who thus wins (else - (let ((ptrs (player-ptrs playerA))) - (player-set-ptrs! (append (cdr ptrs) - (execute-instr (car ptrs))))) - (run playerB player A (+ step 1))))) + (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))) - (match instr - ()))) - + (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)) + (modifier (instr-modifier instr))) + (case (instr-opcode instr) + ((DAT) '()) ;Game over, man, game over! + ((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) + (addr+ ptr + (case mode + ((immediate) 0) + ((direct) num) + ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num))))) + ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num))))) + ((pre-indirect-A) + (let ((aux-instr (vector-ref core (addr+ ptr num)))) + (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr))) + (addr+ num (instr-A-num aux-instr)))) + ((pre-indirect-B) + (let ((aux-instr (vector-ref core (addr+ ptr num)))) + (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr))) + (addr+ num (instr-B-num aux-instr)))) + ((post-indirect-A) + (let* ((aux-instr (vector-ref core (addr+ ptr num))) + (old-A-num (instr-A-num aux-instr))) + (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr))) + (addr+ num old-A-num))) + ((post-indirect-B) + (let* ((aux-instr (vector-ref core (addr+ ptr num))) + (old-B-num (instr-B-num aux-instr))) + (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr))) + (addr+ num old-B-num))) + (else + (error "Unrecognized mode" mode)))))