Pearls of Functional Programming, Chap. 8 Code

pearls-ch8.hs

#!/usr/bin/env stack
-- stack --install-ghc runghc --package=criterion --package=QuickCheck --package=deepseq

-- Pearls of Functional Algorithm Design, Chap. 8
-- Unravelling greedy algorithms

{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

import Control.DeepSeq (deepseq)
import Criterion.Main
import Data.Function ((&), on)
import Data.List (minimumBy, sort)
import Test.QuickCheck (Gen, generate, vectorOf, arbitrary)

supravel_orig :: Ord a => [a] -> [[a]]
supravel_orig = minBy length . filter (all up) . unravels

-- deterministic version of minBy that picks the first in the list
minBy :: Ord b => (a -> b) -> [a] -> a
minBy f xs = minimumBy (compare `on` f) xs

up :: Ord a => [a] -> Bool
up xs = and $ zipWith (<=) xs (tail xs)

unravels :: [a] -> [[[a]]]
unravels = foldr (concatMap . prefixes) [[]]

prefixes :: a -> [[a]] -> [[[a]]]
prefixes x [] = [[[x]]]
prefixes x (xs : xss) =
    [(x : xs) : xss] -- try prepending the new letter to the first word
    ++ map (xs :) -- first word remains unaltered
        (prefixes x xss) -- try prepending the new letter to each of the other words

{-
    Example unraveling:

    *Main> unravels "z"
    [["z"]]
    *Main> unravels "z" & map (prefixes 'y')
    [[["yz"],["z","y"]]]
    *Main> unravels "z" & map (prefixes 'y') & concat
    [["yz"],["z","y"]]
    *Main> unravels "z" & map (prefixes 'y') & concat & map (prefixes 'x')
    [[["xyz"],["yz","x"]],[["xz","y"],["z","xy"],["z","y","x"]]]
    *Main> unravels "z" & map (prefixes 'y') & concat & map (prefixes 'x') & concat
    [["xyz"],["yz","x"],["xz","y"],["z","xy"],["z","y","x"]]
-}

upravels_orig :: Ord a => [a] -> [[[a]]]
upravels_orig = filter (all up) . unravels

upravels :: Ord a => [a] -> [[[a]]]
upravels = foldr (concatMap . uprefixes) [[]]

uprefixes :: Ord a => a -> [[a]] -> [[[a]]]
uprefixes x [] = [[[x]]]
uprefixes x (xs : xss) =
    if x <= head xs
        then [(x : xs) : xss] ++ map (xs :) (uprefixes x xss)
        else map (xs :) (uprefixes x xss)

{-
  fusion law of foldr:
    f . foldr g a = foldr h b
    provided:
    1) f is a strict function
    2) f a = b
    3) for all x, y: f (g x y) = h x (f y)
-}

heads :: Ord a => [[a]] -> [a]
heads = sort . map head

(⪯) :: Ord a => [[a]] -> [[a]] -> Bool
ur ⪯ vr = heads ur ⊴ heads vr

(⊴) :: Ord a => [a] -> [a] -> Bool
[]     ⊴ _      = True
(_:_)  ⊴ []     = False
(x:xs) ⊴ (y:ys) = x >= y && xs ⊴ ys

insert :: Ord a => a -> [[a]] -> [[a]]
insert x [] = [[x]]
insert x (xs : xss) =
    if x <= head xs
        then (x : xs) : xss
        else xs : insert x xss

supravel_ins :: Ord a => [a] -> [[a]]
supravel_ins = foldr insert []

main :: IO ()
main = do
    word10 <- generate $ genWord 10
    letter <- generate $ arbitrary
    let word11 = letter : word10
    deepseq word11 $ do
        defaultMain
            [ bgroup "supravel"
                [ bench "orig_10" $ nf supravel_orig word10
                , bench "ins_10" $ nf supravel_ins word10
                , bench "orig_11" $ nf supravel_orig word11
                , bench "ins_11" $ nf supravel_ins word11
                ]
            ]

genWord :: Int -> Gen [Char]
genWord n = vectorOf n arbitrary