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