-- create a random tree.
randomTree :: Random r => IO (BinaryTree r)
randomTree =
-- randomly pick the left and right sides.
do leftIO <- pick(randomLeaf, randomBranch)
rightIO <- pick(randomLeaf, randomBranch)
-- "un-IO" the sides.
left <- leftIO
right <- rightIO
-- get a random value for the top of the branch/tree.
value <- randomIO
-- create branch and return.
return (Branch left value right)
where
-- return left or right at random.
pick (left, right) =
do useLeft <- randomRIO(True, False)
if useLeft then return left else return right
-- create a random leaf.
randomLeaf =
do value <- randomIO
let leaf = Leaf value
return leaf
-- setup an alias.
randomBranch = randomTree
This code actually works fine, but I'm wondering if there's a way to simplify the "leftIO/rightIO" stuff. Is there some sort of "double arrow" that will un-Monad twice, or is this verbosity unavoidable?
>>29
Sorry to disapoint you, but in this particular case the tree generation isn't lazy, because it's tied to the IO monad.
Name:
Anonymous2008-09-19 1:11
>>43
instance Random r => Random (BinaryTree r) where
randomR (a, b) g = let (useA, g1) = random g in
if useA then (a, g1) else (b, g1)
random g = let (leaf, g1) = random g in
if leaf
then let (value, g2) = random g1 in
(Leaf value, g2)
else let (left, g2) = random g1 in
let (right, g3) = random g2 in
let (value, g4) = random g3 in
(Branch left value right, g4)
There, no monads now. randomR doesn't really work like it's supposed to, but at least now there's no warnings.
Name:
Anonymous2008-09-19 10:17
>>44
I like monads.
import Control.Monad.State
import System.Random
import System
data BinaryTree a = Empty
| Node a (BinaryTree a) (BinaryTree a)
deriving Show
randomS :: (RandomGen s, Random a) => State s a
randomS = State random
randomRS :: (RandomGen s, Random a) => (a, a) -> State s a
randomRS = State . randomR
randomTree :: (RandomGen s, Random a) => State s (BinaryTree a)
randomTree = ([return Empty, randomNode] !!) =<< randomRS (0, 1)
randomNode :: (RandomGen s, Random a) => State s (BinaryTree a)
randomNode = liftM3 Node randomS randomTree randomTree
instance Random a => Random (BinaryTree a) where
--random = runState randomTree
random = runState randomNode
prune 0 _ = Empty
prune height tree
| height < 0 = error "prune: height must be non-negative"
| otherwise =
case tree of (Node v l r) -> Node v (ascend l) (ascend r)
Empty -> Empty
where ascend = prune (height - 1)
One of these days I need to set aside a week or so, hike out into the mountains with a copy of the Haskell documentation and just spend the week in quiet meditation reading and completing the exercises until I have some comprehension of this strange and wonderful language.
>>43,44
Despite the tree generation now being lazy, pruning a resulting tree still wouldn't guarantee termination upon printing. That's because each node's generation depends on state created by the generation of all nodes to its left. For pruning to do what's expected you have to split the random generator before each recursion in the tree generation.
import Control.Monad.State
import Control.Arrow
import System.Random
import System
data BinaryTree a = Empty
| Node a (BinaryTree a) (BinaryTree a)
deriving Show
randomRS :: (RandomGen g, Random a) => (a, a) -> State g a
randomRS bounds = State $ randomR bounds
splitS :: RandomGen g => State g a -> State g a
splitS fork = State $ first (evalState fork) . split
randomTreeS :: (RandomGen g, Random a, Eq a) => (a, a) -> State g (BinaryTree a)
randomTreeS bounds@(l, r)
| l == r = return Empty
| otherwise = do v <- randomRS bounds
splitS $ liftM2 (Node v) (randomTreeS (l, v))
(randomTreeS (v, r))
instance (Random a, Bounded a, Eq a) => Random (BinaryTree a) where
randomR = error "randomR: (BinaryTree a) does not implement this method"
random = runState $ randomTreeS (minBound, maxBound)
prune :: Integral i => i -> BinaryTree a -> BinaryTree a
prune 0 _ = Empty
prune height tree
| height < 0 = error "prune: height must be non-negative"
| otherwise =
case tree of Node v l r -> Node v (ascend l) (ascend r)
Empty -> Empty
where ascend = prune (height - 1)
main :: IO ()
main = print =<< liftM2 prune (fmap (read . head) getArgs)
(randomIO :: IO (BinaryTree Int))