X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=mars.scm;h=d2d73e32d29f7d08fe279f4a74034b40ebb9b96c;hp=40e4ca19a762ea3b3f79f36aadd54986c8016cad;hb=4ccb7fe4e20053cd189864142aeb3d1d6c59c118;hpb=28a3308e193e60e376fe9f171513ef541bb08385 diff --git a/mars.scm b/mars.scm index 40e4ca1..d2d73e3 100644 --- a/mars.scm +++ b/mars.scm @@ -6,12 +6,16 @@ (make-instr make-prog prog-name + prog-author prog-instrs prog-offset + prog->string + dump-prog install-progs make-queue queue-owner queue-ptrs + dump-queues make-core run-mars) @@ -54,8 +58,8 @@ (('->string) (conc opcode "." modifier - " " (mode->string A-mode) A-num - " " (mode->string B-mode) B-num)) + "\t" (mode->string A-mode) A-num + ", " (mode->string B-mode) B-num)) (else (error "Invalid instr arguments" args))))) @@ -76,7 +80,9 @@ ;;; Memory setup and addressing ;; - (define (make-core core-size initial-instr . set-functions) + (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0)) + + (define (make-core core-size . set-functions) (let ((core-vec (make-vector core-size '())) (names-vec (make-vector core-size '()))) (define (norm-addr i) @@ -94,9 +100,15 @@ (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)) + (vector-set! core-vec i (INITIAL-INSTR 'make-copy)) (loop (+ i 1)))) (lambda args (match args @@ -113,29 +125,31 @@ (norm-set! names-vec i n) (run-set-functions i n)) ((i 'name) (norm-ref names-vec i)) + ((i 'dump) + (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) (((? integer? i) v) ((norm-ref core-vec i) v)) - (('->addr (? integer? i)) (norm-addr i)) - (('dump) - (let loop ((i 0)) - (unless (>= i core-size) - (print* i ":\t" ((vector-ref core-vec i) '->string)) - (let ((n (vector-ref names-vec i))) - (unless (null? n) - (print* "\t;" n))) - (print) - (loop (+ i 1))))) - (('size) core-size))))) + (('->addr (? integer? i)) (norm-addr i)))))) + ;;; Programmes and task queues ;; - (define (make-prog name instrs offset) - (list name instrs offset)) + (define (make-prog name author instrs offset) + (list name author 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 (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) @@ -177,26 +191,49 @@ (define (queue-set-ptrs! queue ptrs) (set-cdr! queue ptrs)) + (define (dump-queues queues core) + (for-each (lambda (queue) + (print ";" (queue-owner queue)) + (for-each (lambda (ptr) + (core ptr 'dump) + (print)) + (cdr queue)) + (print)) + queues)) + + (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 - ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins - (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 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 (run-mars core queues steps-left min-queue-count) + (if (or (<= steps-left 0) + (< (length queues) min-queue-count)) + queues + (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) min-queue-count) + (begin + (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs)) + (run-mars core (append remaining-queues (list queue)) + (- steps-left 1) min-queue-count)))))) (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))) @@ -231,19 +268,19 @@ (list (core '->addr (+ ptr 1)))) ((exn arithmetic) '()))) ((JMP) - (list (core '->addr (+ ptr (core A-ptr 'A-num))))) + (list (core '->addr A-ptr))) ((JMZ) - (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name) - (core A-ptr 'A-num) - 1))))) + (list (core '->addr (if (instr-zero? core B-ptr modifier #f name) + A-ptr + (+ ptr 1))))) ((JMN) - (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name)) - (core A-ptr 'A-num) - 1))))) + (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name)) + A-ptr + (+ ptr 1))))) ((DJN) - (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name)) - (core A-ptr 'A-num) - 1))))) + (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) @@ -251,7 +288,7 @@ ((SLT) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1))))) ((SPL) - (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num)))))) + (list (core '->addr (+ ptr 1)) (core '->addr A-ptr))) ((NOP) (list (core '->addr (+ ptr 1)))) (else