{-# OPTIONS -fglasgow-exts #-}
module PVS (pvs) where
import Data.Tree
import Debug.Trace
import Test.QuickCheck
import System.Random
import Control.Monad
-- Top node reflects the current position
b x = Node x []
testt = Node ("p1_1",1)
[Node ("p2_2_1",2)
[b $ ("p1_3_1",-7), b $ ("p1_3_2",-2)],
Node ("p2_2_1",3)
[b $ ("p1_3_1",-4), b $ ("p1_3_2",-6)],
Node ("p2_2_2",4)
[b $ ("p1_3_3",-2), b $ ("p1_3_4",-5)] ]
showTree x = putStr $ drawTree $ fmap show x
test2 = fmap show testt
test3 = putStr $ drawTree test2
-- straightforward minimax (not even with alpha beta)
negamax node = case node of
Node (move,v) [] -> ([move],v)
Node (move,_) (n:nn) -> (move:pvm, pvv)
where (pvm, pvv) = negaLevel (neg (negamax n)) nn
where negaLevel prev_best@(_,old_v) (n:nn)
= negaLevel best4 nn
where best4 = case neg $ negamax n of
value@(_,v) | v > old_v -> value
| otherwise -> prev_best
negaLevel best _ = best
neg (m,v) = (m,-v)
-- Normal alpha beta
alpha_beta alpha beta node = case node of
Node (move,v) [] -> ([move],v)
Node (move,_) nn -> (move:pvm, pvv)
where (pvm, pvv) = negaLevel ([1010101],-1000) alpha beta nn
where negaLevel prev_best@(_,v1) prev_alpha beta (n:nn) | v1 < beta
= negaLevel best4 alpha beta nn
where best4 = case neg $ alpha_beta (-beta) (-alpha) n of
value@(_,v2) | (v2 > v1) -> value
| otherwise -> prev_best
alpha = if v1 > prev_alpha then v1 else prev_alpha
negaLevel best alpha beta _ = best
neg (m,v) = (m,-v)
-- Principle variation search
-- the search continues as long as alpha < pvs < beta
-- as soon pvs hits one these bounds the search stops and returns best
pvs :: (Num a1, Ord a1) => a1 -> a1 -> [Tree (a, a1)] -> ([a], a1)
pvs alpha beta (n:nn) = case negpvs (-beta) (-alpha) n of
best -> negaLevel best alpha beta nn
where negaLevel prev_best@(_,v1) prev_alpha beta (n:nn) | v1 < beta
= negaLevel best4 alpha beta nn
where best4 = case negpvs (-alpha - 1) (-alpha) n of
value@(_,v2) | (alpha < v2) && (v2 < beta)
-> negpvs (-beta) (-v2) n
| (v2 > v1) -> value
| otherwise -> prev_best
alpha = if v1 > prev_alpha then v1 else prev_alpha
negaLevel best alpha beta _ = best
negpvs alpha beta node = case node of
Node (move,v) [] -> ([move], -v)
Node (move,_) nn -> (move:pvm, -pvv)
where (pvm, pvv) = pvs alpha beta nn
pvs _ _ _ = error "PV Search called with empty list"
pvs_topnode (Node (move,v) []) = ([move],v)
pvs_topnode (Node (move,_) nn) = case pvs (-10000) 10000 nn of
(pvm, pvv) -> (move:pvm, pvv)
test5 = pvs_topnode testt
test6 = negamax testt
rtest n = generate 1000 (mkStdGen n)
test7 = rtest 4 $ choose (1, 10)
test8 = rtest 4 $ (vector 5 :: Gen [Int])
-- Twenty numbers from 1 to 10.
test9 = rtest 4 $ sequence [ choose (1,10) | i <- [1..20] ]
instance (Arbitrary x) => Arbitrary (Tree x) where
arbitrary = sized tree'
where tree' 0 = liftM leaf arbitrary
tree' n | n>0 =
oneof [liftM leaf arbitrary,
liftM2 Node arbitrary leaves]
where subtree = tree' (n `div` 2)
leaves = do n <- choose (1,5)
sequence [ subtree | i <- [1..n] ]
leaf = flip Node []
coarbitrary (Node v nodes) =
variant 0 . coarbitrary v .coarbitrary nodes
test10 :: Tree (Int, Int)
test10 = rtest 14 $ arbitrary
test11 = showTree test10
test12 = pvs_topnode test10
test13 = negamax test10
prop_SameResult :: Tree (Int,Int) -> Bool
prop_SameResult node = case pvs' == negamax' of
True -> True
False -> trace (show (pvs', negamax')) False
where pvs' = pvs_topnode node
negamax' = negamax node
test14 = quickCheck prop_SameResult
test15 = verboseCheck prop_SameResult
test16 = test prop_SameResult
-- beta sets the maximum best score.
-- test17 returns -6 because there is a lower node that returns -6, which is good enough
-- we don't need to search further.
-- i.e. test17 <= beta if there is such a score.
test17 = pvs (-1000) (-6) nodes
where Node _ nodes = testt
-- alpha sets the minimum best score.
-- presumably alpha <= test17 <= beta if there is a valid path for this
test18 = pvs (-1000) 1000 nodes
where Node _ nodes = testt
test19 = pvs (-4) 1000 nodes
where Node _ nodes = testt
test20 = pvs (-100001) (-100000) nodes
where Node _ nodes = testt
test21 = pvs 100000 100001 nodes
where Node _ nodes = testt
testt1 = Node ("p1_1",1)
[Node ("p2_2_1",2)
[b $ ("p1_3_1",-7)],
Node ("p2_2_2",4)
[b $ ("p1_3_3",-2), b $ ("p1_3_4",-5)] ]
test22 = pvs (-1000) 1000 nodes
where Node _ nodes = testt1
testt2 = Node ("p1_1",1)
[Node ("p2_2_2",4)
[b $ ("p1_3_3",-2)] ]
test23 = pvs (-1000) 1000 nodes
where Node _ nodes = testt2
--the only failing test, and it makes sense that this fails.
--test24 = pvs (-1000) 1000 []