163 lines
5.9 KiB
Haskell
163 lines
5.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module GEval.Clippings
|
|
where
|
|
|
|
import Data.Attoparsec.Text
|
|
import Data.Text
|
|
import Control.Applicative
|
|
import Control.Exception
|
|
import Data.Char (isSpace)
|
|
import Data.List (unfoldr)
|
|
import Data.Maybe (catMaybes)
|
|
|
|
import Debug.Trace
|
|
|
|
import GEval.Common
|
|
|
|
newtype PageNumber = PageNumber Int
|
|
deriving (Eq, Show)
|
|
|
|
data Point = Point Int Int
|
|
deriving (Show, Eq)
|
|
|
|
data Rectangle = Rectangle Point Point
|
|
deriving (Show, Eq)
|
|
|
|
data Clipping = Clipping PageNumber Rectangle
|
|
deriving (Show, Eq)
|
|
|
|
data ClippingSpec = ClippingSpec PageNumber Rectangle Rectangle
|
|
deriving (Show, Eq)
|
|
|
|
data LabeledClipping = LabeledClipping (Maybe Text) Clipping
|
|
deriving (Show, Eq)
|
|
|
|
matchClippingToSpec :: ClippingSpec -> Clipping -> Bool
|
|
matchClippingToSpec (ClippingSpec pageNo (Rectangle (Point x0' y0') (Point x1' y1'))
|
|
(Rectangle (Point x0'' y0'') (Point x1'' y1'')))
|
|
(Clipping pageNo' (Rectangle (Point x0 y0) (Point x1 y1))) =
|
|
pageNo == pageNo' &&
|
|
isInside x0 x0' x0'' && isInside y0 y0' y0'' && isInside x1 x1' x1'' && isInside y1 y1' y1''
|
|
where isInside c c' c'' = c >= c' && c <= c'' || c <= c' && c >= c''
|
|
|
|
|
|
lineClippingsParser :: Parser [Clipping]
|
|
lineClippingsParser = sepByWhitespaces clippingParser
|
|
|
|
clippingParser :: Parser Clipping
|
|
clippingParser = do
|
|
pageNo <- PageNumber <$> decimal
|
|
char '/'
|
|
rectangle <- rectangleParser
|
|
return $ Clipping pageNo rectangle
|
|
|
|
lineClippingSpecsParser :: Parser [ClippingSpec]
|
|
lineClippingSpecsParser = sepByWhitespaces clippingSpecParser
|
|
|
|
clippingSpecParser :: Parser ClippingSpec
|
|
clippingSpecParser = do
|
|
pageNo <- PageNumber <$> decimal
|
|
char '/'
|
|
rectangle <- rectangleParser
|
|
char '/'
|
|
margin <- decimal
|
|
return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle)
|
|
|
|
labeledClippingParser :: Parser LabeledClipping
|
|
labeledClippingParser =
|
|
choice [clippingWithLabelParser,
|
|
(LabeledClipping Nothing <$> clippingParser)]
|
|
|
|
clippingWithLabelParser :: Parser LabeledClipping
|
|
clippingWithLabelParser = do
|
|
label <- takeWhile1 (\c -> not (isSpace c) && c /= ':')
|
|
string ":"
|
|
clipping <- clippingParser
|
|
return $ LabeledClipping (Just label) clipping
|
|
|
|
lineLabeledClippingsParser :: Parser [LabeledClipping]
|
|
lineLabeledClippingsParser = sepByWhitespaces labeledClippingParser
|
|
|
|
extendedRectangle :: Int -> Rectangle -> Rectangle
|
|
extendedRectangle margin (Rectangle (Point x0 y0) (Point x1 y1)) =
|
|
Rectangle (Point (x0 `nonNegativeDiff` margin) (y0 `nonNegativeDiff` margin))
|
|
(Point (x1 + margin) (y1 + margin))
|
|
|
|
smallerRectangle :: Int -> Rectangle -> Rectangle
|
|
smallerRectangle margin (Rectangle (Point x0 y0) (Point x1 y1)) =
|
|
Rectangle (Point (x0 + margin) (y0 + margin))
|
|
(Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin))
|
|
|
|
|
|
|
|
nonNegativeDiff x y
|
|
| x < y = 0
|
|
| otherwise = x - y
|
|
|
|
rectangleParser :: Parser Rectangle
|
|
rectangleParser = do
|
|
x0 <- decimal
|
|
char ','
|
|
y0 <- decimal
|
|
char ','
|
|
x1 <- decimal
|
|
char ','
|
|
y1 <- decimal
|
|
if x1 < x0 || y1 < y0
|
|
then fail "wrong coordinates"
|
|
else return $ Rectangle (Point x0 y0) (Point x1 y1)
|
|
|
|
rectangleArea :: Rectangle -> Integer
|
|
rectangleArea (Rectangle (Point x0 y0) (Point x1 y1)) =
|
|
(fromIntegral $ x1 - x0 + 1) * (fromIntegral $ y1 - y0 + 1)
|
|
|
|
clippingArea :: LabeledClipping -> Integer
|
|
clippingArea (LabeledClipping _ (Clipping _ rect)) = rectangleArea rect
|
|
|
|
totalArea :: [LabeledClipping] -> Integer
|
|
totalArea = sum . Prelude.map clippingArea
|
|
|
|
coveredBy :: [LabeledClipping] -> [LabeledClipping] -> Integer
|
|
coveredBy clippingsA clippingsB = sum
|
|
$ Prelude.map rectangleArea
|
|
$ catMaybes
|
|
$ Data.List.unfoldr step (clippingsA, clippingsB)
|
|
where
|
|
step ([], _) = Nothing
|
|
step (firstA:restA, b) = Just (result, (newA ++ restA, newB))
|
|
where (result, newA, newB) = step' firstA b
|
|
step' rectA [] = (Nothing, [], [])
|
|
step' a (firstB:restB) = case partitionClippings a firstB of
|
|
Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB)
|
|
Nothing -> let
|
|
(result, leftoversA, leftoversB) = step' a restB
|
|
in (result, leftoversA, firstB:leftoversB)
|
|
|
|
partitionClippings :: LabeledClipping -> LabeledClipping -> Maybe (Rectangle, [LabeledClipping], [LabeledClipping])
|
|
partitionClippings (LabeledClipping label (Clipping page rect@(Rectangle (Point x0 y0) (Point x1 y1))))
|
|
(LabeledClipping label' (Clipping page' rect'@(Rectangle (Point x0' y0') (Point x1' y1'))))
|
|
| label == label' && page == page' && not (areDisjoint rect rect') = Just (commonRect, leftovers, leftovers')
|
|
| otherwise = Nothing
|
|
where commonRect = Rectangle (Point cx0 cy0) (Point cx1 cy1)
|
|
cx0 = max x0 x0'
|
|
cx1 = min x1 x1'
|
|
cy0 = max y0 y0'
|
|
cy1 = min y1 y1'
|
|
leftovers = Prelude.map (\r -> LabeledClipping label (Clipping page r)) $ getLeftovers commonRect rect
|
|
leftovers' = Prelude.map (\r -> LabeledClipping label (Clipping page r)) $ getLeftovers commonRect rect'
|
|
|
|
areDisjoint :: Rectangle -> Rectangle -> Bool
|
|
areDisjoint (Rectangle (Point x0 y0) (Point x1 y1))
|
|
(Rectangle (Point x0' y0') (Point x1' y1')) =
|
|
x1 < x0' || x1' < x0 || y1 < y0' || y1' < y0
|
|
|
|
getLeftovers :: Rectangle -> Rectangle -> [Rectangle]
|
|
getLeftovers (Rectangle (Point x0 y0) (Point x1 y1))
|
|
(Rectangle (Point x0' y0') (Point x1' y1')) =
|
|
Prelude.filter validRectangle [Rectangle (Point x0 y0') (Point x1 (y0 - 1)),
|
|
Rectangle (Point x0 (y1 + 1)) (Point x1 y1'),
|
|
Rectangle (Point x0' y0') (Point (x0 - 1) y1'),
|
|
Rectangle (Point (x1 + 1) y0') (Point x1' y1')]
|
|
where validRectangle (Rectangle (Point x0 y0) (Point x1 y1)) = x0 <= x1 && y0 <= y1
|