--------------------------------------------------------------------
-- |
-- Module    : Graphics.SVG.ReadPath
-- Copyright : (c) 2013 Tillmann Vogt
-- License   : BSD3
--
-- Maintainer: Tillmann Vogt <tillk.vogt@googlemail.com>
-- Stability : stable
-- Portability: portable
--
-- Parsing the SVG path command, see <http://www.w3.org/TR/SVG/paths.html#PathData> :

module Graphics.SVG.ReadPath
 ( pathFromString,
   PathCommand(..),
   commandsToPoints,
   ctp,
   bSubCurve
 )
 where

import Text.ParserCombinators.Parsec hiding (spaces)
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Prim
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(emptyDef)
import System.IO.Unsafe (unsafePerformIO)
import Debug.Trace

type X = Double
type Y = Double
type F2 = (X,Y)
type Tup = (X,Y)
type X1 = X
type Y1 = Y
type X2 = X
type Y2 = Y
data PathCommand =
  M_abs Tup | -- ^Establish a new current point (with absolute coords)
  M_rel Tup | -- ^Establish a new current point (with coords relative to the current point)
  Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point
  L_abs Tup | -- ^A line from the current point to Tup which becomes the new current point
  L_rel Tup |
  H_abs X | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy)
  H_rel X |
  V_abs Y | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y)
  V_rel Y |
  C_abs (X1,Y1,X2,Y2,X,Y) | -- ^Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the
  -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve.
  C_rel (X1,Y1,X2,Y2,X,Y) |
  S_abs (X2,Y2,X,Y) | -- ^Draws a cubic Bézier curve from the current point to (x,y). The first control point is
-- assumed to be the reflection of the second control point on the previous command relative to the current point.
-- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control
-- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at
-- the end of the curve).
  S_rel (X2,Y2,X,Y) |
  Q_abs (X1,Y1,X,Y) | -- ^A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point
  Q_rel (X1,Y1,X,Y) | -- ^Nearly the same as cubic, but with one point less
  T_abs Tup | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto
  T_rel Tup |
  A_abs | -- ^A = Elliptic arc (not used)
  A_rel
  deriving Show

-- | convert a SVG path string into a list of commands
pathFromString :: String -> IO [PathCommand]
pathFromString str
  = do{ case (parse path "" str) of
           Left err -> do{ putStr "parse error at "
                         ; print err
                         ; return []
                         }
           Right x  -> return x
      }

spaces = skipMany space

path :: Parser [PathCommand]
path = do{ l <- many pathElement
         ; eof
         ; return (concat l)
         }

pathElement :: Parser [PathCommand]
pathElement = do{ whiteSpace;
              do{ symbol "M";  l <- many1 tuple2; return (map (\x-> M_abs x) l) } <|>
              do{ symbol "m";  l <- many1 tuple2; return (map (\x-> M_rel x) l) } <|>
              do{ symbol "z"; return [Z]; } <|>
              do{ symbol "Z"; return [Z]; } <|>
              do{ symbol "L";  l <- many1 tuple2; return (map (\x-> L_abs x) l) } <|>
              do{ symbol "l";  l <- many1 tuple2; return (map (\x-> L_rel x) l) } <|>
              do{ symbol "H";  l <- many1 myfloat; return (map (\x-> H_abs (realToFrac x)) l) } <|>
              do{ symbol "h";  l <- many1 myfloat; return (map (\x-> H_rel (realToFrac x)) l) } <|>
              do{ symbol "V";  l <- many1 myfloat; return (map (\x-> V_abs (realToFrac x)) l) } <|>
              do{ symbol "v";  l <- many1 myfloat; return (map (\x-> V_rel (realToFrac x)) l) } <|>
              do{ symbol "C";  l <- many1 tuple6; return (map (\x-> C_abs x) l) } <|>
              do{ symbol "c";  l <- many1 tuple6; return (map (\x-> C_rel x) l) } <|>
              do{ symbol "S";  l <- many1 tuple4; return (map (\x-> S_abs x) l) } <|>
              do{ symbol "s";  l <- many1 tuple4; return (map (\x-> S_rel x) l) } <|>
              do{ symbol "Q";  l <- many1 tuple4; return (map (\x-> Q_abs x) l) } <|>
              do{ symbol "q";  l <- many1 tuple4; return (map (\x-> Q_rel x) l) } <|>
              do{ symbol "T";  l <- many1 tuple2; return (map (\x-> T_abs x) l) } <|>
              do{ symbol "t";  l <- many1 tuple2; return (map (\x-> T_rel x) l) } <|>
              do{ symbol "A";  l <- many1 tuple2; return (map (\x-> A_abs) l) } <|> -- not used
              do{ symbol "a";  l <- many1 tuple2; return (map (\x-> A_rel) l) }     -- not used
            }

