KOTH almost functional.

diff --git a/README b/README
index 17f8560..db77f31 100644 (file)
--- a/README
+++ b/README
@@ -34,4 +34,4 @@ License
 
 JaRS is free software, and is distributed under the terms of version 3
 of the GNU General Public License.  A copy of this license can be found in
 
 JaRS is free software, and is distributed under the terms of version 3
 of the GNU General Public License.  A copy of this license can be found in

-the file named COPYING.
\ No newline at end of file
+the file named COPYING.

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 string)
   (chicken pretty-print)
   (chicken sort)

+  (chicken time posix)

   srfi-1
   matchable
   mars parser)
   srfi-1
   matchable
   mars parser)


@@ -25,7 +26,7 @@
           other-progs)))
 
 (define (score-match spec prog1 prog2)
           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)
   (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))
   (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))))
          (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
         (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)
                                                        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
   
 
 ;;; Hill initialization and specs


@@ -102,11 +118,12 @@
 (define (hill-scores dir)
   (with-input-from-file (make-pathname dir "scores") read))
 
 (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))
 
 (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-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")))
 
   (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)
   (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))))
                 (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 ;;;;
 
 
 ;;;; Main ;;;;
 


@@ -177,7 +205,11 @@
     ((or () ((or "-h" "--help")))
      (print-usage))
     (((or "-i" "--init") dir hill-size core-size game-length games-per-match)
     ((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
     (((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
                     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))
                     default-core-size
                     default-game-length
                     default-games-per-match))

diff --git a/parser.scm b/parser.scm
index 7bc3f90..f116033 100644 (file)
--- a/parser.scm
+++ b/parser.scm
@@ -56,6 +56,7 @@
           (mode-post-indirect-A-irx (irregex "^\\}"))
           (mode-post-indirect-B-irx (irregex "^>"))
           (number-irx (irregex "^(\\+|-)?[0-9]+")))
           (mode-post-indirect-A-irx (irregex "^\\}"))
           (mode-post-indirect-B-irx (irregex "^>"))
           (number-irx (irregex "^(\\+|-)?[0-9]+")))

+

       (define (accept-token irx . rest)
         (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
           (if wsmatch
       (define (accept-token irx . rest)
         (let ((wsmatch (irregex-search whitespace-irx (substring str idx))))
           (if wsmatch


@@ -69,6 +70,7 @@
               (if mandatory
                   (error "Unexpected token at input string index" idx)
                   #f))))
               (if mandatory
                   (error "Unexpected token at input string index" idx)
                   #f))))

+

       (define (load-file)
         (accept-token redcode-irx #t)
         (let loop ((instrs '())
       (define (load-file)
         (accept-token redcode-irx #t)
         (let loop ((instrs '())


@@ -84,28 +86,34 @@
                   ((org) (loop instrs (cdr this-line) name author))
                   ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
                 (make-prog name author (reverse instrs) offset)))))
                   ((org) (loop instrs (cdr this-line) name author))
                   ((instr) (loop (cons (cdr this-line) instrs) offset name author)))
                 (make-prog name author (reverse instrs) offset)))))

+

       (define (line)
         (or (name-line)
             (author-line)
             (comment-line)
             (org-line)
             (instruction-line)))
       (define (line)
         (or (name-line)
             (author-line)
             (comment-line)
             (org-line)
             (instruction-line)))

+

       (define (name-line)
         (if (accept-token name-start-irx)
             (cons 'name (string-trim (accept-token name-irx #t)))
             #f))
       (define (name-line)
         (if (accept-token name-start-irx)
             (cons 'name (string-trim (accept-token name-irx #t)))
             #f))

+

       (define (author-line)
         (if (accept-token author-start-irx)
             (cons 'author (string-trim (accept-token author-irx #t)))
             #f))
       (define (author-line)
         (if (accept-token author-start-irx)
             (cons 'author (string-trim (accept-token author-irx #t)))
             #f))

+

       (define (comment-line)
         (if (accept-token comment-irx)
             '(comment)
             #f))
       (define (comment-line)
         (if (accept-token comment-irx)
             '(comment)
             #f))

+

       (define (org-line)
         (if (accept-token org-irx)
             (cons 'org (string->number (accept-token number-irx #t)))
             #f))
       (define (org-line)
         (if (accept-token org-irx)
             (cons 'org (string->number (accept-token number-irx #t)))
             #f))

+

       (define (instruction-line)
         (let ((oc (opcode)))
           (if oc
       (define (instruction-line)
         (let ((oc (opcode)))
           (if oc


@@ -119,6 +127,7 @@
                     (z (accept-token comment-irx #t)))
                 (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
               #f)))
                     (z (accept-token comment-irx #t)))
                 (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num)))
               #f)))

+

       (define (opcode)
         (let ((res (or (accept-token opcode-DAT-irx)
                        (accept-token opcode-MOV-irx)
       (define (opcode)
         (let ((res (or (accept-token opcode-DAT-irx)
                        (accept-token opcode-MOV-irx)


@@ -138,6 +147,7 @@
                        (accept-token opcode-SPL-irx)
                        (accept-token opcode-NOP-irx))))
           (if res (string->symbol res) #f)))
                        (accept-token opcode-SPL-irx)
                        (accept-token opcode-NOP-irx))))
           (if res (string->symbol res) #f)))

+

       (define (modifier)
         (string->symbol
          (or (accept-token modifier-AB-irx)
       (define (modifier)
         (string->symbol
          (or (accept-token modifier-AB-irx)


@@ -147,6 +157,7 @@
              (accept-token modifier-F-irx)
              (accept-token modifier-X-irx)
              (accept-token modifier-I-irx))))
              (accept-token modifier-F-irx)
              (accept-token modifier-X-irx)
              (accept-token modifier-I-irx))))

+

       (define (mode)
         (or (mode-immediate)
             (mode-direct)
       (define (mode)
         (or (mode-immediate)
             (mode-direct)


@@ -156,28 +167,37 @@
             (mode-pre-indirect-B)
             (mode-post-indirect-A)
             (mode-post-indirect-B)))
             (mode-pre-indirect-B)
             (mode-post-indirect-A)
             (mode-post-indirect-B)))

+

       (define (mode-immediate)
         (and (accept-token mode-immediate-irx)
              'immediate))
       (define (mode-immediate)
         (and (accept-token mode-immediate-irx)
              'immediate))

+

       (define (mode-direct)
         (and (accept-token mode-direct-irx)
              'direct))
       (define (mode-direct)
         (and (accept-token mode-direct-irx)
              'direct))

+

       (define (mode-indirect-A)
         (and (accept-token mode-indirect-A-irx)
              'indirect-A))
       (define (mode-indirect-A)
         (and (accept-token mode-indirect-A-irx)
              'indirect-A))

+

       (define (mode-indirect-B)
         (and (accept-token mode-indirect-B-irx)
              'indirect-B))
       (define (mode-indirect-B)
         (and (accept-token mode-indirect-B-irx)
              'indirect-B))

+

       (define (mode-pre-indirect-A)
         (and (accept-token mode-pre-indirect-A-irx)
              'pre-indirect-A))
       (define (mode-pre-indirect-A)
         (and (accept-token mode-pre-indirect-A-irx)
              'pre-indirect-A))

+

       (define (mode-pre-indirect-B)
         (and (accept-token mode-pre-indirect-B-irx)
              'pre-indirect-B))
       (define (mode-pre-indirect-B)
         (and (accept-token mode-pre-indirect-B-irx)
              'pre-indirect-B))

+

       (define (mode-post-indirect-A)
         (and (accept-token mode-post-indirect-A-irx)
              'post-indirect-A))
       (define (mode-post-indirect-A)
         (and (accept-token mode-post-indirect-A-irx)
              'post-indirect-A))

+

       (define (mode-post-indirect-B)
         (and (accept-token mode-post-indirect-B-irx)
              'post-indirect-B))
       (define (mode-post-indirect-B)
         (and (accept-token mode-post-indirect-B-irx)
              'post-indirect-B))

+

       (load-file))))
       (load-file))))