home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
lisp
/
interpre
/
xlispplu
/
fun
/
kalah.lsp
< prev
next >
Wrap
Text File
|
1987-06-02
|
3KB
|
62 lines
(DEFVAR *INFINITE* 100)
(DEFVAR NAME-OF-THE-GAME "kalah")
(DEFUN INITIALIZE () '(6 6 6 6 6 6 0 6 6 6 6 6 6 0 NIL SOUTH))
(DEFUN PRINT-BOARD (B)
(PRINT 'NORTH)
(DOTIMES (I 6) (PRIC2 (NTH (- 5 I) B))) (TERPRI)
(PRINC " ") (PRIC2 (NTH 6 B)) (PRINC " ")
(PRIC2 (NTH 13 B)) (TERPRI) (PRINC " ")
(DOTIMES (I 6) (PRIC2 (NTH (+ 7 I) B))) (PRINC " ")
(PRINC " SOUTH") (TERPRI))
(DEFUN PRIC2 (N) (PRINC " ") (IF (< N 10) (PRINC " ")) (PRINC N))
(DEFUN GENERATE-MOVES (BS &AUX B J RES) (SETQ B (CAR BS))
(COND ((NTH 14 B) (SETQ RES '(SKIP)))
(T (SETQ J (IF (EQ (CAR (LAST B)) 'SOUTH) 7 0))
(DOTIMES (I 6)
(IF (NOT (ZEROP (NTH (+ J I) B)))
(SETQ RES (CONS (1+ I) RES)))))) RES)
(DEFUN MAKE-MOVE (M B &AUX BC J K) (SETQ BC (APPEND B NIL))
(COND ((EQ M 'SKIP) (SETF (NTH 14 BC) NIL))
(T (SETQ J (IF (EQ (CAR (LAST BC)) 'SOUTH) (+ 6 M) (1- M)))
(SETQ K (NTH J BC)) (SETF (NTH J BC) 0)
(DOTIMES (P K) (SETQ J (REM (1+ J) 14))
(IF (OR (AND (= J 13) (EQ (CAR (LAST BC)) 'NORTH))
(AND (= J 6) (EQ (CAR (LAST BC)) 'SOUTH)))
(SETQ J (REM (1+ J) 14)))
(SETF (NTH J BC) (1+ (NTH J BC))))
(COND ((EQ (CAR (LAST BC)) 'SOUTH)
(SETF (NTH 14 BC) (= J 13))
(COND ((AND (> J 6) (< J 13) (= 1 (NTH J BC))
(> (NTH (- 12 J) BC) 0))
(SETF (NTH 13 BC)
(+ 1 (NTH 13 BC) (NTH (- 12 J) BC)))
(SETF (NTH (- 12 J) BC) 0)
(SETF (NTH J BC) 0))))
(T (SETF (NTH 14 BC) (= J 6))
(COND ((AND (< J 6) (= 1 (NTH J BC))
(> (NTH (- 12 J) BC) 0))
(SETF (NTH 6 BC)
(+ 1 (NTH 6 BC) (NTH (- 12 J) BC)))
(SETF (NTH (- 12 J) BC) 0)
(SETF (NTH J BC) 0)))))
(COND ((OR (AND (ZEROP (NTH 7 BC)) (ZEROP (NTH 8 BC))
(ZEROP (NTH 9 BC)) (ZEROP (NTH 10 BC))
(ZEROP (NTH 11 BC)) (ZEROP (NTH 12 BC)))
(AND (ZEROP (NTH 0 BC)) (ZEROP (NTH 1 BC))
(ZEROP (NTH 2 BC)) (ZEROP (NTH 3 BC))
(ZEROP (NTH 4 BC)) (ZEROP (NTH 5 BC))))
(SETF (NTH 14 BC) NIL)
(DOTIMES (I 6)
(SETF (NTH 6 BC) (+ (NTH 6 BC) (NTH I BC)))
(SETF (NTH 13 BC) (+ (NTH 13 BC) (NTH (+ 7 I) BC)))
(SETF (NTH I BC) 0) (SETF (NTH (+ 7 I) BC) 0))))))
(SETF (NTH 15 BC) (IF (EQ (CAR (LAST BC)) 'SOUTH) 'NORTH 'SOUTH)) BC)
(DEFUN CURRENT-PLAYER (B) (CAR (LAST B)))
(DEFUN EVALUATE (BS &AUX B) (SETQ B (CAR BS))
(* (IF (EQ (CAR (LAST B)) 'SOUTH) 1 -1)
(COND ((< (+ (NTH 13 B) (NTH 6 B)) 72) (- (NTH 13 B) (NTH 6 B)))
((> (NTH 13 B) (NTH 6 B)) *INFINITE*)
((< (NTH 13 B) (NTH 6 B)) (- *INFINITE*))
(T 0))))
(LOAD "game")