Commits

certainty  committed dcf793a

renamed code-breaker

  • Participants
  • Parent commits abb8e2b

Comments (0)

Files changed (3)

File code-breaker/code-breaker.scm

+(use srfi-1)
+;; 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)))
+    (cond
+     ((and (null? lhs) (null? rhs))
+      (reverse! diff))
+     ((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)))
+     (else
+      (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)))
+    (cond
+     ((null? ls) freqs)
+     (else
+      (let ((item (car ls)))
+        (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)))
+    (cond
+     ((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)))
+     (else
+      (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)
+  (unless (list? ls)
+    (signal
+     (make-composite-condition
+      (make-property-condition
+       'exn
+       'message message
+       'arguments (list ls))
+      (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))))

File code-breaker/tests/run.scm

+(use test)
+(load "../code-breaker.scm")
+
+
+(define-syntax condition-of
+  (syntax-rules ()
+    ((_ code)
+     (begin
+       (or (handle-exceptions exn (map car (condition->list exn)) code #f)
+           '())))))
+
+(test-begin "code-breaker")
+
+(test-group "score"
+            (test "empty guess"
+                  '(0 . 0)
+                  (score '(r g g r) '()))
+
+            (test "empty code"
+                  '(0 . 0)
+                  (score '() '(r g g r)))
+
+            (test "exact matches only"
+                  '(2 . 2)
+                  (score '(r g g b) '(r g b g)))
+
+            (test "exact matches don't show up in unordered matches"
+                  '(2 . 2)
+                  (score '(r g g b) '(r b g y)))
+
+            (test "unordered matches only"
+                  '(0 . 2)
+                  (score '(r g g b) '(b r y y)))
+
+
+            (test "ordered and unordered matches"
+                  '(1 . 3)
+                  (score '(r g g b) '(r b b g)))
+
+            (test "it expects guess to be a list"
+                  '(exn code-breaker invalid-argument)
+                   (condition-of (score '() #f)))
+
+            (test "it expects code to be a list"
+                  '(exn code-breaker invalid-argument)
+                  (condition-of (score #f '())))
+
+            )
+
+(test-end "code-breaker")
+
+
+
+(test-exit)

File score-breaker/score-breaker.scm

-