home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / fun / kalah.lsp < prev    next >
Encoding:
Text File  |  1987-06-02  |  3.3 KB  |  62 lines
  1. (DEFVAR *INFINITE* 100)
  2. (DEFVAR NAME-OF-THE-GAME "kalah")
  3. (DEFUN INITIALIZE () '(6 6 6 6 6 6 0 6 6 6 6 6 6 0 NIL SOUTH))
  4. (DEFUN PRINT-BOARD (B)
  5.   (PRINT 'NORTH)
  6.   (DOTIMES (I 6) (PRIC2 (NTH (- 5 I) B))) (TERPRI)
  7.   (PRINC "   ") (PRIC2 (NTH 6 B)) (PRINC "                  ")
  8.   (PRIC2 (NTH 13 B)) (TERPRI) (PRINC "      ")
  9.   (DOTIMES (I 6) (PRIC2 (NTH (+ 7 I) B))) (PRINC "  ")
  10.   (PRINC " SOUTH") (TERPRI))
  11. (DEFUN PRIC2 (N) (PRINC " ") (IF (< N 10) (PRINC " ")) (PRINC N))
  12. (DEFUN GENERATE-MOVES (BS &AUX B J RES) (SETQ B (CAR BS))
  13.        (COND    ((NTH 14 B) (SETQ RES '(SKIP)))    
  14.                 (T (SETQ J (IF (EQ (CAR (LAST B)) 'SOUTH) 7 0))
  15.                    (DOTIMES (I 6)
  16.                      (IF (NOT (ZEROP (NTH (+ J I) B)))
  17.                          (SETQ RES (CONS (1+ I) RES)))))) RES)
  18. (DEFUN MAKE-MOVE (M B &AUX BC J K) (SETQ BC (APPEND B NIL))
  19.        (COND ((EQ M 'SKIP) (SETF (NTH 14 BC) NIL))
  20.              (T  (SETQ J (IF (EQ (CAR (LAST BC)) 'SOUTH) (+ 6 M) (1- M)))
  21.                  (SETQ K (NTH J BC)) (SETF (NTH J BC) 0)
  22.                  (DOTIMES (P K) (SETQ J (REM (1+ J) 14))
  23.                           (IF (OR (AND (= J 13) (EQ (CAR (LAST BC)) 'NORTH))
  24.                                   (AND (= J 6) (EQ (CAR (LAST BC)) 'SOUTH)))
  25.                               (SETQ J (REM (1+ J) 14)))
  26.                           (SETF (NTH J BC) (1+ (NTH J BC))))
  27.                  (COND    ((EQ (CAR (LAST BC)) 'SOUTH)
  28.                          (SETF (NTH 14 BC) (= J 13))
  29.                          (COND ((AND (> J 6) (< J 13) (= 1 (NTH J BC))
  30.                                      (> (NTH (- 12 J) BC) 0))
  31.                                 (SETF (NTH 13 BC)
  32.                                       (+ 1 (NTH 13 BC) (NTH (- 12 J) BC)))
  33.                                 (SETF (NTH (- 12 J) BC) 0)
  34.                                 (SETF (NTH J BC) 0))))
  35.                         (T (SETF (NTH 14 BC) (= J 6))
  36.                            (COND ((AND (< J 6) (= 1 (NTH J BC))
  37.                                        (> (NTH (- 12 J) BC) 0))
  38.                                   (SETF (NTH 6 BC)
  39.                                         (+ 1 (NTH 6 BC) (NTH (- 12 J) BC)))
  40.                                   (SETF (NTH (- 12 J) BC) 0)
  41.                                   (SETF (NTH J BC) 0)))))
  42.                  (COND ((OR (AND (ZEROP (NTH 7 BC)) (ZEROP (NTH 8 BC))
  43.                  (ZEROP (NTH 9 BC)) (ZEROP (NTH 10 BC))
  44.                  (ZEROP (NTH 11 BC)) (ZEROP (NTH 12 BC)))
  45.                             (AND (ZEROP (NTH 0 BC)) (ZEROP (NTH 1 BC))
  46.                      (ZEROP (NTH 2 BC)) (ZEROP (NTH 3 BC))
  47.                  (ZEROP (NTH 4 BC)) (ZEROP (NTH 5 BC))))
  48.                         (SETF (NTH 14 BC) NIL)
  49.                         (DOTIMES (I 6)
  50.                           (SETF (NTH 6 BC) (+ (NTH 6 BC) (NTH I BC)))
  51.                           (SETF (NTH 13 BC) (+ (NTH 13 BC) (NTH (+ 7 I) BC)))
  52.                           (SETF (NTH I BC) 0) (SETF (NTH (+ 7 I) BC) 0))))))
  53.        (SETF (NTH 15 BC) (IF (EQ (CAR (LAST BC)) 'SOUTH) 'NORTH 'SOUTH)) BC)
  54. (DEFUN CURRENT-PLAYER (B) (CAR (LAST B)))
  55. (DEFUN EVALUATE (BS &AUX B) (SETQ B (CAR BS))
  56.   (* (IF (EQ (CAR (LAST B)) 'SOUTH) 1 -1)
  57.      (COND ((< (+ (NTH 13 B) (NTH 6 B)) 72) (- (NTH 13 B) (NTH 6 B)))
  58.        ((> (NTH 13 B) (NTH 6 B)) *INFINITE*)
  59.        ((< (NTH 13 B) (NTH 6 B)) (- *INFINITE*))
  60.        (T 0))))
  61. (LOAD "game")
  62.