#lang racket ;;; Define the game (define no-of-pins 4) (define no-of-colours 6) ;;; Helper functions (define (uniq lst) (if (null? lst) '() (let ((element (car lst)) (cdr-uniq (uniq (cdr lst)))) (if (member element cdr-uniq) cdr-uniq (cons element cdr-uniq))))) ;;; Compare two (implicitly equal length) lists, ;;; return the number of positions at which both ;;; list have the same element (define (exact-matches l1 l2) (if (null? l1) 0 (+ (if (equal? (car l1) (car l2)) 1 0) (exact-matches (cdr l1) (cdr l2))))) ;;; Remove element from list (if it occurs) (define (delete-element e lst) (cond ((null? lst) '()) ((equal? e (car lst)) (cdr lst)) (else (cons (car lst) (delete-element e (cdr lst)))))) ;;; Count occurrances of same elements of l1 in l2 (define (count-occ l1 l2) (if (null? l1) 0 (if (member (car l1) l2) (+ 1 (count-occ (cdr l1) (delete-element (car l1) l2))) (count-occ (cdr l1) l2)))) ;;; Evaluate a MasterMind guess vs the solution. Return value is a list with ;;; number of exact matches, number of correct colours (define (mm-eval guess solution) (let ((exact (exact-matches guess solution))) (list exact (- (count-occ guess solution) exact)))) ;;; For convenience: (define (winning-eval? ev) (= (car ev) no-of-pins)) ;;; Given a tuple and an integer "colours", generate a list of tuples by ;;; prepending the tuple with each integer value from 1 to "colours" (define (add-to-tuple tuple colours) (if (= colours 0) '() (cons (cons colours tuple) (add-to-tuple tuple (- colours 1))))) ;;; Given a set of tuples, and a set of coulours (represented as the number ;;; of the biggest colour), prepend each tuple with each colour and return ;;; the resulting list of tuples. (define (add-to-tuples tuples colours) (if (null? tuples) '() (append (add-to-tuple (car tuples) colours) (add-to-tuples (cdr tuples) colours)))) ;;; Given a number of pins and a number of colours, generate all compatible ;;; tuples (define (make-guesses pins colours) (if (= pins 0) (list '()) (let ((short-tuples (make-guesses (- pins 1) colours))) (add-to-tuples short-tuples colours)))) ;;; Make all tuples for the game as configured (define (make-all-guesses) (sort (make-guesses no-of-pins no-of-colours) (lambda (x y) (> (length (uniq x)) (length (uniq y)))) )) ;;; Generic filter (define (filter lst filter-fun) (if (null? lst) '() (if (filter-fun (car lst)) (cons (car lst) (filter (cdr lst) filter-fun)) (filter (cdr lst) filter-fun)))) ;;; Return true iff the solution candidate results in evaluation ev on guess. (define (is-compatible candidate guess ev) (equal? (mm-eval guess candidate) ev)) ;;; (define (filter-compatible candidates guess ev) (filter candidates (lambda (x) (is-compatible x guess ev)))) ;;; (define (solve-mm solution candidates) (cond ((null? candidates) (display "I'm giving up") (newline) #f) (else (let* ((guess (car candidates)) (ev (mm-eval guess solution))) (display "Guess: ") (display guess) (display " -> ") (display ev) (newline) (if (winning-eval? ev) guess (solve-mm solution (filter-compatible candidates guess ev))))))) ;;; (define (master-mind solution) (display "Game initialized. Secret code: ") (display solution) (newline) (solve-mm solution (make-all-guesses))) (define (master-mind-interactive) (master-mind (read)) (master-mind-interactive)) (exact-matches '() '()) (exact-matches '(1 2 3) '(1 2 3)) (exact-matches '(2 1 3) '(1 2 3)) (delete-element 1 '()) (delete-element 1 '(1)) (delete-element 1 '(2)) (delete-element 1 '(2 1 3)) (count-occ '() '()) (count-occ '(1 2 3) '(3 2 1)) (count-occ '(1 1 1) '(1 2 3)) (mm-eval '(1 2 3 4) '(1 2 3 4)) (mm-eval '(1 2 3 4) '(4 3 2 1)) (mm-eval '(1 2 3 4) '(1 1 1 1)) (add-to-tuple '() 6) (add-to-tuple '(1 2 3) 6) (length (make-all-guesses)) (filter-compatible (make-all-guesses) '(1 2 3 4) '(2 2)) (uniq '(1 2 3 1 1 4)) (master-mind '(1 2 3 4)) (master-mind '(4 2 2 1)) (master-mind '(3 3 3 3)) (master-mind-interactive)