GraphColouring.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module GraphColouring (fiveColour) where
  12
  13 import qualified Data.Map as Map
  14 import Data.Map (Map)
  15 import qualified Data.Set as Set
  16 import Data.Set (Set)
  17 import qualified Data.Vector as Vector
  18 import Data.List
  19 import Data.Maybe
  20
  21 type Colouring a = Map a Int
  22 type Graph a = (Set a, Set (Set a))
  23 type PlanarGraph a = Map a [a]
  24
  25 fiveColour :: Ord a => PlanarGraph a -> Colouring a -> Colouring a
  26 -- ^algorithm based on that presented in
  27 -- http://people.math.gatech.edu/~thomas/PAP/fcstoc.pdf
  28 -- Key point: a planar graph can't have all vertices of degree >= 6
  29 -- (Proof: suppose it does, so |E| >= 3|V|; WLOG the graph is triangulated,
  30 -- so then |F| <= 2/3 |E|. So \xi = |V|-|E|+|F| <= (1/3 - 1 + 2/3)|E| = 0.
  31 -- But a planar graph has Euler characteristic 1.)
  32 -- Aims to minimise changes from given (partial) colouring lastCol.
  33 fiveColour g lastCol =
  34     if Map.keysSet lastCol == Map.keysSet g && isColouring g lastCol
  35         then lastCol
  36         else fiveColour' lastCol g
  37
  38 isColouring :: Ord a => PlanarGraph a -> Colouring a -> Bool
  39 isColouring g mapping = and
  40     [ Map.lookup s mapping /= Map.lookup e mapping
  41     | s <- Map.keys g
  42     , e <- g Map.! s ]
  43
  44 fiveColour' :: Ord a => Colouring a -> PlanarGraph a -> Colouring a
  45 fiveColour' pref g | g == Map.empty = Map.empty
  46 fiveColour' pref g =
  47     let adjsOf v = (nub $ g Map.! v) \\ [v]
  48         v0 = head $ filter ((<=5) . length . adjsOf) $ Map.keys g
  49         adjs = adjsOf v0
  50         addTo c =
  51             let vc = head $ possCols pref v0 \\ map (c Map.!) adjs
  52             in Map.insert v0 vc c
  53     in if length adjs < 5
  54        then addTo $ fiveColour' pref $ deleteNode v0 g
  55        else let (v',v'') = if adjs!!2 `elem` (g Map.! (adjs!!0))
  56                     then (adjs!!1,adjs!!3)
  57                     else (adjs!!0,adjs!!2)
  58             in addTo $ demerge v' v'' $ fiveColour' pref $ merge v0 v' v'' g
  59
  60 possCols :: Ord a => Colouring a -> a -> [Int]
  61 possCols pref v = maybe [0..4] (\lvc -> lvc:([0..4] \\ [lvc])) $ Map.lookup v pref
  62
  63 demerge :: Ord a => a -> a -> Colouring a -> Colouring a
  64 demerge v v' c = Map.insert v' (c Map.! v) c
  65
  66 merge :: Ord a => a -> a -> a -> PlanarGraph a -> PlanarGraph a
  67 merge v v' v'' g =
  68     deleteNode v $ contractNodes v' v''
  69         $ Map.adjust (concatAdjsOver v $ g Map.! v'') v' g
  70
  71 concatAdjsOver :: Ord a => a -> [a] -> [a] -> [a]
  72 concatAdjsOver v adjs adjs' =
  73     let (s,_:e) = splitAt (fromJust $ elemIndex v adjs) adjs
  74     in s ++ adjs' ++ e
  75
  76 deleteNode :: Ord a => a -> PlanarGraph a -> PlanarGraph a
  77 deleteNode v =
  78     fmap (filter (/= v)) . Map.delete v
  79
  80 contractNodes :: Ord a => a -> a -> PlanarGraph a -> PlanarGraph a
  81 contractNodes v v' =
  82     fmap (map (\v'' -> if v'' == v' then v else v'')) . Map.delete v'