X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=jars.git;a=blobdiff_plain;f=koth.scm;h=45e4bb8fe5b7e486b15fa97e4da9053088579cbd;hp=61852c54b5e0341e210539224b9dc4b7b81471e9;hb=7281b0c1eefce213d11cada1cb9f86a2d8fb0779;hpb=15c7998e7f70909c46c5f66d53af4ce6c6e91c14 diff --git a/koth.scm b/koth.scm index 61852c5..45e4bb8 100644 --- 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) @@ -73,50 +74,83 @@ (< (cadr a) (cadr b)))))) (define (challenge hill-dir challenger-file) - (let* ((spec (load-spec hill-dir)) - (scores (load-scores hill-dir)) + (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-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-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-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 ;; -(define (load-scores dir) +(define (hill-scores dir) (with-input-from-file (make-pathname dir "scores") read)) -(define (save-scores scores dir) - (with-output-to-file (make-pathname dir "scores") - (lambda () (pretty-print scores)))) +(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 (load-spec dir) +(define (hill-spec dir) (with-input-from-file (make-pathname dir "spec") read)) (define (hill-files dir) (glob (make-pathname dir "*.red"))) (define (hill-rankings dir) - (scores->rankings (load-scores 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 dir name) + (delete-file (make-pathname dir name ".red"))) + (define (make-spec core-size match-length games-per-match hill-size) (list 'spec hill-size core-size match-length games-per-match)) @@ -139,9 +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 '()))))))) + (hill-save-scores-and-rankings dir '() '()) + (with-output-to-file (make-pathname dir "news") + (lambda () (print '()))) + (hill-news-add dir "Hill created."))))) ;;;; Main ;;;; @@ -149,7 +184,7 @@ (define default-core-size 8000) (define default-game-length 80000) -(define default-games-per-match 1) +(define default-games-per-match 3) (define default-hill-size 10) (define (print-usage) @@ -170,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 @@ -179,14 +218,18 @@ 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)) (((or "-r" "--rankings") dir) - (print "Warrior" "\t" "Score") - (print "-=-=-=-" "\t" "=-=-=") - (for-each (lambda (r) (print (car r) "\t" (cadr r))) (reverse (hill-rankings dir)))) + (let ((rankings (reverse (hill-rankings dir)))) + (if (null? rankings) + (print "No warriors on hill!") + (begin + (print "Warrior" "\t" "Score") + (print "-=-=-=-" "\t" "=-=-=") + (for-each (lambda (r) (print (car r) "\t\t" (cadr r))) rankings))))) ((hill-dir challenger-file) (challenge hill-dir challenger-file)) (else