Filter subsets based on length?

Question

Trying to extract the subsets with length k using filter. Not sure how to approach it? The list has 100 elements.

subsets :: [a] -> [[a]]
subsets [] = [[]]
subsets (x:xs) = [zs | ys <- subsets xs, zs <- [ys, (x:ys)]]

If i use filter this is what i thought it would be:

filter (length(3)) subsets [1,2,3,4,5]

But i'm probably wrong. If there is a different approach rather than filter? I'm new to haskell so not exactly sure.

Answer 1

When I get stuck with a little confusion in filtering, I go a level up and use foldr in this case would be as simple as:

filterLength3 = foldr (\x rs -> if (length x) == 3 then  x : rs else rs) [] 

filterLength3 (subsets [1,2,3,4,5])

output

=> [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[1,2,5],[1,3,5],[2,3,5],[1,4,5],[2,4,5],[3,4,5]]

With filter should be:

filter ((==3) . length) (subsets [1,2,3,4,5])

=> [[1,2,3],[1,2,4],[1,3,4],[2,3,4],[1,2,5],[1,3,5],[2,3,5],[1,4,5],[2,4,5],[3,4,5]]

Edit

After thinking a lot, and with the help of chi, and asking this question I was able to solve it:

import Data.List

subsetsOfThree ws = [ [x,y,z] | (x:xs) <- tails ws, (y:ys) <- tails xs, z <- ys ]

some examples:

  subsetsOfThree [1..3]
=> [[1,2,3]]
   subsetsOfThree [1..4]
=> [[1,2,3],[1,2,4],[1,3,4],[2,3,4]]
   subsetsOfThree [1..5]
=> [[1,2,3],[1,2,4],[1,2,5],[1,3,4],[1,3,5],[1,4,5],[2,3,4],[2,3,5],[2,4,5],[3,4,5]]
   subsetsOfThree [1..10]
=> [[1,2,3],[1,2,4],[1,2,5],[1,2,6],[1,2,7],[1,2,8],[1,2,9],[1,2,10],[1,3,4],[1,3,5],[1,3,6],[1,3,7],[1,3,8],[1,3,9],[1,3,10],[1,4,5],[1,4,6],[1,4,7],[1,4,8],[1,4,9],[1,4,10],[1,5,6],[1,5,7],[1,5,8],[1,5,9],[1,5,10],[1,6,7],[1,6,8],[1,6,9],[1,6,10],[1,7,8],[1,7,9],[1,7,10],[1,8,9],[1,8,10],[1,9,10],[2,3,4],[2,3,5],[2,3,6],[2,3,7],[2,3,8],[2,3,9],[2,3,10],[2,4,5],[2,4,6],[2,4,7],[2,4,8],[2,4,9],[2,4,10],[2,5,6],[2,5,7],[2,5,8],[2,5,9],[2,5,10],[2,6,7],[2,6,8],[2,6,9],[2,6,10],[2,7,8],[2,7,9],[2,7,10],[2,8,9],[2,8,10],[2,9,10],[3,4,5],[3,4,6],[3,4,7],[3,4,8],[3,4,9],[3,4,10],[3,5,6],[3,5,7],[3,5,8],[3,5,9],[3,5,10],[3,6,7],[3,6,8],[3,6,9],[3,6,10],[3,7,8],[3,7,9],[3,7,10],[3,8,9],[3,8,10],[3,9,10],[4,5,6],[4,5,7],[4,5,8],[4,5,9],[4,5,10],[4,6,7],[4,6,8],[4,6,9],[4,6,10],[4,7,8],[4,7,9],[4,7,10],[4,8,9],[4,8,10],[4,9,10],[5,6,7],[5,6,8],[5,6,9],[5,6,10],[5,7,8],[5,7,9],[5,7,10],[5,8,9],[5,8,10],[5,9,10],[6,7,8],[6,7,9],[6,7,10],[6,8,9],[6,8,10],[6,9,10],[7,8,9],[7,8,10],[7,9,10],[8,9,10]]

And now you are able to make your monster a little puppet:

  length $ subsetsOfThree [1..10]
=> 120
   length $ subsetsOfThree [1..20]
=> 1140
   length $ subsetsOfThree [1..50]
=> 19600
   length $ subsetsOfThree [1..100]
=> 161700
length $ subsetsOfThree [1..500]
=> 20708500

