Final queue count now adjustable.

[jars.git] / mars.scm

diff --git a/mars.scm b/mars.scm
index 9610d10..d2d73e3 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -6,6 +6,7 @@
     (make-instr
      make-prog
      prog-name
+     prog-author
      prog-instrs
      prog-offset
      prog->string
@@ -14,7 +15,7 @@
      make-queue
      queue-owner
      queue-ptrs
-     dump-queue
+     dump-queues
      make-core
      run-mars)
 
@@ -79,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)
@@ -105,7 +108,7 @@
         (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
@@ -122,9 +125,7 @@
            (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)
+          ((i 'dump)
            (let ((i1 (- i 4))
                  (i2 (+ i 4)))
              (let loop ((idx i1))
@@ -133,7 +134,10 @@
                      (print* "*"))
                  (dump idx)
                  (loop (+ idx 1))))))
-          (('size) core-size)))))
+          (('size) core-size)
+          (((? integer? i) v) ((norm-ref core-vec i) v))
+          (('->addr (? integer? i)) (norm-addr i))))))
+
 
 
   ;;; Programmes and task queues
@@ -187,12 +191,15 @@
   (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 (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"
@@ -205,24 +212,25 @@
 
   (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 (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 ")")
@@ -262,15 +270,15 @@
         ((JMP)
          (list (core '->addr A-ptr)))
         ((JMZ)
-         (list (core '->addr (if (instr-zero? B-ptr modifier #f name)
+         (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
                                  A-ptr
                                  (+ ptr 1)))))
         ((JMN)
-         (list (core '->addr (if (not (instr-zero? B-ptr modifier #f name))
+         (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? B-ptr modifier #t name))
+         (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
                                  A-ptr
                                  (+ ptr 1)))))
         ((SEQ CMP)
@@ -280,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 A-ptr))))
+         (list (core '->addr (+ ptr 1)) (core '->addr A-ptr)))
         ((NOP)
          (list (core '->addr (+ ptr 1))))
         (else