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 Float 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 wid 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 wid 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
115 noRender :: BoxRenderer
116 noRender _ _ _ _ _ = ""
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)] "gray!50" }
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 2 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 2 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 2 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 2 top x r (TT x y) bot }
207 mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp
208 ; (_, y ,_) <- alloc outp
210 ; simpleDiag "drop" top x y bot [] }
211 mkdiag' (GAS_const i) = do { (top, x ,bot) <- alloc inp
212 ; (_, y ,_) <- alloc outp
214 ; simpleDiag ("const " ++ show i) top x y bot [] }
215 mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
216 ; (_ , x ,_) <- alloc inp
217 ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
218 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
219 drawWires tp x1 x ((x1+x2)/2) x "black" ++
220 drawWires tp ((x1+x2)/2) x x2 y "black" ++
221 drawWires tp ((x1+x2)/2) x x2 z "black"
222 ; return $ DiagramBox 2 top x r (TT y z) bot
224 mkdiag' GAS_merge = do { (top,(TT x y),bot) <- alloc inp
225 ; simpleDiag "times" top (TT x y) x bot [] }
226 mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
227 ; (top,(TT x' y'),bot) <- alloc outp
228 ; constrainEq (T (lowermost x)) (T (lowermost x'))
229 ; constrainEq (T (uppermost y)) (T (uppermost y'))
230 ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
232 do { (top,(TT (TT x y) z),bot) <- alloc inp
233 ; let r tp x1 y1 x2 y2
234 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
235 drawLine x1 y1 x2 y1 "gray!50" "-" ++
236 drawLine x1 y2 x2 y2 "gray!50" "-" ++
237 drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
238 drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
239 drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
240 drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
241 drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
242 drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
243 drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
244 drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
245 drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
246 drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
247 drawWires tp x1 x x2 x "black" ++
248 drawWires tp x1 y x2 y "black" ++
249 drawWires tp x1 z x2 z "black"
250 ; let pin = (TT (TT x y) z)
251 ; let pout = (TT x (TT y z))
252 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
254 mkdiag' GAS_unassoc =
255 do { (top,(TT x (TT 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" "unassoc" ++
258 drawLine x1 y1 x2 y1 "gray!50" "-" ++
259 drawLine x1 y2 x2 y2 "gray!50" "-" ++
260 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
261 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
262 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
263 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
264 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
265 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
266 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
267 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
268 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
269 drawLine x1 ((tp ! uppermost y) - 0.5) x1 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 x (TT y z))
274 ; let pout = (TT (TT x y) z)
275 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
277 mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
278 ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
279 ; constrainTop (lowermost l) loopgap f'
280 ; return $ DiagramLoopTop l f' }
281 mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
282 ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
283 ; constrainBot f' loopgap (uppermost l)
284 ; return $ DiagramLoopBot f' l }
285 mkdiag' (GAS_misc f ) = mkdiag f
287 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
288 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
289 ; constrain pbot GT (lowermost pin) 1
290 ; constrain ptop LT (uppermost pout) (-1)
291 ; constrain pbot GT (lowermost pout) 1
292 ; constrain ptop LT pbot (-1)
293 ; return $ DiagramBox 2 ptop pin r pout pbot
295 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
296 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
298 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
299 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
300 -- ++ wires (x-1) p1 x "green"
301 -- ++ wires (x+w) p2 (x+w+1) "red"
304 --draw_first_second = False
306 draw_first_second = True
308 -- constrain that Ports is at least Int units above the topmost portion of Diagram
309 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
310 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
311 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
312 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
313 constrainTop v i (DiagramBox wid ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
314 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
315 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
317 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
318 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
319 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
320 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
321 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
322 constrainBot (DiagramBox wid ptop pin r pout pbot) i v = constrain v GT pbot i
323 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
324 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
326 -- | The width of a box is easy to calculate
327 width :: TrackPositions -> Diagram -> Float
328 width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
329 width m (DiagramBox wid ptop pin x pout pbot) = wid
330 width m (DiagramBypassTop p d) = (width m d) + (if draw_first_second then 2 else 0)
331 width m (DiagramBypassBot d p) = (width m d) + (if draw_first_second then 2 else 0)
332 width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
333 width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
335 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
336 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
337 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
338 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
339 drawWires tp _ _ _ _ _ = error "drawwires fail"
341 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
342 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
343 wirecos tp (T a) = [(tp!a,True)]
344 wirecos tp (TU a) = [(tp!a,False)]
346 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
347 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
349 color = if b then "black" else "gray!50"
350 style = if b then "-" else "dashed"
351 x' = x - (y - y1) - loopgap
353 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
355 color = if b then "black" else "gray!50"
356 style = if b then "-" else "dashed"
357 x' = x + (y - y1) + loopgap
359 tikZ :: TrackPositions ->
361 Float -> -- horizontal position
365 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
366 ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
367 ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
368 ++ tikZ' d2 (x + width m d1 + 1)
369 tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
370 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
372 let top = getTop d' in
373 let bot = getBot d' in
374 drawBox x top (x+width m d') bot "gray!50" "second"
375 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
377 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
378 ++ drawWires m x p (x+1+width m d+1) p "black"
379 tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
380 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
382 let top = getTop d' in
383 let bot = getBot d' in
384 drawBox x top (x+width m d') bot "gray!50" "first"
385 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
387 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
388 ++ drawWires m x p (x+1+width m d+1) p "black"
389 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
390 let bot = getBot d' in
391 let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
392 drawBox x top (x+width m d') bot "gray!50" "loopl"
394 ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
395 ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
396 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
397 in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
398 ++ let p' = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
399 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
400 in concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
401 ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
402 in drawWires m x rest (x+1+gap) rest "black"
403 ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
404 in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
405 tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
406 tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
408 wires x1 t x2 c = wires' x1 t x2 c "-"
410 wires' :: Float -> Tracks -> Float -> String -> String -> String
411 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
412 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"
413 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
415 getTop :: Diagram -> Float
416 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
417 getTop (DiagramBox wid ptop _ _ _ _) = m ! ptop
418 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
419 getTop (DiagramBypassBot d p) = getTop d - 1
420 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
421 getTop (DiagramLoopBot d p) = getTop d - 1
423 getBot :: Diagram -> Float
424 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
425 getBot (DiagramBox wid _ _ _ _ pbot) = m ! pbot
426 getBot (DiagramBypassTop p d) = getBot d + 1
427 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
428 getBot (DiagramLoopTop p d) = getBot d + 1
429 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
431 -- allocates multiple tracks, adding constraints that they are at least one unit apart
432 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
433 alloc shape = do { tracks <- alloc' shape
436 ; constrain ptop LT (uppermost tracks) (-1)
437 ; constrain pbot GT (lowermost tracks) 1
438 ; return (ptop,tracks,pbot)
441 alloc' :: PortShape a -> ConstraintM Tracks
442 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
443 alloc' (PortFree _) = do { x <- alloc1 ; return x }
444 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
446 ; constrain (lowermost x1) LT (uppermost x2) (-1)
450 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
452 allocLoop :: Tracks -> ConstraintM Tracks
453 allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
454 allocLoop (T _) = do { x <- alloc1 ; return x }
455 allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
457 ; constrain (lowermost x1) LT (uppermost x2) (-1)
461 do_lp_solve :: [Constraint] -> IO String
462 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
464 ; stdout <- readProcess "lp_solve" [] stdin
468 splitWs :: String -> [String]
469 splitWs s = splitWs' "" s
472 splitWs' acc [] = [acc]
473 splitWs' [] (' ':k) = splitWs' [] k
474 splitWs' acc (' ':k) = acc:(splitWs' [] k)
475 splitWs' acc (x:k) = splitWs' (acc++[x]) k
477 lp_solve_to_trackpos :: String -> TrackPositions
478 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
480 grab ('x':k) = Just k
482 parse :: String -> (Int,Float)
483 parse s = case splitWs s of
484 [a,b] -> (read a, read b)
485 _ -> error "parse: should not happen"
486 toTrackPos :: [(Int,Float)] -> TrackPositions
487 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
488 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
490 toTikZ :: GArrowSkeleton m a b -> IO String
492 let cm = do { let g' = detectShape g
496 in do { let (_,constraints) = execState cm (0,[])
497 ; lps <- do_lp_solve $ constraints
498 ; let m = lp_solve_to_trackpos lps
499 ; let d = evalState cm (0,[])
501 ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
502 ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
508 (Int -> PGArrow g (GArrowUnit g) Int) ->
509 (PGArrow g (GArrowTensor g c c) c) ->
512 tikz x = tikz' $ beautify $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }))
515 = do putStrLn "\\documentclass{article}"
516 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
517 putStrLn "\\usepackage{tikz}"
518 putStrLn "\\usepackage{amsmath}"
519 putStrLn "\\usepackage[tightpage,active]{preview}"
520 putStrLn "\\begin{document}"
521 putStrLn "\\setlength\\PreviewBorder{5pt}"
522 putStrLn "\\begin{preview}"
523 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
524 tikz <- toTikZ example
526 putStrLn "\\end{tikzpicture}"
527 putStrLn "\\end{preview}"
528 --putStrLn "\\pagebreak"
529 --putStrLn "\\begin{align*}"
530 --putStr (toTikZ' example)
531 --putStrLn "\\end{align*}"
532 putStrLn "\\end{document}"
534 -- Random TikZ routines
535 textc x y text color =
536 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
537 "{{\\tt{"++text++"}}};\n"
539 drawBox x1 y1 x2 y2 color text =
540 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
541 "{{\\tt{"++text++"}}};\n"
543 "\\path[draw,color="++color++"]"++
544 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
545 show (x2*xscale)++","++show (y2*yscale)++");\n"
547 drawLine x1 y1 x2 y2 color style =
548 "\\path[draw,color="++color++","++style++"] "++
549 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
550 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
552 drawLine' [] color style = ""
553 drawLine' (xy1:xy) color style =
554 "\\path[draw,color="++color++","++style++"] "++
555 foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
558 f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
560 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
563 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
566 -- | extra gap placed between loopback wires and the contents of the loop module