Added hangman.lisp

Pascal J. Bourguignon [2014-04-03 19:03]
Added hangman.lisp
Filename
sources/hangman.lisp
diff --git a/sources/hangman.lisp b/sources/hangman.lisp
new file mode 100644
index 0000000..45fcf70
--- /dev/null
+++ b/sources/hangman.lisp
@@ -0,0 +1,121 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               hangman.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    The Hangman game model.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2014-04-03 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2014 - 2014
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "HANGMAN"
+  (:use "COMMON-LISP")
+  (:export "INITIALIZE" "GET-WORD" "GET-FOUND-WORD" "ERROR-COUNT"
+           "ALPHABET" "TRY-LETTER" "+WINS+" "+LOSES+" "+ALREADY-TRIED+"
+           "+BAD-GUESS+" "+NEW-GUESSED-WORD+"))
+(in-package "HANGMAN")
+
+(defconstant +wins+             0)
+(defconstant +loses+            1)
+(defconstant +already-tried+    2)
+(defconstant +bad-guess+        3)
+(defconstant +new-guessed-word+ 4)
+
+(defstruct hangman
+  word
+  found
+  (tried-letters '())
+  (current-error-count 0)
+  maximum-error-count
+  (missing-letter ".")
+  (alphabet "abcdefghijklmnopqrstuvwxyz"))
+
+
+(defun initialize-found (word)
+  (let ((found (make-array (length word) :initial-element nil)))
+    (setf (aref found 0) t
+          (aref found (1- (length found))) t)
+    found))
+
+(defun initialize (word maximum-error-count)
+  (make-hangman :word word
+                :found (initialize-found word)
+                :maximum-error-count maximum-error-count))
+
+(defun get-word (game)
+  (hangman-word game))
+
+(defun get-found-word (game)
+  (let ((found-word (copy-sequence (hangman-word game))))
+    (loop
+      :with missing-letter = (aref (hangman-missing-letter game) 0)
+      :for i :below (length found-word)
+      :do (unless (aref (hangman-found game) i)
+            (setf (aref found-word i) missing-letter)))
+    found-word))
+
+(defun try-letter (game letter)
+  (let ((letter (aref letter 0)))
+    (if (member letter (hangman-tried-letters game) :test (function equalp))
+        (progn
+          (when (< (hangman-current-error-count game)
+                   (hangman-maximum-error-count game))
+            (incf (hangman-current-error-count game)))
+          (if (>= (hangman-current-error-count game)
+                  (hangman-maximum-error-count game))
+              +loses+
+              +already-tried+))
+        (let ((error t))
+          (push letter (hangman-tried-letters game))
+          (loop
+            :for i :below (length word)
+            :do (when (and (not (aref found i))
+                           (char-equal letter (aref word i)))
+                  (setf (aref found i) t
+                        error nil)))
+          (when error
+            (when (< (hangman-current-error-count game)
+                     (hangman-maximum-error-count game))
+              (incf (hangman-current-error-count game))))
+          (cond
+            ((>= (hangman-current-error-count game)
+                 (hangman-maximum-error-count game))
+             +loses+)
+            ((every (function identity) (hangman-found game))
+             +wins+)
+            (error
+             +bad-guess)
+            (t
+             +new-guessed-word+))))))
+
+(defun error-count (game)
+  (hangman-current-error-count game))
+
+(defun alphabent (game)
+  (hangman-alphabet game))
+
+;;;; THE END ;;;;
ViewGit