Main.hs

{-# LANGUAGE BangPatterns #-}

module Main where
import System.Random (randomRIO)
import Data.Monoid (Sum(..),(<>))
import Data.Tree

main :: IO ()
main = main'

main' :: IO ()
main' = do
  tree <- unfoldTreeM_BF gen 24
  let f x [] = x
      f x xs = x + maximum xs
  print $ foldTree f tree

foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f = go where
    go (Node x ts) = f x (map go ts)

gen :: Int -> IO (Int,[Int])
gen n = do
  r <- randomRIO (1,10)
  return (r,if n == 0 then [] else [n-1,n-1])

main'' :: Int -> IO ()  
main'' l = do
  tree <- gen' l
  print $ solve' tree

data BTree a = Branch a (BTree a) (BTree a) | Leaf a
  deriving (Show)

gen' :: Int -> IO (BTree (Sum Int))
gen' n = do
  v <- fmap Sum $ randomRIO (1,10)
  if (n == 0) then
    return $ Leaf v
  else do
    l <- gen' (n-1)
    r <- gen' (n-1)
    return $ Branch v l r

solve :: (Monoid a,Ord a) => BTree a -> a
solve (Leaf v) = v
solve (Branch v l r) = v <>  max (solve l) (solve r)

solve' :: (Monoid a, Ord a) => BTree a -> a
solve' = maximum . go mempty
  where go acc (Leaf v)  = [v <> acc]
        go acc (Branch v l r) = go acc' l ++ go acc' r
           where acc' = acc <> v
main''' :: Int -> IO ()
main''' n = do
  lvls <- gen'' n
  print $ solve'' $ map (map Sum) lvls

gen'' :: Int -> IO [[Int]]
gen'' 0 = return []
gen'' n = do
  lvl <- randomList (n*2-1) (1,10)
  nxt <- gen'' (n-1)
  return $ lvl :  nxt


randomList :: Int -> (Int,Int) -> IO [Int]
randomList 0 _ = return []
randomList n rng = do
  r  <- randomRIO rng
  rs <- randomList (n-1) rng
  return (r:rs)

solve'' :: (Monoid a, Ord a) => [[a]] -> [a]
solve'' [] = []
solve'' [[a]] = [a]
solve'' (lvl1:lvl2:lvls)= solve'' $ sum':lvls
  where max' = zipWith max lvl1 (tail lvl1)
        sum' = zipWith (<>) max' lvl2

> main''' 1000
[Sum {getSum = 7918}]
(1.61 secs, 724784776 bytes)