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
21 import GHC.HetMet.GArrow
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
75 ------------------------------------------------------------------------------
78 -- | A Diagram is the visual representation of a GArrowSkeleton
80 = DiagramComp Diagram Diagram
81 | DiagramBox TrackIdentifier Tracks BoxRenderer Tracks TrackIdentifier
82 | DiagramBypassTop Tracks Diagram
83 | DiagramBypassBot Diagram Tracks
84 | DiagramLoopTop Tracks Diagram
85 | DiagramLoopBot Diagram Tracks
87 -- | get the output tracks of a diagram
88 getOut :: Diagram -> Tracks
89 getOut (DiagramComp f g) = getOut g
90 getOut (DiagramBox ptop pin q pout pbot) = pout
91 getOut (DiagramBypassTop p f) = TT p (getOut f)
92 getOut (DiagramBypassBot f p) = TT (getOut f) p
93 getOut (DiagramLoopTop t d) = case getOut d of { TT z y -> y ; _ -> error "DiagramLoopTop: mismatch" }
94 getOut (DiagramLoopBot d t) = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
96 -- | get the input tracks of a diagram
97 getIn :: Diagram -> Tracks
98 getIn (DiagramComp f g) = getIn f
99 getIn (DiagramBox ptop pin q pout pbot) = pin
100 getIn (DiagramBypassTop p f) = TT p (getIn f)
101 getIn (DiagramBypassBot f p) = TT (getIn f) p
102 getIn (DiagramLoopTop t d) = case getIn d of { TT z x -> x ; _ -> error "DiagramLoopTop: mismatch" }
103 getIn (DiagramLoopBot d t) = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: mismatch" }
105 -- | A BoxRenderer is just a routine that, given the dimensions of a
106 -- boxes-and-wires box element, knows how to spit out a bunch of TikZ
107 -- code that draws it
109 TrackPositions -> -- resolves the TrackIdentifiers to actual y-coordinates
121 ------------------------------------------------------------------------------
124 -- | a constraint (to be dealt with by lp_solve) relates two track identifiers
125 data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
126 | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
128 -- instance Show Constraint where
129 -- show (C t1 LT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
130 -- show (C t1 GT t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
131 -- show (C t1 EQ t2 k s) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
133 instance Show Constraint where
134 show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
135 show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
136 show (C t1 EQ t2 k) = "x"++(show t1)++" = x"++(show t2)++" + "++(show k) ++ ";\n"
137 show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
138 " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
140 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
141 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
143 -- | pull the constraints out of the monad
144 getConstraints :: ConstraintM [Constraint]
145 getConstraints = do { (_,c) <- get ; return c }
147 -- | add a constraint
148 constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
149 constrain t1 ord t2 k = do { (t,c) <- get
150 ; put (t, (C t1 ord t2 k):c)
154 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
155 ; put (t, (EqualSpace t1a t1b t2a t2b):c)
159 -- | simple form for equality constraints
160 constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
161 constrainEq (T t1 ) (T t2 ) = constrain t1 EQ t2 0
162 constrainEq (TU t1 ) (TU t2 ) = constrain t1 EQ t2 0
163 constrainEq (TU t1 ) (T t2 ) = constrain t1 EQ t2 0
164 constrainEq (T t1 ) (TU t2 ) = constrain t1 EQ t2 0
165 constrainEq t1 t2 = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
167 -- | allocate a TrackIdentifier
168 alloc1 :: ConstraintM Tracks
169 alloc1 = do { (t,c) <- get
174 mkdiag :: GArrowPortShape m () a b -> ConstraintM Diagram
175 mkdiag (GASPortPassthrough inp outp m) = error "not supported"
176 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
178 mkdiag' :: GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
180 mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
181 ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
182 mkdiag' (GAS_first f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
183 ; return $ DiagramBypassBot f' x }
184 mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
185 ; return $ DiagramBypassTop x f' }
186 mkdiag' (GAS_id ) = do { (top, x ,bot) <- alloc inp ; simpleDiag "id" top x x bot [(x,x)] }
187 mkdiag' GAS_cancell = do { (top,(TT x y),bot) <- alloc inp
188 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
189 drawWires tp x1 y x2 y "black" ++
190 drawLine x1 (tp!lowermost x) ((x1+x2)/2) (tp!uppermost y) "gray!50" "dashed"
191 ; return $ DiagramBox top (TT x y) r y bot }
192 mkdiag' GAS_cancelr = do { (top,(TT x y),bot) <- alloc inp
193 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
194 drawWires tp x1 x x2 x "black" ++
195 drawLine x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "gray!50" "dashed"
196 ; return $ DiagramBox top (TT x y) r x bot }
197 mkdiag' GAS_uncancell = do { (top,(TT x y),bot) <- alloc outp
198 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
199 drawWires tp x1 y x2 y "black" ++
200 drawLine ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "gray!50" "dashed"
201 ; return $ DiagramBox top y r (TT x y) bot }
202 mkdiag' GAS_uncancelr = do { (top,(TT x y),bot) <- alloc outp
203 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
204 drawWires tp x1 x x2 x "black" ++
205 drawLine ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "gray!50" "dashed"
206 ; return $ DiagramBox top x r (TT x y) bot }
207 mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp ; simpleDiag "drop" top x x bot [] }
208 mkdiag' (GAS_const i) = do { (top, x ,bot) <- alloc inp
209 ; (_, y ,_) <- alloc outp
211 ; simpleDiag ("const " ++ show i) top x y bot [] }
212 mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
213 ; (_ , x ,_) <- alloc inp
214 ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
215 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
216 drawWires tp x1 x ((x1+x2)/2) x "black" ++
217 drawWires tp ((x1+x2)/2) x x2 y "black" ++
218 drawWires tp ((x1+x2)/2) x x2 z "black"
219 ; return $ DiagramBox top x r (TT y z) bot
221 mkdiag' GAS_merge = do { (top,(TT x y),bot) <- alloc inp
222 ; simpleDiag "times" top (TT x y) x bot [] }
223 mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
224 ; (top,(TT x' y'),bot) <- alloc outp
225 ; constrainEq (T (lowermost x)) (T (lowermost x'))
226 ; constrainEq (T (uppermost y)) (T (uppermost y'))
227 ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
229 do { (top,(TT (TT x y) z),bot) <- alloc inp
230 ; let r tp x1 y1 x2 y2
231 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
232 drawLine x1 y1 x2 y1 "gray!50" "-" ++
233 drawLine x1 y2 x2 y2 "gray!50" "-" ++
234 drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
235 drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
236 drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
237 drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
238 drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
239 drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
240 drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
241 drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
242 drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
243 drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
244 drawWires tp x1 x x2 x "black" ++
245 drawWires tp x1 y x2 y "black" ++
246 drawWires tp x1 z x2 z "black"
247 ; return $ DiagramBox top (TT (TT x y) z) r (TT x (TT y z)) bot
249 mkdiag' GAS_unassoc =
250 do { (top,(TT x (TT y z)),bot) <- alloc inp
251 ; let r tp x1 y1 x2 y2
252 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
253 drawLine x1 y1 x2 y1 "gray!50" "-" ++
254 drawLine x1 y2 x2 y2 "gray!50" "-" ++
255 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
256 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
257 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
258 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
259 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
260 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
261 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
262 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
263 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
264 drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
265 drawWires tp x1 x x2 x "black" ++
266 drawWires tp x1 y x2 y "black" ++
267 drawWires tp x1 z x2 z "black"
268 ; return $ DiagramBox top (TT x (TT y z)) r (TT (TT x y) z) bot
270 mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
271 ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
272 ; constrainTop (lowermost l) loopgap f'
273 ; return $ DiagramLoopTop l f' }
274 mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
275 ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
276 ; constrainBot f' loopgap (uppermost l)
277 ; return $ DiagramLoopBot f' l }
278 mkdiag' (GAS_misc f ) = mkdiag f
280 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
281 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
282 ; constrain pbot GT (lowermost pin) 1
283 ; constrain ptop LT (uppermost pout) (-1)
284 ; constrain pbot GT (lowermost pout) 1
285 ; constrain ptop LT pbot (-1)
286 ; return $ DiagramBox ptop pin r pout pbot
288 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
289 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
291 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
292 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
293 -- ++ wires (x-1) p1 x "green"
294 -- ++ wires (x+w) p2 (x+w+1) "red"
296 -- constrain that Ports is at least Int units above the topmost portion of Diagram
297 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
298 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
299 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
300 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
301 constrainTop v i (DiagramBox ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
302 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
303 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
305 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
306 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
307 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
308 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
309 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
310 constrainBot (DiagramBox ptop pin r pout pbot) i v = constrain v GT pbot i
311 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
312 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
314 -- | The width of a box is easy to calculate
315 width :: TrackPositions -> Diagram -> Float
316 width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
317 width m (DiagramBox ptop pin x pout pbot) = 2
318 width m (DiagramBypassTop p d) = (width m d) + 2
319 width m (DiagramBypassBot d p) = (width m d) + 2
320 width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
321 width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
323 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
324 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
325 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
326 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
327 drawWires tp _ _ _ _ _ = error "drawwires fail"
329 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
330 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
331 wirecos tp (T a) = [(tp!a,True)]
332 wirecos tp (TU a) = [(tp!a,False)]
334 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
335 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
337 color = if b then "black" else "gray!50"
338 style = if b then "-" else "dashed"
339 x' = x - (y - y1) - loopgap
341 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
343 color = if b then "black" else "gray!50"
344 style = if b then "-" else "dashed"
345 x' = x + (y - y1) + loopgap
347 tikZ :: TrackPositions ->
349 Float -> -- horizontal position
353 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
354 ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
355 ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
356 ++ tikZ' d2 (x + width m d1 + 1)
357 tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
358 let bot = getBot d' in
359 drawBox x top (x+width m d') bot "gray!50" "second"
360 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
362 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
363 ++ drawWires m x p (x+1+width m d+1) p "black"
364 tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
365 let bot = getBot d' in
366 drawBox x top (x+width m d') bot "gray!50" "first"
367 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
369 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
370 ++ drawWires m x p (x+1+width m d+1) p "black"
371 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
372 let bot = getBot d' in
373 let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
374 drawBox x top (x+width m d') bot "gray!50" "loopl"
376 ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
377 ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
378 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
379 in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
380 ++ let p' = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
381 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
382 in concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
383 ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
384 in drawWires m x rest (x+1+gap) rest "black"
385 ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
386 in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
387 tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
388 tikZ' d@(DiagramBox ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
390 wires x1 t x2 c = wires' x1 t x2 c "-"
392 wires' :: Float -> Tracks -> Float -> String -> String -> String
393 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
394 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"
395 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
397 getTop :: Diagram -> Float
398 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
399 getTop (DiagramBox ptop _ _ _ _) = m ! ptop
400 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
401 getTop (DiagramBypassBot d p) = getTop d - 1
402 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
403 getTop (DiagramLoopBot d p) = getTop d - 1
405 getBot :: Diagram -> Float
406 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
407 getBot (DiagramBox _ _ _ _ pbot) = m ! pbot
408 getBot (DiagramBypassTop p d) = getBot d + 1
409 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
410 getBot (DiagramLoopTop p d) = getBot d + 1
411 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
413 -- allocates multiple tracks, adding constraints that they are at least one unit apart
414 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
415 alloc shape = do { tracks <- alloc' shape
418 ; constrain ptop LT (uppermost tracks) (-1)
419 ; constrain pbot GT (lowermost tracks) 1
420 ; return (ptop,tracks,pbot)
423 alloc' :: PortShape a -> ConstraintM Tracks
424 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
425 alloc' (PortFree _) = do { x <- alloc1 ; return x }
426 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
428 ; constrain (lowermost x1) LT (uppermost x2) (-1)
432 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
434 allocLoop :: Tracks -> ConstraintM Tracks
435 allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
436 allocLoop (T _) = do { x <- alloc1 ; return x }
437 allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
439 ; constrain (lowermost x1) LT (uppermost x2) (-1)
443 do_lp_solve :: [Constraint] -> IO String
444 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
446 ; stdout <- readProcess "lp_solve" [] stdin
450 splitWs :: String -> [String]
451 splitWs s = splitWs' "" s
454 splitWs' acc [] = [acc]
455 splitWs' [] (' ':k) = splitWs' [] k
456 splitWs' acc (' ':k) = acc:(splitWs' [] k)
457 splitWs' acc (x:k) = splitWs' (acc++[x]) k
459 lp_solve_to_trackpos :: String -> TrackPositions
460 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
462 grab ('x':k) = Just k
464 parse :: String -> (Int,Float)
465 parse s = case splitWs s of
466 [a,b] -> (read a, read b)
467 _ -> error "parse: should not happen"
468 toTrackPos :: [(Int,Float)] -> TrackPositions
469 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
470 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
472 toTikZ :: GArrowSkeleton m a b -> IO String
474 let cm = do { let g' = detectShape g
478 in do { let (_,constraints) = execState cm (0,[])
479 ; lps <- do_lp_solve $ constraints
480 ; let m = lp_solve_to_trackpos lps
481 ; let d = evalState cm (0,[])
483 ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
484 ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
490 (Int -> PGArrow g (GArrowUnit g) Int) ->
491 (PGArrow g (GArrowTensor g c c) c) ->
494 tikz x = tikz' $ beautify $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }))
497 = do putStrLn "\\documentclass{article}"
498 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
499 putStrLn "\\usepackage{tikz}"
500 putStrLn "\\usepackage{amsmath}"
501 putStrLn "\\usepackage[tightpage,active]{preview}"
502 putStrLn "\\begin{document}"
503 putStrLn "\\setlength\\PreviewBorder{5pt}"
504 putStrLn "\\begin{preview}"
505 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
506 tikz <- toTikZ example
508 putStrLn "\\end{tikzpicture}"
509 putStrLn "\\end{preview}"
510 --putStrLn "\\pagebreak"
511 --putStrLn "\\begin{align*}"
512 --putStr (toTikZ' example)
513 --putStrLn "\\end{align*}"
514 putStrLn "\\end{document}"
516 -- Random TikZ routines
517 textc x y text color =
518 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
519 "{{\\tt{"++text++"}}};\n"
521 drawBox x1 y1 x2 y2 color text =
522 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
523 "{{\\tt{"++text++"}}};\n"
525 "\\path[draw,color="++color++"]"++
526 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
527 show (x2*xscale)++","++show (y2*yscale)++");\n"
529 drawLine x1 y1 x2 y2 color style =
530 "\\path[draw,color="++color++","++style++"] "++
531 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
532 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
534 drawLine' [] color style = ""
535 drawLine' (xy1:xy) color style =
536 "\\path[draw,color="++color++","++style++"] "++
537 foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
540 f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
542 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
545 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
548 -- | extra gap placed between loopback wires and the contents of the loop module