module Dihaa.Vectorize (Point (P), Shape (..), RGB (..),
findArrows, findBoxes,
findLabels, findLines,
vectorize) where
import Dihaa
import TwoD
import Control.Applicative
import Control.Monad
import Data.Char (isHexDigit, digitToInt)
import Data.List (find)
import Data.Maybe
import System.Environment (getArgs)
data Point = P Int Int
deriving (Eq, Show)
data Shape = Box Point Point RGB
| Line Point Point
| Label Point String
| Arrow Point Direction
| StyleColor { stylePoint :: Point,
styleColor :: RGB }
deriving Show
data RGB = RGB Int Int Int
deriving Show
pointOnLine :: Point -> Shape -> Bool
pointOnLine (P x y) (Line (P lx1 ly1) (P lx2 ly2))
= (y == ly1 && ly1 == ly2 && x <= max lx1 lx2 && x >= min lx1 lx2)
|| (x == lx1 && lx1 == lx2 && y <= max ly1 ly2 && y >= min ly1 ly2)
pointOnLine _ _ = False
followWhile :: Direction -> [Glyph] -> Dia -> Point -> Point
followWhile dir way d (P x y)
| isInAny [getFromDirection dir] x y d way =
callOnDirection (\x y -> followWhile dir way d (P x y)) dir x y
| otherwise = P x y
followTo :: Direction -> [Glyph] -> [Glyph] -> Dia -> Point -> Maybe Point
followTo dir way goal d (P x y)
| isInAny [getFromDirection dir] x y d goal =
callOnDirection (\x y -> Just (P x y)) dir x y
| isInAny [getFromDirection dir] x y d way =
callOnDirection (\x y -> followTo dir way goal d (P x y)) dir x y
| otherwise = Nothing
findBoxAt :: [Shape] -> Dia -> Int -> Int -> Maybe Shape
findBoxAt ss d x y
| elem (P x y) cNW = liftM3 Box cNW cSE (color <|> Just (RGB 255 255 255))
| otherwise = Nothing
where
cNE = followTo E [LineH, TeeWNE]
[CornerNE, TeeWSE, TeeNWS, Cross]
d (P x y)
cSE = followTo S [LineV, TeeNES]
[CornerSE, TeeWNE, TeeNWS, Cross]
d =<< cNE
cSW = followTo W [LineH, TeeWSE]
[CornerSW, TeeWNE, TeeNES, Cross]
d =<< cSE
cNW = followTo N [LineV, TeeNWS]
[CornerNW, TeeWSE, TeeNES, Cross]
d =<< cSW
colorStyleInBox (P x1 y1) (P x2 y2) c@(StyleColor (P xs ys) _) =
x1 < xs && xs < x2 && y1 < ys && ys < y2
colorStyleInBox _ _ _ = False
color = join $ liftM2
(\p1 p2 -> styleColor <$> find (colorStyleInBox p1 p2) ss)
cNW cSE
findBoxes :: [Shape] -> Dia -> [Shape]
findBoxes ls = catMaybes . foldrTwoDXY addBoxAt []
where
addBoxAt :: Glyph -> [Maybe Shape] -> Dia -> Int -> Int -> [Maybe Shape]
addBoxAt c ss d x y
| elem c [CornerNW, TeeWSE, TeeNES, Cross] = findBoxAt ls d x y : ss
| otherwise = ss
findLineDirAt :: Direction -> [Glyph] -> [Glyph] -> Dia -> Int -> Int
-> Maybe Shape
findLineDirAt dir way goal d x y = liftM2 Line p1 p2
where
p1 = followTo dir way goal d (P x y)
<|> find (/= P x y) [followWhile dir way d (P x y)]
p2 = Just (P x y)
findLineHAt :: Dia -> Int -> Int -> Maybe Shape
findLineHAt = findLineDirAt W [LineH, TeeWNE, TeeWSE, Cross]
[CornerNW, CornerSW, TeeNES, ArrowW]
findLineVAt :: Dia -> Int -> Int -> Maybe Shape
findLineVAt = findLineDirAt N [LineV, TeeNWS, TeeNES, Cross]
[CornerNW, CornerNE, TeeWSE, ArrowN]
findLinesH :: Dia -> [Shape]
findLinesH = catMaybes . foldrTwoDXY addLineAt []
where
addLineAt :: Glyph -> [Maybe Shape] -> Dia -> Int -> Int -> [Maybe Shape]
addLineAt c ss d x y
| elem c [LineH, CornerNE, CornerSE, TeeNWS, ArrowE ]
&& not (any (pointOnLine (P x y)) (catMaybes ss)) = findLineHAt d x y : ss
| otherwise = ss
findLinesV :: Dia -> [Shape]
findLinesV = catMaybes . foldrTwoDXY addLineAt []
where
addLineAt :: Glyph -> [Maybe Shape] -> Dia -> Int -> Int -> [Maybe Shape]
addLineAt c ss d x y
| elem c [LineV, CornerSW, CornerSE, TeeWNE, ArrowS ]
&& not (any (pointOnLine (P x y)) (catMaybes ss)) = findLineVAt d x y : ss
| otherwise = ss
findLines :: Dia -> [Shape]
findLines d = findLinesH d ++ findLinesV d
findArrows :: Dia -> [Shape]
findArrows = foldrTwoDXY addArrowAt []
where
addArrowAt :: Glyph -> [Shape] -> Dia -> Int -> Int -> [Shape]
addArrowAt ArrowN ss _ x y = Arrow (P x y) N : ss
addArrowAt ArrowS ss _ x y = Arrow (P x y) S : ss
addArrowAt ArrowW ss _ x y = Arrow (P x y) W : ss
addArrowAt ArrowE ss _ x y = Arrow (P x y) E : ss
addArrowAt _ ss _ _ _ = ss
collectString :: String -> Dia -> Int -> Int -> String
collectString s d x y
| any isStrElem g = let ns = case fromJust g of
Verbatim c -> c : s
Space -> ' ' : s
in
callOnDirection (collectString ns d) W x y
| otherwise = dropWhile (== ' ') s
where
g = getXY d x y
isStrElem (Verbatim _) = True
isStrElem Space = True
isStrElem _ = False
findLabels :: Dia -> [Shape]
findLabels = foldrTwoDXY addLabelAt []
where
addLabelAt :: Glyph -> [Shape] -> Dia -> Int -> Int -> [Shape]
addLabelAt (Verbatim _) ss d x y
| not $ atAnyString x y ss = let s=collectString "" d x y
in Label (P (x - length s + 1) y) s : ss
| otherwise = ss
addLabelAt _ ss _ _ _ = ss
atString :: Int -> Int -> Shape -> Bool
atString x y (Label (P lx ly) s) = y == ly
&& x >= lx && x < (lx + length s)
atString _ _ _ = False
atAnyString :: Int -> Int -> [Shape] -> Bool
atAnyString x y = any (atString x y)
parseStyleLabel :: Shape -> Shape
parseStyleLabel l@(Label p (':':'#':r:g:b:[]))
| isHexDigit r && isHexDigit g && isHexDigit b = StyleColor p
$ RGB (digitToInt r * 17)
(digitToInt g * 17)
(digitToInt b * 17)
| otherwise = l
parseStyleLabel s = s
parseStyleLabels :: [Shape] -> [Shape]
parseStyleLabels = Prelude.map parseStyleLabel
vectorize :: Dia -> [Shape]
vectorize d = let ls = parseStyleLabels $ findLabels d
in ls ++ findBoxes ls d ++ findLines d ++ findArrows d