home *** CD-ROM | disk | FTP | other *** search
- (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")
-