Implementing memorized alpha beta search. Split Search.hs to Interfac…

…e and Impl. Impls will be stored under Internal dir going forward.

hamilcar.cabal

@@ -5,7 +5,7 @@ cabal-version:     >= 1.2
 
 executable hamilcar
   main-is:         Main.hs
-  hs-source-dirs:  src
+  hs-source-dirs:  src,src/Internal
   ghc-options:     -Wall -O2 -fno-warn-unused-do-bind
   build-depends:   base,
                    bytestring,
@@ -14,7 +14,7 @@ executable hamilcar
 Test-Suite Test
   type:       exitcode-stdio-1.0
   main-is:    Main.hs
-  hs-source-dirs:  src/test, src
+  hs-source-dirs:  src/test, src, src/Internal
   ghc-options:     -W -O2
   build-depends:    base,
                     HUnit,

hamilcar.iml

@@ -1,10 +1,8 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<module type="HASKELL_MODULE" version="4">
+<module type="WEB_MODULE" version="4">
   <component name="NewModuleRootManager" inherit-compiler-output="true">
     <exclude-output />
-    <content url="file://$MODULE_DIR$">
-      <sourceFolder url="file://$MODULE_DIR$/src" isTestSource="false" />
-    </content>
+    <content url="file://$MODULE_DIR$" />
     <orderEntry type="inheritedJdk" />
     <orderEntry type="sourceFolder" forTests="false" />
   </component>

src/Internal/Search.hs

@@ -0,0 +1,64 @@
+module Internal.Search where
+-- friends
+import qualified Board
+import qualified Move
+import qualified MoveGenerator
+import qualified Eval
+-- GHC
+
+-- libraries
+
+-- std
+import Data.Function
+import Data.List
+
+-- type Dep = Int
+
+-- type Cnt = Int
+
+data Result = Result {va :: Int, pv :: [Move.Mv]} deriving (Eq, Ord)
+
+data Tree n = Node {node :: n, childNodes :: [Tree n]} deriving (Show)
+
+conv :: Move.Mv -> Result -> Result
+conv mv res = Result (-va res) (mv : pv res)
+
+minmax :: Int -> Board.Bd -> Result
+minmax 0 bd = Result (Eval.eval bd) []
+minmax dep bd = maximumBy (compare `on` va) nexts
+    where
+        nexts = map next $ MoveGenerator.mvGenFull bd
+        next mv = conv mv . minmax (dep - 1) $ Board.bdDo bd mv
+
+{-
+ -  f - function to replace Node
+ -  g - function to replace Cons
+ -  a - something to replace Nil
+ -}
+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
+
+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
+
+maximize Node {node = n, childNodes = []} = n
+maximize Node {node = n, childNodes = c} = maximum (map minimize c)
+minimize Node {node = n, childNodes = []} = n
+minimize Node {node = n, childNodes = c} = minimum (map maximize c)
+
+prune 0 Node {node = n, childNodes = c} = Node n []
+prune r Node {node = n, childNodes = c} = Node n $ map (prune (r - 1)) c
+
+evaluate = maximize . maptree Eval.eval . (prune 5) . gametree

src/MoveGenerator.hs

@@ -69,9 +69,10 @@ allInNoCheck (Board.Bd sqs _ me _ pcl) =
                                         $ Util.if' (canNoPro pc fr to, [Move.Mv fr to pc cap False], [])
 
 mvGenFullN :: Board.Bd -> [Move.Mv]
-mvGenFullN bd = (allInNoCheckN bd mvAddCaptures) ++ (allInNoCheckN bd mvAddNoCaptures) ++ dropMvs bd
-
-
+mvGenFullN bd =
+    (allInNoCheckN bd mvAddCaptures) ++
+    (allInNoCheckN bd mvAddNoCaptures) ++
+    dropMvs bd
 
 {- Move from cur to the direction of inc.
  - Returns the possible motion from cur to inc
@@ -91,11 +92,6 @@ incMvs me pc sqs from cur mvAdd inc =
     where
         to = cur + inc
         cap = sqs ! to
---        mvAdd =
---            -- Move and promotion, capture if possible
---            Util.if' (canPro pc from to, (Move.Mv from to pc cap True :), id)
---            -- Move and NO promotion, capture if possible
---            $ Util.if' (canNoPro pc from to, [Move.Mv from to pc cap False], [])
 
 mvAddNoCaptures :: Piece.Pc -> Piece.Pos -> Piece.Pos -> Piece.Pc -> [Move.Mv]
 mvAddNoCaptures pc from to cap =

src/Search.hs

@@ -2,31 +2,32 @@ module Search (
     Result (..),
     minmax,
 ) where
--- friends
-import qualified Board
-import qualified Move
-import qualified MoveGenerator
-import qualified Eval
--- GHC
-
--- libraries
-
--- std
-import Data.Function
-import Data.List
-
--- type Dep = Int
-
--- type Cnt = Int
-
-data Result = Result {va :: Int, pv :: [Move.Mv]} deriving (Eq, Ord)
-
-conv :: Move.Mv -> Result -> Result
-conv mv res = Result (-va res) (mv : pv res)
-
-minmax :: Int -> Board.Bd -> Result
-minmax 0 bd = Result (Eval.eval bd) []
-minmax dep bd = maximumBy (compare `on` va) nexts
-    where
-        nexts = map next $ MoveGenerator.mvGenFull bd
-        next mv = conv mv . minmax (dep - 1) $ Board.bdDo bd mv
+import Internal.Search
+---- friends
+--import qualified Board
+--import qualified Move
+--import qualified MoveGenerator
+--import qualified Eval
+---- GHC
+--
+---- libraries
+--
+---- std
+--import Data.Function
+--import Data.List
+--
+---- type Dep = Int
+--
+---- type Cnt = Int
+--
+--data Result = Result {va :: Int, pv :: [Move.Mv]} deriving (Eq, Ord)
+--
+--conv :: Move.Mv -> Result -> Result
+--conv mv res = Result (-va res) (mv : pv res)
+--
+--minmax :: Int -> Board.Bd -> Result
+--minmax 0 bd = Result (Eval.eval bd) []
+--minmax dep bd = maximumBy (compare `on` va) nexts
+--    where
+--        nexts = map next $ MoveGenerator.mvGenFull bd
+--        next mv = conv mv . minmax (dep - 1) $ Board.bdDo bd mv

src/test/Main.hs

@@ -4,6 +4,7 @@ import qualified Usi
 import qualified Board
 import qualified Move
 import qualified MoveGenerator
+import qualified Internal.Search as IS
 -- GHC
 
 -- libraries
@@ -17,8 +18,15 @@ import Data.List
 
 main :: IO ()
 main = do
+    defaultMain $ hUnitTestToTests $ TestLabel "newMoveValidation" $ TestCase mapRep
     defaultMain $ hUnitTestToTests $ TestLabel "newMoveValidation" $ TestCase moveComp
 
+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
     let board = Usi.bdFromSfen [
             "l6nl/5+P1gk/2nl1S3/p1p4Pp/3P2Sp1/1PPb2P1P/P5KS1/R8/LN4bKL",