Brady Bunch

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
import Data.Set (Set)
import qualified Data.Set as Set
import Data.List
import Control.List               -- http://lpaste.net/107211
import Data.Peano                 -- http://lpaste.net/107204
import Control.Monad
import Control.Monad.State.Lazy
import Control.Arrow

{--

Okay! SO!

You get to see two solutions to this problem:

1) 'hella'-inefficent (generate(-all-possible-solutions)-then-test)
2) just wrong (whoopsie! I thought permutations would do it. It didn't)

before, at the bottom of this file, you get to selectBunch

3) 'hella'-fast (0.2 seconds instead of ~4 seconds for 1)

which uses a guarded state-like structure to select only unique members
for each set.

The thing was 3) 'hella'-fast was also 'hella'-easy to write, once
I just simply followed the data-flow and worked with it.

It's neat how easy Haskell is to code in.

kthxbai!

 --}

-- a(n inefficient) solution to http://lpaste.net/107181

data Buddy = Alexandra | Beth | Carla | Da5id | Elie
           | Franny | Graeme | Henry | Isaac
   deriving (Eq, Ord, Enum, Show, Read)

buddies :: Set Buddy
buddies = Set.fromList [Alexandra .. Isaac]

-- given takeout from Control.List, bunch takes out an element
-- from buddies for each member of each clique. Easy!

rawbunch :: (Eq a, Ord a, Enum a) => Set a -> [Int] -> [[[a]]]
rawbunch buddies cliques = 
   let lbuds = Set.toList buddies
       pclix = map (fromInt . toInteger) cliques
   in   mapM (popClique alexandra [] lbuds) pclix >>= return . map fst >>=
        \cliques -> guard (uniqueness cliques) >> return cliques
      where alexandra = toEnum 0

-- from a base set of buddies, populate a clique, yielding it and
-- the reduced base pool

popClique :: (Eq a, Ord a, Enum a) => a -> [a] -> [a] -> Peano -> [([a], [a])]
popClique _ accum base Z = return (accum, base)
popClique first accum base (S n) =
   takeout base >>= \(bud, rest) ->
   guard (bud >= first) >> popClique bud (bud : accum) rest n

uniqueness :: Eq a => [[a]] -> Bool
uniqueness [] = True
uniqueness (clique : cliques) = u' clique (join cliques) && uniqueness cliques
   where u' [] _ = True
         u' (bud : buddies) cliques = notElem bud cliques
                                      && u' buddies cliques

bunch :: (Eq a, Ord a, Enum a) => Set a -> [Int] -> Set (Set (Set a))
bunch buds cliques = buncher buds cliques rawbunch

buncher :: (Eq a, Ord a, Enum a) => Set a -> [Int] ->
           (Set a -> [Int] -> [[[a]]]) ->  Set (Set (Set a))
buncher buds cliques fn = sfl $ msfl (msfl id) $ fn buds cliques
   where sfl = Set.fromList
         msfl f = map (Set.fromList . f)

brady :: [Set (Set Buddy)] -- geddit? the 'brady bunch'? geddit? ;)
brady = Set.toList $ bunch buddies [2,3,4]

-- length brady ~> 1260 because 9c2 * 7*3 * 4c4 == 1260
-- ... but it takes forEVAH to return because of my eh-algorithm :(
-- where forEVAH is defined to be 'around 4 seconds'

{--

Discussion, re: my eh-algorithm. What I did was get all possible
solutions and then mapped through the solution set, eliminating the
non-unique ones. A MUCH better approach would have been to eliminate
the choices made from the pool when a clique is formed so that new
cliques only choose members who are not in the old cliques.

That would have been a MUCH better approach.

--}

-- after the fact pensées:

{--

So, the grouping into cliques is just really subdividing permutations
of the original group. I don't know why I made all this fuss, actually.

So, a much simpler, and faster, solution is:

 --}

permutedBunch :: (Eq a, Ord a, Enum a) => Set a -> [Int] -> [[[a]]]
permutedBunch set cliques =
   map (grouping cliques) (permute $ Set.toList set)

grouping :: [Int] -> [a] -> [[a]]
grouping [] [] = []
grouping (splitter:ss) seed = 
   (second (grouping ss) >>> uncurry (:)) (splitAt splitter seed)
   -- in  hed : grouping ss rest

{--

Shoot! It's not better, and it's not faster! Because permute [1,2,3] gives
six solutions, but 3c3 gives one! permute isn't the answer! Darn!

So I do have to have a stateful state in order to formulate this problem
correctly!

Good experiment, though. Nice try. Sigh!

 --}

{--

So, here's a stetch of what I need. I need a state such that the state
is updated for each sublist so that following lists don't select the
same elements, and I need to impose ordering so that I don't have the
duplicates:

[[1,2], ...] and [[2,1], ...]

Is this doable?

 --}

selectBunch :: (Eq a, Ord a, Enum a) => Set a -> [Int] -> [[[a]]]
selectBunch set cliques =
   let pianos = map (fromInt . toInteger) cliques
   in  s' pianos (Set.toList set) []
      where s' [] _ accum = return accum
            s' (p:ps) rest accum = selectClique p rest [] (toEnum 0) >>=
                     \(clique, rem) -> s' ps rem (clique:accum)

selectClique :: (Ord a) => Peano -> [a] -> [a] -> a -> [([a], [a])]
selectClique Z pool clique _ = return (clique, pool)
selectClique (S n) pool clique min = takeout pool >>= \(h, rest) ->
   guard (h >= min) >>
   selectClique n rest (h:clique) h

{--

Yes, that was doable, surprisingly easily so, as you see above, and the
return, seeing that we've inlined the guard, is very fast now:

*Main Data.Time.Clock> getCurrentTime >>= \t1 -> 
          putStrLn (show (length (selectBunch buddies [2,3,4]))) >> 
          getCurrentTime >>= return . diffUTCTime t1

gives:

1260
-0.22408s

(0.2 seconds)

as opposed to:

*Main Data.Time.Clock> getCurrentTime >>= \t1 -> 
             putStrLn (show (length (bunch buddies [2,3,4]))) >> 
             getCurrentTime >>= return . diffUTCTime t1
1260
-3.693009s

(3.7 seconds)

Woot! Victory!

The type of selectClique is:

selectClique :: (Ord a) => Peano -> [a] -> [a] -> a -> [([a], [a])]

as expected

 --}
51:9: Warning: Use liftM
Found:
mapM (popClique alexandra [] lbuds) pclix >>= return . map fst
Why not:
liftM (map fst) (mapM (popClique alexandra [] lbuds) pclix)