-(import (chicken process-context)
- (chicken file)
- (chicken pathname)
- (chicken string)
- (chicken pretty-print)
- matchable
- mars parser)
-
-;;; Constants
-;;
+(import
+ (chicken io)
+ (chicken process-context)
+ (chicken file)
+ (chicken pathname)
+ (chicken string)
+ (chicken pretty-print)
+ (chicken sort)
+ (chicken time posix)
+ srfi-1
+ matchable
+ mars parser)
-(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-matches 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))))))
- other-progs)))
-
-(define (run-match spec . progs)
- (let loop ((remaining (spec-games-per-match spec)))
- (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
- (queues (install-progs core (list challenger-prog other-prog))))
- (run-mars core queues))
- (loop (- remaining 1))))
-
-;;; Score keeping and specs
+ (string->prog (with-input-from-file file read-string)))
+
+(define (score-challenger-matches spec challenger-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))
+ (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))
+ (results '()))
+ (if (> remaining 0)
+ (loop (- remaining 1)
+ (cons (score-game spec prog1 prog2)
+ results))
+ results)))))
+ (let ((prog1-name (prog-name prog1))
+ (prog2-name (prog-name prog2)))
+ `((,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)))
+ (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 (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 (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-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
+ (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 (load-specs dir)
- (with-input-from-file (make-pathname dir "specs") read))
+(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-files dir)
+ (glob (make-pathname dir "*.red")))
+
+(define (hill-rankings dir)
+ (with-input-from-file (make-pathname dir "rankings") read))
+
+(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 (make-specs core-size match-length games-per-match hill-size)
- (list 'specs hill-size core-size match-length games-per-match))
+(define (hill-add dir file name)
+ (copy-file file (make-pathname dir (->string name) ".red")))
-(define (specs? specs)
- (and (pair? specs) (eq? (car specs) 'specs)))
+(define (hill-remove dir name)
+ (delete-file (make-pathname dir name ".red")))
-(define (specs-hill-size specs) (list-ref specs 1))
-(define (specs-core-size specs) (list-ref specs 2))
-(define (specs-game-length specs) (list-ref specs 3))
-(define (specs-games-per-match specs) (list-ref specs 4))
+(define (make-spec core-size match-length games-per-match hill-size)
+ (list 'spec hill-size core-size match-length games-per-match))
+
+(define (spec? spec)
+ (and (pair? spec) (eq? (car spec) 'spec)))
+
+(define (spec-hill-size spec) (list-ref spec 1))
+(define (spec-core-size spec) (list-ref spec 2))
+(define (spec-game-length spec) (list-ref spec 3))
+(define (spec-games-per-match spec) (list-ref spec 4))
(define (init-hill-dir dir hill-size core-size game-length games-per-match)
(if (or (not (directory-exists? dir)) (not (file-writable? dir)))
(print "Directory " dir " doesn't exist or is not writable.")
(if (not (null? (glob (make-pathname dir "*"))))
(print "Directory " dir " exists but is non-empty.")
- (with-output-to-file (make-pathname dir "specs")
- (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))))
- (with-output-to-file (make-pathname dir "scores")
- (lambda ()
- (pp '()))))))
+ (begin
+ (with-output-to-file (make-pathname dir "spec")
+ (lambda ()
+ (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))))
+ (hill-save-scores-and-rankings dir '() '())
+ (with-output-to-file (make-pathname dir "news")
+ (lambda () (print '())))
+ (hill-news-add dir "Hill created.")))))
;;;; Main ;;;;
(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)
(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"
"\tgame-length: " default-game-length "\n"
"\tgames-per-match: " default-games-per-match)))
-(define (process-args args)
- (match args
+(define (main)
+ (match (cdr (argv))
((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
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)
+ (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)
- (print "Not implemented"))
+ (challenge hill-dir challenger-file))
(else
(print "Invalid arguments: " (apply conc else)))))
-(define (main)
- (process-args (cdr (argv))))
-
(main)
The Lambda Lab / projects / jars.git / blobdiff