Answer 2

Here's a general solution for length-n subsets not using filter.

Where our initial list is x:xs, notice that we can partition these subsets into those containing x and those not containing x. This shows us a nice recursive structure; the first partition is x prepended to each length-(n-1) subset of xs, and the second is just the length-n subsets of xs.

subsetsOfLength n (x:xs) = map (x:) (subsetsOfLength (n-1) xs) ++ subsetsOfLength n xs

All we need are the base cases. There is a single length-0 subset, and no subset is larger than the original:

subsets 0 _  = [[]]
subsets _ [] = []

Stick these bases above the recursive step and throw an appropriate type signature on it, and we're done.

λ> subsetsOfLength 3 [1..5]
[[1,2,3],[1,2,4],[1,2,5],[1,3,4],[1,3,5],[1,4,5],[2,3,4],[2,3,5],[2,4,5],[3,4,5]]

λ> length $ subsetsOfLength 5 [1..100]
252

Nice.

Be careful. (++) is slow; if you know at compile-time the length you'll be using, Damián Rafael Lattenero's tails approach may be more performant. Not entirely sure about this, though. Also, depending on the values, you might do well to swap the operands of (++). I haven't yet done the math.

Answer 3

The number of subsets for a list of 100 elements is about 2¹⁰⁰ ≃ 1.26*10³⁰, a really huge number. So the filter approach does not seem practical. The problem should be solved by manipulating lists containing just a few numbers between 1 and 100.

So we aim to write a function to be named kSubsets which returns the list of all subsets of cardinality k:

kSubsets :: Int -> [a] -> [[a]]

where k is the first argument.

A solution based on recursive list processing:

A possible way to build the functionality of kSubsets consists in using an auxiliary kIndexSubsets function which computes the zero-based indexes of the elements, instead of the elements themselves. The kIndexSubsets function can be written in a recursive fashion.

In that case, the kSubsets function is essentially a wrapper which maps the element indexes to the actual list elements. This gives the following code:

import qualified  Data.Map    as  M
import qualified  Data.Maybe  as  Mb
import qualified  Data.List   as  L

kIndexSubsets :: Int -> Int -> [[Int]]
kIndexSubsets 0 _  = [[]]
kIndexSubsets k nn =
    -- first element chosen must leave room for (k-1) elements after itself
    let lastChoice = if (k > nn)
                     then error "k above nn in kIndexSubsets"
                     else (nn -k)
        choices = [0 .. lastChoice]
        -- for each possible first element, recursively compute
        -- all the possible tails:
        fn hd   = let tails1 = kIndexSubsets (k-1) (nn - (hd+1))
                      -- rebase subsequent indexes:
                      tails2 = map (map (\x -> (x+hd+1))) tails1
                  in  -- add new leftmost element:
                      map  (\ls -> hd:ls)  tails2
    in
        concatMap fn choices


-- return the list of all subsets of ls having k elements:
kSubsets :: Int -> [a] -> [[a]]
kSubsets 0 _  = [[]]
kSubsets k ls = 
    let  nn = length ls
         -- need a map for fast access to elements of ls:
         ma = M.fromList $ zip [0..] ls
         extractor ix = Mb.fromJust(M.lookup ix ma)
         indexSubSets = kIndexSubsets k nn
    in
         map  (map extractor)  indexSubSets

We can now test our kSubsets function. This involves checking that the length of the resulting output list conforms to the classic combinatorics formula, that is n!/(k! * (n-k)!) where n is the length of the input list.

*Main> let ls = "ABCDEFGH"
*Main> kSubsets 0 ls
[""]
*Main> kSubsets 1 ls
["A","B","C","D","E","F","G","H"]

*Main> kSubsets 2 ls
["AB","AC","AD","AE","AF","AG","AH","BC","BD","BE","BF","BG","BH","CD","CE","CF","CG","CH","DE","DF","DG","DH","EF","EG","EH","FG","FH","GH"]

*Main> kSubsets 3 ls
["ABC","ABD","ABE","ABF","ABG","ABH","ACD","ACE","ACF","ACG","ACH","ADE","ADF","ADG","ADH","AEF","AEG","AEH","AFG","AFH","AGH","BCD","BCE","BCF","BCG","BCH","BDE","BDF","BDG","BDH","BEF","BEG","BEH","BFG","BFH","BGH","CDE","CDF","CDG","CDH","CEF","CEG","CEH","CFG","CFH","CGH","DEF","DEG","DEH","DFG","DFH","DGH","EFG","EFH","EGH","FGH"]

