This is ridiculous.

diff --git a/koth.scm b/koth.scm
index c14008d..2324e9c 100644 (file)
--- a/koth.scm
+++ b/koth.scm
@@ -17,31 +17,60 @@
 (define (file->prog file)
   (string->prog (with-input-from-file fname read)))
 
-(define (run-all-matches challenger-file other-files)
+(define (score-challenger-matches spec challenger-file other-files)
   (let ((challenger-prog (file->prog challenger-file))
         (challenger-name (prog-name challenger-prog))
         (other-progs (apply file->prog other-files)))
     (map 
      (lambda (other-prog)
-       (let ((other-name (prog-name other-prog))
-             (result (run-match challenger-prog other-prog)))
-         (cond ((or (= (length result) 2)
-                    (= (length result) 0))
-                `((,challenger-name 1) (,other-name 1)))
-               ((eq? (queue-name (car result)) challenger-name)
-                `((,challenger-name 3) (,other-name 0)))
-               (else
-                `((,challenger-name 0) (,other-name 3))))))
+       (score-match spec challenger-prog other-prog))
      other-progs)))
 
-(define (run-match spec . progs)
-  (let loop ((remaining (spec-games-per-match spec)))
-    (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
-           (queues (install-progs core (list challenger-prog other-prog))))
-      (run-mars core queues))
-    (loop (- remaining 1))))
-
-;;; Score keeping and specs
+(define (score-match spec prog1 prog2)
+  (let ((tally
+         (foldl
+          (lambda (score-a score-b)
+            (list (+ (car score-a) (car score-b))
+                  (+ (cadr score-a) (cadr score-b))))
+          (list 0 0)
+          (let loop ((remaining (spec-games-per-match spec)))
+            (loop (- remaining 1))))))
+    `((,(prog-name prog1 ,(car tally)))
+      (,(prog-name prog2 ,(cadr tally))))))
+
+(define (score-game spec prog1 prog2)
+  (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
+         (queues (install-progs core (list prog1 prog2)))
+         (result (run-mars core queues (spec-game-length spec))))
+    (cond 
+          ((null? result) (error "Invalid game result."))
+          ((= (length result) 1)
+           (let ((winner-name (caar result)))
+             (if (eq? winner-name name1)
+                 '(3 0)
+                 '(0 3))))
+          (else
+           '(1 1)))))
+    
+(define (count-scores-for-progs progs)
+  (map (lambda (prog)
+         (count-scores-for-name scores (prog-name prog)))
+       progs))
+
+(define (count-scores-for-name scores name)
+  (let loop ((score 0)
+             (remaining-scores scores))
+    (if (null? remaining-scores)
+        score
+        (loop
+         (let ((this-score (car remaining-scores)))
+           (cond
+            ((eq? (caar this-score) name)
+             (loop (+ score (cadar this-score)) (cdr remaining-scores)))
+            ((eq? (caadr this-score) name)
+             (loop (+ score (cadadr this-score)) (cdr remaining-scores)))))))))
+
+;;; Hill initialization and specs
 ;;
 
 (define (load-scores dir)

diff --git a/mars.scm b/mars.scm
index a9ba7c5..3ead51f 100644 (file)
--- a/mars.scm
+++ b/mars.scm
@@ -205,24 +205,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))))))))
+    (if (or (<= steps-left 0)
+            (null? queues)
+            (= (length queues) 1))
+        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 (execute-instr core ptr name)
     ;; (print ptr "\t" (core ptr '->string) "\t(" name ")")