mastermind.lisp

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

(defconstant max-colors 8)
(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.~%"))))
    ))