*Main> 
*Main> kSubsets 7 ls
["ABCDEFG","ABCDEFH","ABCDEGH","ABCDFGH","ABCEFGH","ABDEFGH","ACDEFGH","BCDEFGH"]
*Main> 
*Main> kSubsets 8 ls
["ABCDEFGH"]
*Main> 
*Main> 
*Main> div ((100*99*98)::Integer)  ((2*3)::Integer)
161700
*Main> 
*Main> length $ kSubsets 3 [ 1 .. 100 ]
161700
*Main> 
*Main> div ((100*99*98*97*96)::Integer)  ((2*3*4*5)::Integer)
75287520
*Main> length $ kSubsets 5 [ 1 .. 100 ]
75287520
*Main>

The evaluation of kSubsets 3 [ 1 .. 100 ] takes less than 50 msec on a plain vanilla x86-64 Linux machine.

An alternative solution based on a state machine:

The (reversed) list of chosen indexes is taken to be the state of an automaton, and we advance the state step by step, until this is no longer possible, at which point the list of sublists is complete.

Basically, if there is room to advance the rightmost index, fine, otherwise we recurse to advance the rest of the list, and then move the rightmost index as far left as possible.

The approach gives this alternative source code for kIndexSubsets, in which the key piece is the ksAdvance stepping function:

import qualified  Data.Map    as  M
import qualified  Data.Maybe  as  Mb
import qualified  Data.List   as  L


-- works on the *reversed* list of chosen indexes:
ksAdvance :: Int -> Int -> Maybe [Int] -> Maybe [Int]
ksAdvance k nn Nothing        = Nothing
ksAdvance k nn (Just [])      = Nothing
ksAdvance k nn (Just (h:rls)) =
    if (h == (nn-1))
    then -- cannot advance rightmost index, so must recurse
        let mbols2 = ksAdvance (k-1) (nn-1) (Just rls)
        in
            case mbols2 of
            Nothing   -> Nothing
            Just ols2 -> let  y = ((head ols2)+1)  in  Just (y:ols2)
    else -- just advance rightmost index:
        Just ((h+1):rls)


kIndexSubsets :: Int -> Int -> [[Int]]
kIndexSubsets 0 _  = [[]]
kIndexSubsets k nn =
    let startList = reverse  $  [ 0 .. (k-1) ]
        cutList = takeWhile  Mb.isJust
        mbls    = cutList $ iterate  (ksAdvance k nn)  (Just startList)
    in
        map  (reverse . Mb.fromJust)  mbls

This algorithm seems less memory-hungry and faster than the first one.

Using this main program for a quick performance test, with subsets of 5 elements out of 100, generating 75287520 subsets:

kSubsets :: Int -> [a] -> [[a]]
kSubsets 0 _  = [[]]
kSubsets k ls = 
    let  nn = length ls
         -- need a map for fast access to elements of ls:
         ma = M.fromList $ zip [0..] ls
         eltFromIndex = \ix -> Mb.fromJust (M.lookup ix ma)
         indexSubSets = kIndexSubsets k nn
    in
         map  (map eltFromIndex)  indexSubSets


main = do
    let nn  = 100
    let  k  = 5
    let ls  = [ 1 .. nn ]::[Int]
    let str = "count of " ++ (show k) ++ " out of " ++ (show nn) ++
          " elements subsets = " ++ (show $ length (kSubsets k ls))
    putStrLn $ str

Memory performance is improved:

$ /usr/bin/time ./kSubsets03.x +RTS -s
    count of 5 out of 100 elements subsets = 75287520
       4,529,861,272 bytes allocated in the heap
             623,240 bytes copied during GC
              44,504 bytes maximum residency (2 sample(s))
              29,224 bytes maximum slop
                   2 MB total memory in use (0 MB lost due to fragmentation)
 ...
      Productivity  98.4% of total user, 98.5% of total elapsed

    0.70user 0.00system 0:00.72elapsed 99%CPU (0avgtext+0avgdata 4724maxresident)k
    0inputs+0outputs (0major+436minor)pagefaults 0swaps
$ 

Not yet as good as Fortran but getting close :-)