-- | Convert dihaa TwoD Dia to simple vector shapes.

-- -------------------------------------------------------------------
-- Copyright (C) 2017 by Sascha Wilde <wilde@sha-bang.de>

-- 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