{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Geometry.YX (
YX(..),
up, left, right, down,
steps4, steps8,
Box, box, arrayBox, boundingBox,
boxBounds, topLeft, bottomRight,
boxHeight, boxWidth,
inBox, boxDepth, boxRange, boxRows, boxIntersection,
boxNeighbors4, boxNeighbors8,
Center(..), Direction(..), rotate,
Axis(..), mirror,
byteStringToArray, byteStringToArrayM, arrayToByteString
) where
import Prelude hiding (lines)
import Algebra.Lattice (Lattice(..), joinLeq, meetLeq)
import Control.Monad.Except (MonadError, throwError)
import Data.Array.IArray (IArray)
import qualified Data.Array.IArray as IArray
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Foldable (foldl')
import Data.Ix (Ix)
import qualified Data.Ix as Ix
import Data.List (groupBy)
data YX
= YX
{ y :: {-# UNPACK #-} !Int
, x :: {-# UNPACK #-} !Int
} deriving (Eq, Ord, Show)
lift1 :: (Int -> Int) -> YX -> YX
lift1 f (YX y1 x1) = YX (f y1) (f x1)
lift2 :: (Int -> Int -> Int) -> YX -> YX -> YX
lift2 f (YX y1 x1) (YX y2 x2) = YX (f y1 y2) (f x1 x2)
instance Num YX where
(+) = lift2 (+)
(*) = lift2 (*)
abs = lift1 abs
signum = lift1 signum
fromInteger i = let i' = fromInteger i in YX i' i'
negate = lift1 negate
instance Ix YX where
range (YX yl xl, YX yu xu) =
[ YX y0 x0 | y0 <- Ix.range (yl, yu), x0 <- Ix.range (xl, xu) ]
index (YX yl xl, YX yu xu) (YX y0 x0) =
Ix.index (yl, yu) y0 * Ix.rangeSize (xl, xu) + Ix.index (xl, xu) x0
inRange (YX yl xl, YX yu xu) (YX y0 x0) =
Ix.inRange (yl, yu) y0 && Ix.inRange (xl, xu) x0
instance Lattice YX where
YX y0 x0 /\ YX y1 x1 = YX (min y0 y1) (min x0 x1)
YX y0 x0 \/ YX y1 x1 = YX (max y0 y1) (max x0 x1)
up :: YX
up = YX (-1) 0
left :: YX
left = YX 0 (-1)
right :: YX
right = YX 0 1
down :: YX
down = YX 1 0
steps4 :: [YX]
steps4 = [up, left, right, down]
steps8 :: [YX]
steps8 = [up + left, up, up + right, left, right, down + left, down, down + right]
data Box = Box { _topLeft :: !YX , _bottomRight :: !YX } deriving (Eq, Show)
instance Semigroup Box where
(Box tl1 br1) <> (Box tl2 br2) = Box (tl1 /\ tl2) (br1 \/ br2)
box
:: YX
-> YX
-> Maybe Box
box yx0 yx1 =
if joinLeq yx0 yx1 && meetLeq yx0 yx1
then Just $ Box yx0 yx1
else Nothing
arrayBox :: IArray a e => a YX e -> Maybe Box
arrayBox = uncurry box . IArray.bounds
boundingBox :: Foldable f => f YX -> Maybe Box
boundingBox = foldl' go Nothing where
go Nothing yx = Just $ Box yx yx
go (Just (Box tl br)) yx = Just $ Box (tl /\ yx) (br \/ yx)
topLeft :: Box -> YX
topLeft = _topLeft
bottomRight :: Box -> YX
bottomRight = _bottomRight
boxBounds :: Box -> (YX, YX)
boxBounds (Box tl br) = (tl, br)
boxHeight :: Box -> Int
boxHeight (Box (YX y0 _) (YX y1 _)) = y1 - y0
boxWidth :: Box -> Int
boxWidth (Box (YX _ x0) (YX _ x1)) = x1 - x0
boxRange :: Box -> [YX]
boxRange (Box tl br) = Ix.range (tl, br)
inBox :: YX -> Box -> Bool
inBox yx (Box tl br) = joinLeq yx br && meetLeq tl yx
boxDepth :: Box -> YX -> Maybe Int
boxDepth b@(Box (YX y0 x0) (YX y1 x1)) yx@(YX y x) = if yx `inBox` b
then Just $ minimum [y - y0, y1 - y, x - x0, x1 - x]
else Nothing
boxRows :: Box -> [[YX]]
boxRows (Box tl br) = groupBy (\(YX y1 _) (YX y2 _) -> y1 == y2) $ Ix.range (tl, br)
boxNeighbors :: [YX] -> Box -> YX -> [YX]
boxNeighbors steps b yx = filter (`inBox` b) $ fmap (+ yx) steps
boxNeighbors4 :: Box -> YX -> [YX]
boxNeighbors4 = boxNeighbors steps4
boxNeighbors8 :: Box -> YX -> [YX]
boxNeighbors8 = boxNeighbors steps8
boxIntersection :: Box -> Box -> Maybe Box
boxIntersection (Box tl0 br0) (Box tl1 br1) =
if joinLeq tl0 tl1 && meetLeq br0 br1
then Just $ Box (tl0 /\ tl1) (br0 \/ br1)
else Nothing
data Center = Around YX | AroundTopLeftCorner YX deriving (Eq, Ord, Show)
data Direction = Clockwise | CounterClockwise deriving (Bounded, Eq, Enum, Ord, Show)
rotate :: Direction -> Center -> YX -> YX
rotate dir (Around yx0) yx1 =
let YX y2 x2 = yx1 - yx0
in case dir of
Clockwise -> yx0 + YX x2 (-y2)
CounterClockwise -> yx0 + YX (-x2) y2
rotate dir (AroundTopLeftCorner yx0) yx1 = rotate dir (Around yx0) yx1 + left
data Axis
= AboveRow Int
| AtRow Int
| LeftOfColumn Int
| AtColumn Int
deriving (Eq, Ord, Show)
mirror :: Axis -> YX -> YX
mirror (AboveRow y0) yx = mirror (AtRow y0) yx + up
mirror (AtRow y0) (YX y1 x1) = YX (2 * y0 - y1) x1
mirror (LeftOfColumn x0) yx = mirror (AtColumn x0) yx + left
mirror (AtColumn x0) (YX y1 x1) = YX y1 (2 * x0 - x1)
byteStringToArrayM
:: (IArray a e, MonadError String m)
=> (YX -> Char -> m e) -> ByteString -> m (a YX e)
byteStringToArrayM f bs = shape (BS.split '\n' bs) (-1) >>= materialize bs where
shape [] (YX y0 x0) = pure (YX y0 (max x0 0))
shape rows@(row : rows') yx@(YX y0 x0)
| null $ filter (not . BS.null) rows = shape [] yx
| otherwise = let x1 = BS.length row - 1
in if x1 /= x0 && x0 >= 0
then throwError $ "bad row lengths: " ++ show x0 ++ ", " ++ show x1
else shape rows' (YX (y0 + 1) x1)
materialize bs' yx = let t = (0, yx) in IArray.listArray t <$> elems (Ix.range t) bs'
elems yxs bs' = sequenceA $ fmap (uncurry f) $ zip yxs (filter (/= '\n') $ BS.unpack bs')
byteStringToArray :: IArray a e => (Char -> Maybe e) -> ByteString -> Either String (a YX e)
byteStringToArray f bs = byteStringToArrayM (const toElem) bs where
toElem c = case f c of
Just e -> Right e
Nothing -> Left $ "unknown char: " ++ show c
arrayToByteString :: IArray a e => (e -> Char) -> a YX e -> ByteString
arrayToByteString f arr = BS.intercalate "\n" lines where
lines = fmap (BS.pack . fmap (f . (arr IArray.!))) . boxRows . uncurry Box . IArray.bounds $ arr