module Graphics.Curves.SVG.Path
  ( Path, CoordType(..), PathCmd(..)
  , parsePath, drawPath
  ) where

import Data.Char
import Data.Monoid
import Graphics.Curves

-- | A path is a sequence of path commands.
type Path = [PathCmd]

-- | Path commands can use absolute or relative coordinates.
data CoordType = Absolute | Relative
  deriving Show

-- | The path commands specified by <http://www.w3.org/TR/SVG/paths.html#PathData>.
data PathCmd = MoveTo CoordType Point
             | LineTo CoordType Point
             | HorLineTo CoordType Scalar
             | VerLineTo CoordType Scalar
             | BezierTo CoordType [Point]   -- ^ number of points = degree of the Bézier curve
             | SmoothBezierTo CoordType [Point] -- ^ first control point is
                                                -- the mirror of the
                                                -- previous control point
             | ArcTo CoordType Vec Scalar Bool Bool Point
             | ClosePath
  deriving Show

data PathToken = TokNum Scalar
               | TokCmd Char

instance Show PathToken where
  show (TokCmd c)    = [c]
  show (TokNum x) = show x

lexNum :: String -> Maybe (String, String)
lexNum s = start s
  where
    eat c = fmap (\(a, b) -> (c:a, b))
    ret s = Just ("", s)
    bad   = Nothing

    start ('-':s) = eat '-' $ num s
    start s       = num s

    num (c:s) | isDigit c = eat c $ num1 s
    num _ = bad

    num1 (c:s) | isDigit c = eat c $ num1 s
    num1 ('.':s) = eat '.' $ frac s
    num1 ('e':s) = eat 'e' $ expn s
    num1 s       = ret s

    frac (c:s) | isDigit c = eat c $ frac1 s

    frac1 (c:s) | isDigit c = eat c $ frac1 s
    frac1 ('e':s) = eat 'e' $ expn s
    frac1 s = ret s

    expn ('-':s) = eat '-' $ expn1 s
    expn s = expn1 s

    expn1 (c:s) | isDigit c = eat c $ expn2 s
    expn1 _ = bad

    expn2 (c:s) | isDigit c = eat c $ expn2 s
    expn2 s = ret s

