オセロの自動プレイ

$  arc < reversi.arc

で起動すると、オセロを自動プレイする。
AIは単純なαβ探索で5手先まで読む、中盤からは毎回手筋が変わる。

reversi.arc

(= poss (map (fn (x) (map (fn (y) (cons x y)) (range 0 7))) (range 0 7)))

(def setxy ((x . y) b c)
  (if (and (<= 0 x) (< x 8) (<= 0 y) (< y 8))
      (+ (firstn y b)
         (let cd (nthcdr y b)
           (+ (let l (copy (car cd)) (= (l x) c) (list l)) (cdr cd))))
      b))

(def getxy ((x . y) b) (if (and (<= 0 x) (< x 8) (<= 0 y) (< y 8)) ((b y) x)))
(def setxys (poss b c) (if poss (setxys (cdr poss) (setxy (car poss) b c) c) b))

(def get-around-poss (p1 n)
  (let f (list (fn (x) (- x n)) (fn (x) x) (fn (x) (+ x n)))
    (rem [iso _ p1]
         (mappend (fn (f1) (map (fn (f2)
                                  (cons (f1 (car p1)) (f2 (cdr p1))))
                                f))
                  f))))

(def get-around-posss (p)
  (apply map list (map (fn (n) (get-around-poss p n)) (range 1 7))))

(def con (c) (case c w 'b b 'w))
(def get-possible-around-poss (p b c)
  (mappend
    (fn (ps)
      ((afn (p acc)
         (if p
             (aif (getxy (car p) b)
                  (if (is c it)       (rev acc)
                      (is (con c) it) (self (cdr p) (cons (car p) acc))))))
       ps '()))
    (get-around-posss p)))

(def can-put? (p b c) (and (is (getxy p b) 'g) (get-possible-around-poss p b c)))

(def get-puttable-poss (b c)
  (mappend (fn (l) (mappend (fn (i) (if (can-put? i b c) (list i))) l)) poss))

(def put (p b c) (setxys (+ (get-possible-around-poss p b c) (list p)) b c))

(def get-points (b c)
  (apply + (mappend (fn (bl evl) (mappend (fn (bi evi) (if (is bi c) (list evi))) bl evl)) b ev-tbl)))

(def get-rand (l n)
  (if (> n 0) (if (>= n (len l)) l (let x (rand-elt l) (cons x (get-rand (rem x l) (- n 1)))))))

(def get-best (b c d)
  ((afn (b c d fc al be)
    (if (or (is d 0) (no (find [find 'g _] b))) ;; last-depth or game-set                                                                                                         
        (cons (get-points b fc) nil)
        (let my-turn (is fc c)
          (aif (get-puttable-poss b c)

               (ccc
                 (fn (cc)
                   (best (fn (a b) ((if my-turn > <) (car a) (car b)))
                         (map
                           (fn (vp)
                             (let nb (put vp b c)
                               (let pt (self nb (con c) (- d 1) fc al be)
                                 (let cpt (car pt)
                                   (if my-turn
                                       (when (> cpt al)
                                         (= al cpt)
                                         (if (>= al be) (cc (cons be vp))))  ;; alpha-cut                                                                                         
                                       (when (< cpt be)
                                         (= be cpt)
                                         (if (>= al be) (cc (cons al vp))))))  ;; beta-cut                                                                                        
                                 (scdr pt vp) pt)))
                           (get-rand it ev-space))))) ;; cut-off if candidates are over space.                                                                                    

               (self b (con c) (- d 1) fc al be))))) ;; pass                                                                                                                      

   b c d c -inf.0 +inf.0))

(def print-board (b)
  (each l b
    (each i l
      (pr (case i
        g "--"
        w "○"
        b "●"
        )))
    (pr "\n")))

(= ev-tbl '((400 -2  4  0  0  4 -2  400)
            ( -2 -50 0  0  0  0 -50 -2)
            (  4  0  4  0  0  4  0  4)
            (  0  0  0  0  0  0  0  0)
            (  0  0  0  0  0  0  0  0)
            (  4  0  4  0  0  4  0  4)
            ( -2 -50 0  0  0  0 -50 -2)
            (400 -2  4  0  0  4 -2  400)))

(def get-stone-number (b c)
  (apply + (map (fn (l) (count c l)) b)))

(= ev-depth 5)
(= ev-space 10)

(def game ()
  (with (b (n-of 8 (n-of 8 'g)) turn 'b n 0)
    (= b (setxys '((4 . 3) (3 . 4)) (setxys '((3 . 3) (4 . 4)) b 'w) 'b))
    (pr "\n\n\n\n\n\n *** NEW GAME START *** \n\n")
    (while (find [find 'g _] b)
           (print-board b)
           (pr "\n")
           (pr "TURN " n ": " (if (is turn 'b) "BLACK" "WHITE") "\n")
           (pr "POINT: " (get-points b turn) "\n")
           (= b (let pos (cdr (get-best b turn ev-depth))
                  (if pos
                      (do
                        (pr "PUT: " pos "\n")
                        (put pos b turn))
                      b)))
           (= turn (con turn))
           (++ n)
           (pr "\n"))

    (with (wnum (get-stone-number b 'w) bnum (get-stone-number b 'b))
      (pr "WHITE: " wnum "\n")
      (pr "BLACK: " bnum "\n\n\n")
      (pr (if (> wnum bnum)
              " !!! WHITE is won !!!\n\n\n" 
              (> bnum wnum)
              " !!! BLACK is won !!!\n\n\n"
              " !!! DRAW !!!\n\n\n")))))

(while t (game) (sleep 20))