(define (file->prog file)
(string->prog (with-input-from-file fname read)))
-(define (run-all-matches challenger-file other-files)
+(define (score-challenger-matches spec 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))))))
+ (score-match spec challenger-prog other-prog))
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
+(define (score-match spec prog1 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)))
+ (loop (- remaining 1))))))
+ `((,(prog-name prog1 ,(car tally)))
+ (,(prog-name prog2 ,(cadr tally))))))
+
+(define (score-game spec prog1 prog2)
+ (let* ((core (make-core (spec-core-size spec) INITIAL-INSTR))
+ (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 (eq? winner-name name1)
+ '(3 0)
+ '(0 3))))
+ (else
+ '(1 1)))))
+
+(define (count-scores-for-progs progs)
+ (map (lambda (prog)
+ (count-scores-for-name scores (prog-name prog)))
+ progs))
+
+(define (count-scores-for-name scores name)
+ (let loop ((score 0)
+ (remaining-scores scores))
+ (if (null? remaining-scores)
+ score
+ (loop
+ (let ((this-score (car remaining-scores)))
+ (cond
+ ((eq? (caar this-score) name)
+ (loop (+ score (cadar this-score)) (cdr remaining-scores)))
+ ((eq? (caadr this-score) name)
+ (loop (+ score (cadadr this-score)) (cdr remaining-scores)))))))))
+
+;;; Hill initialization and specs
;;
(define (load-scores dir)