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,Opaque(..),toTikZ,tikz_header,tikz_footer,skelify',skelify'')
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 skelify' :: (forall g . (GArrowCopy g (,) (), GArrowDrop g (,) (), GArrowSwap g (,) (), GArrowLoop g (,) ()) => g x y) ->
31 GArrowSkeleton Opaque x y
34 skelify'' :: GArrowSkeleton Opaque x y -> GArrowSkeleton Opaque x y
37 ------------------------------------------------------------------------------
41 -- Figuring out the x-coordinates of the boxes is easy, but we'll need
42 -- to use lp_solve to get a nice layout for the y-coordinates of the
43 -- wires. A @Track@ is basically just a y-axis position for one of
44 -- the horizontal wires in the boxes-and-wires diagram; we will assign
45 -- a unique Int to each visual element that has a y-coordinate, then
46 -- generate a big pile of constraints on these y-coordinates and have
47 -- lp_solve find a solution.
49 type TrackIdentifier = Int
51 data Tracks = T TrackIdentifier
52 | TU TrackIdentifier -- a track known to be of unit type
55 instance Show Tracks where
56 show (T ti ) = "(T "++show ti++")"
57 show (TU ti ) = "(TU "++show ti++")"
58 show (TT t1 t2) = "(TT "++show t1++" "++show t2++")"
61 -- | TrackPositions maps TrackIdentifiers to actual y-axis positions;
62 -- this is what lp_solve gives us
64 type TrackPositions = TrackIdentifier -> Float
66 (!) :: TrackPositions -> TrackIdentifier -> Float
69 -- | get the uppermost TrackIdentifier in a Tracks
72 uppermost (TT x y) = uppermost x
74 -- | get the lowermost TrackIdentifier in a Tracks
77 lowermost (TT x y) = lowermost y
80 class ToDiagram g where
81 toDiagram :: GArrowPortShape g () x y -> ConstraintM Diagram
83 instance (Detect m, ToDiagram m) => ToDiagram (GArrowSkeleton m) where
84 toDiagram s = mkdiag s
87 MkOpaque :: String -> DetectM (GArrowPortShape Opaque UVar x y) -> Opaque x y
89 instance Detect Opaque where
90 detect' (MkOpaque _ dm) = dm
92 instance ToDiagram Opaque where
93 toDiagram (GASPortPassthrough inp outp (MkOpaque s _)) =
94 do { (top, x ,bot) <- alloc inp
95 ; (_, y ,_) <- alloc outp
97 ; simpleDiag'' s top x y bot [] "black" }
98 toDiagram q = mkdiag q
100 -- do (top, x ,bot) <- alloc inp
101 -- simpleDiag' s top x x bot [(x,x)] "gray!50"
104 ------------------------------------------------------------------------------
107 -- | A Diagram is the visual representation of a GArrowSkeleton
109 = DiagramComp Diagram Diagram
110 | DiagramBox Float TrackIdentifier Tracks BoxRenderer Tracks TrackIdentifier
111 | DiagramBypassTop Tracks Diagram
112 | DiagramBypassBot Diagram Tracks
113 | DiagramLoopTop Tracks Diagram
114 | DiagramLoopBot Diagram Tracks
116 -- | get the output tracks of a diagram
117 getOut :: Diagram -> Tracks
118 getOut (DiagramComp f g) = getOut g
119 getOut (DiagramBox wid ptop pin q pout pbot) = pout
120 getOut (DiagramBypassTop p f) = TT p (getOut f)
121 getOut (DiagramBypassBot f p) = TT (getOut f) p
122 getOut (DiagramLoopTop t d) = case getOut d of { TT z y -> y ; _ -> error "DiagramLoopTop: mismatch" }
123 getOut (DiagramLoopBot d t) = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
125 -- | get the input tracks of a diagram
126 getIn :: Diagram -> Tracks
127 getIn (DiagramComp f g) = getIn f
128 getIn (DiagramBox wid ptop pin q pout pbot) = pin
129 getIn (DiagramBypassTop p f) = TT p (getIn f)
130 getIn (DiagramBypassBot f p) = TT (getIn f) p
131 getIn (DiagramLoopTop t d) = case getIn d of { TT z x -> x ; _ -> error "DiagramLoopTop: mismatch" }
132 getIn (DiagramLoopBot d t) = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: mismatch" }
134 -- | A BoxRenderer is just a routine that, given the dimensions of a
135 -- boxes-and-wires box element, knows how to spit out a bunch of TikZ
136 -- code that draws it
138 TrackPositions -> -- resolves the TrackIdentifiers to actual y-coordinates
144 noRender :: BoxRenderer
145 noRender _ _ _ _ _ = ""
150 ------------------------------------------------------------------------------
153 -- | a constraint (to be dealt with by lp_solve) relates two track identifiers
154 data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
155 | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
157 -- instance Show Constraint where
158 -- show (C t1 LT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
159 -- show (C t1 GT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
160 -- show (C t1 EQ t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
162 instance Show Constraint where
163 show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
164 show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
165 show (C t1 EQ t2 k) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
166 show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
167 " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
169 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
170 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
172 -- | pull the constraints out of the monad
173 getConstraints :: ConstraintM [Constraint]
174 getConstraints = do { (_,c) <- get ; return c }
176 -- | add a constraint
177 constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
178 constrain t1 ord t2 k = do { (t,c) <- get
179 ; put (t, (C t1 ord t2 k):c)
183 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
184 ; put (t, (EqualSpace t1a t1b t2a t2b):c)
188 -- | simple form for equality constraints
189 constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
190 constrainEq (T t1 ) (T t2 ) = constrain t1 EQ t2 0
191 constrainEq (TU t1 ) (TU t2 ) = constrain t1 EQ t2 0
192 constrainEq (TU t1 ) (T t2 ) = constrain t1 EQ t2 0
193 constrainEq (T t1 ) (TU t2 ) = constrain t1 EQ t2 0
194 constrainEq t1 t2 = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
196 -- | allocate a TrackIdentifier
197 alloc1 :: ConstraintM Tracks
198 alloc1 = do { (t,c) <- get
203 mkdiag :: ToDiagram m => GArrowPortShape m () a b -> ConstraintM Diagram
204 mkdiag (GASPortPassthrough inp outp m) = toDiagram (GASPortPassthrough inp outp m)
205 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
207 mkdiag' :: ToDiagram m => GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
209 mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
210 ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
211 mkdiag' (GAS_first f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
212 ; return $ DiagramBypassBot f' x }
213 mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
214 ; return $ DiagramBypassTop x f' }
215 mkdiag' (GAS_id ) = do { (top, x ,bot) <- alloc inp ; simpleDiag' "id" top x x bot [(x,x)] "gray!50" }
216 mkdiag' GAS_cancell = do { (top,(TT x y),bot) <- alloc inp
217 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
218 drawWires tp x1 y x2 y "black" ++
219 drawLine x1 (tp!lowermost x) ((x1+x2)/2) (tp!uppermost y) "gray!50" "dashed"
220 ; return $ DiagramBox 2.4 top (TT x y) r y bot }
221 mkdiag' GAS_cancelr = do { (top,(TT x y),bot) <- alloc inp
222 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
223 drawWires tp x1 x x2 x "black" ++
224 drawLine x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "gray!50" "dashed"
225 ; return $ DiagramBox 2.4 top (TT x y) r x bot }
226 mkdiag' GAS_uncancell = do { (top,(TT x y),bot) <- alloc outp
227 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
228 drawWires tp x1 y x2 y "black" ++
229 drawLine ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "gray!50" "dashed"
230 ; return $ DiagramBox 2.8 top y r (TT x y) bot }
231 mkdiag' GAS_uncancelr = do { (top,(TT x y),bot) <- alloc outp
232 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
233 drawWires tp x1 x x2 x "black" ++
234 drawLine ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "gray!50" "dashed"
235 ; return $ DiagramBox 2.8 top x r (TT x y) bot }
236 mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp
237 ; (_, y ,_) <- alloc outp
239 ; simpleDiag "drop" top x y bot [] }
240 mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
241 ; (_ , x ,_) <- alloc inp
242 ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
243 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
244 drawWires tp x1 x ((x1+x2)/2) x "black" ++
245 drawWires tp ((x1+x2)/2) x x2 y "black" ++
246 drawWires tp ((x1+x2)/2) x x2 z "black"
247 ; return $ DiagramBox defaultWidth top x r (TT y z) bot
249 mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
250 ; (top,(TT x' y'),bot) <- alloc outp
251 ; constrainEq (T (lowermost x)) (T (lowermost x'))
252 ; constrainEq (T (uppermost y)) (T (uppermost y'))
253 ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
255 do { (top,(TT (TT x y) z),bot) <- alloc inp
256 ; let r tp x1 y1 x2 y2
257 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
258 drawLine x1 y1 x2 y1 "gray!50" "-" ++
259 drawLine x1 y2 x2 y2 "gray!50" "-" ++
260 drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
261 drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
262 drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
263 drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
264 drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
265 drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
266 drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
267 drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
268 drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
269 drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
270 drawWires tp x1 x x2 x "black" ++
271 drawWires tp x1 y x2 y "black" ++
272 drawWires tp x1 z x2 z "black"
273 ; let pin = (TT (TT x y) z)
274 ; let pout = (TT x (TT y z))
275 ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
277 mkdiag' GAS_unassoc =
278 do { (top,(TT x (TT y z)),bot) <- alloc inp
279 ; let r tp x1 y1 x2 y2
280 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
281 drawLine x1 y1 x2 y1 "gray!50" "-" ++
282 drawLine x1 y2 x2 y2 "gray!50" "-" ++
283 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
284 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
285 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
286 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
287 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
288 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
289 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
290 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
291 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
292 drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
293 drawWires tp x1 x x2 x "black" ++
294 drawWires tp x1 y x2 y "black" ++
295 drawWires tp x1 z x2 z "black"
296 ; let pin = (TT x (TT y z))
297 ; let pout = (TT (TT x y) z)
298 ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
300 mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
301 ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
302 ; constrainTop (lowermost l) loopgap f'
303 ; return $ DiagramLoopTop l f' }
304 mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
305 ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
306 ; constrainBot f' loopgap (uppermost l)
307 ; return $ DiagramLoopBot f' l }
308 mkdiag' (GAS_misc f ) = mkdiag f
312 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
313 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
314 ; constrain pbot GT (lowermost pin) 1
315 ; constrain ptop LT (uppermost pout) (-1)
316 ; constrain pbot GT (lowermost pout) 1
317 ; constrain ptop LT pbot (-1)
318 ; return $ DiagramBox defaultWidth ptop pin r pout pbot
320 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
321 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
323 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
324 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
325 -- ++ wires (x-1) p1 x "green"
326 -- ++ wires (x+w) p2 (x+w+1) "red"
327 simpleDiag'' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
329 defren tp x1 y1 x2 y2 = drawBoxC x1 y1 x2 y2 color text ++
330 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
331 -- ++ wires (x-1) p1 x "green"
332 -- ++ wires (x+w) p2 (x+w+1) "red"
335 draw_first_second = False
337 --draw_first_second = True
339 -- constrain that Ports is at least Int units above the topmost portion of Diagram
340 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
341 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
342 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
343 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
344 constrainTop v i (DiagramBox wid ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
345 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
346 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
348 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
349 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
350 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
351 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
352 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
353 constrainBot (DiagramBox wid ptop pin r pout pbot) i v = constrain v GT pbot i
354 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
355 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
357 -- | The width of a box is easy to calculate
358 width :: TrackPositions -> Diagram -> Float
359 width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
360 width m (DiagramBox wid ptop pin x pout pbot) = wid
361 width m (DiagramBypassTop p d) = (width m d) + (if draw_first_second then 2 else 0)
362 width m (DiagramBypassBot d p) = (width m d) + (if draw_first_second then 2 else 0)
363 width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
364 width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
366 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
367 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
368 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
369 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
370 drawWires tp _ _ _ _ _ = error "drawwires fail"
372 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
373 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
374 wirecos tp (T a) = [(tp!a,True)]
375 wirecos tp (TU a) = [(tp!a,False)]
377 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
378 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
380 color = if b then "black" else "gray!50"
381 style = if b then "-" else "dashed"
382 x' = x - (y - y1) - loopgap
384 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
386 color = if b then "black" else "gray!50"
387 style = if b then "-" else "dashed"
388 x' = x + (y - y1) + loopgap
390 tikZ :: TrackPositions ->
392 Float -> -- horizontal position
396 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
397 ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
398 ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
399 ++ tikZ' d2 (x + width m d1 + 1)
400 tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
401 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
403 let top = getTop d' in
404 let bot = getBot d' in
405 drawBox x top (x+width m d') bot "gray!50" "second"
406 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
408 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
409 ++ drawWires m x p (x+1+width m d+1) p "black"
410 tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
411 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
413 let top = getTop d' in
414 let bot = getBot d' in
415 drawBox x top (x+width m d') bot "gray!50" "first"
416 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
418 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
419 ++ drawWires m x p (x+1+width m d+1) p "black"
420 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
421 let bot = getBot d' in
422 let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
423 drawBox x top (x+width m d') bot "gray!50" "loopl"
425 ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
426 ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
427 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
428 in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
429 ++ let p' = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
430 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
431 in concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
432 ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
433 in drawWires m x rest (x+1+gap) rest "black"
434 ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
435 in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
436 tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
437 tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
439 wires x1 t x2 c = wires' x1 t x2 c "-"
441 wires' :: Float -> Tracks -> Float -> String -> String -> String
442 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
443 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"
444 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
446 getTop :: Diagram -> Float
447 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
448 getTop (DiagramBox wid ptop _ _ _ _) = m ! ptop
449 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
450 getTop (DiagramBypassBot d p) = getTop d - 1
451 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
452 getTop (DiagramLoopBot d p) = getTop d - 1
454 getBot :: Diagram -> Float
455 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
456 getBot (DiagramBox wid _ _ _ _ pbot) = m ! pbot
457 getBot (DiagramBypassTop p d) = getBot d + 1
458 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
459 getBot (DiagramLoopTop p d) = getBot d + 1
460 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
462 -- allocates multiple tracks, adding constraints that they are at least one unit apart
463 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
464 alloc shape = do { tracks <- alloc' shape
467 ; constrain ptop LT (uppermost tracks) (-1)
468 ; constrain pbot GT (lowermost tracks) 1
469 ; return (ptop,tracks,pbot)
472 alloc' :: PortShape a -> ConstraintM Tracks
473 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
474 alloc' (PortFree _) = do { x <- alloc1 ; return x }
475 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
477 ; constrain (lowermost x1) LT (uppermost x2) (-1)
481 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
483 allocLoop :: Tracks -> ConstraintM Tracks
484 allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
485 allocLoop (T _) = do { x <- alloc1 ; return x }
486 allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
488 ; constrain (lowermost x1) LT (uppermost x2) (-1)
492 do_lp_solve :: [Constraint] -> IO String
493 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
495 ; stdout <- readProcess "lp_solve" [] stdin
499 splitWs :: String -> [String]
500 splitWs s = splitWs' "" s
503 splitWs' acc [] = [acc]
504 splitWs' [] (' ':k) = splitWs' [] k
505 splitWs' acc (' ':k) = acc:(splitWs' [] k)
506 splitWs' acc (x:k) = splitWs' (acc++[x]) k
508 lp_solve_to_trackpos :: String -> TrackPositions
509 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
511 grab ('x':k) = Just k
513 parse :: String -> (Int,Float)
514 parse s = case splitWs s of
515 [a,b] -> (read a, read b)
516 _ -> error "parse: should not happen"
517 toTrackPos :: [(Int,Float)] -> TrackPositions
518 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
519 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
522 toTikZ :: (ToDiagram m, Detect m) => GArrowSkeleton m a b -> IO String
524 let cm = do { let g' = detectShape g
528 in do { let (_,constraints) = execState cm (0,[])
529 ; lps <- do_lp_solve $ constraints
530 ; let m = lp_solve_to_trackpos lps
531 ; let d = evalState cm (0,[])
533 ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
534 ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
538 "\\documentclass{article}\n" ++
539 "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}\n" ++
540 "\\usepackage{tikz}\n" ++
541 "\\usepackage{amsmath}\n" ++
542 "\\usepackage[tightpage,active]{preview}\n" ++
543 "\\begin{document}\n" ++
544 "\\setlength\\PreviewBorder{5pt}\n" ++
545 "\\begin{preview}\n" ++
546 "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]\n"
549 "\\end{tikzpicture}\n" ++
550 "\\end{preview}\n" ++
554 do putStrLn tikz_header
555 tikz <- toTikZ example
559 -- Random TikZ routines
560 textc x y text color =
561 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
562 "{{\\tt{"++text++"}}};\n"
564 drawBox x1 y1 x2 y2 color text =
565 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
566 "{{\\tt{"++text++"}}};\n"
568 "\\path[draw,color="++color++"]"++
569 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
570 show (x2*xscale)++","++show (y2*yscale)++");\n"
572 drawBoxC x1 y1 x2 y2 color text =
573 "\\node[anchor=center] at ("++show ((x1+x2)*xscale/2)++"cm,"++show ((y1+y2)*yscale/2)++"cm) "++
574 "{{\\tt{"++text++"}}};\n"
576 "\\path[draw,color="++color++"]"++
577 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
578 show (x2*xscale)++","++show (y2*yscale)++");\n"
580 drawLine x1 y1 x2 y2 color style =
581 "\\path[draw,color="++color++","++style++"] "++
582 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
583 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
585 drawLine' [] color style = ""
586 drawLine' (xy1:xy) color style =
587 "\\path[draw,color="++color++","++style++"] "++
588 foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
591 f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
593 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
596 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
599 -- | extra gap placed between loopback wires and the contents of the loop module