BoardColouring.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 BoardColouring where
  12
  13 import           Control.Applicative
  14 import           Control.Monad
  15 import           Data.Function       (on)
  16 import           Data.List
  17 import           Data.Map            (Map)
  18 import qualified Data.Map            as Map
  19 import           Data.Maybe
  20 import           Data.Set            (Set)
  21 import qualified Data.Set            as Set
  22
  23 import           GameState
  24 import           GameStateTypes
  25 import           GraphColouring
  26 import           Hex
  27 import           Util
  28
  29 type PieceColouring = Map PieceIdx Int
  30
  31 colouredPieces :: Bool -> GameState -> [PieceIdx]
  32 colouredPieces colourFixed st = [ idx |
  33     (idx, PlacedPiece _ p) <- enumVec $ placedPieces st
  34     , isPivot p ||
  35         isBlock p && (idx > 0) && colourFixed || not (null $ springsEndAtIdx st idx) ]
  36
  37 pieceTypeColouring :: GameState -> [PieceIdx] -> PieceColouring
  38 pieceTypeColouring st coloured = Map.fromList
  39     [ (idx, col) | (idx, PlacedPiece _ p) <- enumVec $ placedPieces st
  40         , idx `elem` coloured
  41         , let col = if isBlock p then 1+((connGraphHeight st idx - 1) `mod` 5) else 0 ]
  42
  43
  44 boardColouring :: GameState -> [PieceIdx] -> PieceColouring -> PieceColouring
  45 boardColouring st coloured = fiveColour graph
  46     where
  47         board = stateBoard st
  48         graph = Map.fromList [ (idx, nub $ neighbours idx)
  49             | idx <- coloured ]
  50         neighbours idx =
  51             neighbours' idx (perim idx) []
  52         perim :: PieceIdx -> Set (HexPos,HexDir)
  53         perim idx =
  54             Set.fromList $ nubBy ((==)`on`fst) [ (pos', neg dir)
  55                 | dir <- hexDirs
  56                 , pos <- fullFootprint st idx
  57                 , let pos' = dir +^ pos
  58                 , Just True /= do
  59                     (idx',_) <- Map.lookup pos' board
  60                     return $ idx == idx'
  61                 ]
  62         neighbours' :: PieceIdx -> Set (HexPos,HexDir) -> [PieceIdx] -> [PieceIdx]
  63         neighbours' idx as ns
  64             | Set.null as = ns
  65             | otherwise =
  66                 let a = head $ Set.elems as
  67                     (path, ns') = march idx (fst a) a True
  68                 in neighbours' idx
  69                     (Set.filter (\(pos,_) -> pos `notElem` path) as)
  70                     (ns++ns')
  71         -- |march around the piece's boundary, returning positions visited and
  72         -- neighbouring pieces met (in order)
  73         march idx startPos (pos,basedir) init
  74             | not init && pos == startPos = ([],[])
  75             | otherwise =
  76             let mn = do
  77                     (idx',_) <- Map.lookup pos board
  78                     guard $ idx' `elem` coloured
  79                     return idx'
  80                 mNext = listToMaybe
  81                     [ (pos', rotate (h-2) basedir)
  82                     | h <- [1..5]
  83                     , let pos' = rotate h basedir+^pos
  84                     , (fst <$> Map.lookup pos' board) /= Just idx
  85                     ]
  86                 (path,ns) = case mNext of
  87                     Nothing   -> ([],[])
  88                     Just next -> march idx startPos next False
  89             in (pos:path, maybeToList mn++ns)
  90