Source

haskell-playground / StackOverflow / Multiples.hs

{-
    Multiples of Numbers in a List
    
    from StackOverflow:
        http://stackoverflow.com/questions/2692152/
    
    Compile with:
        ghc --make -O2 Multiples.hs
-}

{-
    On my Mac, the results of the bench marks are:

    benchmarking short list: f [4,6,9] !! 300000
        multiplesS  mean: 147.8353 ms
        multiplesH  mean: 112.0491 ms
        multiplesM  mean: 589.0232 ms
        multiplesN  mean:  57.89328 ms

    benchmarking long list: f [1000..2000] !! 10000
        multiplesS  mean: 1054.590 ms,
        multiplesH  mean:   19.73719 ms
        multiplesM  mean:  898.1853 ms
        multiplesN  mean:  357.2146 ms
-}

import Criterion.Main
import Data.Heap as Heap (MinHeap, insert, empty, view)
import Data.List (group, sort)
import Test.HUnit
import Test.QuickCheck



--
-- ShreevatsaR's first solution
-- 

multiplesS xs = merge [map (*x) [1..] | x<-xs]
    where
        merge xss
            | all null xss = []
            | otherwise    = m : merge (map (avoid m) xss)
            where
              m = minimum [head xs | xs<-xss, xs/=[]]
              avoid m (x:xs) | m==x  = xs
              avoid m   xs           = xs

--
-- ShreevatsR's second solution
--

multiplesH xs = uniq $ tail $ map fst $ iterate (next . snd) (0, prep xs)
    where
      prep :: Ord a => [a] -> MinHeap (a,a)
      prep = foldr (\x -> insert (x,x)) empty
      next h = case view h of Just ((x,n),hh) -> (x, insert (x+n,n) hh)
      uniq (x:y:ys) | x==y  = uniq (y:ys)
      uniq (x:xs)           = x: (uniq xs)
      uniq []               = []


--
-- MtnViewMark's first solution
--

multiplesM :: (Num a, Ord a) => [a] -> [a]
multiplesM = map (fst.head) . iterate step . prep
    where prep                    = uniq . foldr (\i -> insert (i,i)) []

          next (m,i)              = (m+i,i)

          step (p:ps)             = uniq $ insert (next p) ps

          insert q  []            = [q]
          insert q (p:ps) | q > p = p : insert q ps
          insert q  ps            = q : ps

          uniq p@((ma,_):(mb,_):_) | ma == mb = step p
          uniq p                              = p


--
-- MtnViewMark's second solution
--


multiplesN :: (Num a, Ord a) => [a] -> [a]
multiplesN = uniq . merge . map (\n -> iterate (+n) n)
    where
        merge :: (Ord a) => [[a]] -> [a]
        merge rs =
            case foldr minToFront [] rs of
                []          -> []
                ([]:rs)     ->     merge rs
                ((a:as):rs) -> a : merge (as:rs)
            where
                minToFront a (b:rs) | b `before` a = b:a:rs
                minToFront a  qs                   = a:qs
                
                []    `before` _     = True
                _     `before` []    = False
                (a:_) `before` (b:_) = a <= b
        
        
        uniq :: (Eq a) => [a] -> [a]
        uniq []                    = []
        uniq (a:bs@(b:_)) | a == b =    uniq bs
        uniq (a:bs)                = a: uniq bs



--
-- jakebman's solution
--

multiplesJ xs = filter (isDividedByAny xs) [1..]
       where isDividedByAny xs int =  any (divides int) xs
                      where divides int elem  = int `mod` elem == 0


--
-- Drivers to put these through their paces
--

type MultiplesFunc = [Int] -> [Int]

solutionsToTest, solutionsToCheck, solutionsToBench
    :: [ (String, MultiplesFunc) ]
solutionsToCheck = [
    ("multiplesS", multiplesS),
    ("multiplesH", multiplesH),
    ("multiplesM", multiplesM),
    ("multiplesN", multiplesN)
    ]

solutionsToTest = solutionsToCheck ++ [
    ("multiplesJ", multiplesJ)  -- too slow to QuickCheck or Benchmark!
    ]
    
solutionsToBench = solutionsToCheck

multiplesTest :: Test
multiplesTest = TestList $ map buildTests solutionsToTest
  where
    buildTests (name, func) = name ~: TestList [

        take 10 (func [4,5])       ~?= [4,5,8,10,12,15,16,20,24,25],
        take 10 (func [4,9,20])    ~?= [4,8,9,12,16,18,20,24,27,28],
    
        take 20 (func [4,6,9])
            ~?= [4,6,8,9,12,16,18,20,24,27,28,30,32,36,40,42,44,45,48,52],
            
        take 20 (func [4,9])
            ~?= [4,8,9,12,16,18,20,24,27,28,32,36,40,44,45,48,52,54,56,60],
    
        take 20 (func [4,8,10])
            ~?= [4,8,10,12,16,20,24,28,30,32,36,40,44,48,50,52,56,60,64,68],
    
        take 20 (func [4,9,20])
            ~?= [4,8,9,12,16,18,20,24,27,28,32,36,40,44,45,48,52,54,56,60]
        ]

multiplesCheck :: [Property]
multiplesCheck = map buildCheck solutionsToCheck
  where
    buildCheck (name, func) = label name $ check func
    
    check :: MultiplesFunc -> NonEmptyList Int -> Bool
    check func (NonEmpty ps) = (take 100 $ func is) == (dumbMult 100 is)
      where is = map (\p -> abs (p `mod` 1000000) + 1) ps
      
    dumbMult n = take n . map head . group . sort
                    . concatMap (\i -> map (*i) [1..n])


multiplesBench = [
        each "short list" [4,6,9]       300000,
        each "long list"  [1000..2000]  10000
        ]
  where
    each s is n = bgroup s $ map buildBench solutionsToBench
      where
        buildBench (name, func) = bench name $ nf (q func n) is
        q func n is = func is !! n




main :: IO ()
main = do
    _ <- runTestTT multiplesTest
    mapM_ quickCheck multiplesCheck
    defaultMain multiplesBench
    return ()