lexPath :: String -> [PathToken]
lexPath [] = []
lexPath (c:s)
  | isAlpha c   = TokCmd c : lexPath s
  | isNumChar c =
    case lexNum (c:s) of
      Just (d, s') -> TokNum (read d) : lexPath s'
      Nothing      -> error $ "lex error on " ++ show (take 25 (c:s)) ++ "..."
  | otherwise   = lexPath s
  where
    isNumChar c = isDigit c || c == '-'

-- | Read a path string.
parsePath :: String -> Path
parsePath s = parse (lexPath s)
  where
    parse ts = case ts of
      [] -> []
      TokCmd 'M' : ts -> args1p 'M' (MoveTo Absolute) ts
      TokCmd 'm' : ts -> args1p 'm' (MoveTo Relative) ts
      TokCmd 'Z' : ts -> ClosePath : parse ts
      TokCmd 'z' : ts -> ClosePath : parse ts
      TokCmd 'L' : ts -> args1p 'L' (LineTo Absolute) ts
      TokCmd 'l' : ts -> args1p 'l' (LineTo Relative) ts
      TokCmd 'H' : ts -> args1 'H' (HorLineTo Absolute) ts
      TokCmd 'h' : ts -> args1 'h' (HorLineTo Relative) ts
      TokCmd 'V' : ts -> args1 'V' (VerLineTo Absolute) ts
      TokCmd 'v' : ts -> args1 'v' (VerLineTo Relative) ts
      TokCmd 'C' : ts -> argsNp 3 'C' (BezierTo Absolute) ts
      TokCmd 'c' : ts -> argsNp 3 'c' (BezierTo Relative) ts
      TokCmd 'S' : ts -> argsNp 2 'S' (SmoothBezierTo Absolute) ts
      TokCmd 's' : ts -> argsNp 2 's' (SmoothBezierTo Relative) ts
      TokCmd 'Q' : ts -> argsNp 2 'Q' (BezierTo Absolute) ts
      TokCmd 'q' : ts -> argsNp 2 'q' (BezierTo Relative) ts
      TokCmd 'T' : ts -> argsNp 1 'T' (SmoothBezierTo Absolute) ts
      TokCmd 't' : ts -> argsNp 1 't' (SmoothBezierTo Relative) ts
      TokCmd 'A' : ts -> argsN 7 'A' (arcTo Absolute) ts
      TokCmd 'a' : ts -> argsN 7 'a' (arcTo Relative) ts
      TokCmd c : _ -> error $ "parsePath: unknown command: " ++ [c]
      TokNum _ : _ -> error $ "parsePath: not a command " ++ show (take 3 ts)
      where
        next c ts = parse (prevCmd c ts)
        prevCmd c ts@(TokNum _ : _) = TokCmd c : ts
        prevCmd c ts                = ts

        arcTo rel [rx, ry, angle, largeArc, sweep, x, y] =
          ArcTo rel (Vec rx ry) angle (largeArc /= 0) (sweep /= 0) (Vec x y)

        args1 :: Char -> (Scalar -> PathCmd) -> [PathToken] -> Path
        args1 c f (TokNum x : ts) = f x : next c ts

        args1p :: Char -> (Vec -> PathCmd) -> [PathToken] -> Path
        args1p c f (TokNum x : TokNum y : ts) = f (Vec x y) : next c ts

        args2p :: Char -> (Vec -> Vec -> PathCmd) -> [PathToken] -> Path
        args2p c f (TokNum x : TokNum y : TokNum x' : TokNum y' : ts) = f (Vec x y) (Vec x' y') : next c ts

        argsN :: Int -> Char -> ([Scalar] -> PathCmd) -> [PathToken] -> Path
        argsN n c f ts
          | all isNum xs = f (map getNum xs) : next c ts'
          | otherwise    = error $ "Expected " ++ show n ++ " numerical arguments to " ++ show c ++ ". Got: " ++ show xs
          where
            (xs, ts') = splitAt n ts

            isNum TokNum{} = True
            isNum _        = False

            getNum (TokNum x) = x

        argsNp :: Int -> Char -> ([Vec] -> PathCmd) -> [PathToken] -> Path
        argsNp n c f = argsN (2 * n) c (f . points)
          where
            points (x:y:xs) = Vec x y : points xs
            points [] = []

data DrawState =
  DrawState { dsCurrentPoint     :: Point
            , dsLastControlPoint :: Point
            , dsStartOfSubCurve  :: Point }

-- | Render a path.
drawPath :: Path -> Image
drawPath p = snd $ foldl draw (DrawState 0 0 0, mempty) p
  where
    draw (ds, i) cmd = case cmd of
      MoveTo ct p -> (newSubCurve p', i +.+ point p')
        where p' = pt ds ct p
      LineTo ct p -> (newPt ds p', i ++> p')
        where p' = pt ds ct p
      HorLineTo ct x -> (newPt ds p', i ++> p')
        where Vec _ y  = dsCurrentPoint ds
              Vec x' _ = pt ds ct (Vec x 0)
              p'       = Vec x' y
      VerLineTo ct y -> (newPt ds p', i ++> p')
        where Vec x _  = dsCurrentPoint ds
              Vec _ y' = pt ds ct (Vec 0 y)
              p'       = Vec x y'
      BezierTo ct ps -> (newPt ds (last ps'), i +++ bezierSegment (dsCurrentPoint ds : ps'))
        where ps' = map (pt ds ct) ps
      SmoothBezierTo ct ps -> (newPt ds (last ps'), i +++ bezierSegment (p0 : cp : ps'))
        where ps' = map (pt ds ct) ps
              p0  = dsCurrentPoint ds
              cp  = 2 * p0 - dsLastControlPoint ds
      ArcTo{} -> error "TODO: elliptical arcs"
      ClosePath -> (newPt ds p, i ++> p)
        where p = dsStartOfSubCurve ds

    pt ds Absolute p = p
    pt ds Relative p = p + dsCurrentPoint ds

    newPt ds p = ds { dsCurrentPoint = p, dsLastControlPoint = p }
    newSubCurve p = DrawState p p p