{- | Module : FMP.Syntax Copyright : (c) 2003-2010 Peter Simons (c) 2002-2003 Ferenc Wágner (c) 2002-2003 Meik Hellmund (c) 1998-2002 Ralf Hinze (c) 1998-2002 Joachim Korittky (c) 1998-2002 Marco Kuhlmann License : GPLv3 Maintainer : simons@cryp.to Stability : provisional Portability : portable -} {- This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . -} module FMP.Syntax where import Numeric import FMP.PP import FMP.Term import FMP.Types import FMP.Color import FMP.Picture hiding ( empty, text ) class HasEmit a where emit :: a -> Doc -- This data type contains the compiled graphics, ready to |emit|. data MetaPost = MPAssign Term Term | MPAssignPath String MPPath | MPBoxit String MetaPost | MPBitLine (Term, Term) Term String | MPCloneit String String | MPClearIt | MPClip MPPath | MPComment String | MPConc MetaPost MetaPost | MPDef String Term | MPDefineTrans String MPTransform | MPDraw MPArrow MPPath MPPattern MPColor MPPen | MPDrawAHead MPArrow MPPath MPColor MPPen | MPDrawPic MPColor Term | MPDrawUnBoxed [String] | MPEquals [Term] | MPFigure Int MetaPost | MPFill MPPath MPColor MPPen | MPFixPos [String] | MPFixSize [String] | MPGraduate MPColor MPColor MPPath Int Double | MPGraduatePic MPColor MPColor Term Int Double | MPGraduatePath MPArrow MPColor MPColor MPPath MPPattern MPPen Int Double | MPGroup MetaPost | MPIfElse Term MetaPost MetaPost | MPImage String MetaPost | MPRelax | MPShapeit String | MPSubBox Int MetaPost | MPTex String | MPText String | MPVerbatim String deriving Eq --------------------- instance HasConcat MetaPost where MPRelax & a = a a & MPRelax = a a & b = MPConc a b instance HasRelax MetaPost where relax = MPRelax mpConcs :: [MetaPost] -> MetaPost mpConcs as = foldl (&) MPRelax as data MPArrow = MPNormal | MPArrow (Maybe Double) (Maybe Double) MPArrowStyle | MPReverse (Maybe Double) (Maybe Double) MPArrowStyle deriving Eq data MPArrowStyle = MPArrowStyleFilled | MPArrowStyleLine deriving Eq mpArrowStyle :: ArrowHeadStyle -> MPArrowStyle mpArrowStyle AHFilled = MPArrowStyleFilled mpArrowStyle AHLine = MPArrowStyleLine mpPathArrow :: ArrowHead -> MPArrow mpPathArrow DefaultArrowHead = MPNormal mpPathArrow (ArrowHead a l style) = MPArrow a l (mpArrowStyle style) mpPathRArrow :: ArrowHead -> MPArrow mpPathRArrow DefaultArrowHead = MPNormal mpPathRArrow (ArrowHead a l style) = MPReverse a l (mpArrowStyle style) data MPTransform = MPTransform Term Term Term Term Term Term deriving Eq data MPPath = MPPathNorm MPPathSub | MPCutbefore MPPath MPPath | MPCutafter MPPath MPPath | MPBPath Term | MPTransformP [Int] MPPath | MPShiftedP Term MPPath | MPSubPath Term Term MPPath | MPPathTerm Term deriving Eq data MPPathSub = MPPathSub Term MPPathJoin MPPathSub | MPPathEndDir Term MPPathDir | MPPathEnd Term | MPCycle | MPPathBuildCycle [MPPath] | MPPathTransform MPTransform MPPathSub deriving Eq data MPPathJoin = MPPathJoin MPPathDir MPPathBasicJoin MPPathDir deriving Eq data MPPathBasicJoin = MPPathBasicJoinCat | MPPathBasicJoin2 | MPPathBasicJoin3 | MPPathBasicJoinTense | MPPathBasicJoinStraight | MPPathBasicJoinTension1 MPPathBasicJoinTension | MPPathBasicJoinTension2 MPPathBasicJoinTension MPPathBasicJoinTension | MPPathBasicJoinControls1 Term | MPPathBasicJoinControls2 Term Term deriving Eq data MPPathDir = MPDefaultPathDir | MPPathDirCurl Term | MPPathDirPair Term Term | MPPathDir Term deriving Eq data MPPathBasicJoinTension = MPPathBasicJoinTension Term | MPPathBasicJoinAtLeast Term deriving Eq data MPColor = MPDefaultColor | MPColor Double Double Double deriving Eq mpColor :: Color -> MPColor mpColor (Color r g b) = MPColor r g b mpColor (Graduate c1 _ _ _) = mpColor c1 mpColor DefaultColor = MPDefaultColor data MPPen = MPDefaultPen | MPPenCircle (Term, Term) Term | MPPenSquare (Term, Term) Term deriving Eq mpPen :: Pen -> MPPen mpPen DefaultPen = MPDefaultPen mpPen (PenCircle (a,b) c) = MPPenCircle (mpNumeric a,mpNumeric b) (mpNumeric c) mpPen (PenSquare (a,b) c) = MPPenSquare (mpNumeric a,mpNumeric b) (mpNumeric c) data MPPattern = MPDefaultPattern | MPDashPattern [Double] deriving Eq mpPattern :: Pattern -> MPPattern mpPattern DefaultPattern = MPDefaultPattern mpPattern (DashPattern pat) = MPDashPattern pat mpEquations :: [Equation] -> MetaPost mpEquations [] = MPRelax mpEquations (PEquations ps:eqs) = MPEquals (mpPEquations ps) & mpEquations eqs mpEquations (NEquations ns:eqs) = MPEquals (mpNEquations ns) & mpEquations eqs mpEquations (EquationCond b t e:eqs) = MPIfElse (mpBoolean b) (mpEquations [t]) (mpEquations [e]) & mpEquations eqs mpEquations (Equations e:eqs) = mpEquations e & mpEquations eqs mpPEquations :: [Point] -> [Term] mpPEquations [] = [] mpPEquations (p:ps) = mpPoint p:mpPEquations ps mpNEquations :: [Numeric] -> [Term] mpNEquations [] = [] mpNEquations (n:ns) = mpNumeric n:mpNEquations ns mpBoolean :: Boolean -> Term mpBoolean (Boolean True) = Id "true" mpBoolean (Boolean False) = Id "false" mpBoolean (BoolNum a c b) = Infix (mpNumeric a) (mpBoolRelat c) (mpNumeric b) mpBoolean (BoolPnt a c b) = Infix (mpPoint a) (mpBoolRelat c) (mpPoint b) mpBoolean (BoolOr a b) = Infix (Parens (mpBoolean a)) "or" (Parens (mpBoolean b)) mpBoolean (BoolAnd a b) = Infix (Parens (mpBoolean a)) "and" (Parens (mpBoolean b)) mpBoolean (BoolNot a) = VerbFunction "not" (Parens (mpBoolean a)) mpBoolRelat :: BoolRelat -> String mpBoolRelat BoolEQ = "=" mpBoolRelat BoolL = "<" mpBoolRelat BoolLE = "<=" mpBoolRelat BoolNE = "<>" mpPoint :: Point -> Term mpPoint (PointVarArray' n m) = Id ("pvi"++show n++" "++show m) mpPoint (PointVar' n m) = Id ("pv"++show n++" "++show m) mpPoint (PointPic' n d) = tdot (suff n) d mpPoint (PointTrans' p []) = mpPoint p mpPoint (PointTrans' p ts) = Transform ts (mpPoint p) mpPoint (PointPPP PPPAdd p1 p2 ) = mpPoint p1 + mpPoint p2 mpPoint (PointPPP PPPSub p1 p2 ) = mpPoint p1 - mpPoint p2 mpPoint (PointPPP PPPDiv p1 p2 ) = mpPoint p1 / mpPoint p2 mpPoint (PointDirection a) = Dirop (mpNumeric a) mpPoint (PointVec (ox,oy)) = Pair (mpNumeric ox) (mpNumeric oy) mpPoint (PointMediate o p1 p2) = Mediate (mpNumeric o) (mpPoint p1) (mpPoint p2) mpPoint (PointNMul n p) = Mul (mpNumeric n) (mpPoint p) mpPoint (PointNeg p) = -mpPoint p mpPoint PointWhatever = Id "whatever" mpPoint (PointCond b t e) = IfElse (mpBoolean b) (mpPoint t) (mpPoint e) mpPoint _ = Id "" mpCutPic :: CutPic -> Term mpCutPic (CutPic' name) = Id name mpCutPic (CutPicTrans c []) = mpCutPic c mpCutPic (CutPicTrans c ts) = Transform ts (mpCutPic c) mpCutPic _ = Id "" mpNumeric :: Numeric -> Term mpNumeric (Numeric a) = Const a mpNumeric (NumericArray' n m) = Id ("nvi"++show n++" "++show m) mpNumeric (NumericVar' n m) = Id ("nv"++show n++" "++show m) mpNumeric (NumericDist p1 p2) = Pythagoras (XPart (mpPoint p1-mpPoint p2)) (YPart (mpPoint p1-mpPoint p2)) mpNumeric (NumericMediate a b c) = Mediate (mpNumeric a) (mpNumeric b) (mpNumeric c) mpNumeric (NumericNNN NNNAdd a1 a2) = mpNumeric a1 + mpNumeric a2 mpNumeric (NumericNNN NNNSub a1 a2) = mpNumeric a1 - mpNumeric a2 mpNumeric (NumericNNN NNNMul a1 a2) = mpNumeric a1 * mpNumeric a2 mpNumeric (NumericNNN NNNDiv a1 a2) = mpNumeric a1 / mpNumeric a2 mpNumeric (NumericNNN NNNPyth a b) = Pythagoras (mpNumeric a) (mpNumeric b) mpNumeric (NumericNNN NNNPower a b) = Power (mpNumeric a) (mpNumeric b) mpNumeric (NumericNsN NsNMin as) = Min (map mpNumeric as) mpNumeric (NumericNsN NsNMax as) = max' (map mpNumeric as) mpNumeric (NumericPN PNXPart p ) = XPart (mpPoint p) mpNumeric (NumericPN PNYPart p ) = YPart (mpPoint p) mpNumeric (NumericPN PNAngle a ) = Angle (mpPoint a) mpNumeric (NumericNN NNSinD a) = SinD (mpNumeric a) mpNumeric (NumericNN NNCosD a) = CosD (mpNumeric a) mpNumeric (NumericNN NNSqrt a) = Sqrt (mpNumeric a) mpNumeric (NumericNN NNNeg a) = -mpNumeric a mpNumeric (NumericNN NNExp a) = Exp (mpNumeric a) mpNumeric (NumericNN NNLog a) = Ln (mpNumeric a) mpNumeric (NumericNN NNRound a ) = Round (mpNumeric a) mpNumeric (NumericNN NNCeil a) = Ceil (mpNumeric a) mpNumeric (NumericNN NNFloor a ) = Floor (mpNumeric a) mpNumeric NumericWhatever = Id "whatever" mpNumeric (NumericCond b t e) = IfElse (mpBoolean b) (mpNumeric t) (mpNumeric e) mpNumeric _ = Id "" emitL :: [String] -> Doc emitL [] = empty emitL [d] = text d emitL (d:ds) = hcat (text d:[comma <+> text d | d <- ds]) instance HasEmit MetaPost where emit (MPAssign l r) = emit l <+> text ":=" <+> emit r <> semi emit (MPAssignPath l p) = text l <+> text ":=" <+> emit p <> semi emit (MPBoxit s pic) = text "boxit." <> text s <> parens (emit pic) <> semi emit (MPBitLine (x,y) d bs) = text "bitline(" <> emit x <> comma <+>emit y <> comma <+> emit d <> comma <+>text (show bs) <> char ')' <> semi emit (MPCloneit s s2) = text "cloneit." <> text s <> parens (text s2) <> semi emit (MPShapeit s) = text "shapeit." <> text s <> semi emit MPClearIt = text "clearit" <> semi emit (MPClip path) = text "clip currentpicture to "<+> emit path <> semi emit (MPComment s) = char '%' <+> text s $+$ empty emit (MPDef s t) = text ("def "++s++" = ") <> emit t <+>text "enddef" <> semi emit (MPDefineTrans s tr ) = emitDefTrans s tr emit (MPDrawUnBoxed []) = empty emit (MPConc (MPDrawUnBoxed s1) (MPConc (MPDrawUnBoxed s2) mp)) = emit (MPDrawUnBoxed (s1++s2) & mp) emit (MPDrawUnBoxed s) = text "drawunboxed" <> parens (emitL s) <> semi emit (MPConc left@((MPDraw a (MPSubPath s e path ) d c p)) (MPConc right@(MPDraw a' (MPSubPath s' e' path') d' c' p') mp)) = if path == path' && a == a' && d == d' && c == c' && p == p' then if s == e' then emit (MPDraw a (MPSubPath s' e path) d c p & mp) else if e == s' then emit (MPDraw a (MPSubPath s e' path) d c p & mp) --- else (emit left $+$ emit (right & mp)) else (emit left $+$ emit (right & mp)) emit (MPConc left@((MPDraw a (MPSubPath s e path ) d c p)) right@(MPDraw a' (MPSubPath s' e' path') d' c' p')) = if path == path' && a == a' && d == d' && c == c' && p == p' then if s == e' then emit (MPDraw a (MPSubPath s' e path) d c p) else if e == s' then emit (MPDraw a (MPSubPath s e' path) d c p) else (emit left $+$ emit right) else (emit left $+$ emit right) emit (MPConc a b) = emit a $+$ emit b emit (MPDraw ar p d c pen) = text "draw" <+> parens (emit p) <> emit d <> emit c <> emit pen <> semi <+>emit (MPDrawAHead ar p c pen) emit (MPDrawAHead MPNormal _ _ _) = empty emit (MPDrawAHead ar p c pen) = empty $$ style ar <> parens (revOrNot ar <> parens (emit p) <> comma <+> double (fst (al ar)) <> comma <+> double (snd (al ar))) <+> emit c <+> emit pen <> semi where al (MPArrow a l _) = (getDefault a 4, getDefault l 45) al (MPReverse a l _) = (getDefault a 4, getDefault l 45) al MPNormal = (0, 0) style (MPArrow _ _ MPArrowStyleFilled) = text "fill varrowheadFull" style (MPArrow _ _ MPArrowStyleLine) = text "draw varrowhead" style (MPReverse _ _ MPArrowStyleFilled) = text "fill varrowheadFull" style (MPReverse _ _ MPArrowStyleLine) = text "draw varrowhead" revOrNot (MPReverse _ _ _) = text " reverse " revOrNot _ = text "" emit (MPDrawPic c p) = text "draw" <+> emit p <+> emit c <> semi emit (MPEquals []) = empty emit (MPEquals (eq:eqs)) = emit eq <> doc eqs <> semi where doc [] = empty doc (eq:eqs) = empty <+> equals <+> emit eq <> doc eqs emit (MPFigure n mp) = text "beginfig" <> parens (int n) <> semi $+$ emit mp $+$ text "endfig" <> semi emit (MPFill path c p) = text "fill" <+> emit path <+> emit c <+> emit p <> semi emit (MPFixSize []) = empty emit (MPFixSize s) = text "fixsize" <> parens (emitL s) <> semi emit (MPFixPos []) = empty emit (MPFixPos s) = text "fixpos" <> parens (emitL s) <> semi emit (MPGraduate c1 c2 path q a) = text "graduate" <> parens (emitColor' c1 <> comma <+> emitColor' c2 <> comma <+> emit path <> comma <+> int q <> comma <+> double a) <> semi emit (MPGraduatePic c1 c2 t q a) = text "graduatePic" <> parens (emitColor' c1 <> comma <+> emitColor' c2 <> comma <+> emit t <> comma <+> int q <> comma <+> double a) <> semi emit (MPGraduatePath ar c1 c2 path pat pen q a) = text "graduatePath" <+>parens (emitColor' c1 <> comma <+> emitColor' c2 <> comma <+> emit path <> comma <+> emitPattern' pat <> comma <+> emitPen' pen <> comma <+> int q <> comma <+> double a) <> semi $+$emit (MPDrawAHead ar path c2 pen) emit (MPGroup mp) = text "begingroup" $+$ emit mp$+$text "endgroup" <> semi emit (MPIfElse b t e) = text "if" <+> emit b <> colon $+$ emit t $+$ text "else" <> colon $+$ emit e $+$ text "fi" <> semi emit (MPRelax) = empty emit (MPSubBox n mp) = text "p" <> int n <+> text " := currentpicture" <> semi <+>text "clearit" <> semi $+$emit mp $+$emit (shiftRefPoint n) <> text " := llcorner currentpicture" <> semi $+$text ("boxit."++suff n ++ "(currentpicture)") <> semi $+$text (suff n++".dx = 0") <> semi <+>text (suff n++".dy = 0") <> semi $+$text "currentpicture := p" <> int n <> semi emit (MPTex s) = text "btex" <+> text s <+> text "etex" emit (MPText s) = text $ show s emit (MPVerbatim a) = text a emit (MPImage s mp) = text (s++":=image(") $+$emit mp $+$char ')' <> semi -- Konvertierung f"ur den Typ Pfad instance HasEmit MPPath where emit (MPPathNorm p) = emit p emit (MPCutbefore p1 p2)= emit p1 <+> text "cutbefore" <+> emit p2 emit (MPCutafter p1 p2) = emit p1 <+> text "cutafter" <+> emit p2 emit (MPBPath a) = text "bpath" <+> emit a emit (MPTransformP ts a)= emit a <> hsep [ text " transformed" <> text (tr t) | t<-ts] emit (MPShiftedP a p) = emit p <+> text "shifted" <+> emit a emit (MPSubPath beg end p) = text "subpath (" <> emit beg <> comma <> emit end <> text ") of " <> emit p emit (MPPathTerm s) = emit s instance HasEmit MPPathSub where emit (MPPathSub a j s) = emit a <> emit j <> emit s emit (MPPathEndDir a d) = emit a <> emit d emit (MPPathEnd a) = emit a emit MPCycle = text "cycle" emit (MPPathBuildCycle (p1:p2:_)) = text "buildcycle(" <> emit p1 <> comma <> emit p2 <> char ')' emit (MPPathTransform (MPTransform a b c d e f) p) = char '(' <> emit p <> text ") transformed" <+> emit (TransformedM a b c d e f) instance HasEmit MPPathJoin where emit (MPPathJoin _ MPPathBasicJoinTense _) = text "---" emit (MPPathJoin _ MPPathBasicJoinStraight _) = text "--" emit (MPPathJoin dir1 bj dir2) = emit dir1 <> emit bj <> emit dir2 instance HasEmit MPPathDir where emit MPDefaultPathDir = empty emit (MPPathDirCurl a) = text "{curl (" <> emit a <> text ")}" emit (MPPathDirPair a b)= char '{' <> emit a <> comma <> emit b <> char '}' emit (MPPathDir a) = text "{dir (" <> emit a <> text ")}" instance HasEmit MPPathBasicJoin where emit MPPathBasicJoinCat = text " & " emit MPPathBasicJoin2 = text ".." emit MPPathBasicJoin3 = text "..." emit MPPathBasicJoinTense = text "---" emit MPPathBasicJoinStraight = text "--" emit (MPPathBasicJoinTension1 a) = text "..tension " <> emit a <> text ".." emit (MPPathBasicJoinTension2 a b) = text "..tension " <> emit a <> text " and " <> emit b <> text ".." emit (MPPathBasicJoinControls1 a) = text "..controls" <+> emit a <> text ".." emit (MPPathBasicJoinControls2 a b) = text "..controls" <+> emit a <+> text "and" <+> emit b <> text".." instance HasEmit MPPathBasicJoinTension where emit (MPPathBasicJoinTension a) = emit a emit (MPPathBasicJoinAtLeast a) = text "atleast" <+> emit a showFF :: Double -> ShowS showFF = showFFloat (Just 3) instance HasEmit Term where emit (Const 0) = text "0" emit (Const n) = if n < 0 then text ('(':(showFFloat (Just 4) n ")")) else text (showFFloat (Just 4) n "") emit (Pos n m) = text (pos n m) emit (Max []) = char '0' emit (Max [a]) = emit a emit (Max (t:ts)) = text "max(" <> emit t <> hcat [comma <> emit t'|t'<-ts] <> char ')' emit (Min []) = char '0' emit (Min [a]) = emit a emit (Min (t:ts)) = text "min(" <> emit t <> hcat [comma <> emit t'|t'<-ts] <> char ')' emit (Neg a) = text "(-(" <> emit a <> text "))" emit (Add a b) = emit a <> char '+' <> emit b emit (Sub a b) = emit a <> text "-(" <> emit b <> char ')' emit (Mul a b) = char '(' <> emit a <> text ")*(" <> emit b <> char ')' emit (Pair a b) = char '(' <> emit a <> char ',' <> emit b <> char ')' emit (XPart a) = text "(xpart (" <> emit a <> text "))" emit (YPart a) = text "(ypart (" <> emit a <> text "))" emit (Id a) = text a emit (Pythagoras a b) = char '(' <> emit a <> text "++" <> emit b <> char ')' emit Identity = text "identity" emit CurrentPicture = text "currentpicture" emit (Infix a b c) = emit a <+> text b <+> emit c emit (LLCorner a) = text "llcorner (" <> emit a <> char ')' emit (URCorner a) = text "urcorner (" <> emit a <> char ')' emit (Pic a) = text "pic" <+> text a emit (Shifted a b) = char '(' <> emit a <> text ") shifted (" <> emit b <> char ')' emit (Transformed a b) = char '(' <> emit a <> text ") transformed (" <> emit b <> char ')' emit (TransformedM a b c d e f) = text "trans(" <> emit a <> comma <> emit b <> comma <> emit c <> comma <> emit d <> comma <> emit e <> comma <> emit f <> char ')' emit (SinD a) = text "sind(" <> emit a <> char ')' emit (Power a b) = text "((" <> emit a <> text ")**(" <> emit b <> text "))" emit (CosD a) = text "cosd(" <> emit a <> char ')' emit (Sqrt a) = text "sqrt(" <> emit a <> char ')' emit (Exp a) = text "mexp(256*(" <> emit a <> text "))" emit (Ln a) = text "(mlog(" <> emit a <> text ")/256)" emit (Round a) = text "round(" <> emit a <> char ')' emit (Angle a) = text "angle(" <> emit a <> char ')' emit (Dirop a) = text "(dir (" <> emit a <> text "))" emit (Ceil a) = text "ceil(" <> emit a <> char ')' emit (Floor a) = text "floor(" <> emit a <> char ')' emit (Div a b) = char '(' <> emit a <> text ")/(" <> emit b <> text ")" emit (Mediate a b c) = emit a <> brackets (emit b <> comma <> emit c) emit (Transform ts a) = emit a <> hsep [ text (" transformed "++tr t) | t <- reverse ts] emit (TDot a d) = text (a ++ emitDir d) emit (Parens a) = parens (emit a) emit (VerbFunction a b) = text a <> parens (emit b) emit (IfElse b t e) = text "if" <+> emit b <> char ':' <> emit t <+> text "else:" <> emit e <+> text "fi " instance HasEmit MPArrow where emit MPNormal = text "draw" emit (MPArrow _ _ _) = text "drawarrow" emit (MPReverse _ _ _) = text "drawarrow reverse" instance HasEmit MPPattern where emit MPDefaultPattern = text "" emit (MPDashPattern pat) = text "dashed dashpattern" <+> parens (on pat) where on [] = text "" on ((-1):as) = off as on (a:as) = text "on" <+> double a <+> off as off [] = text "" off (a:as) = text "off" <+> double a <+> on as emitPattern' :: MPPattern -> Doc emitPattern' MPDefaultPattern = text "0" emitPattern' (MPDashPattern pat) = text "dashpattern" <+> parens (on pat) where on [] = text "" on ((-1):as) = off as on (a:as) = text "on" <+> double a <+> off as off [] = text "" off (a:as) = text "off" <+> double a <+> on as emitDefTrans :: String -> MPTransform -> Doc emitDefTrans s (MPTransform xx xy yx yy _ _) = text ("xpart "++s++"=0; ypart "++s++"=0;") $+$ text ("xxpart "++s++"=") <> emit xx <> semi $+$ text ("xypart "++s++"=") <> emit xy <> semi $+$ text ("yxpart "++s++"=") <> emit yx <> semi $+$ text ("yypart "++s++"=") <> emit yy <> semi instance HasEmit MPColor where emit MPDefaultColor = empty emit (MPColor r g b) = text (" withcolor "++show (r,g,b)++" ") emitColor' :: MPColor -> Doc emitColor' MPDefaultColor = text "(0,0,0)" emitColor' (MPColor r g b) = text (show (r,g,b)) instance HasEmit MPPen where emit MPDefaultPen = empty emit (MPPenCircle (x,y) a) = text " withpen pencircle" <+> emitPen2 (x,y) a emit (MPPenSquare (x,y) a) = text " withpen pensquare" <+> emitPen2 (x,y) a emitPen2 :: (Num b, HasEmit b, Eq a, HasEmit a) => (a,a) -> b -> Doc emitPen2 (x,y) a = (if x == y then text "scaled" <+> parens (emit x) else text "xscaled" <+> parens (emit x) <+> text "yscaled" <+> parens (emit y)) <+>if a == 0 then empty else text "rotated" <+> parens (emit a) emitPen' :: MPPen -> Doc emitPen' MPDefaultPen = text "pencircle" emitPen' (MPPenCircle (x,y) a)= text "pencircle" <+> emitPen2 (x,y) a emitPen' (MPPenSquare (x,y) a)= text "pensquare" <+> emitPen2 (x,y) a emitDir :: Dir -> String emitDir C = ".c" emitDir N = ".n" emitDir NE = ".ne" emitDir E = ".e" emitDir SE = ".se" emitDir S = ".s" emitDir SW = ".sw" emitDir W = ".w" emitDir NW = ".nw" tdot :: String -> Dir -> Term tdot s C = TDot s C tdot s N = TDot s N tdot s NE = TDot s NE tdot s E = TDot s E tdot s SE = TDot s SE tdot s S = TDot s S tdot s SW = TDot s SW tdot s W = TDot s W tdot s NW = TDot s NW tr :: Int -> String tr n = "_t_" ++ savestring (show n) pos :: Int -> Int -> String pos a b = "p" ++ show a ++ " " ++ show b savestring :: String -> String savestring [] = [] savestring (a:as) = toEnum (b+hi):toEnum (b+lo):savestring as where b = fromEnum 'A' lo = mod (fromEnum a) 16 hi = div (fromEnum a) 16 defDX, defDY, txtDX, txtDY :: Term defDX = Id "defDX" defDY = Id "defDY" txtDX = Id "txtDX" txtDY = Id "txtDY" shiftRefPoint :: Int -> Term shiftRefPoint n = Id ("s" ++ show n) suff :: Int -> String suff n = "b" ++ show n