{-# Language FlexibleInstances,
             OverloadedStrings
 #-}
module Data.Geometry.Ipe.Pickle( Coordinate(..)
                               , loadFile
                               , storeFile

                               , loadFileA
                               , storeFileA

                               , unpickle

                               , xpLoadSettings
                               , xpStoreSettings
                               )
                                where

import Numeric


import Control.Arrow
import Control.Applicative((<$>))

import Data.Ratio
import Data.Maybe

import Data.Geometry.Point
import Data.Geometry.Geometry
import Data.Geometry.Ipe.InternalTypes


import Text.Parsec
import Text.Parsec.String

import Data.Text.Lazy(Text)
import Data.Text.Format

import Data.Tree.NTree.TypeDefs

import Text.XML.HXT.Arrow.Pickle
import Text.XML.HXT.Arrow.Pickle.Xml
import Text.XML.HXT.Core hiding (trace)

import qualified Data.Map as M
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Data.Text.Lazy as T

-----------------------------------------------------------------------

-- | Represent stuff that can be used as a coordinate in ipe. (similar to show/read)

class (Fractional a, Ord a) => Coordinate a where
    toIpeOut :: a -> String
    fromSeq            :: Integer -> Maybe Integer -> a
    fromSeq x Nothing  = fromInteger x
    fromSeq x (Just y) = let x'        = fromInteger x
                             y'        = fromInteger y
                             asDecimal = head . dropWhile (>= 1) . iterate (* 0.1) in
                         signum x' * (abs x' + asDecimal y')

instance Coordinate Double where
    toIpeOut = show

instance Coordinate (Ratio Integer) where
    toIpeOut r = show (fromRat r :: Double)
    fromSeq x  Nothing = fromInteger x
    fromSeq x (Just y) = fst . head $ readSigned readFloat (show x ++ "." ++ show y)



-----------------------------------------------------------------------
-- instance declarations for parsing ipe stuff

instance Coordinate a => XmlPickler (IpeObject a) where
    xpickle = xpIpeObject

instance Coordinate a => XmlPickler (IpePage a) where
    xpickle = xpPage

instance Coordinate a => XmlPickler (IpeFile a) where
    xpickle = xpIpeFile


instance XmlPickler ViewDefinition where
    xpickle = xpViewDefinition

-----------------------------------------------------------------------

-- | Load an ipe drawing from a file
loadFile      :: Coordinate a => FilePath -> IO (IpeFile a)
loadFile path = do
  [d] <- unpickle xpIpeFile path
  return d

unpickle :: PU a -> FilePath -> IO [a]
unpickle p path = runX $ xunpickleDocument p xpLoadSettings path

-- | Store an ipe drawing in a file
storeFile              :: Coordinate a => IpeFile a -> FilePath -> IO ()
storeFile ipeFile path =
    do
      runX $ constA ipeFile >>> xpickleDocument xpIpeFile xpStoreSettings path
      return ()

xpLoadSettings :: [SysConfig]
xpLoadSettings = [ withRemoveWS yes   -- remove redundant whitespace
                 , withValidate no    -- don't validate source
                 ]

xpStoreSettings :: [SysConfig]
xpStoreSettings = [ withIndent yes        -- indent XML
                  , withAddDefaultDTD yes   -- add a default DTD
                  ]


--------
-- Arrow versions of the stuff above

loadFileA :: Coordinate a => Kleisli IO FilePath (IpeFile a)
loadFileA = Kleisli loadFile

storeFileA      :: Coordinate a => FilePath -> Kleisli IO (IpeFile a) ()
storeFileA path =  Kleisli (flip storeFile path)

-----------------------------------------------------------------------

xpIpeFile :: Coordinate a => PU (IpeFile a)
xpIpeFile = xpElem "ipe" $
                xpWrap ( \(version,creator,date,bitmaps,p,s,ps) -> IpeFile p s ps
                       , \(IpeFile p s ps) -> ( "70005"      -- ipe version
                                             , Just "hipe"  -- Creator
                                             , Nothing      -- don't generate an info field
                                             , []           -- don't generate bitmaps
                                             , p            -- latex preamble
                                             , s            -- ipestyles
                                             , ps           -- pages
                                             )
                       ) $
                xp7Tuple (xpTextAttr "version")
                         (xpTextAttrImplied "creator")
                         (xpOption $ xpElem "info" xpVarTextAttrs)
                         (xpList     xpBitmap)
                         (xpOption   xpPreamble)
                         (xpList xpIpeStyle)
                         (xpList xpPage)


xpIpeStyle :: PU IpeStyle
xpIpeStyle = xpElem "ipestyle" $
             xpWrap ( uncurry IpeStyle
                    , \(IpeStyle name content) -> (name,content)) $
             xpPair (xpTextAttrImplied "name") xpTrees


xpPreamble :: PU IpePreamble
xpPreamble = xpElem "preamble" $
             xpWrap ( uncurry IpePreamble
                    , \(IpePreamble enc cont) -> (enc,cont)
                    ) $
             xpPair (xpTextAttrImplied "encoding") xpTree

xpBitmap :: PU IpeBitmap
xpBitmap = xpElem "bitmap" xpTree

xpPage :: Coordinate a => PU (IpePage a)
xpPage = xpElem "page" $
         xpWrap ( \(lrs,vws,obs) -> IpePage lrs vws (markWithlayers "alpha" obs)
                , \(IpePage lrs vws obs) -> (lrs,vws,obs)
                ) $
         xpTriple (xpList xpLayerDefinition)
                  (xpList xpViewDefinition)
                  (xpList xpIpeObject)


markWithlayers              :: HasAttributes a => String -> [a] -> [a]
markWithlayers lrName []    = []
markWithlayers lrName (o:obs)
               | hasLayer o = o : markWithlayers (getLayer o) obs
               | otherwise  = markOb lrName o : markWithlayers lrName obs
    where
      hasLayer      = M.member "layer" . attrs
      getLayer      = fromJust . M.lookup "layer" . attrs
      markOb lrName = updateWith (M.insert "layer" lrName)


xpLayerDefinition :: PU String
xpLayerDefinition = xpElem "layer" $
                    xpTextAttr "name"

xpViewDefinition :: PU ViewDefinition
xpViewDefinition = xpElem "view" $
                   xpWrap ( \(lrs,a) -> ViewDefinition (words lrs) a
                          , \vd -> (unwords $ layerNames vd, activeLayer vd)
                          ) $
                   xpPair (xpTextAttr "layers") (xpTextAttr "active")

-----------------------------------------------------------------------

-- | Pickler for ipe objects

xpIpeObject :: Coordinate a => PU (IpeObject a)
xpIpeObject = xpWrap (applyMatrix,id) $ xpAlt tag ps
    where
      tag (Path _ _)    = 0
      tag (Group _ _)   = 1
      tag (IpeText _ _) = 2
      tag (Use _ _)     = 3
      ps = [ xpPath, xpGroup, xpIpeText , xpIpeUse ]

xpGroup :: Coordinate a => PU (IpeObject a)
xpGroup = xpElem "group" $
          xpWrap ( uncurry Group
                 , \(Group o a) -> (o,a)) $
          xpPair (xpList xpIpeObject) xpVarTextAttrs


xpIpeText :: PU (IpeObject a)
xpIpeText = xpElem "text" $
            xpWrap ( uncurry IpeText
                   , \(IpeText s a) -> (s,a)) $
            xpPair xpText xpVarTextAttrs


applyMatrix :: Coordinate a => IpeObject a -> IpeObject a
applyMatrix o = transformWith m . extractAttr "matrix" $ o
    where
      m          = fromMaybe identityMatrix3 . fmap readMatrix . getAttr "matrix" $ o

-----------------------------------------------------------------------
-- | pickler for symbols (use)

xpIpeUse :: Coordinate a => PU (IpeObject a)
xpIpeUse = xpElem "use" $
           xpWrap ( fromMap
                  , \(Use p a) -> M.insert "pos" (toString p) a
                  )
           xpVarTextAttrs

-- use the information in an AMap to construct a symbol
fromMap       :: Coordinate a => AMap -> IpeObject a
fromMap attrs = Use p attrs'
    where
      at     = M.lookup "pos" attrs
      p      = fromMaybe (Point2 (0,0)) $ readPoint =<< at
      attrs' = M.update (const at) "pos" attrs

-----------------------------------------------------------------------
-- | Pickler for paths

xpPath :: Coordinate a => PU (IpeObject a)
xpPath = xpElem "path" $
         xpWrap ( \(opStr, attrs)   -> Path (readPathOperations opStr) attrs
                , \(Path ops attrs) -> (opsString ops, attrs)
                ) $
         xpPair xpText xpVarTextAttrs

-----------------------------------------------------------------------
-- | Pickler that pickles an AMap into attributes

xpVarTextAttrs :: PU AMap
xpVarTextAttrs = PU { appPickle   = \m st -> M.foldrWithKey addAtt' st m
                    , appUnPickle = UP $ \st ->
                                    (Right . M.fromList . mapMaybe toPair . attributes $ st, st {attributes = []})
                    , theSchema   = theSchema xpText -- schema is not used here I guess
                    } where
    addAtt' k v      = putAtt (mkName k) (txt v)
    txt v            = contents $ appPickle xpText v emptySt


-- | Get the name and the value from this attribute
toPair   :: XmlTree -> Maybe (String,String)
toPair t@(XN.NTree (XAttr qn) chs) = let st = emptySt { contents = chs} in
                                     case fst . runUP (appUnPickle xpText) $ st of
                                       (Left _)  -> Nothing
                                       (Right s) -> Just (localPart qn, s)


xpTextAttrImplied :: String -> PU (Maybe String)
xpTextAttrImplied s = xpAttrImplied s xpText


-- -- | Tree picklers that consume the attributes as well
-- xpTree'          :: PU XmlTree
-- xpTree'          = PU { appPickle   = putCont
--                       , appUnPickle = UP $ \st ->
--                                         let (e,st')   = runUP getCont st
--                                             (as,st'') = getAtts st' in
--                                       (e, st'')
--                       , theSchema   = theSchema xpTree
--                       }
--                    where
--                      getAtts st                 = (attributes st, st { attributes = []})
--                      appendChs (NTree x chs') ys = NTree x (ys ++ chs')

-- xpTrees' = (xpList xpTree' ) { theSchema = theSchema xpTrees }


