Principal variation search

{-# 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 []