Final queue count now adjustable.

[jars.git] / mars.scm

diff --git a/mars.scm b/mars.scm
index 677d754..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)
 
@@ -124,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))
@@ -135,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
@@ -189,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"
@@ -212,20 +217,20 @@
   ;;; Executive function
   ;;
 
-  (define (run-mars core queues steps-left)
+  (define (run-mars core queues steps-left min-queue-count)
     (if (or (<= steps-left 0)
-            (null? queues)
-            (= (length queues) 1))
+            (< (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))
+              (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)))))))
+                (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 ")")