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
175 mkdiag :: GArrowPortShape m () a b -> ConstraintM Diagram
176 mkdiag (GASPortPassthrough inp outp m) = error "not supported"
177 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
179 mkdiag' :: GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
181 mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
182 ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
183 mkdiag' (GAS_first f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
184 ; return $ DiagramBypassBot f' x }
185 mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
186 ; return $ DiagramBypassTop x f' }
187 mkdiag' (GAS_id ) = do { (top, x ,bot) <- alloc inp ; simpleDiag "id" top x x bot [(x,x)] }
188 mkdiag' GAS_cancell = do { (top,(TT x y),bot) <- alloc inp
189 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
190 drawWires tp x1 y x2 y "black" ++
191 drawLine x1 (tp!lowermost x) ((x1+x2)/2) (tp!uppermost y) "black" "dashed"
192 ; return $ DiagramBox top (TT x y) r y bot }
193 mkdiag' GAS_cancelr = do { (top,(TT x y),bot) <- alloc inp
194 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
195 drawWires tp x1 x x2 x "black" ++
196 drawLine x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "black" "dashed"
197 ; return $ DiagramBox top (TT x y) r x bot }
198 mkdiag' GAS_uncancell = do { (top,(TT x y),bot) <- alloc outp
199 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
200 drawWires tp x1 y x2 y "black" ++
201 drawLine ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "black" "dashed"
202 ; return $ DiagramBox top y r (TT x y) bot }
203 mkdiag' GAS_uncancelr = do { (top,(TT x y),bot) <- alloc outp
204 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
205 drawWires tp x1 x x2 x "black" ++
206 drawLine ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "black" "dashed"
207 ; return $ DiagramBox top x r (TT x y) bot }
208 mkdiag' GAS_drop = do { (top, x ,bot) <- alloc inp ; simpleDiag "drop" top x x bot [] }
209 mkdiag' (GAS_const i) = do { (top, x ,bot) <- alloc inp
210 ; (_, y ,_) <- alloc outp
212 ; simpleDiag ("const " ++ show i) top x y bot [] }
213 mkdiag' GAS_copy = do { (top,(TT y z),bot) <- alloc outp
214 ; (_ , x ,_) <- alloc inp
215 ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
216 ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
217 drawWires tp x1 x ((x1+x2)/2) x "black" ++
218 drawWires tp ((x1+x2)/2) x x2 y "black" ++
219 drawWires tp ((x1+x2)/2) x x2 z "black"
220 ; return $ DiagramBox top x r (TT y z) bot
222 mkdiag' GAS_merge = do { (top,(TT x y),bot) <- alloc inp
223 ; simpleDiag "times" top (TT x y) x bot [] }
224 mkdiag' GAS_swap = do { (top,(TT x y),bot) <- alloc inp
225 ; (top,(TT x' y'),bot) <- alloc outp
226 ; constrainEq (T (lowermost x)) (T (lowermost x'))
227 ; constrainEq (T (uppermost y)) (T (uppermost y'))
228 ; simpleDiag' "swap" top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
230 do { (top,(TT (TT x y) z),bot) <- alloc inp
231 ; let r tp x1 y1 x2 y2
232 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
233 drawLine x1 y1 x2 y1 "gray!50" "-" ++
234 drawLine x1 y2 x2 y2 "gray!50" "-" ++
235 drawLine x1 y1 x1 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
236 drawLine x1 ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
237 drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
238 drawLine (x1+0.2) ((tp ! lowermost y) + 0.5) x1 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
239 drawLine x1 ((tp ! lowermost y) + 0.5) x1 y2 "gray!50" "-"++
240 drawLine x2 y2 x2 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
241 drawLine x2 ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
242 drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
243 drawLine (x2-0.2) ((tp ! uppermost y) - 0.5) x2 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
244 drawLine x2 ((tp ! uppermost y) - 0.5) x2 y1 "gray!50" "-"++
245 drawWires tp x1 x x2 x "black" ++
246 drawWires tp x1 y x2 y "black" ++
247 drawWires tp x1 z x2 z "black"
248 ; return $ DiagramBox top (TT (TT x y) z) r (TT x (TT y z)) bot
250 mkdiag' GAS_unassoc =
251 do { (top,(TT x (TT y z)),bot) <- alloc inp
252 ; let r tp x1 y1 x2 y2
253 = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
254 drawLine x1 y1 x2 y1 "gray!50" "-" ++
255 drawLine x1 y2 x2 y2 "gray!50" "-" ++
256 drawLine x2 y1 x2 ((tp ! uppermost x) - 0.5) "gray!50" "-"++
257 drawLine x2 ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
258 drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
259 drawLine (x2-0.2) ((tp ! lowermost y) + 0.5) x2 ((tp ! lowermost y) + 0.5) "gray!50" "-"++
260 drawLine x2 ((tp ! lowermost y) + 0.5) x2 y2 "gray!50" "-"++
261 drawLine x1 y2 x1 ((tp ! lowermost z) + 0.5) "gray!50" "-"++
262 drawLine x1 ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
263 drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
264 drawLine (x1+0.2) ((tp ! uppermost y) - 0.5) x1 ((tp ! uppermost y) - 0.5) "gray!50" "-"++
265 drawLine x1 ((tp ! uppermost y) - 0.5) x1 y1 "gray!50" "-"++
266 drawWires tp x1 x x2 x "black" ++
267 drawWires tp x1 y x2 y "black" ++
268 drawWires tp x1 z x2 z "black"
269 ; return $ DiagramBox top (TT x (TT y z)) r (TT (TT x y) z) bot
271 mkdiag' (GAS_loopr f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
272 ; return $ DiagramLoopBot f' x }
273 mkdiag' (GAS_loopl f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
274 ; return $ DiagramLoopTop x f' }
275 mkdiag' (GAS_misc f ) = mkdiag f
277 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
278 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin) (-1)
279 ; constrain pbot GT (lowermost pin) 1
280 ; constrain ptop LT (uppermost pout) (-1)
281 ; constrain pbot GT (lowermost pout) 1
282 ; constrain ptop LT pbot (-1)
283 ; return $ DiagramBox ptop pin r pout pbot
285 simpleDiag text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
286 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
288 defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
289 concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
290 -- ++ wires (x-1) p1 x "green"
291 -- ++ wires (x+w) p2 (x+w+1) "red"
293 -- constrain that Ports is at least Int units above the topmost portion of Diagram
294 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
295 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
296 constrainTop v i (DiagramBypassTop p d) = constrain v LT (uppermost p) (-1 * i)
297 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
298 constrainTop v i (DiagramBox ptop pin r pout pbot) = constrain v LT ptop (-1 * i)
299 constrainTop v i (DiagramLoopTop p d) = constrain v LT (uppermost p) (-1 * i)
300 constrainTop v i (DiagramLoopBot d p) = constrainTop v (i+1) d
302 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
303 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
304 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
305 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
306 constrainBot (DiagramBypassBot d p) i v = constrain v GT (lowermost p) 2
307 constrainBot (DiagramBox ptop pin r pout pbot) i v = constrain v GT pbot i
308 constrainBot (DiagramLoopTop p d) i v = constrainBot d (i+1) v
309 constrainBot (DiagramLoopBot d p) i v = constrain v GT (lowermost p) 2
311 -- | The width of a box is easy to calculate
312 width :: Diagram -> Float
313 width (DiagramComp d1 d2) = (width d1) + 1 + (width d2)
314 width (DiagramBox ptop pin x pout pbot) = 2
315 width (DiagramBypassTop p d) = (width d) + 2
316 width (DiagramBypassBot d p) = (width d) + 2
317 width (DiagramLoopTop p d) = (width d) + 2
318 width (DiagramLoopBot d p) = (width d) + 2
320 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
321 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
322 drawWires tp x1 (T a) x2 (T a') color = drawLine x1 (tp!a) x2 (tp!a') color "-"
323 drawWires tp x1 (TU a) x2 (TU a') color = drawLine x1 (tp!a) x2 (tp!a') color "dashed"
324 drawWires tp _ _ _ _ _ = error "drawwires fail"
326 tikZ :: TrackPositions ->
328 Float -> -- horizontal position
332 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
333 ++ wires' (x+width d1) (getOut d1) (x+width d1+0.5) "black" "->"
334 ++ wires' (x+width d1+0.5) (getOut d1) (x+width d1+1) "black" "-"
335 ++ tikZ' d2 (x + width d1 + 1)
336 tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
337 let bot = getBot d' in
338 drawBox x top (x+width d') bot "gray!50" "second"
339 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
341 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
342 ++ drawWires m x p (x+1+width d+1) p "black"
343 tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
344 let bot = getBot d' in
345 drawBox x top (x+width d') bot "gray!50" "first"
346 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
348 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
349 ++ drawWires m x p (x+1+width d+1) p "black"
350 tikZ' d'@(DiagramLoopTop p d) x = let top = getTop d' in
351 let bot = getBot d' in
352 drawBox x top (x+width d') bot "gray!50" "loopl"
353 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
355 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
356 ++ drawWires m x p (x+1+width d+1) p "black"
357 tikZ' d'@(DiagramLoopBot d p) x = let top = getTop d' in
358 let bot = getBot d' in
359 drawBox x top (x+width d') bot "gray!50" "loopr"
360 ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
362 ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
363 ++ drawWires m x p (x+1+width d+1) p "black"
364 tikZ' d@(DiagramBox ptop pin r pout pbot) x = r m x (m ! ptop) (x + width d) (m ! pbot)
366 wires x1 t x2 c = wires' x1 t x2 c "-"
368 wires' :: Float -> Tracks -> Float -> String -> String -> String
369 wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
370 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"
371 wires' x1 (TU v) x2 color st = drawLine x1 (m ! v) x2 (m ! v) color "dashed"
373 getTop :: Diagram -> Float
374 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
375 getTop (DiagramBox ptop _ _ _ _) = m ! ptop
376 getTop (DiagramBypassTop p d) = (m ! uppermost p) - 1
377 getTop (DiagramBypassBot d p) = getTop d - 1
378 getTop (DiagramLoopTop p d) = (m ! uppermost p) - 1
379 getTop (DiagramLoopBot d p) = getTop d - 1
381 getBot :: Diagram -> Float
382 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
383 getBot (DiagramBox _ _ _ _ pbot) = m ! pbot
384 getBot (DiagramBypassTop p d) = getBot d + 1
385 getBot (DiagramBypassBot d p) = (m ! lowermost p) + 1
386 getBot (DiagramLoopTop p d) = getBot d + 1
387 getBot (DiagramLoopBot d p) = (m ! lowermost p) + 1
389 -- allocates multiple tracks, adding constraints that they are at least one unit apart
390 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
391 alloc shape = do { tracks <- alloc' shape
394 ; constrain ptop LT (uppermost tracks) (-1)
395 ; constrain pbot GT (lowermost tracks) 1
396 ; return (ptop,tracks,pbot)
399 alloc' :: PortShape a -> ConstraintM Tracks
400 alloc' PortUnit = do { T x <- alloc1 ; return (TU x) }
401 alloc' (PortFree _) = do { x <- alloc1 ; return x }
402 alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
404 ; constrain (lowermost x1) LT (uppermost x2) (-1)
408 do_lp_solve :: [Constraint] -> IO String
409 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
411 ; stdout <- readProcess "lp_solve" [] stdin
415 splitWs :: String -> [String]
416 splitWs s = splitWs' "" s
419 splitWs' acc [] = [acc]
420 splitWs' [] (' ':k) = splitWs' [] k
421 splitWs' acc (' ':k) = acc:(splitWs' [] k)
422 splitWs' acc (x:k) = splitWs' (acc++[x]) k
424 lp_solve_to_trackpos :: String -> TrackPositions
425 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
427 grab ('x':k) = Just k
429 parse :: String -> (Int,Float)
430 parse s = case splitWs s of
431 [a,b] -> (read a, read b)
432 _ -> error "parse: should not happen"
433 toTrackPos :: [(Int,Float)] -> TrackPositions
434 toTrackPos [] tr = 0 -- error $ "could not find track "++show tr
435 toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
437 toTikZ :: GArrowSkeleton m a b -> IO String
439 let cm = do { let g' = detectShape g
443 in do { let (_,constraints) = execState cm (0,[])
444 ; lps <- do_lp_solve $ constraints
445 ; let trackpos = lp_solve_to_trackpos lps
446 ; return $ tikZ trackpos (evalState cm (0,[])) 0
449 tikz :: (forall g a .
450 (Int -> PGArrow g (GArrowUnit g) a) ->
452 forall b . PGArrow g (GArrowTensor g b b) b) ->
453 PGArrow g (GArrowUnit g) a) -> IO ()
455 tikz x = tikz' $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }) )
458 = do putStrLn "\\documentclass{article}"
459 putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
460 putStrLn "\\usepackage{tikz}"
461 putStrLn "\\usepackage{amsmath}"
462 putStrLn "\\usepackage[tightpage,active]{preview}"
463 putStrLn "\\begin{document}"
464 putStrLn "\\setlength\\PreviewBorder{5pt}"
465 putStrLn "\\begin{preview}"
466 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
467 tikz <- toTikZ example
469 putStrLn "\\end{tikzpicture}"
470 putStrLn "\\end{preview}"
471 --putStrLn "\\pagebreak"
472 --putStrLn "\\begin{align*}"
473 --putStr (toTikZ' example)
474 --putStrLn "\\end{align*}"
475 putStrLn "\\end{document}"
477 -- Random TikZ routines
478 textc x y text color =
479 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
480 "{{\\tt{"++text++"}}};\n"
482 drawBox x1 y1 x2 y2 color text =
483 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
484 "{{\\tt{"++text++"}}};\n"
486 "\\path[draw,color="++color++"]"++
487 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
488 show (x2*xscale)++","++show (y2*yscale)++");\n"
490 drawLine x1 y1 x2 y2 color style =
491 "\\path[draw,color="++color++","++style++"] "++
492 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
493 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
495 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
498 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes