A Haskell "transcript" of Guy Steele's talk "Four Solutions to a Trivial Problem" (https://www.youtube.com/watch?v=ftcIcn8AmSY)

four-solutions-to-a-trivial-problem.hs

{-# LANGUAGE TypeSynonymInstances #-}

import Data.Monoid
import Data.Maybe

-- How much water does a "histogram" hold?
--
-- Inspired by Guy Steele's talk "Four Solutions to a Trivial Problem"
-- https://www.youtube.com/watch?v=ftcIcn8AmSY

type Height = Int
type Histogram = [Height]

-- Guy Steele's example histogram:
--
--         █
--         █~~~~~~~█
--     █~~~█~~~~~~~█        ~ : water (total volume: 35)
--     █~█~█~~~~█~██
--     █~█~█~█~~█~███
--     ███~█~█~~█████
--    ██████~████████
--    ████████████████
--    2635281422535741

guySteelesExample :: Histogram
guySteelesExample = [2,6,3,5,2,8,1,4,2,2,5,3,5,7,4,1]


-----------------------------------------------------------------------
-- The sequential version
-- Exemplifies simple list processing (sum, zipWith, scanr1, scanl1)

sequential :: Histogram -> Int
sequential x = sum (zipWith (-) waterLevels x)
  where
    waterLevels = zipWith min highestToTheLeft highestToTheRight

    highestToTheLeft, highestToTheRight :: [Height]

    highestToTheLeft  = scanl1 max x  -- left-to-right sweep
    highestToTheRight = scanr1 max x  -- right-to-left sweep



-----------------------------------------------------------------------
-- The bitonic glob version (divide and conquer)

-- A plateau (height, width) in a histogram
type Plateau = (Height, Int)

-- Definition of a glob, see slide 46
data Glob = Glob { -- list of plateaux to the left of the highest plateau,
                   -- monotonically increasing heights
                   left  :: [Plateau],
                   -- highest plateau
                   top   :: Plateau,
                   -- list of plateaux to the right of the highest plateau
                   -- monotonically decreasing heights
                   right :: [Plateau],
                   -- volume of water contained in glob
                   water :: Int
                 }
  deriving Show


-- overall width of a list of plateaux
width :: [Plateau] -> Int
width x = sum [ q | (p, q) <- x ]

-- volume held by list of plateaux if water is filled in to level m
fill :: [Plateau] -> Int -> Int
fill x m = sum [ q * (m - p) | (p, q) <- x ]


instance Monoid Glob where
  mempty = Glob [] (minBound, 0) [] 0

  -- mappend is indeed associative, says Guy
  mappend (Glob xleft (xht, xwd) xright xwater) (Glob yleft (yht, ywd) yright ywater)
    | xht < yht = let (lss, eql, gtr) = threeWaySplit yleft xht
                  in  Glob (xleft ++ [(xht, xwd + width xright + width lss + fromMaybe 0 eql)] ++ gtr)
                           (yht, ywd)
                           yright
                           (xwater + fill xright xht + fill lss xht + ywater)
    | xht > yht = let (lss, eql, gtr) = threeWaySplit xright yht
                  in  Glob xleft
                           (xht, xwd)
                           (yright ++ [(yht, fromMaybe 0 eql + width lss + width yleft + ywd)] ++ gtr)
                           (xwater + fill lss yht + fill yleft yht + ywater)
    | xht == yht = Glob xleft
                        (xht, xwd + width xright + width yleft + ywd)
                        yright
                        (xwater + fill xright xht + fill yleft xht + ywater)
    where
      -- Given a plateaux list (with monotonically increasing heights) and a level m,
      -- split it into three:
      -- 1. the part below level m
      -- 2. the width of the plateaux list at level m
      -- 3. the part above level m
      threeWaySplit :: [Plateau] -> Int -> ([Plateau], Maybe Int, [Plateau])
      threeWaySplit []        _             = ([], Nothing, [])
      threeWaySplit x@[(a,b)] m
        | a < m     = (x, Nothing, [])
        | a > m     = ([], Nothing, x)
        | otherwise = ([], Just b, [])
      threeWaySplit x         m
        | m < n     = let (p, q, r) = threeWaySplit y m
                      in  (p, q, r ++ z)
        | otherwise = let (p, q, r) = threeWaySplit z m
                      in  (y ++ p, q, r)
        where (y, z@((n,_):_)) = splitAt (length x `div` 2) x

-- introduce oplus symbol
(⨁) :: Monoid a => [a] -> a
(⨁) = mconcat


bitonic :: Histogram -> Int
bitonic x = water ((⨁) [ singletonGlob v | v <- x ]) -- may use parallel implementation of ⨁
  where
    -- a trivial glob of height h and width 1 (doesn't hold water)
    singletonGlob :: Height -> Glob
    singletonGlob h = Glob [] (h, 1) [] 0


-----------------------------------------------------------------------
-- The monoid-cached tree version

data CachedTree a
  = NullNode      a
  | SingletonNode a
  | PairNode      a (CachedTree a) (CachedTree a)
  deriving Show

val :: CachedTree a -> a
val (NullNode v)      = v
val (SingletonNode v) = v
val (PairNode v _ _)  = v


monoidCachedTree :: Monoid a => [a] -> CachedTree a
monoidCachedTree []   = NullNode mempty
monoidCachedTree [x0] = SingletonNode (x0 `mappend` mempty)
monoidCachedTree x    = let (a, b) = (monoidCachedTree p, monoidCachedTree q) -- parallel
                        in  PairNode (val a `mappend` val b) a b
  where
    (p, q) = splitAt (length x `div` 2) x


-- we will build a max cached tree
instance Monoid Height where
  mempty  = minBound
  mappend = max


-- implements left-to-right and right-to-left sweep on the monoid cached tree
process :: CachedTree Height -> Int -> Int -> Int
process (PairNode _ a b)  left right = process a left (val b `max` right) +  -- parallelism
                                       process b (left `max` val a) right    -- opportunity here
process (SingletonNode v) left right = ((left `min` right) `max` v) - v
process (NullNode _)      left right = 0


monoidcached :: Histogram -> Int
monoidcached x = process (monoidCachedTree x) minBound minBound


-----------------------------------------------------------------------
-- The concise version
-- (NB. this is just like the sequential version)

(-->) = scanl1
(<--) = scanr1

concise :: Histogram -> Int
concise x = sum [ (left `min` right) - v | (v, left, right) <- zip3 x (max--> x) (max<-- x) ]

-----------------------------------------------------------------------

main :: IO ()
main = mapM_ print ([sequential, bitonic, monoidcached, concise] <*> pure guySteelesExample)

Deliberately adopts Guy's naming of identifiers and thus somewhat deviates from idiomatic Haskell.