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

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.

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

main = print =<< liftM2 prune (fmap (read . head) getArgs)
                              (randomIO :: IO (BinaryTree Int))