Implemented memorizes/lazy alpha beta search. Need to fit it to the f…

…orm of Result.
ysnrkdm · Dec 7, 2014 · bfce85c · bfce85c
1 parent f9fa917
commit bfce85c
Show file tree

Hide file tree

Showing 6 changed files with 140 additions and 37 deletions.
diff --git a/hamilcar.cabal b/hamilcar.cabal
@@ -4,18 +4,36 @@ Build-Type:        Simple
 cabal-version:     >= 1.2
 
 executable hamilcar
-  main-is:         Main.hs
-  hs-source-dirs:  src,src/Internal
-  ghc-options:     -Wall -O2 -fno-warn-unused-do-bind
-  build-depends:   base,
-                   bytestring,
-                   array
+  main-is:          Main.hs
+  hs-source-dirs:   src,
+                    src/Internal
+  ghc-options:      -O2
+--                    -fllvm
+  build-depends:    base,
+                    bytestring,
+                    array
+
+executable movegenbench
+  main-is:          Main.hs
+  hs-source-dirs:   src/bench,
+                    src,
+                    src/Internal
+  ghc-options:      -O2
+--                    -fllvm
+  build-depends:    base,
+                    bytestring,
+                    array,
+                    criterion
 
 Test-Suite Test
-  type:       exitcode-stdio-1.0
-  main-is:    Main.hs
-  hs-source-dirs:  src/test, src, src/Internal
-  ghc-options:     -W -O2
+  type:             exitcode-stdio-1.0
+  main-is:          Main.hs
+  hs-source-dirs:   src/test,
+                    src/,
+                    src/Internal
+  ghc-options:      -O2
+--                    -fllvm
+                    -prof -fprof-auto -rtsopts
   build-depends:    base,
                     HUnit,
                     test-framework,

