twisty-0.1.0: Twisty/Searching.hs

{-
Copyright 2011 Google Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

{-# LANGUAGE FlexibleContexts #-}

-- | Functions for finding algorithms that satisfy some given conditions.
module Twisty.Searching where

import Twisty.Group
import Twisty.Puzzle

import Control.Monad
import Control.Monad.Random
import Control.Parallel.Strategies
import Data.Set (Set)
import qualified Data.Set as Set


-- | Given a root node, and a way to calculate the children of a node, does a
-- parallel depth-first walk of the implied tree looking for nodes that satisfy
-- a given predicate.  We wrap the search in a monad, to allow for randomness
-- and I/O in the callbacks.
--
-- Typically the trees in question will be successive algorithms through a
-- twisty puzzle.  We've generalized the types to allow for additional state to
-- be included with the algorithms, for efficiency's sake: this extra state can
-- be maintained incrementally rather than recalculated for each node.
searchTree :: (Monad m) => (a -> Bool -> m [a]) -> (a -> m Bool) -> m a -> m [a]
searchTree calcChildren satisfies root = root >>= st
  where st node = do
          sat <- satisfies node
          let this = [return [node] | sat]
          children <- calcChildren node sat
          let results = this ++ map st children
          concatM results


concatM :: (Monad m) => [m [a]] -> m [a]
concatM = liftM concat . sequence

-- | For nodes that encapsulate twisty algorithms, produces a list of successor
-- algorithms given a way to generate moves.
generateChildren :: (Monad m, Puzzle p, Ord (Move p)) =>
                    (a -> Algorithm p) -> (a -> m (Move p)) -> Int -> a -> m [Algorithm p]
generateChildren getAlg genMove count node = collect 0 Set.empty []
  where alg = getAlg node
        collect n seen algs
          | n >= count  = return algs
          | otherwise   = do mv <- genMove node
                             if mv `Set.member` seen then collect n seen algs
                               else let alg' = alg `applyMove` mv
                                        seen' = mv `Set.insert` seen
                                    in if isNontrivial alg' && lastMove alg' == mv
                                       then collect (n+1) seen' (alg':algs)
                                       else collect n seen' algs

-- | Stops generating children after reaching algorithms of a particular length.
generateChildrenToLength :: (Monad m, Puzzle p, Ord (Move p)) =>
                            Int -> (a -> Algorithm p) -> (a -> m (Move p)) -> Int -> a -> m [Algorithm p]
generateChildrenToLength len getAlg genMove count node =
  if (moveCount . getAlg) node >= len
  then return []
  else generateChildren getAlg genMove count node


-- | Returns a stream of deterministic random number generators given a seed.
seededStdGens :: Int -> IO [StdGen]
seededStdGens = return . stdGenToStream . mkStdGen

-- | A stream of random number generators.
stdGenStream :: IO [StdGen]
stdGenStream = fmap stdGenToStream newStdGen

-- | Returns a stream of random number generators given an initial generator.
stdGenToStream :: StdGen -> [StdGen]
stdGenToStream gen = let (g1, g2) = split gen in g1 : stdGenToStream g2