KOTH almost functional.

[jars.git] / koth.scm

diff --git a/koth.scm b/koth.scm
index 3ad5925..a9c1a84 100644 (file)
--- a/koth.scm
+++ b/koth.scm
@@ -6,6 +6,7 @@
   (chicken string)
   (chicken pretty-print)
   (chicken sort)
+  (chicken time posix)
   srfi-1
   matchable
   mars parser)
@@ -25,7 +26,7 @@
           other-progs)))
 
 (define (score-match spec prog1 prog2)
-  (print "Matching " (prog-name prog1) " against " (prog-name prog2))
+  (print "... Matching " (prog-name prog1) " against " (prog-name prog2))
   (let ((tally
          (foldl
           (lambda (score-a score-b)
@@ -76,24 +77,39 @@
   (let* ((spec (hill-spec hill-dir))
          (scores (hill-scores hill-dir))
          (challenger-prog (file->prog challenger-file))
+         (challenger-name (prog-name challenger-prog))
          (hill-progs (map file->prog (hill-files hill-dir))))
-    (if (member (prog-name challenger-prog) (map prog-name hill-progs))
-        (print "Challenger already on hill!")
+    (hill-news-add hill-dir "Challenger '" challenger-name "' accepted for battle.")
+    (if (member challenger-name (map prog-name hill-progs))
+        (hill-news-add hill-dir "Challenge aborted: challenger already on hill!")
         (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-hill-scores-and-rankings new-scores rankings hill-dir)
-                (hill-add-file challenger-file (prog-name challenger-prog) hill-dir))
-              (let ((loser (caar rankings)))
-                (save-hill-scores-and-rankings (filter (lambda (score)
-                                                         (not (or (equal? (car score) loser)
-                                                                  (equal? (cadr score) loser))))
+                (hill-save-scores-and-rankings hill-dir new-scores rankings)
+                (hill-add hill-dir challenger-file challenger-name)
+                (hill-news-add hill-dir "Challenger '" challenger-name "' added to the hill."))
+              (let ((loser-name (caar rankings)))
+                (hill-save-scores-and-rankings hill-dir
+                                               (filter (lambda (score)
+                                                         (not (or (equal? (car score) loser-name)
+                                                                  (equal? (cadr score) loser-name))))
                                                        new-scores)
-                                               (cdr rankings)
-                                               hill-dir)
-                (hill-remove loser hill-dir)))))))
+                                               (cdr rankings))
+                (hill-add hill-dir challenger-file challenger-name)
+                (hill-remove hill-dir loser-name)
+                (if (equal? loser-name challenger-name)
+                    (hill-news-add hill-dir
+                                   "Challenger '" challenger-name
+                                   "' failed to best any warrior on the hill.")
+                    (begin
+                      (hill-news-add hill-dir
+                                     "Challenger '" challenger-name
+                                     "' defeated at least one warrior on the hill.")
+                      (hill-news-add hill-dir
+                                     "Warrior '" loser-name
+                                     "' has been pushed off the hill!")))))))))
   
 
 ;;; Hill initialization and specs
@@ -102,11 +118,12 @@
 (define (hill-scores dir)
   (with-input-from-file (make-pathname dir "scores") read))
 
-(define (save-hill-scores-and-rankings scores rankings dir)
-  (with-output-to-file (make-pathname dir "scores")
-    (lambda () (pretty-print scores)))
-  (with-output-to-file (make-pathname dir "rankings")
-    (lambda () (pretty-print rankings))))
+(define (hill-save-scores-and-rankings dir scores rankings)
+  (for-each
+   (lambda (p)
+     (with-output-to-file (make-pathname dir (car p))
+       (lambda () (pretty-print (cdr p)))))
+   `(("scores" . ,scores) ("rankings" . ,rankings))))
 
 (define (hill-spec dir)
   (with-input-from-file (make-pathname dir "spec") read))
@@ -117,10 +134,21 @@
 (define (hill-rankings dir)
   (with-input-from-file (make-pathname dir "rankings") read))
 
-(define (hill-add-file file name dir)
+(define (hill-news dir)
+  (with-input-from-file (make-pathname dir "news") read))
+
+(define (hill-news-add dir . args)
+  (let* ((old-news (hill-news dir))
+         (news-string (apply conc args))
+         (new-news (cons (cons (seconds->string) news-string) old-news)))
+    (print news-string)
+    (with-output-to-file (make-pathname dir "news")
+      (lambda () (pretty-print new-news)))))
+
+(define (hill-add dir file name)
   (copy-file file (make-pathname dir (->string name) ".red")))
 
-(define (hill-remove-file name dir)
+(define (hill-remove dir name)
   (delete-file (make-pathname dir name ".red")))
 
 (define (make-spec core-size match-length games-per-match hill-size)
@@ -145,10 +173,10 @@
                 (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 '())))
-            (with-output-to-file (make-pathname dir "rankings")
-              (lambda () (pp '())))))))
+            (hill-save-scores-and-rankings dir '() '())
+            (with-output-to-file (make-pathname dir "news")
+              (lambda () (print '())))
+            (hill-news-add dir "Hill created.")))))
 
 ;;;; Main ;;;;
 
@@ -177,7 +205,11 @@
     ((or () ((or "-h" "--help")))
      (print-usage))
     (((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))
+     (init-hill-dir dir
+                    (string->number hill-size)
+                    (string->number core-size)
+                    (string->number game-length)
+                    (string->number games-per-match)))
     (((or "-i" "--init") dir)
      (init-hill-dir dir
                     default-hill-size
@@ -186,7 +218,7 @@
                     default-games-per-match))
     (((or "-i" "--init") dir hill-size)
      (init-hill-dir dir
-                    hill-size
+                    (string->number hill-size)
                     default-core-size
                     default-game-length
                     default-games-per-match))