module Data.Geometry.Ipe.IpeTypes( IpeDrawing(..)
, Page(..)
, Layer(..)
, emptyDrawing
, emptyPage
, emptyLayer
, HasContent(..)
, extend
, view
, runOnFile
, runOnPath
, findLayer
, findLayer'
, IpeFile
, LayerDefinition
, ViewDefinition(..)
, AMap
, HasAttributes(..)
) where
import Control.Arrow
import Data.Monoid
import Data.Function(on)
import Data.Maybe
import Data.List
import Data.Geometry.Point
import Data.Geometry.Geometry
import Data.Geometry.Ipe.IGC(IGC,empty,mergeAll,updateAll)
import Data.Geometry.Ipe.ReadIpeGeometry hiding (PM)
import Data.Geometry.Ipe.WriteIpeGeometry hiding (PM)
import Data.Geometry.Ipe.InternalTypes
import Data.Geometry.Ipe.Pickle
data IpeDrawing a = IpeDrawing { pages :: [Page a] }
deriving (Show,Eq)
data Page a = Page { layers :: [Layer a]
, views :: [ViewDefinition]
}
deriving (Show,Eq)
data Layer a = Layer { layerDef :: LayerDefinition
, layerContent :: IGC a
}
deriving (Show,Eq)
emptyDrawing :: IpeDrawing a
emptyDrawing = IpeDrawing [emptyPage]
emptyPage :: Page a
emptyPage = Page [emptyLayer] []
emptyLayer :: Layer a
emptyLayer = Layer "alpha" empty
instance Monoid (IpeDrawing a) where
mempty = emptyDrawing
(IpeDrawing pgs) `mappend` (IpeDrawing pgs') = IpeDrawing $ pgs++pgs'
extend :: IpeDrawing a -> IpeDrawing a -> IpeDrawing a
extend (IpeDrawing pgs) (IpeDrawing pgs') = IpeDrawing $ zipWith mappend pgs pgs'
instance Monoid (Page a) where
mempty = emptyPage
p@(Page lrs vds) `mappend` q@(Page lrs' vds') =
Page (combineLayers lrs lrs') (vds ++ vds')
combineLayers :: [Layer a] -> [Layer a] -> [Layer a]
combineLayers lrs lrs' = map mergeCommon commonNames ++
filter (not . inSet commonNames) (lrs++lrs')
where
names = map layerDef
commonNames = names lrs `intersect` names lrs'
inSet ns lr = let n = layerDef lr in n `elem` ns
mergeCommon n = findL n lrs `mergeLayers` findL n lrs'
mergeLayers :: Maybe (Layer a) -> Maybe (Layer a) -> Layer a
mergeLayers (Just lr) (Just lr') = lr `mappend` lr'
mergeLayers mlr mlr' = fromMaybe mempty (mlr `mappend` mlr')
instance Monoid (Layer a) where
mempty = emptyLayer
(Layer n xs) `mappend` (Layer _ ys) = Layer n (xs `mappend` ys)
view :: [LayerDefinition] -> ViewDefinition
view lrns = ViewDefinition lrns (head lrns)
class HasContent t where
type PM t
content :: t -> IGC (PM t)
instance HasContent (IpeDrawing a) where
type PM (IpeDrawing a) = a
content = mergeAll . map content . pages
instance HasContent (Page a) where
type PM (Page a) = a
content = mergeAll . map content . layers
instance HasContent (Layer a) where
type PM (Layer a) = a
content = layerContent
fromIpeFile :: IpeFile a -> IpeDrawing a
fromIpeFile (IpeFile _ _ pgs) = IpeDrawing $ map gatherPage pgs
gatherPage :: IpePage a -> Page a
gatherPage (IpePage _ vds obs) = Page lrs vds
where
lrs = map mkLayer . groupBy' layerName $ obs
groupBy' f = groupBy ((==) `on` f) . sortBy (compare `on` f)
mkLayer :: [IpeObject a] -> Layer a
mkLayer [] = emptyLayer
mkLayer obs@(o:_) = Layer (layerName o) (listToIGC obs)
layerName :: IpeObject a -> String
layerName = fromMaybe "alpha" . getAttr "layer"
updateIpeFile :: IpeFile t -> IpeDrawing a -> IpeFile a
updateIpeFile ipeFile (IpeDrawing pgs) =
ipeFile { ipePages = map constructIpePage pgs}
constructIpePage :: Page a -> IpePage a
constructIpePage (Page lrs vds) = IpePage lds vds obs
where
lds = map layerDef lrs
obs = toIpeObjects' . mergeAll . map f $ lrs
f (Layer n col) = updateAll (setAttr "layer" n) col
runOnPath f = loadFileA >>> runOnFile f
runOnFile :: Arrow arr => arr (IpeDrawing a) (IpeDrawing b) -> arr (IpeFile a) (IpeFile b)
runOnFile f = arr id &&& (fromIpeFile ^>> f)
>>>
arr (uncurry updateIpeFile)
findLayer :: Int -> LayerDefinition -> IpeDrawing a -> Maybe (Layer a)
findLayer i lr (IpeDrawing pgs) = let mpg = listToMaybe . drop i $ pgs in
mpg >>= findLayer' lr
findLayer' :: LayerDefinition -> Page a -> Maybe (Layer a)
findLayer' name = findL name . layers
findL name = listToMaybe . filter ((== name) . layerDef)