find subsets with sum

sums-extract-groups.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Sums where
import Data.IntMap.Lazy (IntMap)
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.IntMap as IntMap

-- find all subsets which add upto the given size, given a function to
-- extract the size.  Only pick at most one element from each input subset.
sums :: forall a.(a -> Int) -> Int -> [[a]] -> [[a]]
sums size sum_ = fromMaybe [] . IntMap.lookup sum_ . sumsAux2
  where
    sumsAux2 :: [[a]] -> IntMap [[a]]
    sumsAux2 = foldr (\xs im -> foldr (sumsAux im) im xs) IntMap.empty
    
    sumsAux :: IntMap [[a]] -> a -> IntMap [[a]] -> IntMap [[a]]
    sumsAux origIm x newIm
      | size x > sum_ = newIm
      | otherwise = 
          IntMap.insertWith (<>) (size x) [[x]] $ 
          IntMap.foldrWithKey (\key val im2 ->
                                 if key + size x > sum_ then im2
                                 else IntMap.insertWith (<>) (key + size x)
                                      (map (x:) val) im2)
          newIm origIm

sums-extract.hs

-- find all subsets which add upto the given size, given a function to
-- extract the size
sums :: forall a.(a -> Int) -> Int -> [a] -> [[a]]
sums size sum_ l =
  fromMaybe [] $ IntMap.lookup sum_ $ sumsAux l
  where
    sumsAux :: [a] -> IntMap [[a]]
    sumsAux [] = IntMap.empty
    sumsAux (x:xs)
      | size x > sum_ = sumsAux xs
      | otherwise = 
        IntMap.insertWith (<>) (size x) [[x]] $ 
        IntMap.foldrWithKey (\key val im2 ->
                               if key + size x > sum_ then im2
                               else IntMap.insertWith (<>) (key + size x)
                                    (map (x:) val) im2)
        im im
      where im = sumsAux xs

sums.hs

module Sums where
import Data.IntMap.Lazy (IntMap)
import Data.Maybe
import Data.Monoid ((<>))
import qualified Data.IntMap as IntMap

sums :: Int -> [Int] -> [[Int]]
sums sum_ l = fromMaybe [] $ IntMap.lookup sum_ $  sumsAux sum_ l 

sumsAux :: Int -> [Int] -> IntMap [[Int]]
sumsAux _ [] = IntMap.empty
sumsAux sum_ (x:xs)
  | x > sum_ = sumsAux sum_ xs
  | otherwise = 
    IntMap.insertWith (<>) x [[x]] $ 
    IntMap.foldrWithKey (\key val im2 ->
                           if key + x > sum_ then im2
                           else IntMap.insertWith (<>) (key + x)
                                (map (x:) val) im2)
    im im
  where im = sumsAux sum_ xs