(chicken pathname)
(chicken string)
(chicken pretty-print)
+ (chicken sort)
srfi-1
matchable
mars parser)
(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))
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)))
((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))
+ (let* ((spec (hill-spec hill-dir))
+ (scores (hill-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-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))))
+ new-scores)
+ (cdr rankings)
+ hill-dir)
+ (hill-remove loser hill-dir)))))))
;;; 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)
+(define (save-hill-scores-and-rankings scores rankings dir)
(with-output-to-file (make-pathname dir "scores")
- (lambda () (pretty-print scores))))
+ (lambda () (pretty-print scores)))
+ (with-output-to-file (make-pathname dir "rankings")
+ (lambda () (pretty-print 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)
+ (with-input-from-file (make-pathname dir "rankings") read))
+
(define (hill-add-file file name dir)
(copy-file file (make-pathname dir (->string name) ".red")))
+(define (hill-remove-file name dir)
+ (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))
(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 '())))))))
+ (lambda () (pp '())))
+ (with-output-to-file (make-pathname dir "rankings")
+ (lambda () (pp '())))))))
;;;; 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"
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 rankings)
+ (print "Warrior" "\t" "Score")
+ (print "-=-=-=-" "\t" "=-=-=")
+ (for-each (lambda (r) (print (car r) "\t" (cadr r))) rankings)))))
((hill-dir challenger-file)
(challenge hill-dir challenger-file))
(else
(print "Invalid arguments: " (apply conc else)))))
-;; (main)
+(main)
The Lambda Lab / projects / jars.git / blobdiff