diff --git a/src/Board.hs b/src/Board.hs
@@ -84,13 +84,14 @@ bdDo bd mv =
             (//. [(pc, subtract 1)])
             Util.oppEn (+ 1)
             (//. [(pc, (to :))])
-        (Move.Mv fr to pc cap isPro) -> let tPc = (isPro |+> Piece.pcOppPro) pc in
-            bdModify bd
-            (// [(fr, Piece.Empty), (to, tPc)])
-            (cap /= Piece.Empty |+> (//. [(Piece.pcOppCo . Piece.unpPc $ cap, (+ 1))]))
-            Util.oppEn (+ 1)
-            ((//. [(tPc, (to :))]) . (//. ((pc, delete fr) :
-                Util.if' (cap /= Piece.Empty, [(cap, delete to)], []))))
+        (Move.Mv fr to pc cap isPro) ->
+            let tPc = (isPro |+> Piece.pcOppPro) pc in
+                bdModify bd
+                (// [(fr, Piece.Empty), (to, tPc)])
+                (cap /= Piece.Empty |+> (//. [(Piece.pcOppCo . Piece.unpPc $ cap, (+ 1))]))
+                Util.oppEn (+ 1)
+                ((//. [(tPc, (to :))]) . (//. ((pc, delete fr) :
+                    Util.if' (cap /= Piece.Empty, [(cap, delete to)], []))))
 bdUndo bd mv =
     case mv of
         (Move.Drop to pc) ->

diff --git a/src/Eval.hs b/src/Eval.hs
@@ -3,6 +3,7 @@ module Eval (
 ) where
 -- friends
 import Util ((|->))
+import qualified Util
 import qualified Piece
 import qualified Board
 -- GHC
@@ -16,6 +17,7 @@ import Data.List
 import Data.Int
 import Data.Word
 import System.IO.Unsafe
+import Debug.Trace
 
 type Va = Int
 
@@ -24,7 +26,20 @@ type Va = Int
 -- type Be = Int
 
 eval :: Board.Bd -> Va
-eval bd = matVa bd + bonaVa bd
+eval bd =
+--    trace ("Evaluating : " ++ (show bd)) $
+    if terminated bd /= 0
+        then
+--            trace ("Terminated!" ++ (show $ terminated bd))
+            terminated bd
+        else
+            matVa bd + bonaVa bd
+
+-- Simple termination check
+terminated (Board.Bd _ _ co _ pcl)
+    | length (pcl ! Piece.Pc co Piece.Unp Piece.OU) == 0 = -999999
+    | length (pcl ! Piece.Pc (Util.oppEn co) Piece.Unp Piece.OU) == 0 = 999999
+    | otherwise = 0
 
 matVa :: Board.Bd -> Va
 matVa (Board.Bd _ hs co _ pcl) = co == Piece.B |-> negate $
@@ -42,9 +57,7 @@ pcVa = (!) $ listArray Piece.pcBnd (a ++ negate `fmap` a)
             ]
 
 fv :: Int -> Va
-fv i = (fromIntegral :: Int8 -> Int) . (fromIntegral :: Word8 -> Int8) $
-    BS.head $
-    BS.drop i fvbin
+fv i = (fromIntegral :: Int8 -> Int) . (fromIntegral :: Word8 -> Int8) $ BS.index fvbin i
 
 fvbin :: BS.ByteString
 fvbin = unsafePerformIO $ BS.readFile "./fv.bin"
@@ -107,7 +120,8 @@ bonaPos co sqq = if co == Piece.B then a ! sqq else b ! sqq
         b = listArray (0, 220) [(80 -) $ sq `quot` 17 * 9 + sq `rem` 17 - 22 | sq <- [0 .. 220]]
 
 posK :: Board.Pcl -> (Piece.Co, Piece.Co) -> Piece.Pos
-posK pcl (kingColor, pieceColor) = bonaPos pieceColor . head $
+posK pcl (kingColor, pieceColor) =
+    bonaPos pieceColor . head $
     pcl ! Piece.Pc kingColor Piece.Unp Piece.OU
 
 bonaVa :: Board.Bd -> Va

diff --git a/src/Internal/Search.hs b/src/Internal/Search.hs
@@ -11,12 +11,16 @@ import qualified Eval
 -- std
 import Data.Function
 import Data.List
+import Data.Ord
+import Debug.Trace
 
 -- type Dep = Int
 
 -- type Cnt = Int
 
 data Result = Result {va :: Int, pv :: [Move.Mv]} deriving (Eq, Ord)
+instance Show Result where
+    show (Result va pv) = "va: " ++ (show va) ++ ", pv : " ++ (show pv)
 
 data Tree n = Node {node :: n, childNodes :: [Tree n]} deriving (Show)
 
@@ -37,28 +41,64 @@ minmax dep bd = maximumBy (compare `on` va) nexts
  -}
 redtree :: (t -> t1 -> t2) -> (t2 -> t1 -> t1) -> t1 -> Tree t -> t2
 redtree f g a Node {node = n, childNodes = c} = f n (redtree' f g a c)
---redtree' :: (t -> t1 -> t2) -> (t2 -> t1 -> t1) -> t1 -> Tree t -> t1
 redtree' f g a (hd : rest) = g (redtree f g a hd) (redtree' f g a rest)
 redtree' f g a [] = a
 
---maptree :: Tree t -> Tree b
 maptree f = redtree (Node . f) (:) []
 
-moves :: Board.Bd -> [Board.Bd]
-moves bd = map (Board.bdDo bd) $ MoveGenerator.mvGenFull bd
+moves :: (Board.Bd, Result) -> [(Board.Bd, Result)]
+moves (bd, result) =
+    map (\ x -> (Board.bdDo bd x, (conv x result))) $ MoveGenerator.mvGenFull bd
 
 reptree :: (t -> [t]) -> t -> Tree t
 reptree f a = Node a (map (reptree f) (f a))
 
-gametree :: Tree Board.Bd -> Tree Board.Bd
-gametree p = reptree moves $ node p
+gametree :: Board.Bd -> Tree (Board.Bd, Result)
+gametree p = reptree moves $ (p, Result 0 [Move.Nil])
 
 maximize Node {node = n, childNodes = []} = n
-maximize Node {node = n, childNodes = c} = maximum (map minimize c)
+maximize Node {node = _, childNodes = c} = maximum (map minimize c)
 minimize Node {node = n, childNodes = []} = n
-minimize Node {node = n, childNodes = c} = minimum (map maximize c)
+minimize Node {node = _, childNodes = c} = minimum (map maximize c)
 
-prune 0 Node {node = n, childNodes = c} = Node n []
+prune 0 Node {node = n, childNodes = _} = Node n []
 prune r Node {node = n, childNodes = c} = Node n $ map (prune (r - 1)) c
 
-evaluate = maximize . maptree Eval.eval . (prune 5) . gametree
+-- minmax method
+evaluate = maximize . maptree (Eval.eval . fst) . (prune 3) . gametree
+
+-- alpha beta method
+maximize' Node {node = n, childNodes = []} = n : []
+maximize' Node {node = _, childNodes = c} = mapmin (map minimize' c)
+minimize' Node {node = n, childNodes = []} = n : []
+minimize' Node {node = _, childNodes = c} = mapmax (map maximize' c)
+
+-- map min/max
+mapmin (nums : rest) = (minimum nums) : (omitmin (minimum nums) rest)
+mapmax (nums : rest) = (maximum nums) : (omitmax (maximum nums) rest)
+
+omitmin pot [] = []
+omitmin pot (nums : rest)
+    | minleq nums pot = omitmin pot rest
+    | otherwise = (minimum nums) : (omitmin (minimum nums) rest)
+
+minleq [] pot = False
+minleq (num : rest) pot
+    | num <= pot = True
+    | otherwise = minleq rest pot
+
+omitmax pot [] = []
+omitmax pot (nums : rest)
+    | maxgeq nums pot = omitmax pot rest
+    | otherwise = (maximum nums) : (omitmax (maximum nums) rest)
+
+maxgeq [] pot = False
+maxgeq (num : rest) pot
+    | num >= pot = True
+    | otherwise = maxgeq rest pot
+
+highfirst Node {node = n, childNodes = c} = Node n (sortBy (comparing node) (map lowfirst c))
+lowfirst Node {node = n, childNodes = c} = Node n (sortBy (flip $ comparing node) (map highfirst c))
+
+-- alphabeta
+alphabeta = maximum . maximize' . highfirst . maptree (Eval.eval . fst) . (prune 3) . gametree
diff --git a/src/Move.hs b/src/Move.hs
@@ -15,7 +15,8 @@ import Control.Applicative
 import Data.Array
 
 data Mv =
-      Drop {dropTo :: Piece.Pos, dropPc :: Piece.Pc}
+      Nil
+    | Drop {dropTo :: Piece.Pos, dropPc :: Piece.Pc}
     | Mv {
         fr :: Piece.Pos,
         to :: Piece.Pos,
@@ -28,6 +29,7 @@ instance Show Mv where
     show (Drop to pc) = dropToUSI pc ++ Util.notation to
     -- Move is shown as 00XX(00)+, e.g., moving white bishop from 66 to 57 is 57WB(66). Promotion adds + at the end.
     show (Mv fr to pc _ isPro) = Util.notation to ++ show pc ++ "(" ++ Util.notation fr ++ ")" ++ Util.if' (isPro, "+", "")
+    show Nil = "Nil"
 
 isCapture = (/= Piece.Empty) . cap
 

diff --git a/src/test/Main.hs b/src/test/Main.hs
@@ -18,23 +18,51 @@ import Data.List
 
 main :: IO ()
 main = do
-    defaultMain $ hUnitTestToTests $ TestLabel "newMoveValidation" $ TestCase mapRep
-    defaultMain $ hUnitTestToTests $ TestLabel "newMoveValidation" $ TestCase moveComp
+    print "Running test ..."
+--    defaultMain $ hUnitTestToTests $ TestLabel "mapRep" $ TestCase mapRep
+--    defaultMain $ hUnitTestToTests $ TestLabel "moveComp" $ TestCase moveComp
+    defaultMain $ hUnitTestToTests $ TestLabel "searchTest" $ TestCase searchTest
+    defaultMain $ hUnitTestToTests $ TestLabel "alphabetaTest" $ TestCase alphabetaTest
 
 mapRep = do
     let tree = IS.Node 10 [IS.Node 20 [IS.Node 30 []], IS.Node 15 [IS.Node 20 [], IS.Node 40 []]]
     print tree
     print $ IS.maptree (\x -> x + 10) tree
---    IS.
 
-moveComp = do
+searchTest = do
     let board = Usi.bdFromSfen [
             "l6nl/5+P1gk/2nl1S3/p1p4Pp/3P2Sp1/1PPb2P1P/P5KS1/R8/LN4bKL",
             "w",
             "GR5pnsg" ]
     printf "board is now\n"
     print board
     printf "\n"
+    print "start searching by minmax..."
+    let val = IS.evaluate board
+    print "done. val is"
+    print val
+
+alphabetaTest = do
+    let board = Usi.bdFromSfen [
+            "l6nl/5+P1gk/2nl1S3/p1p4Pp/3P2Sp1/1PPb2P1P/P5GS1/R8/LN4bKL",
+            "w",
+            "GR5pnsg" ]
+    printf "board is now\n"
+    print board
+    printf "\n"
+    print "start searching by alphabeta..."
+    print "done. val is"
+    let val = IS.alphabeta board
+    print val
+
+moveComp = do
+    let board = Usi.bdFromSfen [
+            "l6nl/5+P1gk/2nl1S3/p1p4Pp/3P2Sp1/1PPb2P1P/P5GS1/R8/LN4bKL",
+            "w",
+            "GR5pnsg" ]
+    printf "board is now\n"
+    print board
+    printf "\n"
     let moves = sort $ MoveGenerator.mvGenFull board
     let movess = sort $ MoveGenerator.mvGenFullN board
     print moves