X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=koth.scm;h=2324e9cdca9e2441f19adb0eb7a28374f9bce5b8;hp=1ca77c31cf4a9c5d4b24ad2acd4e7ea138d59583;hb=5dd63750e8c44fb6fbf2c8c0b1c01ef564d08f99;hpb=7a4ae6a55e8bd93b9b08bbec346caad7b1c2e83d

diff --git a/koth.scm b/koth.scm
index 1ca77c3..2324e9c 100644
--- a/koth.scm
+++ b/koth.scm
@@ -6,38 +6,76 @@
         matchable
         mars parser)
 
-(define CORE-SIZE 8000)
-(define GAMES-PER-MATCH 1)
+;;; Constants
+;;
+
 (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)))
 
-(define (run-all-challenges 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 . progs)
-  (let* ((core (make-core CORE-SIZE INITIAL-INSTR))
-         (queues (install-progs core (list challenger-prog other-prog))))
-    (run-mars core queues)))
+(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)))))))))
 
-;;; Score keeping
+;;; Hill initialization and specs
 ;;
 
+(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))
 
@@ -61,16 +99,33 @@
             (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)))))))
+              (pp (make-specs core-size game-length games-per-match hill-size))))
+          (with-output-to-file (make-pathname dir "scores")
+            (lambda ()
+              (pp '()))))))
 
 ;;;; Main ;;;;
 
+;; Default values
+
+(define default-core-size 8000)
+(define default-game-length 80000)
+(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")
-    (print "Usage:\t" binary " hill-directory challenger-file")
+    (print "\nUsage:\t" binary " hill-directory challenger-file")
     (print "\t" binary " [-h|--help]")
-    (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")))
+    (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
+    (print "\nDefault values are as follows:\n"
+           "\thill-size: " default-hill-size "\n"
+           "\tcore-size: " default-core-size "\n"
+           "\tgame-length: " default-game-length "\n"
+           "\tgames-per-match: " default-games-per-match)))
 
 (define (process-args args)
   (match args
@@ -79,9 +134,17 @@
     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
      (init-hill-dir dir hill-size core-size game-length games-per-match))
     (((or "-i" "--init") dir)
-     (init-hill-dir dir 10 8000 80000 10))
+     (init-hill-dir dir
+                    default-hill-size
+                    default-core-size
+                    default-game-length
+                    default-games-per-match))
     (((or "-i" "--init") dir hill-size)
-     (init-hill-dir dir hill-size 8000 80000 10))
+     (init-hill-dir dir
+                    hill-size
+                    default-core-size
+                    default-game-length
+                    default-games-per-match))
     ((hill-dir challenger-file)
      (print "Not implemented"))
     (else