module XFig where import ParseLib data XFigDoc = XFDoc {orientation :: Orientation, justification :: Justification, units :: Units, papersize :: PaperSize, magnification :: Magnification, multiplePage :: MultiplePage, transpColor :: TransparentColor, resolution :: FigResolution, coordSystem :: CoordinateSystem, objects :: [Object]} deriving Eq data Orientation = Landscape | Portrait deriving (Eq,Read,Show) data Justification = Center | FlushLeft deriving Eq data Units = Metric | Inches deriving (Eq,Read,Show) data PaperSize = Letter | Legal | Ledger | Tabloid | A | B | C | D | E | A4 | A3 | A2 | A1 | A0 | B5 deriving (Eq,Read,Show) type Magnification = Float data MultiplePage = Single | Multiple deriving (Eq,Read,Show) type TransparentColor = Int type FigResolution = Int -- Fig units/ inch data CoordinateSystem = OrigLowerLeft -- Do not use | OrigUpperLeft deriving (Eq,Enum) -- XFig objects data Object = ColorPO ColorPOData | Arc ArcData | Ellipse EllipseData | Polyline PolylineData | Spline SplineData | Text TextData | Compound CompoundData deriving Eq type ColorPOData = NYI type ArcData = NYI type EllipseData = NYI type SplineData = NYI type CompoundData = NYI -- Polyline Object data data PolylineData = MkPolylineData {plSubtype :: PolySubType, plLineStyle :: LineStyleField, plThickness :: Thickness, plPenColor :: ColorField, plFillColor :: ColorField, plDepth :: DepthField, plPenStyle :: Int, plAreaFill :: AreaFillField, plStyleVal :: Float, plJoinStyle :: Int, plCapStyle :: Int, plRadius :: Int, plForwardArrow :: OffOn, plBackwardArrow :: OffOn, plNPoints :: Int, plPoints :: [Point]} deriving Eq -- Text Object data data TextData = MkTextData {tJustification :: TextJustification, tColor :: ColorField, tDepth :: DepthField, tPenStyle :: Int, tFont :: Int, tFontSize :: Int, tAngle :: Float, tFontFlags :: Int, tBoundBox :: Point, tPoint :: Point, tText :: String} deriving Eq {- Color Field: -1 Default 0 Preto 1 Azul 2 Verde 3 Azul Claro (cyan) 4 Vermelho 5 Violeta (mangenta) 6 Amarelo 7 Branco ... outras cores...-} type ColorField = Int type AreaFillField = Int type DepthField = Int data LineStyleField = LSFDefault | LSFSolid | LSFDashed | LSFDotted | LSFDashDotted | LSFDashDoubleDotted | LSFDashTripleDotted deriving (Eq,Enum) data OffOn = Off | On deriving (Eq,Enum) type Thickness = Int data Point = Pt {xcord::Int, ycord::Int} deriving Eq data PolySubType = PolyLine | Box | Polygon | ArcBox | BoundingBox deriving (Eq,Enum) data TextJustification = LeftJustified | CenterJustified | RightJustified deriving (Eq,Enum) ----------------------------------------------------------------------- ----------------------------------------------------------------------- -- Utility Functions -- type NYI = () -- NOT YET IMPLEMENTED type... showEnumAt :: (Enum a) => Int -> a -> ShowS showEnumAt i x = shows $ fromEnum x + i readEnumAt :: (Enum a) => Int -> ReadS a readEnumAt i s = do -- List (x,s') <- reads s return (toEnum (x - i),s') parseFloat :: Parser Float parseFloat = readS2Parser reads repeatnSepby :: Int -> Parser a -> Parser b -> Parser [a] repeatnSepby 1 pa pb = do {x<-pa; return [x]} repeatnSepby n pa pb = do {x<-pa; pb; xs<-repeatnSepby (n-1) pa pb; return(x:xs)} -- string terminada por... stringT :: Parser a -> Parser String stringT p = readS2Parser $ \s -> let l = papply p s in case l of [] -> let [(r,s')]=papply (stringT p) (tail s) in [((head s):r,s')] [(_,s)] -> [("",s)] nl :: ShowS nl s = '\n':s space :: ShowS space s = ' ':s -------------------------------------------------------------------- ------- SHOW instances... -- -- Faz-se coincidir a representação textual das estruturas de dados -- com o formato dos ficheiros XFig. -- Desta forma criar um ficheiro XFig reduz-se a efectuar um "dump" -- dessa representação. -- -- note que em muitos tipos se utiliza a derivada automaticamente... -- instance Show XFigDoc where showsPrec _ x = (showString "#FIG 3.2"). nl. (shows (orientation x)). nl. (shows (justification x)). nl. (shows (units x)). nl. (shows (papersize x)). nl. (shows (magnification x)). nl. (shows (multiplePage x)). nl. (shows (transpColor x)). nl. (shows (resolution x)). space. (shows (coordSystem x)). nl. (shows (objects x)) instance Show Justification where showsPrec _ Center = showString "Center" showsPrec _ FlushLeft = showString "Flush Left" instance Show CoordinateSystem where showsPrec _ = showEnumAt (1) instance Show LineStyleField where showsPrec _ = showEnumAt (-1) instance Show Object where showsPrec _ (Polyline x) = (showString "2 ") . (shows x) showsPrec _ (Text x) = (showString "4 ") . (shows x) showsPrec _ _ = id showList [] = id showList (x:xs) = (shows x). (shows xs) instance Show PolylineData where showsPrec _ x = (shows (plSubtype x)). space. (shows (plLineStyle x)). space. (shows (plThickness x)). space. (shows (plPenColor x)). space. (shows (plFillColor x)). space. (shows (plDepth x)). space. (shows (plPenStyle x)). space. (shows (plAreaFill x)). space. (shows (plStyleVal x)). space. (shows (plJoinStyle x)). space. (shows (plCapStyle x)). space. (shows (plRadius x)). space. (shows (plForwardArrow x)). space. (shows (plBackwardArrow x)). space. (shows (plNPoints x)). nl. (showChar '\t'). (shows (plPoints x)) instance Show TextData where showsPrec _ x = (shows (tJustification x)). space. (shows (tColor x)). space. (shows (tDepth x)). space. (shows (tPenStyle x)). space. (shows (tFont x)). space. (shows (tFontSize x)). space. (shows (tAngle x)). space. (shows (tFontFlags x)). space. (shows (tBoundBox x)). space. (shows (tPoint x)). space. (showString (tText x)). (showString "\\001"). nl instance Show TextJustification where showsPrec _ = showEnumAt 0 instance Show PolySubType where showsPrec _ = showEnumAt 1 instance Show OffOn where showsPrec _ = showEnumAt 0 instance Show Point where showsPrec _ (Pt x y) = (shows x). space. (shows y) showList [] = nl showList (x:xs) = (shows x). (showChar ' ').(shows xs) ------------------------------------------------------------------------ ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- I/O functions -- -- Funções que escrevem/leem ficheiros no formato XFig. -- Como se referiu atrás, quase todo o trabalho é deixado às funções -- de "show". Fica só a tarefa de aceder aos ficheiros... -- -- As funções recebem como argumento o nome dos ficheiros. readXFigFile :: String -> IO XFigDoc readXFigFile f = do -- IO t <- readFile f let [(fig,"")]=(papply parseXFigDoc t) return fig writeXFigFile :: XFigDoc -> String -> IO () writeXFigFile fig f = writeFile f (show fig) -- ------------ Interface para HTML (applet DrawXfig.class) -- -- Para vizualizar os ficheiros XFig em MS-Windows, vamos fazer uso -- de um "applet" em Java. Esta função gera o ficheiro HTML que -- invoca esse applet com os argumentos necessários. writeXFigHtmlFile :: XFigDoc -> String -> IO() writeXFigHtmlFile fig f = writeFile f $ "\n \nx++" "++y) "" (lines (show fig))) ++ "\">\n\n" ------------------------------------------------------------------------ ------------------------------------------------------------------------ ------------------------------------------------------------------------ ---- DEFAULT OBJECTS... ---- ---- o formato XFig possui muitos campos que normalmente são utilizados ---- com valores standard (e.g. papel A4, etc.). Para facilitar a ---- utilização criam-se objectos "default" que podem depois ser facilmente ---- alterados. defaultXFigDoc :: [Object] -> XFigDoc defaultXFigDoc = XFDoc Landscape Center Metric A4 100.0 Single (-2) 1200 OrigUpperLeft -- caixa paralela aos eixos posicionada no 1º arg, com dims dadas pelo 2º arg. defaultBox :: Point -> Point -> PolylineData defaultBox (Pt ox oy) (Pt mx my) = MkPolylineData Box LSFSolid 1 0 7 0 0 (-1) 0.0 0 0 (-1) Off Off 5 [Pt ox oy,Pt (ox+mx) oy, Pt (ox+mx) (oy+my),Pt ox (oy+my), Pt ox oy] {- default arguments for Text Objects LeftJustified; Black; Top; unused PenStyle; Courier PS Font; Size=12; Angle=0.0; Flags=PS Font; etc. -} defaultText :: Point -> String -> TextData defaultText p s = MkTextData LeftJustified 0 0 0 12 12 0.0 4 (Pt 120 (105*(length s))) p s ------------------------------------------------------------------------ ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- -- -- -- {- O código que se segue não 'e estritamente necessário para a execução do trabalho prático e envolve alguns conceitos que fogem do âmbito deste curso (ou ainda não foram referidos aquando da apresentação deste trabalho). A inclusão é demonstrativa e poderá servir para alguma extensão ao que se pretenda realizar... -} ------------------------------------------------------------------------- ------------------------------------------------------------------------- -- PARSERS & READ instaces... -- -- ...realizam a função inversa de SHOW, i.e. dado uma representação -- textual reconstroiem a estrutura de dados... -- parseXFigDoc :: Parser XFigDoc parseXFigDoc = do -- Parser string "#FIG 3.2" spaces o <- parseOrientation spaces j <- parseJustification spaces u <- parseUnits spaces p <- parsePaperSize spaces mag <- parseFloat spaces mul <- parseMultiplePage spaces tc <- int spaces res <- int spaces cs <- parseCoordinateSystem spaces objs <- parseObject `sepby` spaces return (XFDoc o j u p mag mul tc res cs objs) instance Read XFigDoc where readsPrec _ = papply parseXFigDoc parseOrientation :: Parser Orientation parseOrientation = readS2Parser reads parseJustification = do -- Parser s <- (string "Center") +++ (string "Flush Left") case s of "Center" -> return Center _ -> return FlushLeft instance Read Justification where readsPrec _ = papply parseJustification parseUnits :: Parser Units parseUnits = readS2Parser reads parsePaperSize :: Parser PaperSize parsePaperSize = readS2Parser reads parseMultiplePage :: Parser MultiplePage parseMultiplePage = readS2Parser reads instance Read CoordinateSystem where readsPrec _ = readEnumAt (1) parseCoordinateSystem :: Parser CoordinateSystem parseCoordinateSystem = readS2Parser reads parseObject = parsePolyline +++ parseText instance Read Object where readsPrec _ = papply parseObject parsePolyline = do -- Parser string "2" spaces st <- parsePolySubType spaces ls <- parseLineStyleField spaces t <- int spaces pc <- int spaces fc <- int spaces d <- int spaces ps <- int spaces af <- int spaces sv <- parseFloat spaces js <- int spaces cs <- int spaces rad <- int spaces fa <- parseOffOn spaces ba <- parseOffOn spaces np <- int spaces lp <- repeatnSepby np parsePoint spaces return (Polyline (MkPolylineData st ls t pc fc d ps af sv js cs rad fa ba np lp)) parseText = do -- Parser string "4" spaces tj <- parseTextJustification spaces c <- int spaces d <- int spaces ps <- int spaces f <- int spaces fs <- int spaces a <- parseFloat spaces ff <- int spaces bb <- parsePoint spaces pos <- parsePoint spaces ts <- parseTextString return (Text (MkTextData tj c d ps f fs a ff bb pos ts)) instance Read LineStyleField where readsPrec _ = readEnumAt (-1) parseLineStyleField :: Parser LineStyleField parseLineStyleField = readS2Parser reads instance Read PolySubType where readsPrec _ = readEnumAt 1 parsePolySubType :: Parser PolySubType parsePolySubType = readS2Parser reads instance Read OffOn where readsPrec _ = readEnumAt 0 parseOffOn :: Parser OffOn parseOffOn = readS2Parser reads parsePoint = do {x<- int; spaces; y<-int; return (Pt x y)} instance Read Point where readsPrec _ = papply parsePoint instance Read TextJustification where readsPrec _ = readEnumAt 0 parseTextJustification :: Parser TextJustification parseTextJustification = readS2Parser reads parseTextString :: Parser String parseTextString = stringT (string "\\001")