Final queue count now adjustable.

diff --git a/koth.scm b/koth.scm
index d25dcd1..db68efa 100644 (file)
--- a/koth.scm
+++ b/koth.scm
@@ -48,7 +48,7 @@
 (define (score-game spec prog1 prog2)
   (let* ((core (make-core (spec-core-size spec)))
          (queues (install-progs core (list prog1 prog2)))
 (define (score-game spec prog1 prog2)
   (let* ((core (make-core (spec-core-size spec)))
          (queues (install-progs core (list prog1 prog2)))

-         (result (run-mars core queues (spec-game-length spec))))
+         (result (run-mars core queues (spec-game-length spec) 2)))

     (cond 
           ((null? result) (error "Invalid game result."))
           ((= (length result) 1)
     (cond 
           ((null? result) (error "Invalid game result."))
           ((= (length result) 1)

diff --git a/mars.scm b/mars.scm
index ae70c88..d2d73e3 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -15,7 +15,7 @@
      make-queue
      queue-owner
      queue-ptrs
      make-queue
      queue-owner
      queue-ptrs

-     dump-queue
+     dump-queues

      make-core
      run-mars)
 
      make-core
      run-mars)
 


@@ -125,9 +125,7 @@
            (norm-set! names-vec i n)
            (run-set-functions i n))
           ((i 'name) (norm-ref names-vec i))
            (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))
            (let ((i1 (- i 4))
                  (i2 (+ i 4)))
              (let loop ((idx i1))


@@ -136,7 +134,10 @@
                      (print* "*"))
                  (dump idx)
                  (loop (+ idx 1))))))
                      (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
 
 
   ;;; Programmes and task queues


@@ -190,12 +191,15 @@
   (define (queue-set-ptrs! queue ptrs)
     (set-cdr! queue ptrs))
 
   (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"
 
   (define (prog->string prog)
     (conc ";redcode\n\n"


@@ -213,20 +217,20 @@
   ;;; Executive function
   ;;
 
   ;;; Executive function
   ;;
 

-  (define (run-mars core queues steps-left . rest)
-    (let ((min-queue-count (if (null? rest) 2 (car rest))))
-      (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))
-                (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 ")")
 
   (define (execute-instr core ptr name)
     ;; (print ptr "\t" (core ptr '->string) "\t(" name ")")

diff --git a/run-mars.scm b/run-mars.scm
index 30b9e5c..04aa81e 100644 (file)
--- a/run-mars.scm
+++ b/run-mars.scm
@@ -20,7 +20,7 @@
                     (cdr progs-left)
                     (cdr colors-left)))))))
 
                     (cdr progs-left)
                     (cdr colors-left)))))))
 

-(define (mars-runner files iters core-size visualization)
+(define (mars-runner files iters core-size visualization min-queue-count)

   (print "Iters: " iters ", core size: " core-size)
   (let* ((progs (map
                  (lambda (fname)
   (print "Iters: " iters ", core size: " core-size)
   (let* ((progs (map
                  (lambda (fname)


@@ -30,15 +30,11 @@
                    (let* ((colors '("red" "blue" "green" "magenta" "cyan"))
                           (color-map (make-color-map progs colors))
                           (vis (make-vis 640 480 core-size color-map)))
                    (let* ((colors '("red" "blue" "green" "magenta" "cyan"))
                           (color-map (make-color-map progs colors))
                           (vis (make-vis 640 480 core-size color-map)))

-                     (make-core 8000 (lambda (i n)
-                                       (vis 'update-owner i n))))
-                   (make-core 8000)))
-         (queues (run-mars core (install-progs core progs) iters)))
-    (for-each (lambda (q)
-                (print)
-                (print "Final queue for " (queue-owner q) ":")
-                (dump-queue q core))
-              queues)
+                     (make-core core-size (lambda (i n)
+                                            (vis 'update-owner i n))))
+                   (make-core core-size)))
+         (queues (run-mars core (install-progs core progs) iters min-queue-count)))
+    (dump-queues queues core)

     (when visualization
       (print* "Press enter to finish...")
       (read-line))))
     (when visualization
       (print* "Press enter to finish...")
       (read-line))))


@@ -48,23 +44,27 @@
          "       run-mars [-c|--core size]\n"
          "                [-i|--iterations iters]\n"
          "                [-n|--no-visualization]\n"
          "       run-mars [-c|--core size]\n"
          "                [-i|--iterations iters]\n"
          "                [-n|--no-visualization]\n"

+         "                [-m|--min-queue-count]\n"

          "                warrior1.red [warrior2.red [...]]"))
 
 (define (main)
   (let loop ((args (cdr (argv)))
              (iters 10000)
              (core-size 8000)
          "                warrior1.red [warrior2.red [...]]"))
 
 (define (main)
   (let loop ((args (cdr (argv)))
              (iters 10000)
              (core-size 8000)

-             (visualization #t))
+             (visualization #t)
+             (min-queue-count 2))

     (match args
       ((or () ((or "-h" "--help")))
        (print-usage))
       (((or "-i" "--iterations") istr rest ...)
     (match args
       ((or () ((or "-h" "--help")))
        (print-usage))
       (((or "-i" "--iterations") istr rest ...)

-       (loop rest (string->number istr) core-size visualization))
+       (loop rest (string->number istr) core-size visualization min-queue-count))

       (((or "-c" "--core-size") cstr rest ...)
       (((or "-c" "--core-size") cstr rest ...)

-       (loop rest iters (string->number cstr) visualization))
+       (loop rest iters (string->number cstr) visualization min-queue-count))

       (((or "-n" "--no-visualization") rest ...)
       (((or "-n" "--no-visualization") rest ...)

-       (loop rest iters core-size #f))
+       (loop rest iters core-size #f min-queue-count))
+      (((or "-m" "--min-queue-count") mstr rest ...)
+       (loop rest iters core-size visualization (string->number mstr)))

       ((files ...)
       ((files ...)

-       (mars-runner files iters core-size visualization)))))
+       (mars-runner files iters core-size visualization min-queue-count)))))

 
 (main)
 
 (main)