-----------------------------------------------------------------------
-- Parsing stuff starts here

-- for parsing the position in a symbol
readPoint   :: Coordinate a => String -> Maybe (Point2' a)
readPoint s = case parse point "" s of
                Left  _ -> Nothing
                Right p -> Just p

readPathOperations :: Coordinate a => String -> [Operation a]
readPathOperations s = case parse path "" s of
                         Left  err -> error $ show err
                         Right ops -> ops


path :: Coordinate a => Parser [Operation a]
path = do many (newline <|> space)
          line `sepEndBy` newline

line :: Coordinate a => Parser (Operation a)
line = close <|> do pts <- many1 (do { p <- point ; space ; return p })
                    operation pts

operation :: Coordinate a => [Point2' a] -> Parser (Operation a)
operation pts
          | length pts == 1 = let [p]     = pts in moveTo p <|> lineTo p
          | length pts == 2 = let [p,q]   = pts in qCurveTo p q
          | length pts == 3 = let [p,q,r] = pts in curveTo p q r
-- TODO: Otherwise

moveTo :: Coordinate a => Point2' a -> Parser (Operation a)
moveTo p = char 'm' >> return (MoveTo p)


lineTo :: Coordinate a => Point2' a -> Parser (Operation a)
lineTo p = char 'l' >> return (LineTo p)


qCurveTo :: Coordinate a => Point2' a -> Point2' a -> Parser (Operation a)
qCurveTo p q = char 'q' >> return (QCurveTo p q)


curveTo :: Coordinate a => Point2' a -> Point2' a -> Point2' a -> Parser (Operation a)
curveTo p q r = char 'c' >> return (CurveTo p q r)


close :: Parser (Operation a)
close = char 'h' >> return ClosePath

point ::  Coordinate a => Parser (Point2' a)
point = do { x <- coord
           ; space
           ; y <- coord
           ; return $ Point2 (x,y)
           }


coord :: Coordinate a => Parser a
coord = uncurry fromSeq <$> do s <- option 1 (char '-' >> return (-1))
                               x <- int
                               y <- optionMaybe (char '.' >> int)
                               return (s*x,y)

int :: Parser Integer
int = read <$> many1 digit


-- | Read the matrix:
-- Our matrix has the following order of doubles:
-- 012
-- 345
--
-- But ipe uses the following order:
-- 024
-- 135
readMatrix   :: Coordinate a => String -> Matrix3 a
readMatrix s = case parse matrixAttr "" s of
                 Left  err           -> error $ show err
                 Right [a,b,c,d,e,f] -> matrix3FromLists [ [a, c, e]
                                                         , [b, d, f]
                                                         , [0, 0, 1]]
                 Right xs            -> error (
                                          "matrix with wrong number of elems: "
                                          ++ show (length xs))


matrixAttr :: Coordinate a => Parser [a]
matrixAttr = coord `sepBy` space

-----------------------------------------------------------------------
-- | Write ipe stuff


class IsIpeWriteable c where
    toOnly :: Coordinate a => c a -> Only Text
    toOnly = Only . toText
    toText :: Coordinate a => c a -> Text

    toString  :: Coordinate a => c a -> String
    toString = T.unpack . toText

    textSepBy        :: Coordinate a => [c a] -> Text -> Text
    xs `textSepBy` s =  T.intercalate s . map toText $ xs


instance IsIpeWriteable Matrix3 where
    -- | Note, we only use the first 6 values (the first two rows)
    --   furthermore, the order of the ipe matrices is switched again.
    toText m = let [[a,b,c],[d,e,f],_] = matrix3ToLists m
                   ipeM                = [a, c, e, b, d, f] in
               T.intercalate " " . map (T.pack . toIpeOut) $ ipeM


instance IsIpeWriteable Point2' where
    toText (Point2 (x,y)) = format "{} {}" $ map toIpeOut [x,y]


instance IsIpeWriteable Operation where
    toText (MoveTo p)         = format "{} m"       $ toOnly p
    toText (LineTo p)         = format "{} l"       $ toOnly p
    toText (CurveTo p q r)    = format "{} {} {} c" $ map toText [p,q,r]
    toText (QCurveTo p q)     = format "{} {} q"    $ map toText [p,q]
    toText (Ellipse m)        = format "{} e"       $ toOnly m
    toText (ArcTo m p)        = format "{} {} a"      [toText m , toText p]
    toText (Spline pts)       = format "{} u"       $ Only $ pts `textSepBy` " "
    toText (ClosedSpline pts) = format "{} u"       $ Only $ pts `textSepBy` " "
    toText ClosePath          = "h"

opsString     :: Coordinate a => [Operation a] -> String
opsString ops = T.unpack $ "\n" `T.append` (ops `textSepBy` "\n") `T.append` "\n"