Derangement.hs

-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA

-- | A module for finding derangements of multisets
-- This uses a reduction to the Max Flow problem and then
-- the Edmonds-Karp algorithm provided by "Data.Graph.Inductive.Query.MaxFlow"
-- to find a valid matching.
module Data.List.Derangement (derangement,derangementWRT,derangementBy) where
   import Data.Graph.Inductive.Graph
   import Data.Graph.Inductive.Tree
   import Data.Graph.Inductive.Query.MaxFlow
   import Maybe

   -- | Returns a derangement of a multiset or of a maximal fixed-point free subset represented here as (a,b) where a is paired with b
   derangement :: (Eq a) => [a] -> [a]
   derangement = derangementWRT id

   -- | Like derangement but applies @f :: (Eq b) => (a -> b)@
   derangementWRT :: (Eq b) => (a -> b) -> [a] -> [a]
   derangementWRT f = derangementBy (\x y -> f x == f y)

   -- | Like derangement this returns a zipped derangement but applies @f :: (a -> b)@ before doing equality tests.
   derangementBy :: (a -> a -> Bool) -> [a] -> [a]
   derangementBy cmp xs = map edgeToLab importantEdges
      where g'                    = matchingGraphBy cmp xs
            edgeToLab     (_,b,_) = fromJust $ lab g' b
            importantEdges        = filter isMatch $ labEdges $ maxFlowgraph g' (-1) 0
            isMatch   (u,v,(f,_)) = and [f == 1, u /= -1, v /= 0] -- Note -1 is the source and 0 is the sink

   -- A helper function for generating the G' to run Max flow on
   matchingGraphBy :: (a -> a -> Bool) -> [a] -> Gr a Integer
   matchingGraphBy cmp xs = mkGraph nodeSet edgeSet
      where edgeSet       = concatMap mkEdges zipped
            mkEdges (x,y) = [(-1,x,1), (x+1,0,1)] ++ [(x,a+1,1)| (a,_) <- zipCut y]
            nodeSet       = [(-1,undefined),(0,undefined)] ++ zipped ++ map (\(x,y)-> (x+1,y)) zipped
            zipped        = zip [2,4..] xs
            zipCut      x = filter (\(_,a) -> not $ cmp a x) zipped