-- | Convert dihaa TwoD Dia to simple vector shapes. -- ------------------------------------------------------------------- -- Copyright (C) 2017 by Sascha Wilde -- This program is free software under the GNU GPL (>=v2) -- Read the file COPYING coming with the software for details. -- ------------------------------------------------------------------- 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 -- for testing and debugging only: 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