module Math.RandomTree.Algorithms where
import Data.Maybe
import Data.Tree
import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Applicative
--Cabal
import Control.Monad.Random
import Control.Lens ((??))
import Math.TreeFun.Tree
import Math.TreeFun.Types
import Math.RandomTree.Types
import Math.RandomTree.Label
runTree :: ReaderStateRandom a
-> Int
-> Int
-> Int
-> Int
-> StdGen
-> Maybe a
runTree start minS maxS minC maxC g
| minS > maxS = error "Minimum size is larger than maximum size."
| otherwise = (evalRand ?? g)
. runMaybeT
. (evalStateT ?? treeState)
. (runReaderT ?? treeConfig)
. runReaderStateRandom
$ start
where
treeState = TreeState { size = 0 }
treeConfig = TreeConfig { maxSize = maxS
, minSize = minS
, minChildren = minC
, maxChildren = maxC }
treeRecursion :: ReaderStateRandom (Tree Int)
treeRecursion = do
treeConfig <- ask
treeState <- get
when (size treeState > maxSize treeConfig) mzero
when ( size treeState >= minSize treeConfig
&& size treeState <= maxSize treeConfig )
$ return ()
put (treeState { size = size treeState + 1 })
r <- getRandomR (minChildren treeConfig, maxChildren treeConfig)
if r == minChildren treeConfig
then return Node { rootLabel = size treeState, subForest = [] }
else do
newSubForest <- replicateM r treeRecursion
return Node { rootLabel = size treeState
, subForest = newSubForest }
checkLowerBound :: ReaderStateRandom (Tree Int)
checkLowerBound = do
put TreeState { size = 0 }
tree <- treeRecursion
treeState <- get
treeConfig <- ask
guard $ size treeState >= minSize treeConfig
return tree
getTree :: ReaderStateRandom (Tree Int)
getTree = checkLowerBound `mplus` getTree
makeTree :: [String]
-> Int
-> Int
-> Int
-> Int
-> Int
-> Bool
-> IO (PropertySuperTree String String)
makeTree propertyList neighborDistance minS maxS minC maxC clumpBool = do
gen1 <- newStdGen
gen2 <- newStdGen
let (Just intTree) = runTree getTree minS maxS minC maxC gen1
tree = show <$> intTree
propertyMap = emptyPropertyMap . leaves $ tree
filledPropertyList = take (length . leaves $ tree)
. concat
. repeat
$ propertyList
currentSuperTree = toSuperNodeTree SuperRoot $ tree
newPropertyMap = assignRandomClumpedProperties
filledPropertyList
neighborDistance
currentSuperTree
gen2
propertyMap
newUniformPropertyMap = assignRandomProperties
filledPropertyList
gen2
propertyMap
if clumpBool
then return
$ PropertySuperTree { superTree = currentSuperTree
, superProperties = M.map fromJust newPropertyMap }
else return
$ PropertySuperTree { superTree = currentSuperTree
, superProperties = M.map fromJust newUniformPropertyMap }