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 "mismatch" }
94 getOut (DiagramLoopBot d t) = case getOut d of { TT y z -> y ; _ -> error "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 "mismatch" }
103 getIn (DiagramLoopBot d t) = case getIn d of { TT x z -> x ; _ -> error "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_loopr f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
271 ; return $ DiagramLoopBot f' x }
272 mkdiag' (GAS_loopl f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
273 ; return $ DiagramLoopTop x f' }
274 mkdiag' (GAS_misc f ) = mkdiag f
276 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
277 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
278 ; constrain pbot GT (lowermost pin) 1
279 ; constrain ptop LT (uppermost pout) (-1)
280 ; constrain pbot GT (lowermost pout) 1
281 ; constrain ptop LT pbot (-1)
282 ; return $ DiagramBox ptop pin r pout pbot
284 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
285 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
287 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
288 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
289 -- ++ wires (x-1) p1 x "green"
290 -- ++ wires (x+w) p2 (x+w+1) "red"
292 -- constrain that Ports is at least Int units above the topmost portion of Diagram
293 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
294 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
295 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
296 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
297 constrainTop v i (DiagramBox ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
298 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
299 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
301 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
302 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
303 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
304 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
305 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
306 constrainBot (DiagramBox ptop pin r pout pbot) i v = constrain v GT pbot i
307 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
308 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
310 -- | The width of a box is easy to calculate
311 width :: Diagram -> Float
312 width (DiagramComp d1 d2) = (width d1) + 1 + (width d2)
313 width (DiagramBox ptop pin x pout pbot) = 2
314 width (DiagramBypassTop p d) = (width d) + 2
315 width (DiagramBypassBot d p) = (width d) + 2
316 width (DiagramLoopTop p d) = (width d) + 2
317 width (DiagramLoopBot d p) = (width d) + 2
319 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
320 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
321 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
322 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
323 drawWires tp _ _ _ _ _ = error "drawwires fail"
325 tikZ :: TrackPositions ->
327 Float -> -- horizontal position
331 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
332 ++ wires' (x+width d1) (getOut d1) (x+width d1+0.5) "black" "->"
333 ++ wires' (x+width d1+0.5) (getOut d1) (x+width d1+1) "black" "-"
334 ++ tikZ' d2 (x + width d1 + 1)
335 tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
336 let bot = getBot d' in
337 drawBox x top (x+width m d') bot "gray!50" "second"
338 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
340 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
341 ++ drawWires m x p (x+1+width d+1) p "black"
342 tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
343 let bot = getBot d' in
344 drawBox x top (x+width m d') bot "gray!50" "first"
345 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
347 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
348 ++ drawWires m x p (x+1+width d+1) p "black"
349 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
350 let bot = getBot d' in
351 drawBox x top (x+width d') bot "gray!50" "loopl"
352 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
354 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
355 ++ drawWires m x p (x+1+width d+1) p "black"
356 tikZ' d'@(DiagramLoopBot d p) x = let top = getTop d' in
357 let bot = getBot d' in
358 drawBox x top (x+width d') bot "gray!50" "loopr"
359 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
361 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
362 ++ drawWires m x p (x+1+width d+1) p "black"
363 tikZ' d@(DiagramBox ptop pin r pout pbot) x = r m x (m ! ptop) (x + width d) (m ! pbot)
365 wires x1 t x2 c = wires' x1 t x2 c "-"
367 wires' :: Float -> Tracks -> Float -> String -> String -> String
368 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
369 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"
370 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
372 getTop :: Diagram -> Float
373 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
374 getTop (DiagramBox ptop _ _ _ _) = m ! ptop
375 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
376 getTop (DiagramBypassBot d p) = getTop d - 1
377 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
378 getTop (DiagramLoopBot d p) = getTop d - 1
380 getBot :: Diagram -> Float
381 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
382 getBot (DiagramBox _ _ _ _ pbot) = m ! pbot
383 getBot (DiagramBypassTop p d) = getBot d + 1
384 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
385 getBot (DiagramLoopTop p d) = getBot d + 1
386 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
388 -- allocates multiple tracks, adding constraints that they are at least one unit apart
389 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
390 alloc shape = do { tracks <- alloc' shape
393 ; constrain ptop LT (uppermost tracks) (-1)
394 ; constrain pbot GT (lowermost tracks) 1
395 ; return (ptop,tracks,pbot)
398 alloc' :: PortShape a -> ConstraintM Tracks
399 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
400 alloc' (PortFree _) = do { x <- alloc1 ; return x }
401 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
403 ; constrain (lowermost x1) LT (uppermost x2) (-1)
407 do_lp_solve :: [Constraint] -> IO String
408 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
410 ; stdout <- readProcess "lp_solve" [] stdin
414 splitWs :: String -> [String]
415 splitWs s = splitWs' "" s
418 splitWs' acc [] = [acc]
419 splitWs' [] (' ':k) = splitWs' [] k
420 splitWs' acc (' ':k) = acc:(splitWs' [] k)
421 splitWs' acc (x:k) = splitWs' (acc++[x]) k
423 lp_solve_to_trackpos :: String -> TrackPositions
424 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
426 grab ('x':k) = Just k
428 parse :: String -> (Int,Float)
429 parse s = case splitWs s of
430 [a,b] -> (read a, read b)
431 _ -> error "parse: should not happen"
432 toTrackPos :: [(Int,Float)] -> TrackPositions
433 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
434 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
436 toTikZ :: GArrowSkeleton m a b -> IO String
438 let cm = do { let g' = detectShape g
442 in do { let (_,constraints) = execState cm (0,[])
443 ; lps <- do_lp_solve $ constraints
444 ; let trackpos = lp_solve_to_trackpos lps
445 ; return $ tikZ trackpos (evalState cm (0,[])) 0
448 tikz :: (forall g a .
449 (Int -> PGArrow g (GArrowUnit g) a) ->
451 forall b . PGArrow g (GArrowTensor g b b) b) ->
452 PGArrow g (GArrowUnit g) a) -> IO ()
454 tikz x = tikz' $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }) )
457 = do putStrLn "\\documentclass{article}"
458 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
459 putStrLn "\\usepackage{tikz}"
460 putStrLn "\\usepackage{amsmath}"
461 putStrLn "\\usepackage[tightpage,active]{preview}"
462 putStrLn "\\begin{document}"
463 putStrLn "\\setlength\\PreviewBorder{5pt}"
464 putStrLn "\\begin{preview}"
465 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
466 tikz <- toTikZ example
468 putStrLn "\\end{tikzpicture}"
469 putStrLn "\\end{preview}"
470 --putStrLn "\\pagebreak"
471 --putStrLn "\\begin{align*}"
472 --putStr (toTikZ' example)
473 --putStrLn "\\end{align*}"
474 putStrLn "\\end{document}"
476 -- Random TikZ routines
477 textc x y text color =
478 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
479 "{{\\tt{"++text++"}}};\n"
481 drawBox x1 y1 x2 y2 color text =
482 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
483 "{{\\tt{"++text++"}}};\n"
485 "\\path[draw,color="++color++"]"++
486 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
487 show (x2*xscale)++","++show (y2*yscale)++");\n"
489 drawLine x1 y1 x2 y2 color style =
490 "\\path[draw,color="++color++","++style++"] "++
491 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
492 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
494 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
497 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes