home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
lisp
/
interpre
/
xlispplu
/
fun
/
pangki.lsp
< prev
next >
Wrap
Text File
|
1987-06-02
|
5KB
|
108 lines
(DEFVAR *INFINITE* 10)
(DEFVAR NAME-OF-THE-GAME "pangki")
(DEFVAR DIRS '(1 -1 6 -6))
(DEFVAR PLACES '(7 8 9 10 13 14 15 16 19 20 21 22 25 26 27 28))
(DEFVAR A1A2 '(25 . 19)) (DEFVAR A1B1 '(25 . 26))
(DEFVAR D1D2 '(28 . 22)) (DEFVAR D1C1 '(28 . 27))
(DEFVAR B1A1 '(26 . 25)) (DEFVAR B1B2 '(26 . 20))
(DEFVAR B1C1 '(26 . 27)) (DEFVAR C1B1 '(27 . 26))
(DEFVAR C1C2 '(27 . 21)) (DEFVAR C1D1 '(27 . 28))
(DEFVAR A2A1 '(19 . 25)) (DEFVAR A2B2 '(19 . 20))
(DEFVAR A2A3 '(19 . 13)) (DEFVAR A3A2 '(13 . 19))
(DEFVAR A3B3 '(13 . 14)) (DEFVAR A3A4 '(13 . 7))
(DEFVAR A4A3 '( 7 . 13)) (DEFVAR A4B4 '( 7 . 8))
(DEFVAR D4D3 '(10 . 16)) (DEFVAR D4C4 '(10 . 9))
(DEFVAR B4A4 '( 8 . 7)) (DEFVAR B4B3 '( 8 . 14))
(DEFVAR B4C4 '( 8 . 9)) (DEFVAR C4B4 '( 9 . 8))
(DEFVAR C4C3 '( 9 . 15)) (DEFVAR C4D4 '( 9 . 10))
(DEFVAR D3D2 '(16 . 22)) (DEFVAR D3C3 '(16 . 15))
(DEFVAR D3D4 '(16 . 10)) (DEFVAR D2D3 '(22 . 16))
(DEFVAR D2C2 '(22 . 21)) (DEFVAR D2D1 '(22 . 28))
(DEFVAR B2B1 '(20 . 26)) (DEFVAR B2B3 '(20 . 14))
(DEFVAR B2A2 '(20 . 19)) (DEFVAR B2C2 '(20 . 21))
(DEFVAR C2C1 '(21 . 27)) (DEFVAR C2C3 '(21 . 15))
(DEFVAR C2B2 '(21 . 20)) (DEFVAR C2D2 '(21 . 22))
(DEFVAR B3B2 '(14 . 20)) (DEFVAR B3B4 '(14 . 8))
(DEFVAR B3A3 '(14 . 13)) (DEFVAR B3C3 '(14 . 15))
(DEFVAR C3C2 '(15 . 21)) (DEFVAR C3C4 '(15 . 9))
(DEFVAR C3B3 '(15 . 14)) (DEFVAR C3D3 '(15 . 16))
(DEFUN INITIALIZE ()
(LIST 'O 6 6 NIL NIL NIL
NIL '* '* '* '* NIL NIL '* '- '- '* NIL
NIL 'O '- '- 'O NIL NIL 'O 'O 'O 'O))
(DEFUN PRINT-BOARD (BOARD)
(DOTIMES (I 4) (PRINT (- 4 I))
(DOTIMES (J 4) (PRINC " ")
(PRINC (NTH (+ 7 (* 6 I) J) BOARD))))
(TERPRI) (PRINC " a b c d") (TERPRI))
(DEFUN GENERATE-MOVES (BRDS &AUX RES BRD) (SETQ BRD (CAR BRDS))
(COND ((AND (> (CADR BRD) 1) (> (CADDR BRD) 1) (NOT (REP BRDS)))
(SETQ RES '(PASS))
(DOLIST (I PLACES)
(IF (EQ (NTH I BRD) (CAR BRD))
(DOLIST (J DIRS)
(IF (EQ (NTH (+ I J) BRD) '-)
(SETQ RES (CONS
(CASE I (7 (CASE J (1 'A4B4) (6 'A4A3)))
(8 (CASE J (1 'B4C4) (6 'B4B3) (-1 'B4A4)))
(9 (CASE J (1 'C4D4) (6 'C4C3) (-1 'C4B4)))
(10 (CASE J (-1 'D4C4) (6 'D4D3)))
(13 (CASE J (-6 'A3A4) (1 'A3B3) (6 'A3A2)))
(14 (CASE J (-6 'B3B4) (1 'B3C3)
(6 'B3B2) (-1 'B3A3)))
(15 (CASE J (-6 'C3C4) (1 'C3D3)
(6 'C3C2) (-1 'C3B3)))
(16 (CASE J (-6 'D3D4) (6 'D3D2) (-1 'D3C3)))
(19 (CASE J (-6 'A2A3) (1 'A2B2) (6 'A2A1)))
(20 (CASE J (-6 'B2B3) (1 'B2C2)
(6 'B2B1) (-1 'B2A2)))
(21 (CASE J (-6 'C2C3) (1 'C2D2)
(6 'C2C1) (-1 'C2B2)))
(22 (CASE J (-6 'D2D3) (6 'D2D1) (-1 'D2C2)))
(25 (CASE J (1 'A1B1) (-6 'A1A2)))
(26 (CASE J (-1 'B1A1) (-6 'B1B2) (1 'B1C1)))
(27 (CASE J (-1 'C1B1) (-6 'C1C2) (1 'C1D1)))
(28 (CASE J (-1 'D1C1) (-6 'D1D2))))
RES)))))))) RES)
(DEFUN MAKE-MOVE (MV BOARD &AUX B TO ME YOU)
(SETQ B (APPEND BOARD NIL))
(SETQ ME (CAR B)) (SETQ YOU (IF (EQ ME 'O) '* 'O))
(COND ((NOT (EQ MV 'PASS)) (SETF (NTH (CAR (EVAL MV)) B) '-)
(SETF (NTH (SETQ TO (CDR (EVAL MV))) B) ME)
(DOLIST (I DIRS)
(COND ((EQ (NTH (+ TO I) B) ME)
(COND ((AND (EQ (NTH (+ TO I I) B) YOU)
(OR (EQ (NTH (- TO I) B) '-)
(EQ (NTH (+ TO I I I) B) '-)))
(SETF (NTH (+ TO I I) B) '-)
(IF (EQ ME 'O) (SETF (NTH 2 B) (1- (CADDR B)))
(SETF (NTH 1 B) (1- (CADR B)))))
(T (COND ((AND (EQ (NTH (- TO I) B) YOU)
(OR (EQ (NTH (- TO I I) B) '-)
(EQ (NTH (+ TO I I) B) '-)))
(SETF (NTH (- TO I) B) '-)
(IF (EQ ME 'O) (SETF (NTH 2 B) (1- (CADDR B)))
(SETF (NTH 1 B) (1- (CADR B)))))))))))))
(SETF (CAR B) YOU) B)
(DEFUN EVALUATE (BRDS &AUX BRD) (SETQ BRD (CAR BRDS))
(IF (REP BRDS) 0 (IF (EQ (CAR BRD) 'O)
(COND ((< (CADR BRD) 2) (- *INFINITE*))
((< (CADDR BRD) 2) *INFINITE*)
(T (- (CADR BRD) (CADDR BRD))))
(COND ((< (CADR BRD) 2) *INFINITE*)
((< (CADDR BRD) 2) (- *INFINITE*))
(T (- (CADDR BRD) (CADR BRD)))))))
(DEFUN REP (BRDS)
(MEMBER (CAR BRDS) (CDR (MEMBER (CAR BRDS) (CDR BRDS) :TEST #'EQUAL))
:TEST #'EQUAL))
(DEFUN CURRENT-PLAYER (BRD) (CAR BRD))
(LOAD "game")