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