home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 September / Simtel20_Sept92.cdr / msdos / xlisp / ufg.arc / PANGKI.LSP < prev    next >
Text File  |  1987-06-02  |  5KB  |  108 lines
  1. (DEFVAR *INFINITE* 10)
  2. (DEFVAR NAME-OF-THE-GAME "pangki")
  3. (DEFVAR DIRS '(1 -1 6 -6))
  4. (DEFVAR PLACES '(7 8 9 10 13 14 15 16 19 20 21 22 25 26 27 28))
  5. (DEFVAR A1A2 '(25 . 19)) (DEFVAR A1B1 '(25 . 26))
  6. (DEFVAR D1D2 '(28 . 22)) (DEFVAR D1C1 '(28 . 27))
  7. (DEFVAR B1A1 '(26 . 25)) (DEFVAR B1B2 '(26 . 20)) 
  8. (DEFVAR B1C1 '(26 . 27)) (DEFVAR C1B1 '(27 . 26))
  9. (DEFVAR C1C2 '(27 . 21)) (DEFVAR C1D1 '(27 . 28))
  10. (DEFVAR A2A1 '(19 . 25)) (DEFVAR A2B2 '(19 . 20)) 
  11. (DEFVAR A2A3 '(19 . 13)) (DEFVAR A3A2 '(13 . 19))
  12. (DEFVAR A3B3 '(13 . 14)) (DEFVAR A3A4 '(13 .  7))
  13. (DEFVAR A4A3 '( 7 . 13)) (DEFVAR A4B4 '( 7 .  8))
  14. (DEFVAR D4D3 '(10 . 16)) (DEFVAR D4C4 '(10 .  9))
  15. (DEFVAR B4A4 '( 8 .  7)) (DEFVAR B4B3 '( 8 . 14))
  16. (DEFVAR B4C4 '( 8 .  9)) (DEFVAR C4B4 '( 9 .  8))
  17. (DEFVAR C4C3 '( 9 . 15)) (DEFVAR C4D4 '( 9 . 10))
  18. (DEFVAR D3D2 '(16 . 22)) (DEFVAR D3C3 '(16 . 15))
  19. (DEFVAR D3D4 '(16 . 10)) (DEFVAR D2D3 '(22 . 16))
  20. (DEFVAR D2C2 '(22 . 21)) (DEFVAR D2D1 '(22 . 28))
  21. (DEFVAR B2B1 '(20 . 26)) (DEFVAR B2B3 '(20 . 14))
  22. (DEFVAR B2A2 '(20 . 19)) (DEFVAR B2C2 '(20 . 21))
  23. (DEFVAR C2C1 '(21 . 27)) (DEFVAR C2C3 '(21 . 15))
  24. (DEFVAR C2B2 '(21 . 20)) (DEFVAR C2D2 '(21 . 22))
  25. (DEFVAR B3B2 '(14 . 20)) (DEFVAR B3B4 '(14 .  8))
  26. (DEFVAR B3A3 '(14 . 13)) (DEFVAR B3C3 '(14 . 15))
  27. (DEFVAR C3C2 '(15 . 21)) (DEFVAR C3C4 '(15 .  9))
  28. (DEFVAR C3B3 '(15 . 14)) (DEFVAR C3D3 '(15 . 16))
  29.  
  30. (DEFUN INITIALIZE ()
  31.   (LIST 'O 6 6 NIL NIL NIL
  32.       NIL '* '* '* '* NIL NIL '* '- '- '* NIL
  33.       NIL 'O '- '- 'O NIL NIL 'O 'O 'O 'O))
  34.  
  35. (DEFUN PRINT-BOARD (BOARD)
  36.   (DOTIMES (I 4) (PRINT (- 4 I))
  37.            (DOTIMES (J 4) (PRINC " ")
  38.              (PRINC (NTH (+ 7 (* 6 I) J) BOARD))))
  39.   (TERPRI) (PRINC "   a b c d") (TERPRI))
  40.  
  41. (DEFUN GENERATE-MOVES (BRDS &AUX RES BRD) (SETQ BRD (CAR BRDS))
  42.        (COND ((AND (> (CADR BRD) 1) (> (CADDR BRD) 1) (NOT (REP BRDS)))
  43.               (SETQ RES '(PASS))
  44.               (DOLIST (I PLACES)
  45.                 (IF (EQ (NTH I BRD) (CAR BRD))
  46.                     (DOLIST (J DIRS)
  47.                       (IF (EQ (NTH (+ I J) BRD) '-)
  48.                           (SETQ RES (CONS
  49.                 (CASE I (7 (CASE J (1 'A4B4) (6 'A4A3)))
  50.                 (8 (CASE J (1 'B4C4) (6 'B4B3) (-1 'B4A4)))
  51.                 (9 (CASE J (1 'C4D4) (6 'C4C3) (-1 'C4B4)))
  52.                 (10 (CASE J (-1 'D4C4) (6 'D4D3)))
  53.                 (13 (CASE J (-6 'A3A4) (1 'A3B3) (6 'A3A2)))
  54.                 (14 (CASE J (-6 'B3B4) (1 'B3C3)
  55.                         (6 'B3B2) (-1 'B3A3)))
  56.                 (15 (CASE J (-6 'C3C4) (1 'C3D3)
  57.                         (6 'C3C2) (-1 'C3B3)))
  58.                 (16 (CASE J (-6 'D3D4) (6 'D3D2) (-1 'D3C3)))
  59.                 (19 (CASE J (-6 'A2A3) (1 'A2B2) (6 'A2A1)))
  60.                 (20 (CASE J (-6 'B2B3) (1 'B2C2)
  61.                         (6 'B2B1) (-1 'B2A2)))
  62.                 (21 (CASE J (-6 'C2C3) (1 'C2D2)
  63.                         (6 'C2C1) (-1 'C2B2)))
  64.                 (22 (CASE J (-6 'D2D3) (6 'D2D1) (-1 'D2C2)))
  65.                 (25 (CASE J (1 'A1B1) (-6 'A1A2)))
  66.                 (26 (CASE J (-1 'B1A1) (-6 'B1B2) (1 'B1C1)))
  67.                 (27 (CASE J (-1 'C1B1) (-6 'C1C2) (1 'C1D1)))
  68.                 (28 (CASE J (-1 'D1C1) (-6 'D1D2))))
  69.                 RES)))))))) RES)
  70.  
  71. (DEFUN MAKE-MOVE (MV BOARD &AUX B TO ME YOU)
  72.  (SETQ B (APPEND BOARD NIL))
  73.  (SETQ ME (CAR B)) (SETQ YOU (IF (EQ ME 'O) '* 'O))
  74.  (COND ((NOT (EQ MV 'PASS)) (SETF (NTH (CAR (EVAL MV)) B) '-)
  75.         (SETF (NTH (SETQ TO (CDR (EVAL MV))) B) ME)
  76.     (DOLIST (I DIRS)
  77.      (COND ((EQ (NTH (+ TO I) B) ME)
  78.             (COND ((AND (EQ (NTH (+ TO I I) B) YOU)
  79.                 (OR (EQ (NTH (- TO I) B) '-)
  80.                 (EQ (NTH (+ TO I I I) B) '-)))
  81.                (SETF (NTH (+ TO I I) B) '-)
  82.                (IF (EQ ME 'O) (SETF (NTH 2 B) (1- (CADDR B)))
  83.                       (SETF (NTH 1 B) (1- (CADR B)))))
  84.               (T (COND ((AND (EQ (NTH (- TO I) B) YOU)
  85.                      (OR (EQ (NTH (- TO I I) B) '-)
  86.                      (EQ (NTH (+ TO I I) B) '-)))
  87.                 (SETF (NTH (- TO I) B) '-)
  88.                 (IF (EQ ME 'O) (SETF (NTH 2 B) (1- (CADDR B)))
  89.                     (SETF (NTH 1 B) (1- (CADR B)))))))))))))
  90.  (SETF (CAR B) YOU) B)
  91.  
  92. (DEFUN EVALUATE (BRDS &AUX BRD) (SETQ BRD (CAR BRDS))
  93.        (IF (REP BRDS) 0 (IF (EQ (CAR BRD) 'O)
  94.                             (COND ((< (CADR BRD) 2) (- *INFINITE*))
  95.                                   ((< (CADDR BRD) 2) *INFINITE*)
  96.                                   (T (- (CADR BRD) (CADDR BRD))))
  97.                             (COND ((< (CADR BRD) 2) *INFINITE*)
  98.                                   ((< (CADDR BRD) 2) (- *INFINITE*))
  99.                                   (T (- (CADDR BRD) (CADR BRD)))))))
  100.  
  101. (DEFUN REP (BRDS)
  102.   (MEMBER (CAR BRDS) (CDR (MEMBER (CAR BRDS) (CDR BRDS) :TEST #'EQUAL))
  103.           :TEST #'EQUAL))
  104.  
  105. (DEFUN CURRENT-PLAYER (BRD) (CAR BRD))
  106.  
  107. (LOAD "game")
  108.