Регистрация | Войти
Lisp — программируемый язык программирования
Крестики-нолики
Автор: Menschenkindlein - 2011-08-21T16:30:55.000000+04:00
(defpackage :xo (:use :cl) (:export :start-game))

(in-package :xo)

(defvar *game-space* (make-array '(3 3)))

(defvar *turns-history*)

(defmacro other-player (who)
  `(if (eql ,who :X)
       :0 :X
)
)


(defmacro first-possible (&rest forms)
  (if forms
      `(if ,(car forms) ,(car forms)
           (first-possible ,@(cdr forms))
)
)
)


(defvar *printing* t)

(defvar *ai* nil)

;;; Printing section ;;;

(defun print-game-space ()
  (princ "  - 1 - 2 - 3 -")                ;; X indexes
 (princ #\Newline)
  (princ "- -------------")
  (loop for i upto 2 doing
       (princ #\Newline)
       (princ (+ 1 i)) (princ " |")        ;; Y indexes
      (loop for j upto 2 doing
            (format t " ~a |"
                    (first-possible
                     (aref *game-space* i j)
                     " "
)
)
)

       (princ #\Newline)
       (princ "- -------------")
)

  (princ #\Newline) nil
)


(defun print-turns-history ()
  (princ #\Newline)
  (princ "The turns were:")
  (princ #\Newline)
  (let ((who :X))
    (loop
       for i upto 9
       for (x y) in (reverse *turns-history*) doing
         (format t "~d.  The ~a turn was: x - ~d, y - ~d.~%"
                 (+ i 1) who (+ x 1) (+ y 1)
)

         (setf who (other-player who))
)
)
)


(defun win (who &optional technical)
  (when *printing*
    (print-game-space)
    (format t "~a is winner!" who)
    (if technical
        (progn (princ "  Technical victory!") nil)
        (print-turns-history)
)
)

  (list who technical)
)


(defun draw ()
  (when *printing*
    (print-game-space)
    (princ "Draw!  Nobody wins.")
    (print-turns-history)
)

  nil
)


;;; end Printing section ;;;

;;; AI section ;;;

(defun ensure-row (how-many who row)
  (if (= how-many (loop for i upto 2 summing
                       (if (eql who
                                (elt (second row) i)
)

                           1 (if (eql (other-player who)
                                      (elt (second row) i)
)

                                 -2 0
)
)
)
)

      (first row)
)
)


(defun row (game-space n &optional (column nil))
  (let ((indexes
         (loop for i to 2 collecting
              (list (if column n i) (if column i n))
)
)
)

    (list indexes
          (loop for i in indexes collecting
               (aref game-space (first i) (second i))
)
)
)
)


(defun diagonal (game-space &optional (minus nil))
  (let ((indexes
         (loop for i to 2 collecting
              (list (if minus (- 2 i) i) i)
)
)
)

    (list indexes
          (loop for index in indexes collecting
               (aref game-space (first index) (second index))
)
)
)
)


(defun search-for-all-empties (list-of-cells game-space)
  (remove-if-not #'(lambda (x) (null (aref game-space
                                           (first x)
                                           (second x)
)
)
)
list-of-cells
)
)


(defun the-most-frequent (minimum &rest lists)
  (let ((great-list
         (apply #'concatenate 'list lists)
)
)

    (nth (first-possible
          (position (if (<= minimum
                            (loop for cell in great-list maximize
                                 (count cell great-list :test #'equal)
)
)

                        (loop for cell in great-list maximize
                             (count cell great-list :test #'equal)
)

                        nil
)

                    (loop for cell in great-list collecting
                         (count cell great-list :test #'equal)
)
)

          99
)

         great-list
)
)
)


(defun whole-space (game-space)
  (concatenate 'list
               (first (row game-space 0))
               (first (row game-space 1))
               (first (row game-space 2))
)
)


(defun all-space (game-space)
  (list
   (row game-space 0)
   (row game-space 1)
   (row game-space 2)
   (row game-space 0 t)
   (row game-space 1 t)
   (row game-space 2 t)
   (diagonal game-space)
   (diagonal game-space t)
)
)


(defun ai-find-turn (who game-space &optional aim)
  (cond
    ((eql aim :win) (setf aim 2))
    ((eql aim :trapping) (setf aim 1))
    (t (setf aim 0))
)

  (search-for-all-empties
   (apply #'concatenate 'list
          (remove-if #'null
                     (loop for row in
                          (all-space game-space)
                        collecting
                          (ensure-row aim who row)
)
)
)
game-space
)
)


(defun ai-find-good-turn (who game-space)                ;; this is bad
 (first-possible
   (the-most-frequent 1
                      (ai-find-turn who game-space :trapping)
                      (ai-find-turn who game-space)
                      (ai-find-turn who game-space)
)
)
)


(defun ai-find-trap (who game-space &optional of-enemy)  ;; this is better
 (if of-enemy (setf who (other-player who)))
  (first-possible
   (the-most-frequent (if of-enemy 3 2)
                      (ai-find-turn who game-space :trapping)
                      (if of-enemy           ;; to block a trap with attack
                          (ai-find-turn (other-player who)
                                        game-space :trapping
)
)
)
)
)


(defun ai-find-any (game-space)
  (search-for-all-empties (whole-space game-space) game-space)
)


(defun ai (who game-space level)
  (first-possible
   (if (> level 0)
       (car (ai-find-turn who game-space :win))
)

   (if (> level 1)
       (car (ai-find-turn (other-player who) game-space :win))
)

   (if (> level 3)
       (ai-find-trap who game-space)
)

   (if (> level 4)
       (ai-find-trap who game-space t)
)

   (if (> level 2)
       (ai-find-good-turn who game-space)
)

   (first
    (ai-find-any game-space)
)
)
)


;;; end AI section ;;;

;;; X0 section ;;;

;; WARNING This function uses some functions from AI section
(defun check-for-victory (who)
  (find-if-not #'null
               (loop for row in (all-space *game-space*) collecting
                    (ensure-row 3 who row)
)
)
)


(defun check-for-correctness (x y)
  (and (and (find x '(1 2 3))
            (find y '(1 2 3))
)
                ;; If some other symbol inserted
      (null (aref *game-space* (- x 1) (- y 1)))
)
)
 ;; If already exists

(defun check-for-draw ()
  (= 0
     (loop for i upto 2
        summing
          (loop for j upto 2
             summing
               (if (null (aref *game-space* i j)) 1 0)
)
)
)
)


(defun ask-for-input (who)
  (cond
    ((eql who (first *ai*)) (ai who *game-space* (second *ai*)))
    ((eql :X0 (first *ai*)) (ai who *game-space*
                                (if (eql :X who)
                                    (first (second *ai*))
                                    (second (second *ai*))
)
)
)

    (t (let ((x (read)) (y (read)))
         (if (eql :ai x)
             (ai who *game-space* y)
             (if (check-for-correctness x y)
                 (list (decf x) (decf y))
)
)
)
)
)
)
;; Make input numbers indexes.

(defun turn (&optional (who :X))
  (when *printing*
    (princ "It is the turn of ")
    (princ (if (eql :X who) "X!" "0!"))
    (princ #\Newline)
    (print-game-space)
)

  (let ((input (ask-for-input who)))
    (if (null input)
        (win (other-player who) t)         ;; Exit variant #1 -- not win.
        (let ((x (first input)) (y (second input)))
          (push (list x y) *turns-history*)
          (setf (aref *game-space* x y) who)
          (if (check-for-victory who)
              (win who)                    ;; Exit variant #2 -- win.
              (if (check-for-draw)
                  (draw)                   ;; Exit variant #3 -- draw.
                  (turn (other-player who))
)
)
)
)
)
)
  ;; Recursive call!

(defun start-game (&optional (ai nil) (printing t))
  (setf *printing* printing)
  (setf *ai* ai)
  (setf *turns-history* nil)                   ;; Turns history clearing.
 (loop for i upto 2 doing
       (loop for j upto 2 doing
            (setf (aref *game-space* i j) nil)
)
)
 ;; Game space clearing.
 (turn)
)


;;; end X0 section ;;;
@2009-2013 lisper.ru