1 {-# LANGUAGE RankNTypes, MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeOperators #-}
2 -----------------------------------------------------------------------------
6 -- License : public domain
8 -- Maintainer : Adam Megacz <megacz@acm.org>
9 -- Stability : experimental
11 -- | Renders a @GArrowSkeleton@ using TikZ; the result is LaTeX code.
12 -- You must have lp_solve installed in order for this to work.
15 module GArrowTikZ (tikz)
18 import Prelude hiding ( id, (.), lookup )
19 import Control.Category
20 import Control.Monad.State
22 import Data.List hiding (lookup, insert)
23 import Data.Map hiding (map, (!))
24 import Data.Maybe (catMaybes)
27 import GArrowPortShape
28 import GHC.HetMet.Private
30 ------------------------------------------------------------------------------
34 -- Figuring out the x-coordinates of the boxes is easy, but we'll need
35 -- to use lp_solve to get a nice layout for the y-coordinates of the
36 -- wires. A @Track@ is basically just a y-axis position for one of
37 -- the horizontal wires in the boxes-and-wires diagram; we will assign
38 -- a unique Int to each visual element that has a y-coordinate, then
39 -- generate a big pile of constraints on these y-coordinates and have
40 -- lp_solve find a solution.
42 type TrackIdentifier = Int
44 data Tracks = T TrackIdentifier
45 | TU TrackIdentifier -- a track known to be of unit type
48 instance Show Tracks where
49 show (T ti ) = "(T "++show ti++")"
50 show (TU ti ) = "(TU "++show ti++")"
51 show (TT t1 t2) = "(TT "++show t1++" "++show t2++")"
54 -- | TrackPositions maps TrackIdentifiers to actual y-axis positions;
55 -- this is what lp_solve gives us
57 type TrackPositions = TrackIdentifier -> Float
59 (!) :: TrackPositions -> TrackIdentifier -> Float
62 -- | get the uppermost TrackIdentifier in a Tracks
65 uppermost (TT x y) = uppermost x
67 -- | get the lowermost TrackIdentifier in a Tracks
70 lowermost (TT x y) = lowermost y
73 class ToDiagram g where
74 toDiagram :: GArrowPortShape g () x y -> ConstraintM Diagram
76 instance (Detect m, ToDiagram m) => ToDiagram (GArrowSkeleton m) where
77 toDiagram s = mkdiag s
80 MkOpaque :: String -> DetectM (GArrowPortShape Opaque UVar x y) -> Opaque x y
82 instance Detect Opaque where
83 detect' (MkOpaque _ dm) = dm
85 instance ToDiagram Opaque where
86 toDiagram (GASPortPassthrough inp outp (MkOpaque s _)) =
87 do { (top, x ,bot) <- alloc inp
88 ; (_, y ,_) <- alloc outp
90 ; simpleDiag s top x y bot [] }
91 toDiagram q = mkdiag q
93 -- do (top, x ,bot) <- alloc inp
94 -- simpleDiag' s top x x bot [(x,x)] "gray!50"
97 ------------------------------------------------------------------------------
100 -- | A Diagram is the visual representation of a GArrowSkeleton
102 = DiagramComp Diagram Diagram
103 | DiagramBox Float TrackIdentifier Tracks BoxRenderer Tracks TrackIdentifier
104 | DiagramBypassTop Tracks Diagram
105 | DiagramBypassBot Diagram Tracks
106 | DiagramLoopTop Tracks Diagram
107 | DiagramLoopBot Diagram Tracks
109 -- | get the output tracks of a diagram
110 getOut :: Diagram -> Tracks
111 getOut (DiagramComp f g) = getOut g
112 getOut (DiagramBox wid ptop pin q pout pbot) = pout
113 getOut (DiagramBypassTop p f) = TT p (getOut f)
114 getOut (DiagramBypassBot f p) = TT (getOut f) p
115 getOut (DiagramLoopTop t d) = case getOut d of { TT z y -> y ; _ -> error "DiagramLoopTop: mismatch" }
116 getOut (DiagramLoopBot d t) = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
118 -- | get the input tracks of a diagram
119 getIn :: Diagram -> Tracks
120 getIn (DiagramComp f g) = getIn f
121 getIn (DiagramBox wid ptop pin q pout pbot) = pin
122 getIn (DiagramBypassTop p f) = TT p (getIn f)
123 getIn (DiagramBypassBot f p) = TT (getIn f) p
124 getIn (DiagramLoopTop t d) = case getIn d of { TT z x -> x ; _ -> error "DiagramLoopTop: mismatch" }
125 getIn (DiagramLoopBot d t) = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: mismatch" }
127 -- | A BoxRenderer is just a routine that, given the dimensions of a
128 -- boxes-and-wires box element, knows how to spit out a bunch of TikZ
129 -- code that draws it
131 TrackPositions -> -- resolves the TrackIdentifiers to actual y-coordinates
137 noRender :: BoxRenderer
138 noRender _ _ _ _ _ = ""
143 ------------------------------------------------------------------------------
146 -- | a constraint (to be dealt with by lp_solve) relates two track identifiers
147 data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
148 | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
150 -- instance Show Constraint where
151 -- show (C t1 LT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
152 -- show (C t1 GT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
153 -- show (C t1 EQ t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
155 instance Show Constraint where
156 show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
157 show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
158 show (C t1 EQ t2 k) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
159 show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
160 " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
162 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
163 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
165 -- | pull the constraints out of the monad
166 getConstraints :: ConstraintM [Constraint]
167 getConstraints = do { (_,c) <- get ; return c }
169 -- | add a constraint
170 constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
171 constrain t1 ord t2 k = do { (t,c) <- get
172 ; put (t, (C t1 ord t2 k):c)
176 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
177 ; put (t, (EqualSpace t1a t1b t2a t2b):c)
181 -- | simple form for equality constraints
182 constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
183 constrainEq (T t1 ) (T t2 ) = constrain t1 EQ t2 0
184 constrainEq (TU t1 ) (TU t2 ) = constrain t1 EQ t2 0
185 constrainEq (TU t1 ) (T t2 ) = constrain t1 EQ t2 0
186 constrainEq (T t1 ) (TU t2 ) = constrain t1 EQ t2 0
187 constrainEq t1 t2 = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
189 -- | allocate a TrackIdentifier
190 alloc1 :: ConstraintM Tracks
191 alloc1 = do { (t,c) <- get
196 mkdiag :: ToDiagram m => GArrowPortShape m () a b -> ConstraintM Diagram
197 mkdiag (GASPortPassthrough inp outp m) = toDiagram (GASPortPassthrough inp outp m)
198 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
200 mkdiag' :: ToDiagram m => GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
202 mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
203 ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
204 mkdiag' (GAS_first f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
205 ; return $ DiagramBypassBot f' x }
206 mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
207 ; return $ DiagramBypassTop x f' }
208 mkdiag' (GAS_id ) = do { (top, x ,bot) <- alloc inp ; simpleDiag' "id" top x x bot [(x,x)] "gray!50" }
209 mkdiag' GAS_cancell = do { (top,(TT x y),bot) <- alloc inp
210 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
211 drawWires tp x1 y x2 y "black" ++
212 drawLine x1 (tp!lowermost x) ((x1+x2)/2) (tp!uppermost y) "gray!50" "dashed"
213 ; return $ DiagramBox 2 top (TT x y) r y bot }
214 mkdiag' GAS_cancelr = do { (top,(TT x y),bot) <- alloc inp
215 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
216 drawWires tp x1 x x2 x "black" ++
217 drawLine x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "gray!50" "dashed"
218 ; return $ DiagramBox 2 top (TT x y) r x bot }
219 mkdiag' GAS_uncancell = do { (top,(TT x y),bot) <- alloc outp
220 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
221 drawWires tp x1 y x2 y "black" ++
222 drawLine ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "gray!50" "dashed"
223 ; return $ DiagramBox 2 top y r (TT x y) bot }
224 mkdiag' GAS_uncancelr = do { (top,(TT x y),bot) <- alloc outp
225 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
226 drawWires tp x1 x x2 x "black" ++
227 drawLine ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "gray!50" "dashed"
228 ; return $ DiagramBox 2 top x r (TT x y) bot }
229 mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp
230 ; (_, y ,_) <- alloc outp
232 ; simpleDiag "drop" top x y bot [] }
233 mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
234 ; (_ , x ,_) <- alloc inp
235 ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
236 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
237 drawWires tp x1 x ((x1+x2)/2) x "black" ++
238 drawWires tp ((x1+x2)/2) x x2 y "black" ++
239 drawWires tp ((x1+x2)/2) x x2 z "black"
240 ; return $ DiagramBox 2 top x r (TT y z) bot
242 mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
243 ; (top,(TT x' y'),bot) <- alloc outp
244 ; constrainEq (T (lowermost x)) (T (lowermost x'))
245 ; constrainEq (T (uppermost y)) (T (uppermost y'))
246 ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
248 do { (top,(TT (TT x y) z),bot) <- alloc inp
249 ; let r tp x1 y1 x2 y2
250 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
251 drawLine x1 y1 x2 y1 "gray!50" "-" ++
252 drawLine x1 y2 x2 y2 "gray!50" "-" ++
253 drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
254 drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
255 drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
256 drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
257 drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
258 drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
259 drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
260 drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
261 drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
262 drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
263 drawWires tp x1 x x2 x "black" ++
264 drawWires tp x1 y x2 y "black" ++
265 drawWires tp x1 z x2 z "black"
266 ; let pin = (TT (TT x y) z)
267 ; let pout = (TT x (TT y z))
268 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
270 mkdiag' GAS_unassoc =
271 do { (top,(TT x (TT y z)),bot) <- alloc inp
272 ; let r tp x1 y1 x2 y2
273 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
274 drawLine x1 y1 x2 y1 "gray!50" "-" ++
275 drawLine x1 y2 x2 y2 "gray!50" "-" ++
276 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
277 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
278 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
279 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
280 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
281 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
282 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
283 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
284 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
285 drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
286 drawWires tp x1 x x2 x "black" ++
287 drawWires tp x1 y x2 y "black" ++
288 drawWires tp x1 z x2 z "black"
289 ; let pin = (TT x (TT y z))
290 ; let pout = (TT (TT x y) z)
291 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
293 mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
294 ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
295 ; constrainTop (lowermost l) loopgap f'
296 ; return $ DiagramLoopTop l f' }
297 mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
298 ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
299 ; constrainBot f' loopgap (uppermost l)
300 ; return $ DiagramLoopBot f' l }
301 mkdiag' (GAS_misc f ) = mkdiag f
303 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
304 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
305 ; constrain pbot GT (lowermost pin) 1
306 ; constrain ptop LT (uppermost pout) (-1)
307 ; constrain pbot GT (lowermost pout) 1
308 ; constrain ptop LT pbot (-1)
309 ; return $ DiagramBox 2 ptop pin r pout pbot
311 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
312 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
314 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
315 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
316 -- ++ wires (x-1) p1 x "green"
317 -- ++ wires (x+w) p2 (x+w+1) "red"
320 draw_first_second = False
322 --draw_first_second = True
324 -- constrain that Ports is at least Int units above the topmost portion of Diagram
325 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
326 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
327 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
328 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
329 constrainTop v i (DiagramBox wid ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
330 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
331 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
333 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
334 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
335 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
336 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
337 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
338 constrainBot (DiagramBox wid ptop pin r pout pbot) i v = constrain v GT pbot i
339 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
340 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
342 -- | The width of a box is easy to calculate
343 width :: TrackPositions -> Diagram -> Float
344 width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
345 width m (DiagramBox wid ptop pin x pout pbot) = wid
346 width m (DiagramBypassTop p d) = (width m d) + (if draw_first_second then 2 else 0)
347 width m (DiagramBypassBot d p) = (width m d) + (if draw_first_second then 2 else 0)
348 width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
349 width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
351 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
352 drawWires tp x1 (TT a b) x2 (TT a' b') color = drawWires tp x1 a x2 a' color ++ drawWires tp x1 b x2 b' color
353 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
354 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
355 drawWires tp _ _ _ _ _ = error "drawwires fail"
357 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
358 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
359 wirecos tp (T a) = [(tp!a,True)]
360 wirecos tp (TU a) = [(tp!a,False)]
362 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
363 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
365 color = if b then "black" else "gray!50"
366 style = if b then "-" else "dashed"
367 x' = x - (y - y1) - loopgap
369 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
371 color = if b then "black" else "gray!50"
372 style = if b then "-" else "dashed"
373 x' = x + (y - y1) + loopgap
375 tikZ :: TrackPositions ->
377 Float -> -- horizontal position
381 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
382 ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
383 ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
384 ++ tikZ' d2 (x + width m d1 + 1)
385 tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
386 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
388 let top = getTop d' in
389 let bot = getBot d' in
390 drawBox x top (x+width m d') bot "gray!50" "second"
391 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
393 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
394 ++ drawWires m x p (x+1+width m d+1) p "black"
395 tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
396 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
398 let top = getTop d' in
399 let bot = getBot d' in
400 drawBox x top (x+width m d') bot "gray!50" "first"
401 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
403 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
404 ++ drawWires m x p (x+1+width m d+1) p "black"
405 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
406 let bot = getBot d' in
407 let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
408 drawBox x top (x+width m d') bot "gray!50" "loopl"
410 ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
411 ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
412 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
413 in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
414 ++ let p' = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
415 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
416 in concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
417 ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
418 in drawWires m x rest (x+1+gap) rest "black"
419 ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
420 in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
421 tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
422 tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
424 wires x1 t x2 c = wires' x1 t x2 c "-"
426 wires' :: Float -> Tracks -> Float -> String -> String -> String
427 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
428 wires' x1 (T v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) color st -- ++ textc ((x1+x2) / 2) (m!v) (show v) "purple"
429 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
431 getTop :: Diagram -> Float
432 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
433 getTop (DiagramBox wid ptop _ _ _ _) = m ! ptop
434 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
435 getTop (DiagramBypassBot d p) = getTop d - 1
436 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
437 getTop (DiagramLoopBot d p) = getTop d - 1
439 getBot :: Diagram -> Float
440 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
441 getBot (DiagramBox wid _ _ _ _ pbot) = m ! pbot
442 getBot (DiagramBypassTop p d) = getBot d + 1
443 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
444 getBot (DiagramLoopTop p d) = getBot d + 1
445 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
447 -- allocates multiple tracks, adding constraints that they are at least one unit apart
448 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
449 alloc shape = do { tracks <- alloc' shape
452 ; constrain ptop LT (uppermost tracks) (-1)
453 ; constrain pbot GT (lowermost tracks) 1
454 ; return (ptop,tracks,pbot)
457 alloc' :: PortShape a -> ConstraintM Tracks
458 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
459 alloc' (PortFree _) = do { x <- alloc1 ; return x }
460 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
462 ; constrain (lowermost x1) LT (uppermost x2) (-1)
466 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
468 allocLoop :: Tracks -> ConstraintM Tracks
469 allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
470 allocLoop (T _) = do { x <- alloc1 ; return x }
471 allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
473 ; constrain (lowermost x1) LT (uppermost x2) (-1)
477 do_lp_solve :: [Constraint] -> IO String
478 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
480 ; stdout <- readProcess "lp_solve" [] stdin
484 splitWs :: String -> [String]
485 splitWs s = splitWs' "" s
488 splitWs' acc [] = [acc]
489 splitWs' [] (' ':k) = splitWs' [] k
490 splitWs' acc (' ':k) = acc:(splitWs' [] k)
491 splitWs' acc (x:k) = splitWs' (acc++[x]) k
493 lp_solve_to_trackpos :: String -> TrackPositions
494 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
496 grab ('x':k) = Just k
498 parse :: String -> (Int,Float)
499 parse s = case splitWs s of
500 [a,b] -> (read a, read b)
501 _ -> error "parse: should not happen"
502 toTrackPos :: [(Int,Float)] -> TrackPositions
503 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
504 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
506 toTikZ :: (ToDiagram m, Detect m) => GArrowSkeleton m a b -> IO String
508 let cm = do { let g' = detectShape g
512 in do { let (_,constraints) = execState cm (0,[])
513 ; lps <- do_lp_solve $ constraints
514 ; let m = lp_solve_to_trackpos lps
515 ; let d = evalState cm (0,[])
517 ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
518 ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
524 (Int -> PGArrow g (GArrowUnit g) Int) ->
525 (PGArrow g (GArrowTensor g c c) c) ->
528 tikz x = tikz' $ beautify $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_misc (oconst c) })
529 (PGArrowD { unG = GAS_misc omult }))
531 oconst :: Int -> Opaque () a
532 oconst c = MkOpaque ("const "++(show c)) $
534 return $ GASPortPassthrough PortUnit (PortFree x) (oconst c)
536 omult :: Opaque (a,a) a
537 omult = MkOpaque "mult" $
539 return $ GASPortPassthrough (PortTensor (PortFree x) (PortFree x)) (PortFree x) omult
542 = do putStrLn "\\documentclass{article}"
543 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
544 putStrLn "\\usepackage{tikz}"
545 putStrLn "\\usepackage{amsmath}"
546 putStrLn "\\usepackage[tightpage,active]{preview}"
547 putStrLn "\\begin{document}"
548 putStrLn "\\setlength\\PreviewBorder{5pt}"
549 putStrLn "\\begin{preview}"
550 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
551 tikz <- toTikZ example
553 putStrLn "\\end{tikzpicture}"
554 putStrLn "\\end{preview}"
555 --putStrLn "\\pagebreak"
556 --putStrLn "\\begin{align*}"
557 --putStr (toTikZ' example)
558 --putStrLn "\\end{align*}"
559 putStrLn "\\end{document}"
561 -- Random TikZ routines
562 textc x y text color =
563 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
564 "{{\\tt{"++text++"}}};\n"
566 drawBox x1 y1 x2 y2 color text =
567 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
568 "{{\\tt{"++text++"}}};\n"
570 "\\path[draw,color="++color++"]"++
571 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
572 show (x2*xscale)++","++show (y2*yscale)++");\n"
574 drawLine x1 y1 x2 y2 color style =
575 "\\path[draw,color="++color++","++style++"] "++
576 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
577 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
579 drawLine' [] color style = ""
580 drawLine' (xy1:xy) color style =
581 "\\path[draw,color="++color++","++style++"] "++
582 foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
585 f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
587 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
590 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
593 -- | extra gap placed between loopback wires and the contents of the loop module