Instantly share code, notes, and snippets.

# Teggy/four-solutions-to-a-trivial-problem.hs

Last active September 23, 2022 21:44
Star You must be signed in to star a gist
A Haskell "transcript" of Guy Steele's talk "Four Solutions to a Trivial Problem" (https://www.youtube.com/watch?v=ftcIcn8AmSY)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters
 {-# 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)

### Teggy commented Feb 9, 2016

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