Ranking calculations implemented.

diff --git a/koth.scm b/koth.scm
index c6be230..61852c5 100644 (file)
--- a/koth.scm
+++ b/koth.scm
@@ -5,6 +5,7 @@
   (chicken pathname)
   (chicken string)
   (chicken pretty-print)
+  (chicken sort)
   srfi-1
   matchable
   mars parser)
@@ -17,10 +18,11 @@
   (string->prog (with-input-from-file file read-string)))
 
 (define (score-challenger-matches spec challenger-prog other-progs)
-  (map 
-   (lambda (other-prog)
-     (score-match spec challenger-prog other-prog))
-   other-progs))
+  (foldl append '()
+         (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))
@@ -39,8 +41,8 @@
                 results)))))
     (let ((prog1-name (prog-name prog1))
           (prog2-name (prog-name prog2)))
-      `(((,prog1-name ,prog2-name) ,(car tally))
-        ((,prog2-name ,prog1-name) ,(cadr tally))))))
+      `((,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)))
@@ -50,23 +52,47 @@
           ((null? result) (error "Invalid game result."))
           ((= (length result) 1)
            (let ((winner-name (caar result)))
-             (if (eq? winner-name (prog-name prog1))
+             (if (equal? winner-name (prog-name prog1))
                  '(3 0)
                  '(0 3))))
           (else
            '(1 1)))))
-    
+
+(define (scores->rankings scores)
+  (let* ((prog-names (delete-duplicates (map car scores)))
+         (prog-scores
+          (map (lambda (prog-name)
+                 (apply +
+                        (map caddr
+                             (filter (lambda (score)
+                                       (equal? prog-name (car score)))
+                                     scores))))
+               prog-names)))
+    (sort (zip prog-names prog-scores)
+          (lambda (a b)
+            (< (cadr a) (cadr b))))))
+
 (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))
+    (if (member (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)))))
+        (let* ((new-scores (append (score-challenger-matches spec challenger-prog hill-progs)
+                                   scores))
+               (rankings (scores->rankings new-scores)))
+          (if (<= (length rankings) (spec-hill-size spec))
+              (begin
+                (save-scores new-scores hill-dir)
+                (hill-add-file challenger-file (prog-name challenger-prog) hill-dir))
+              (let ((loser (caar rankings)))
+                (save-scores (filter (lambda (score)
+                                       (not (or (equal? (car score) loser)
+                                                (equal? (cadr score) loser))))
+                                     new-scores)
+                             hill-dir)
+                (hill-remove loser hill-dir)))))))
   
 
 ;;; Hill initialization and specs
@@ -85,6 +111,9 @@
 (define (hill-files dir)
   (glob (make-pathname dir "*.red")))
 
+(define (hill-rankings dir)
+  (scores->rankings (load-scores dir)))
+
 (define (hill-add-file file name dir)
   (copy-file file (make-pathname dir (->string name) ".red")))
 
@@ -127,6 +156,7 @@
   (let ((binary (pathname-file (car (argv)))))
     (print "King of the Hill Tournament Manager")
     (print "\nUsage:\t" binary " hill-directory challenger-file")
+    (print "\t" binary " [-r|--rankings] hill-directory")
     (print "\t" binary " [-h|--help]")
     (print "\t" binary " [-i|--init] hill-directory [hill-size [core-size game-length games-per-match]]")
     (print "\nDefault values are as follows:\n"
@@ -153,9 +183,13 @@
                     default-core-size
                     default-game-length
                     default-games-per-match))
+    (((or "-r" "--rankings") dir)
+     (print "Warrior" "\t" "Score")
+     (print "-=-=-=-" "\t" "=-=-=")
+     (for-each (lambda (r) (print (car r) "\t" (cadr r))) (reverse (hill-rankings dir))))
     ((hill-dir challenger-file)
      (challenge hill-dir challenger-file))
     (else
      (print "Invalid arguments: " (apply conc else)))))
 
-;; (main)
+(main)