- (string->prog (with-input-from-file fname read)))
-
-(define (run-all-challenges 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 . progs)
- (let* ((core (make-core CORE-SIZE INITIAL-INSTR))
- (queues (install-progs core (list challenger-prog other-prog))))
- (run-mars core queues)))
-
-;;; Score keeping
+ (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 (load-spec hill-dir))
+ (scores (load-scores hill-dir))
+ (challenger-prog (file->prog challenger-file))
+ (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!")
+ (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 initialization and specs