Settled on score format, challengers now added to hill.

diff --git a/koth.scm b/koth.scm
index 2324e9c..c6be230 100644 (file)
--- a/koth.scm
+++ b/koth.scm
@@ -1,74 +1,73 @@
-(import (chicken process-context)
-        (chicken file)
-        (chicken pathname)
-        (chicken string)
-        (chicken pretty-print)
-        matchable
-        mars parser)
-
-;;; Constants
-;;
+(import
+  (chicken io)
+  (chicken process-context)
+  (chicken file)
+  (chicken pathname)
+  (chicken string)
+  (chicken pretty-print)
+  srfi-1
+  matchable
+  mars parser)
 
-(define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
 
 ;;; Games and Matches
 ;;
 
 (define (file->prog file)
-  (string->prog (with-input-from-file fname read)))
+  (string->prog (with-input-from-file file read-string)))
 
-(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)
-       (score-match spec challenger-prog other-prog))
-     other-progs)))
+(define (score-challenger-matches spec challenger-prog other-progs)
+  (map 
+   (lambda (other-prog)
+     (score-match spec challenger-prog other-prog))
+   other-progs))
 
 (define (score-match spec prog1 prog2)
+  (print "Matching " (prog-name prog1) " against " (prog-name 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))))))
+          (let loop ((remaining (spec-games-per-match spec))
+                     (results '()))
+            (if (> remaining 0)
+                (loop (- remaining 1)
+                      (cons (score-game spec prog1 prog2)
+                            results))
+                results)))))
+    (let ((prog1-name (prog-name prog1))
+          (prog2-name (prog-name prog2)))
+      `(((,prog1-name ,prog2-name) ,(car tally))
+        ((,prog2-name ,prog1-name) ,(cadr tally))))))
 
 (define (score-game spec prog1 prog2)
-  (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
+  (let* ((core (make-core (spec-core-size spec)))
          (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)
+             (if (eq? winner-name (prog-name prog1))
                  '(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)))))))))
+(define (challenge hill-dir challenger-file)
+  (let* ((spec (load-spec hill-dir))
+         (scores (load-scores hill-dir))
+         (challenger-prog (file->prog challenger-file))
+         (hill-progs (map file->prog (hill-files hill-dir))))
+    (if (memq (prog-name challenger-prog) (map prog-name hill-progs))
+        (print "Challenger already on hill!")
+        (let ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
+                                  scores)))
+          (save-scores new-scores hill-dir)
+          (hill-add-file challenger-file (prog-name challenger-prog) hill-dir)))))
+  
 
 ;;; Hill initialization and specs
 ;;
@@ -76,33 +75,44 @@
 (define (load-scores dir)
   (with-input-from-file (make-pathname dir "scores") read))
 
-(define (load-specs dir)
-  (with-input-from-file (make-pathname dir "specs") read))
+(define (save-scores scores dir)
+  (with-output-to-file (make-pathname dir "scores")
+    (lambda () (pretty-print scores))))
+
+(define (load-spec dir)
+  (with-input-from-file (make-pathname dir "spec") read))
+
+(define (hill-files dir)
+  (glob (make-pathname dir "*.red")))
+
+(define (hill-add-file file name dir)
+  (copy-file file (make-pathname dir (->string name) ".red")))
 
-(define (make-specs core-size match-length games-per-match hill-size)
-  (list 'specs hill-size core-size match-length games-per-match))
+(define (make-spec core-size match-length games-per-match hill-size)
+  (list 'spec hill-size core-size match-length games-per-match))
 
-(define (specs? specs)
-  (and (pair? specs) (eq? (car specs) 'specs)))
+(define (spec? spec)
+  (and (pair? spec) (eq? (car spec) 'spec)))
 
-(define (specs-hill-size specs) (list-ref specs 1))
-(define (specs-core-size specs) (list-ref specs 2))
-(define (specs-game-length specs) (list-ref specs 3))
-(define (specs-games-per-match specs) (list-ref specs 4))
+(define (spec-hill-size spec) (list-ref spec 1))
+(define (spec-core-size spec) (list-ref spec 2))
+(define (spec-game-length spec) (list-ref spec 3))
+(define (spec-games-per-match spec) (list-ref spec 4))
 
 (define (init-hill-dir dir hill-size core-size game-length games-per-match)
   (if (or (not (directory-exists? dir)) (not (file-writable? dir)))
       (print "Directory " dir " doesn't exist or is not writable.")
       (if (not (null? (glob (make-pathname dir "*"))))
           (print "Directory " dir " exists but is non-empty.")
-          (with-output-to-file (make-pathname dir "specs")
-            (lambda ()
-              (print ";; Hill specifications.")
-              (print ";; ('specs hill-size core-size game-length games-per-match\n")
-              (pp (make-specs core-size game-length games-per-match hill-size))))
-          (with-output-to-file (make-pathname dir "scores")
-            (lambda ()
-              (pp '()))))))
+          (begin
+            (with-output-to-file (make-pathname dir "spec")
+              (lambda ()
+                (print ";; Hill specifications.")
+                (print ";; ('spec hill-size core-size game-length games-per-match\n")
+                (pp (make-spec core-size game-length games-per-match hill-size))))
+            (with-output-to-file (make-pathname dir "scores")
+              (lambda ()
+                (pp '())))))))
 
 ;;;; Main ;;;;
 
@@ -113,8 +123,6 @@
 (define default-games-per-match 1)
 (define default-hill-size 10)
 
-
-
 (define (print-usage)
   (let ((binary (pathname-file (car (argv)))))
     (print "King of the Hill Tournament Manager")
@@ -127,8 +135,8 @@
            "\tgame-length: " default-game-length "\n"
            "\tgames-per-match: " default-games-per-match)))
 
-(define (process-args args)
-  (match args
+(define (main)
+  (match (cdr (argv))
     ((or () ((or "-h" "--help")))
      (print-usage))
     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
@@ -146,11 +154,8 @@
                     default-game-length
                     default-games-per-match))
     ((hill-dir challenger-file)
-     (print "Not implemented"))
+     (challenge hill-dir challenger-file))
     (else
      (print "Invalid arguments: " (apply conc else)))))
 
-(define (main)
-  (process-args (cdr (argv))))
-  
-(main)
+;; (main)

diff --git a/run-mars.scm b/run-mars.scm
index db5a8b5..1d04af8 100644 (file)
--- a/run-mars.scm
+++ b/run-mars.scm
@@ -64,4 +64,5 @@
        (loop rest iters core-size #f))
       ((files ...)
        (mars-runner files iters core-size visualization)))))
+
 (main)