comma = do{ spaces; try (do { (char ','); return () }) <|> spaces }

tuple2 :: Parser (X,Y)
tuple2 = do{ x <- myfloat; comma; y <- myfloat; spaces;
             return (realToFrac x, realToFrac y)
           }

tuple4 :: Parser (X,Y,X,Y)
tuple4 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces;
              x <- myfloat; comma;  y <- myfloat; spaces;
             return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y)
           }

tuple6 :: Parser (X,Y,X,Y,X,Y)
tuple6 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces;
             x2 <- myfloat; comma; y2 <- myfloat; spaces;
              x <- myfloat; comma;  y <- myfloat; spaces;
             return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2, realToFrac x, realToFrac y)
           }

myfloat = try (do{ symbol "-"; n <- float; return (negate n) }) <|>
          try float <|> -- 0 is not recognized as a float, so recognize it as an integer and then convert to float
              do { i<-integer; return(fromIntegral i) } 

lexer = P.makeTokenParser emptyDef

whiteSpace      = P.whiteSpace lexer    
symbol          = P.symbol lexer    
integer         = P.integer lexer    
float           = P.float lexer

-------------------------------------------
-- | convert path-commands to outline points
commandsToPoints :: [PathCommand] -> F2 -> F2 -> [[F2]]
commandsToPoints commands (dx, dy) (offsetX, offsetY) | null result = []
                                                      | otherwise = result
 where result = ctp commands [(0,0)] (0,0) False (dx,dy) (offsetX, offsetY)

unequal :: (Fractional a, Fractional a1, Ord a, Ord a1) => a -> a1 -> (a, a1) -> (a, a1) -> Bool
unequal dx dy (x0,y0) (x1,y1) | (abs (x0-x1) < dx/4) && (abs (y0-y1) < dy/4) = False
                              | otherwise = True

ctp :: [PathCommand] -> [F2] -> F2 -> Bool -> F2 -> F2 -> [[F2]]
ctp [] p _ _ _ _ = [tail p]
ctp (c:commands) points lastContr useTex (dx, dy) (ox,oy) -- dx, dy is the size of a pixel, used for rasterisation
             -- one outline completed
            | null nextPoints = [tail points] ++ (if useTex && unequal dx dy (last points) (head points)
                                                  -- add a line from the last point to the first point
                                                  then [( go (L_abs (head  (tail points))) )] 
                                                  else []) ++
                              ( ctp commands [(0,0)]                       (contr c) useTex (dx,dy) (ox,oy))
            | otherwise       = ctp commands (points ++ (tail nextPoints)) (contr c) useTex (dx,dy) (ox,oy) -- work on outline
 where nextPoints = (go c)
       contr ( C_abs (_,_,x2,y2,x,y) ) = (   x+x-x2,    y+y-y2 ) -- control point of bezier curve
       contr ( C_rel (_,_,x2,y2,x,y) ) = (x0+x+x-x2, y0+y+y-y2 )
       contr ( S_abs (x2,y2,x,y) )     = (   x+x-x2,    y+y-y2 )
       contr ( S_rel (x2,y2,x,y) )     = (x0+x+x-x2, y0+y+y-y2 )
       contr ( Q_abs (x1,y1,x,y) ) = (   x+x-x1,    y+y-y1 )
       contr ( Q_rel (x1,y1,x,y) ) = (x0+x+x-x1, y0+y+y-y1 )
       contr ( T_abs (x,y) )       = (   x+x-cx,    y+y-cy )
       contr ( T_rel (x,y) )       = ( 2*(x0+x)-cx, 2*(y0+y)-cy ) -- absolute coordinates
       contr ( L_abs (x,y) ) = (     x,      y)
       contr ( L_rel (x,y) ) = (x0 + x, y0 + y)
       contr ( M_abs (x,y) ) = (     x,      y)
       contr ( M_rel (x,y) ) = (x0 + x, y0 + y)
       contr ( H_abs x ) = (     x, y0 )
       contr ( H_rel x ) = (x0 + x, y0 )
       contr ( V_abs y ) = (x0,      y )
       contr ( V_rel y ) = (x0, y0 + y )
       contr _ = error "error at parsing SVG path command,  arcs not implemented yet"

       go ( M_abs (x,y) ) = [(0, 0), (x + ox, y + oy)]
       go ( M_rel (x,y) ) = [(0, 0), (x0 + x + ox, y0 + y + oy)]
       go ( L_abs (x,y) ) | useTex = bsub [(x0,y0), (x, y)]
                          | otherwise =   [(x0,y0), (x, y)]
       go ( L_rel (x,y) ) | useTex = bsub [(x0,y0), (x0 + x, y0 + y)]
                          | otherwise =   [(x0,y0), (x0 + x, y0 + y)]
       go ( H_abs x) | useTex = bsub [(x0,y0), (x, y0)]
                     | otherwise =   [(x0,y0), (x, y0)]
       go ( H_rel x) | useTex = bsub [(x0,y0), (x0 + x, y0)]
                     | otherwise =   [(x0,y0), (x0 + x, y0)]
       go ( V_abs y) | useTex = bsub [(x0,y0), (x0, y)]
                     | otherwise =   [(x0,y0), (x0, y)]
       go ( V_rel y) | useTex = bsub [(x0,y0), (x0, y0 + y)]
                     | otherwise =   [(x0,y0), (x0, y0 + y)]
       go ( C_abs (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x1, y1), (x2, y2), (x, y)]
       go ( C_rel (x1,y1,x2,y2,x,y) ) = bsub [(x0, y0), (x0+x1, y0+y1), (x0+x2,y0+y2), (x0+x,y0+y)]
       go ( S_abs (      x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x2, y2), (x, y) ]
       go ( S_rel (      x2,y2,x,y) ) = bsub [(x0, y0), (cx, cy), (x0 + x2, y0 + y2), (x0 + x, y0 + y)]
       go ( Q_abs (x1,y1,x,y) ) = bsub [(x0, y0), (x1, y1), (x, y)]
       go ( Q_rel (x1,y1,x,y) ) = bsub [(x0, y0), (x0 + x1, y0 + y1), (x0 + x, y0 + y)]
       go ( T_abs (x,y) ) = bsub [(x0,y0), (cx, cy), (x, y)     ]
       go ( T_rel (x,y) ) = bsub [(x0,y0), (cx, cy), (x0 + x, y0 + y)]
       go ( Z ) = []
       go _ = error "error at parsing SVG path command,  arcs not implemented yet"

       x0 = fst (last points)
       y0 = snd (last points)
       cx = (fst lastContr) -- last control point is always in absolute coordinates
       cy = (snd lastContr)

       bsub xs = bSubCurve useTex (dx,dy) xs

