iso2.lisp

用commonlisp实现的一个棋类游戏

;; ISOLATION, the main procedure about this game
;; Input: 2 methods ,  initial state,  the race of player1
;; Output: display next-state  and winner if the game is over
(defun ISOLATION (p1 p2 init-state p1-race)
  (show-chessboard init-state)
  (let ((next (funcall p1 init-state p1-race)))
    (if (equal next '(-1 -1))
        (game-over p1-race)
      (let ((new-state (make-state init-state next p1-race)))
        (ISOLATION p2 p1 new-state (change-race p1-race))))))

;; some small assistant procs 
(defun change-race (race)
  (cond ((equal race 'X) 'O)
        ((equal race 'O) 'X)
        (T (error "Wrong ISOLATE race---" race))))
(defun game-over (loser-race)
 (progn  (print "Winner is ---")
   (print (change-race loser-race))
   'GAME-OVER))
(defun show-chessboard (state)
  (terpri)
  (show-chessboard-helper (state-board state)))
(defun show-chessboard-helper (board)
  (if (null board)
      'done
    (progn (print (car board))
      ;;(terpri)
      (show-chessboard-helper (cdr board)))))
    

(defun repeat-proc (proc init times)
  (if (= times 0)
      init
    (repeat-proc proc
                 (funcall proc init)
                 (- times 1))))

;; --------procedures about state-----------
(defun state-board (state) (car state))
    ;; position starts from (1 1) to (8 8)

;; if x is not in board , return (1 1)
(defun state-X-position (state) 
  (let ((p (car (cadr state))))
    (if (equal p '(-1 -1))
        '(1 1)
      p)))
(defun state-O-position (state) 
  (let ((p (cadr (cadr state))))
    (if (equal p '(-1 -1))
        '(1 1)
      p)))

(defun change-board (init-board position new-element)
  (if (equal position '(-1 -1))
      init-board
    (change-board-helper init-board 
                         (car position)
                         (cadr position)
                         new-element)))
(defun change-board-helper (the-board row column new-element)
    (if (= row 1)
        (cons (change-line (car the-board) column new-element)
              (cdr the-board))
      (cons (car the-board)
            (change-board-helper (cdr the-board)
                                 (- row 1)
                                 column
                                 new-element))))
(defun change-line (sequence n new-element)
  (if (= n 1)
      (cons new-element (cdr sequence))
    (cons (car sequence)
          (change-line (cdr sequence)
                       (- n 1)
                       new-element))))

(defun make-state (init-state next-step player-race)
  (cond ((equal player-race 'X)
         (let ((X-filled-board
                (change-board (state-board init-state)
                              (state-X-position init-state)
                              '*)))
           (list (change-board X-filled-board 
                               next-step
                               'X)
                 (list next-step
                       (state-O-position init-state)))))
        ((equal player-race 'O)
         (let ((O-filled-board
                (change-board (state-board init-state)
                              (state-O-position init-state)
                              '*)))
           (list (change-board O-filled-board
                               next-step
                               'O)
                 (list (state-X-position init-state)
                       next-step))))
        (T
         (error "Wrong player-race found---" player-race))))



;;;
(setf empty-state
 (let ((empty-board 
        (let ((empty-row  (repeat-proc #'(lambda (x) (cons '- x))
                                       '()
                                       8)))
          (repeat-proc #'(lambda (x) (cons empty-row x))
                       '()
                       8))))
   (list empty-board '((-1 -1) (-1 -1)))))  ;;(-1 -1) means not in the chessboard


(defun board-element (board position)
  (nth (- (cadr position) 1)
       (nth (- (car position) 1)
            board)))
  
                 
;; -----procedures for state over----------
         


;; player, a player with a method
;; Input: initial-state ,  his race
;; Output: next-state such as (3,4)  or (-1, -1) if he losed

;; It's U!
(defun human-player (init-state his-race)
  (read))

;; stupid-player :   If there is a way, I will go

(defun stupid-player (init-state his-race)
  (let ((all-steps (all-available-route init-state his-race)))
    (if (null all-steps)
        '(-1 -1)
      (car all-steps))))


;;========= Procedures to find available positions=====
(defun all-available-route (state player-race)
  (let ((1-8-seq '(1 2 3 4 5 6 7 8)))
    (accumulate (flat-map #'(lambda (length)
                              (available-route-length length state player-race))
                          1-8-seq)
                #'cons
                '())))


(defun available-route-length (length  state player-race)
  (let ((current-position 
         (if (equal player-race 'X)
             (state-X-position state)
             (state-O-position state)))
        (board (state-board state)))
    (filter (n-neighbour current-position length)
            #'(lambda (position)
                (check position current-position (state-board state))))))
(defun check (test-position current-position board)
  (let ((path-nodes (queen-steps-between current-position test-position)))
    (if (= (apply '* (mapcar #'(lambda (position)
                                 (if (equal (board-element board position) '-)
                                     1
                                   0))
                                 path-nodes))
           1)
        T
      nil)))


;; give those positions from p1 to p2
(defun queen-steps-between (position1 position2)
  ;; return the steps needed for a queen from position1 to position2
  (let ((row-step 
         (cond ((= (car position1) (car position2)) 0)
               ((> (car position1) (car position2)) -1)
               (T 1)))
        (column-step
         (cond ((= (cadr position1) (cadr position2)) 0)
               ((> (cadr position1) (cadr position2)) -1)
               (T 1))))
    (queen-steps-between-helper position1 position2 row-step column-step)))
(defun queen-steps-between-helper (p1 p2 rs cs)
  (if (equal p1 p2)
      nil
    (let ((p1-next (list (+ (car p1) rs) (+ (cadr p1) cs))))
      (cons p1-next
            (queen-steps-between-helper p1-next p2 rs cs)))))
;;--queen steps done--

                  
(defun n-neighbour (position length)
  (let ((r (car position))
        (c (cadr position)))
    (let ((all-neighbour 
           (list (list (- r length) c)
                 (list (- r length) (- c length))
                 (list r (- c length))
                 (list (+ r length) (- c length))
                 (list (+ r length) c)
                 (list (+ r length) (+ c length))
                 (list r (+ c length))
                 (list (- r length) (+ c length)))))
      (filter all-neighbour
              #'(lambda (position)
                  (let ((rr (car position))
                        (cc (cadr position)))
                    (and (> rr 0)
                         (> cc 0)
                         (< rr 9)
                         (< cc 9))))))))
(defun filter (seq proc)
  (cond ((null seq) '())
        ((funcall proc (car seq))
         (cons (car seq)
               (filter (cdr seq) proc)))
        (T (filter (cdr seq) proc))))
(defun accumulate (seq proc init)
  (if (null seq)
      init
    (accumulate (cdr seq)
                proc
                (funcall proc (car seq) init))))
(defun flat-map (proc seq)
  (if (null seq)
      '()
    (append (funcall proc (car seq))
            (flat-map proc (cdr seq)))))
;; ======procs for available positions over========

;;test-proc
;; Now you can play with this stupid-player ... not so easy in fact...
;; (ISOLATION 'human-player 'stupid-player empty-state 'X)