+;; little helper that produces the difference between two lists

+;; it places a #f on every position where the lists differ

+(define (list-diff lhs rhs)

+ (define (fill-list ls amount)

+ (append ls (list-tabulate amount (constantly #f))))

+ (let lp ((lhs lhs) (rhs rhs) (diff (list)))

+ ((and (null? lhs) (null? rhs))

+ ((and (null? lhs) (not (null? rhs)))

+ (fill-list (reverse diff) (- (length rhs) (length lhs))))

+ ((and (not (null? lhs)) (null? rhs))

+ (fill-list (reverse diff) (- (length lhs) (length rhs))))

+ ((equal? (car lhs) (car rhs))

+ (lp (cdr lhs) (cdr rhs) (cons (car lhs) diff)))

+ (lp (cdr lhs) (cdr rhs) (cons #f diff))))))

+;; how many pegs in code are also in guess taking into account the position

+(define (exact-matches code guess)

+ (length (remove (cut not <>) (list-diff code guess))))

+;; given a list of items it returns an alist that maps each item to

+;; how many times it accures in ls

+(define (frequencies ls)

+ (let lp ((ls ls) (freqs (list)))

+ (receive (matches rest) (partition (cut equal? <> item) ls)

+ (lp rest (cons (cons item (length matches)) freqs))))))))

+;; merges two dictionaries using the supplied merger

+(define (merge-with merger lhs rhs)

+ (let lp ((lhs lhs) (rhs rhs) (res (list)))

+ ((and (null? lhs) (null? rhs)) res)

+ ((and (null? lhs) (not (null? rhs))) (append res rhs))

+ ((and (not (null? lhs)) (null? rhs)) (append res lhs))

+ ((eqv? (caar lhs) (caar rhs))

+ (lp (cdr lhs) (cdr rhs) (cons (cons (caar lhs) (merger (cdar lhs) (cdar rhs))) res)))

+ (lp (cdr lhs) (cdr rhs) (cons (car lhs) res))))))

+(define (select-keys alist keys)

+ (filter (lambda (e) (member (car e) keys)) alist))

+;; how many pegs of code are in guess not taking into account the position

+(define (unordered-matches code guess)

+ (let ((f1 (select-keys (frequencies code) guess))

+ (f2 (select-keys (frequencies guess) code)))

+ (merge-with min f1 f2)))

+(define (assert-list ls message)

+ (make-composite-condition

+ (make-property-condition

+ (make-property-condition 'code-breaker)

+ (make-property-condition 'invalid-argument)))))

+;; finally we can welcome our score function

+(define (score code guess)

+ (assert-list code "code must be a list")

+ (assert-list guess "guess must be a list")

+ (let ((exact (exact-matches code guess))

+ (unordered (apply + (map cdr (unordered-matches code guess)))))

+ (cons exact (- unordered exact))))