-
-(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)))))))))
+
+(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))
+ (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-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)))))))
+