content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  module Strategies
    ( bfsSearch, dfsSearch, parSearch
    , idsSearch, idsDefaultDepth, idsDefaultIncr
    ) where
  
  import Control.Monad.SearchTree
  import Control.Parallel.TreeSearch (parSearch)
  
  import MonadSearch
  
  instance MonadSearch SearchTree where
    constrainMSearch _ _ x = x
    var              x _   = x
  
  -- |Breadth-first search
  bfsSearch :: SearchTree a -> [a]
  bfsSearch t = bfs [t]
    where
    bfs [] = []
    bfs ts = values ts ++ bfs (children ts)
  
    values []           = []
    values (One x : ts) = x : values ts
    values (_     : ts) = values ts
  
    children []                = []
    children (Choice x y : ts) = x : y : children ts
    children (_          : ts) = children ts
  
  -- |Depth first search
  dfsSearch :: SearchTree a -> [a]
  dfsSearch None         = []
  dfsSearch (One      x) = [x]
  dfsSearch (Choice x y) = dfsSearch x ++ dfsSearch y
  
  idsDefaultDepth :: Int
  idsDefaultDepth = 100
  
  idsDefaultIncr :: Int -> Int
  idsDefaultIncr = (*2)
  
  -- |Return all values in a search tree via iterative-deepening search.
  -- The first argument is the initial depth bound and
  -- the second argument is a function to increase the depth in each
  -- iteration.
  idsSearch :: Int -> (Int -> Int) -> SearchTree a -> [a]
  idsSearch initdepth incr st = iterIDS initdepth (collectBounded 0 initdepth st)
    where
    iterIDS _ Nil         = []
    iterIDS n (Cons x xs) = x : iterIDS n xs
    iterIDS n Abort       = let newdepth = incr n
                            in  iterIDS newdepth (collectBounded n newdepth st)
  
  -- |Collect solutions within some level bounds in a tree.
  collectBounded :: Int -> Int -> SearchTree a -> AbortList a
  collectBounded oldbound newbound st = collectLevel newbound st
    where
    collectLevel _ None          = Nil
    collectLevel d (One      x)
      | d <= newbound - oldbound = x `Cons` Nil
      | otherwise                = Nil
    collectLevel d (Choice x y)
      | d > 0     = collectLevel (d-1) x +! collectLevel (d-1) y
      | otherwise = Abort
  
  -- |List containing 'Abort's to implement the iterative depeening strategy
  data AbortList a = Nil | Cons a (AbortList a) | Abort
  
  -- |Concatenation on abort lists where aborts are moved to the right
  (+!) :: AbortList a -> AbortList a -> AbortList a
  (+!) Abort       Abort       = Abort
  (+!) Abort       Nil         = Abort
  (+!) Abort       (Cons x xs) = x `Cons` (Abort +! xs)
  (+!) Nil         ys          = ys
  (+!) (Cons x xs) ys          = x `Cons` (xs +! ys)
  