mastermind

mastermind.lisp

(defconstant color-names '("Red" "Green" "Orange" "Yellow" "Purple" "Tan" "Black" "White" "Brown" "Grey" ))
(defconstant color-letters "0123456789")

(defconstant max-colors 10)
(defconstant max-positions 8)
(defconstant max-rounds 10)
(defconstant max-moves 20)

(defun make-permutation (positions colors)
  (let ((color-string (make-array positions :element-type 'character)))
    (dotimes (i positions)
      (let ((color (char color-letters (random colors))))
  (setf (aref color-string i) color)))
    color-string))

(defun input-permutation (move positions colors)
  (format t "~&Move #~D   Guess ? " (1+ move))
  (loop
   (let ((permutation
    (progn
      (clear-input)
      (string-upcase (read-line)))))
     (cond
      ((string= permutation "QUIT")
       (return-from input-permutation permutation))
      ((string= permutation "BOARD")
       (return-from input-permutation permutation))
      ((not (= (length permutation) positions))
       (progn
   (format t "~&Entry has the wrong length!~%")
   (format t "~&Reenter ? ")
   (force-output)))
      (t (progn
     (let ((legal t))
       (block check
         (dotimes (i positions)
     (let ((index (position (char permutation i) color-letters)))
       (when (or (not index) (>= index colors))
         (format t "~&Not a legal color ~c!~%" (char permutation i))
         (format t "~&Reenter ? ")
         (force-output)
         (setf legal nil)
         (return-from check)
         ))))
       (if legal (return-from input-permutation permutation)))))
      ))))

(defun test-candidate (solution candidate)
  (let ((candidate (copy-seq candidate))
  (solution (copy-seq solution))
  (black 0)
  (white 0))
    (dotimes (i (length candidate))
      (when (char= (char solution i) (char candidate i))
  (setf (aref candidate i) #\#)
  (setf (aref solution i) #\#)
  (incf black)))
    (dotimes (i (length candidate))
      (when (char/= (aref candidate i) #\#)
  (let ((pos nil))
    (dotimes (j (length solution))
      (when (char= (aref candidate i) (aref solution j))
        (setf pos j)
        (return)
        ))
    (when pos
      (setf (aref solution pos) #\#)
      (incf white)))))
    (values black white)))

(defun print-board (move guesses whites blacks)
  (when (> move 0)
    (format t "~&~%Move Guess     White Black~%---------------------------~%")
    (dotimes (i move)
      (format t " #~D  ~8A    ~1D     ~1D~%"
        (1+ i)
        (aref guesses i)
        (aref whites i)
        (aref blacks i)))
    (format t "---------------------------~%")))

(defun input-color-evaluation (candidate move positions)
  (format t "Move #~D: My guess is: ~S  Blacks, Whites ? " (1+ move) candidate)
  (flet ((print-error () (progn
         (format t "~&Reenter ? ")
         (force-output))))
    (loop
     (clear-input)
     (let ((input-string (read-line)))
       (cond
  ((= (length input-string) 0) (print-error))
  ((string= (string-upcase input-string) "QUIT") (return "QUIT"))
  ((string= (string-upcase input-string) "BOARD") (return "BOARD"))
  (t (block check
       (multiple-value-bind (black-value position)
     (ignore-errors (parse-integer input-string :junk-allowed t))
         (when (>= position (length input-string))
     (print-error)
     (return-from check))
         (loop while (char= (char input-string position) #\SPACE) do (incf position))
         (if (char= (char input-string position) #\,)
       (incf position)
     (progn
       (print-error)
       (return-from check)))
         (loop while (char= (char input-string position) #\SPACE) do (incf position))
         (let ((white-value (ignore-errors
            (parse-integer input-string
               :start position :junk-allowed t))))
     (if (or (not black-value) (not white-value)
       (< black-value 0) (< white-value 0)
       (> (+ black-value white-value) positions))
         (print-error)
       (return-from input-color-evaluation (list black-value white-value)))
     )))))))))

(defun permute (i)
  (declare (special max-position max-color process permutation))

  (when (< i max-position)
    (permute (1+ i)))

  (loop for c from 1 to max-color do
  (setf (aref permutation i) (char color-letters c))
  (funcall process permutation)
  (when (< i max-position)
    (permute (1+ i))))
  (setf (aref permutation i) (char color-letters 0)))

(defun generate-permutations (positions colors func)
  (let ((max-position (1- positions))
  (max-color (1- colors))
  (permutation (make-array positions
         :element-type 'character
         :initial-element (char color-letters 0)))
  (process func))
    (declare (special max-position max-color process permutation))
    (funcall process permutation)
    (permute 0)
    ))


(defun comb (colors positions)
  (expt colors positions))

(defun make-guess (positions colors move guesses blacks whites)
  (flet ((check (permutation)
    (dotimes (i move)
      (when (string= (aref guesses i) permutation)
        (return-from check nil))
      (multiple-value-bind (same-pos same-color)
          (test-candidate (aref guesses i) permutation)
        (when (or (/= (aref blacks i) same-pos)
            (/= (aref whites i) same-color))
          (return-from check nil))))
    (return-from check t)
    ))
    (let* ((candidate nil)
     (nPermutations 0)
     (pos 0)
     (choice 0)
     (count (lambda (permutation)
        (declare (ignore permutation))
        (when (check permutation)
          (incf nPermutations))))
     (pick (lambda (permutation)
       (when (check permutation)
         (when (= pos choice)
           (setf candidate (copy-seq permutation)))
         (incf pos)
         ))))
      (generate-permutations positions colors count)
      (when (= nPermutations 0)
  (return-from make-guess nil))
      (setf choice (random nPermutations))
      (generate-permutations positions colors pick)
      candidate
      )))
  
(defun mastermind (&key (colors 6)
      (positions 4)
      (rounds 1)
      (moves 6)
      (skip-user nil)
      (skip-computer nil))

  (when (or (not (numberp colors))
      (< colors 0)
      (> colors max-colors))
    (format t "~&Illegal number of colors! (0-~D)~%" max-colors)
    (return-from mastermind nil))

  (when (or (not (numberp positions))
      (< positions 0)
      (> positions max-positions))
    (format t "~&Illegal number of positions! (0-~D)~%" max-positions)
    (return-from mastermind nil))

  (when (or (not (numberp moves))
      (< rounds 0)
      (> rounds max-moves))
    (format t "~&Illegal number of rounds! (0-~D)~%" max-moves)
    (return-from mastermind nil))

  (when (or (not (numberp rounds))
      (< rounds 0)
      (> rounds max-rounds))
    (format t "~&Illegal number of rounds! (0-~D)~%" max-rounds)
    (return-from mastermind nil))

  (format t "~&Number of colors: ~D~%" colors)
  (format t "Number of positions: ~D~%" positions)
  (format t "Number of moves: ~D~%" moves)
  (format t "Number of rounds: ~D~2%" rounds)

  (setf *random-state* (make-random-state t))
  (format t "~&Total combinations = ~D~%" (comb colors positions))
  
  (format t "~%Color      Letter~%")
  (format t "~&======     ======~%")
  (loop for i from 0 to (1- colors) do
  (format t "~&~6A        ~c~%"
    (nth i color-names)
    (char color-letters i)))

  (let ((computer-score 0)
  (user-score 0)
  (move)
  (guessed)
  (guesses (make-array moves))
  (whites (make-array moves))
  (blacks (make-array moves)))

    (dotimes (round rounds)
      (format t "~%ROUND NUMBER ~d ----~%" (1+ round))

      ;; User Guess main loop
      (when (not skip-user)
  (setf move 0)
  (setf guessed nil)
  (format t "~%Guess my combination.~%")
  (block user-guess
    (let ((solution (make-permutation positions colors)))
      (loop until (>= move moves) do
      (block move-block
        (let ((candidate
         (input-permutation move positions colors)))
          (cond ((string= candidate "QUIT")
           (return-from mastermind nil))
          ((string= candidate "BOARD")
           (progn
             (print-board move guesses whites blacks)
             (return-from move-block)))
          (t (progn
         (multiple-value-bind (black-pegs white-pegs)
             (test-candidate solution candidate)
           (setf (aref guesses move) candidate)
           (setf (aref whites move) white-pegs)
           (setf (aref blacks move) black-pegs)
           (if (= black-pegs positions)
               (progn
           (setf guessed t)
           (incf user-score (* 10 (1+ (- moves move))))
           (format t "~2%You guessed it in ~d moves!~2%" (1+ move))
           (return-from user-guess))
             (progn
               (format t "~&You have ~D black pegs and ~D white pegs."
                 black-pegs white-pegs)
               (setf move (1+ move))))
           )))))))
      (if (not guessed)
    (progn
      (format t "~2%You ran out of moves! That's all you get..~%")
      (format t "The solution was: ~A~2%" solution))))))

      ;; Computer guess main loop
      (when (not skip-computer)
  (block computer-guess
    (loop
       (when (not skip-user)
         (format t "~&Now I guess. Think of a combination.~%")
         (format t "~&Hit Return when ready ? ")
         (clear-input)
         (read-line))
     (block computer-try
       (setf move 0)
       (setf guessed nil)
       (loop until (>= move moves) do
       (block move
         (let ((candidate (make-guess positions colors
              move guesses blacks whites)))
           (when(not candidate)
       (format t "~2%You have given me inconsistent information.~%")
       (format t "Try again. And this time be more carefull!~2%")
       (return-from computer-try))
           (let ((response (input-color-evaluation candidate move positions)))
       (cond
        ((and (stringp response) (string= response "QUIT"))
         (return-from mastermind NIL))
        ((and (stringp response) (string= response "BOARD"))
         (progn
           (print-board move guesses whites blacks)
           (return-from move)))
        (t (progn
             (let ((black-pegs (first response))
             (white-pegs (second response)))
         (setf (aref guesses move) candidate)
         (setf (aref whites move) white-pegs)
         (setf (aref blacks move) black-pegs)
         (if (= black-pegs positions)
             (progn
               (setf guessed t)
               (incf computer-score (* 10 (1+ (- moves move))))
               (format t "~2%I got it in ~d moves!~%" (1+ move))
               (return-from computer-guess)))
         (setf move (1+ move))
         ))))))
         ))
       (return-from computer-guess))))
  (if (not guessed)
      (progn
        (format t "~2%I used up all my moves!~%")
        (format t "I guess my CPU is just having a off day!~2%"))))

      )         ;rounds

    (when (and (not skip-user) (not skip-computer))
      (format t "~%Game over.~%Final score:~%    Computer: ~D~%    User:     ~D~%"
        computer-score user-score)
      (cond
       ((> computer-score user-score)
  (format t "I win!~%"))
       ((< computer-score user-score)
  (format t "You win!~%"))
       (t (format t "It's a tie.~%"))))
    ))