Skip to content

Instantly share code, notes, and snippets.

@smihica
Created July 26, 2012 04:57
Show Gist options
  • Save smihica/3180343 to your computer and use it in GitHub Desktop.
Save smihica/3180343 to your computer and use it in GitHub Desktop.
オセロの自動プレイ
(= 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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment