minesweeper-0.8.9: Core/Square.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Squares.
module Core.Square 
    (
    -- * Types
      Board
    , board
    , xSize
    , ySize

    , Square
    , coords
    , square
    , restrictSquare
    , squares
    , neighbours

    , SquareSet
    ) where

import Data.Binary
import Data.Bits
import Data.Maybe
import Data.SetClass
import qualified Data.IntSet as IS
import Prelude hiding (null)

-----------

-- | Board of a board.
newtype Board 
    = S { unS :: Int }
        deriving (Eq, Ord, Binary)

instance Show Board where
    show = show . unS

xSize, ySize :: Board -> Int
xSize = fst . unpack . unS
ySize = snd . unpack . unS

board :: Int -> Int -> Board
board i j | i `between` (1, 255) && j `between` (1, 255) = S $ pack i j

--------------------------

-- | Square on a board.
newtype Square 
    = P { unP :: Int } 
        deriving (Eq, Ord, Binary)

instance Show Square where
    show = show . coords 

coords :: Square -> (Int, Int)
coords (P i) = unpack i

square :: Board -> Int -> Int -> Maybe Square
square s i j 
    | i `between` (1, xSize s) && j `between` (1, ySize s) = Just $ P $ pack i j
    | otherwise = Nothing

restrictSquare :: Board -> Square -> Square
restrictSquare s (coords -> (i, j)) 
    = P $ pack (max 1 $ min (xSize s) i) (max 1 $ min (ySize s) j) 

-----------------------------------

-- | Squares of a board.
squares :: Board -> SquareSet
squares s = fromList [P p | x <- [1..xSize s], p <- take (ySize s) [pack x 1 ..]]

-- | Neighbours of a square on a board.
neighbours :: Board -> Square -> SquareSet
neighbours s (coords -> (i, j))
    = fromList $ catMaybes 
        [square s (i+a) (j+b) | (a, b) <- [(-1,0),(-1,-1),(0,-1),(1,-1),(1,0),(1,1),(0,1),(-1,1)]]

----------------------- auxiliary functions

infix 4 `between`
a `between` (b, c) = b <= a && a <= c

unpack :: Int -> (Int, Int)
unpack i = (shiftR i 8, i .&. 255)

pack :: Int -> Int -> Int
pack i j = shiftL i 8 .|. j

---------------------------------

newtype SquareSet = SS { unSS :: IS.IntSet } deriving (Show, Binary)

instance Set SquareSet where

   type SetElem SquareSet = Square

   toList      = map P . toList . unSS
   fromList    = SS . fromList . map unP
   size        = size . unSS
   intersection = bi intersection
   (\\)        = bi (\\)
   union       = bi union
   null        = null . unSS
   empty       = SS empty

bi f a b = SS $ f (unSS a) (unSS b)