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 ; 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 2 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 ; let pin = (TT (TT x y) z)
248 ; let pout = (TT x (TT y z))
249 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
251 mkdiag' GAS_unassoc =
252 do { (top,(TT x (TT y z)),bot) <- alloc inp
253 ; let r tp x1 y1 x2 y2
254 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
255 drawLine x1 y1 x2 y1 "gray!50" "-" ++
256 drawLine x1 y2 x2 y2 "gray!50" "-" ++
257 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
258 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
259 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
260 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
261 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
262 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
263 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
264 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
265 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
266 drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
267 drawWires tp x1 x x2 x "black" ++
268 drawWires tp x1 y x2 y "black" ++
269 drawWires tp x1 z x2 z "black"
270 ; let pin = (TT x (TT y z))
271 ; let pout = (TT (TT x y) z)
272 ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
274 mkdiag' (GAS_loopl f) = do { f' <- mkdiag' f
275 ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
276 ; constrainTop (lowermost l) loopgap f'
277 ; return $ DiagramLoopTop l f' }
278 mkdiag' (GAS_loopr f) = do { f' <- mkdiag' f
279 ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
280 ; constrainBot f' loopgap (uppermost l)
281 ; return $ DiagramLoopBot f' l }
282 mkdiag' (GAS_misc f ) = mkdiag f
284 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
285 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
286 ; constrain pbot GT (lowermost pin) 1
287 ; constrain ptop LT (uppermost pout) (-1)
288 ; constrain pbot GT (lowermost pout) 1
289 ; constrain ptop LT pbot (-1)
290 ; return $ DiagramBox 2 ptop pin r pout pbot
292 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
293 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
295 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
296 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
297 -- ++ wires (x-1) p1 x "green"
298 -- ++ wires (x+w) p2 (x+w+1) "red"
301 --draw_first_second = False
303 draw_first_second = True
305 -- constrain that Ports is at least Int units above the topmost portion of Diagram
306 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
307 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
308 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
309 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
310 constrainTop v i (DiagramBox wid ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
311 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
312 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
314 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
315 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
316 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
317 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
318 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
319 constrainBot (DiagramBox wid ptop pin r pout pbot) i v = constrain v GT pbot i
320 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
321 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
323 -- | The width of a box is easy to calculate
324 width :: TrackPositions -> Diagram -> Float
325 width m (DiagramComp d1 d2) = (width m d1) + 1 + (width m d2)
326 width m (DiagramBox wid ptop pin x pout pbot) = wid
327 width m (DiagramBypassTop p d) = (width m d) + (if draw_first_second then 2 else 0)
328 width m (DiagramBypassBot d p) = (width m d) + (if draw_first_second then 2 else 0)
329 width m (DiagramLoopTop p d) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
330 width m (DiagramLoopBot d p) = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
332 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
333 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
334 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
335 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
336 drawWires tp _ _ _ _ _ = error "drawwires fail"
338 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
339 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
340 wirecos tp (T a) = [(tp!a,True)]
341 wirecos tp (TU a) = [(tp!a,False)]
343 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
344 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
346 color = if b then "black" else "gray!50"
347 style = if b then "-" else "dashed"
348 x' = x - (y - y1) - loopgap
350 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
352 color = if b then "black" else "gray!50"
353 style = if b then "-" else "dashed"
354 x' = x + (y - y1) + loopgap
356 tikZ :: TrackPositions ->
358 Float -> -- horizontal position
362 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
363 ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
364 ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
365 ++ tikZ' d2 (x + width m d1 + 1)
366 tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
367 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
369 let top = getTop d' in
370 let bot = getBot d' in
371 drawBox x top (x+width m d') bot "gray!50" "second"
372 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
374 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
375 ++ drawWires m x p (x+1+width m d+1) p "black"
376 tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
377 then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
379 let top = getTop d' in
380 let bot = getBot d' in
381 drawBox x top (x+width m d') bot "gray!50" "first"
382 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
384 ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
385 ++ drawWires m x p (x+1+width m d+1) p "black"
386 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
387 let bot = getBot d' in
388 let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
389 drawBox x top (x+width m d') bot "gray!50" "loopl"
391 ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
392 ++ let p' = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
393 pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
394 in concatMap (wire90 (x+1+gap) (m ! lowermost p)) pzip
395 ++ let p' = case getOut 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+width m d) (m ! lowermost p)) pzip
398 ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
399 in drawWires m x rest (x+1+gap) rest "black"
400 ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
401 in drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
402 tikZ' d'@(DiagramLoopBot d p) x_ = error "not implemented"
403 tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
405 wires x1 t x2 c = wires' x1 t x2 c "-"
407 wires' :: Float -> Tracks -> Float -> String -> String -> String
408 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
409 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"
410 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
412 getTop :: Diagram -> Float
413 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
414 getTop (DiagramBox wid ptop _ _ _ _) = m ! ptop
415 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
416 getTop (DiagramBypassBot d p) = getTop d - 1
417 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
418 getTop (DiagramLoopBot d p) = getTop d - 1
420 getBot :: Diagram -> Float
421 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
422 getBot (DiagramBox wid _ _ _ _ pbot) = m ! pbot
423 getBot (DiagramBypassTop p d) = getBot d + 1
424 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
425 getBot (DiagramLoopTop p d) = getBot d + 1
426 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
428 -- allocates multiple tracks, adding constraints that they are at least one unit apart
429 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
430 alloc shape = do { tracks <- alloc' shape
433 ; constrain ptop LT (uppermost tracks) (-1)
434 ; constrain pbot GT (lowermost tracks) 1
435 ; return (ptop,tracks,pbot)
438 alloc' :: PortShape a -> ConstraintM Tracks
439 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
440 alloc' (PortFree _) = do { x <- alloc1 ; return x }
441 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
443 ; constrain (lowermost x1) LT (uppermost x2) (-1)
447 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
449 allocLoop :: Tracks -> ConstraintM Tracks
450 allocLoop (TU _) = do { T x <- alloc1 ; return (TU x) }
451 allocLoop (T _) = do { x <- alloc1 ; return x }
452 allocLoop (TT t1 t2) = do { x1 <- allocLoop t2
454 ; constrain (lowermost x1) LT (uppermost x2) (-1)
458 do_lp_solve :: [Constraint] -> IO String
459 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
461 ; stdout <- readProcess "lp_solve" [] stdin
465 splitWs :: String -> [String]
466 splitWs s = splitWs' "" s
469 splitWs' acc [] = [acc]
470 splitWs' [] (' ':k) = splitWs' [] k
471 splitWs' acc (' ':k) = acc:(splitWs' [] k)
472 splitWs' acc (x:k) = splitWs' (acc++[x]) k
474 lp_solve_to_trackpos :: String -> TrackPositions
475 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
477 grab ('x':k) = Just k
479 parse :: String -> (Int,Float)
480 parse s = case splitWs s of
481 [a,b] -> (read a, read b)
482 _ -> error "parse: should not happen"
483 toTrackPos :: [(Int,Float)] -> TrackPositions
484 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
485 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
487 toTikZ :: GArrowSkeleton m a b -> IO String
489 let cm = do { let g' = detectShape g
493 in do { let (_,constraints) = execState cm (0,[])
494 ; lps <- do_lp_solve $ constraints
495 ; let m = lp_solve_to_trackpos lps
496 ; let d = evalState cm (0,[])
498 ; return (t ++ drawWires m 0 (getIn d) 1 (getIn d) "black"
499 ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
505 (Int -> PGArrow g (GArrowUnit g) Int) ->
506 (PGArrow g (GArrowTensor g c c) c) ->
509 tikz x = tikz' $ beautify $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }))
512 = do putStrLn "\\documentclass{article}"
513 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
514 putStrLn "\\usepackage{tikz}"
515 putStrLn "\\usepackage{amsmath}"
516 putStrLn "\\usepackage[tightpage,active]{preview}"
517 putStrLn "\\begin{document}"
518 putStrLn "\\setlength\\PreviewBorder{5pt}"
519 putStrLn "\\begin{preview}"
520 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
521 tikz <- toTikZ example
523 putStrLn "\\end{tikzpicture}"
524 putStrLn "\\end{preview}"
525 --putStrLn "\\pagebreak"
526 --putStrLn "\\begin{align*}"
527 --putStr (toTikZ' example)
528 --putStrLn "\\end{align*}"
529 putStrLn "\\end{document}"
531 -- Random TikZ routines
532 textc x y text color =
533 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
534 "{{\\tt{"++text++"}}};\n"
536 drawBox x1 y1 x2 y2 color text =
537 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
538 "{{\\tt{"++text++"}}};\n"
540 "\\path[draw,color="++color++"]"++
541 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
542 show (x2*xscale)++","++show (y2*yscale)++");\n"
544 drawLine x1 y1 x2 y2 color style =
545 "\\path[draw,color="++color++","++style++"] "++
546 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
547 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
549 drawLine' [] color style = ""
550 drawLine' (xy1:xy) color style =
551 "\\path[draw,color="++color++","++style++"] "++
552 foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
555 f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
557 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
560 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
563 -- | extra gap placed between loopback wires and the contents of the loop module