Haskell help, /prog/!


-- 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?

>>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))