subsets performance

bench.hs

import Criterion.Main
import Control.Monad

main :: IO ()
main = defaultMain [
   bgroup "subsets" [
      go "naive" naive,
      go "memoi" memoi,
      go "fused" fused,
      go "hbase" hbase,
      go "monad" monad,
      go "tomsm" tomsm
      ]
   ]
   where
   go s f = bench s $ whnf (length . f) [0..19]

naive = subsets
   where
   subsets [] = [[]]
   subsets (x:xs) = map (x :) (subsets xs) ++ (subsets xs)

memoi = subsets
   where
   subsets [] = [[]]
   subsets (x:xs) = map (x :) ss ++ ss
      where
      ss = subsets xs

fused = subsets
   where
   subsets [] = [[]]
   subsets (x:xs) = ss x (subsets xs)
      where
      ss _ [] = []
      ss x (y:ys) = (x:y) : y : ss x ys

monad = filterM (const [True, False])

tomsm = subsets
   where
   subsets = ss []
      where
      ss a [] = [a]
      ss a (x:xs) = ss (x : a) xs ++ ss a xs

hbase = subsets
   where
   subsets [] = []
   subsets (x:xs) = [x] : foldr f [] (subsets xs)
      where
      f ys r = ys : (x : ys) : r

subsets.hs

-- banchmark: length $ s [0..26]
-- unoptimized vs optimized time

-- naive: 56s vs 13s
subsets [] = [[]]
subsets (x:xs) = map (x :) (subsets xs) ++ (subsets xs)

-- memoized: 15s vs 13s
subsets [] = [[]]
subsets (x:xs) = map (x :) ss ++ ss
   where
   ss = subsets xs

-- fused: 1.8s vs 1.5s
subsets [] = [[]]
subsets (x:xs) = ss x (subsets xs)
   where                                                               
   ss _ [] = []
   ss x (y:ys) = (x : y) : y : ss x ys
   
-- monadic: 41s vs 33s
subsets = filterM (const [True,False])

-- tomsmeding: 22s vs 14s
subsets = ss []
   where
   ss a [] = [a]
   ss a (x:xs) = ss (x : a) xs ++ ss a xs