-----------------
-- bezier-curves
-----------------
linearInterp :: Num t => t -> ((t, t), (t, t)) -> (t, t)
linearInterp t ((x0,y0), (x1,y1)) = ( (1-t)*x0 + t*x1, (1-t)*y0 + t*y1)

tuplesOfTwo :: [t] -> [(t, t)]
tuplesOfTwo (bi:bj:[]) = [(bi,bj)]
tuplesOfTwo (bi:bj:bs) = (bi,bj) : tuplesOfTwo (bj:bs)
tuplesOfTwo _ = error "tuplesOfTwo"

eval t bs = map (linearInterp t) (tuplesOfTwo bs)

deCas2 :: Num t => t -> [(t, t)] -> [(t, t)]
deCas2 t (bi:[]) = [bi]
deCas2 t bs = [head bs] ++ (deCas2 t e) ++ [last bs]
 where e = eval t bs

-- | bSubcurve uses bezier subdivision. (inspired by Hersch, Font Rasterization: the State of the Art (freely available))
-- It divides an arc into two arcs recursively until the arc is either completely
-- between two vertical raster lines or completely between two horizontal raster lines or the line is at most 1 pixel long.
-- This function computes outline points (tex==False) as well as border points for rasterisation (tex==True) by using
-- an x-, y-resoultion raster. dx, dy is the width and height of a pixel of this raster.
bSubCurve :: Bool -> (X,Y) -> [F2] -> [F2]
bSubCurve useTex (dx,dy) bs | ( (abs (p1x_int-p0x_int)) == 1 && (abs (p1y_int-p0y_int)) == 1 ) || -- at most one point per pixel
                              ( (abs (p1x-p0x)) < dx && (abs (p1y-p0y)) < dy ) ||
                              ( (abs (p1x-p0x)) < dx && p0x_int == p1x_int && useTex ) || -- vertical line
                              ( (abs (p1y-p0y)) < dy && p0y_int == p1y_int && useTex )    -- horizontal line
                                    = [ (p0x, p0y), (p1x, p1y) ]
                            | otherwise = firstArc ++ (tail secondArc) -- subdivide

 where firstArc =  bSubCurve useTex (dx,dy) (take l twoArcs)
       secondArc = bSubCurve useTex (dx,dy) (drop (l-1) twoArcs)
       twoArcs = deCas2 0.5 bs
       l = (length twoArcs) `div` 2 + 1

       (p0x, p0y) = head bs
       (p1x, p1y) = last bs
       (p0x_int, p0y_int) | p0y < p1y = (truncate (p0x/dx), truncate (p0y/dy))
                          | otherwise = (truncate (p1x/dx), truncate (p1y/dy))
       (p1x_int, p1y_int) | p0y < p1y = (truncate (p1x/dx), truncate (p1y/dy))
                          | otherwise = (truncate (p0x/dx), truncate (p0y/dy))