add -fflatten and -funsafe-skolemize flags
[coq-hetmet.git] / examples / GArrowTikZ.hs
1 {-# LANGUAGE RankNTypes, MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, TypeOperators #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module      :  GArrowTikZ
5 -- Copyright   :  none
6 -- License     :  public domain
7 --
8 -- Maintainer  :  Adam Megacz <megacz@acm.org>
9 -- Stability   :  experimental
10 --
11 -- | Renders a @GArrowSkeleton@ using TikZ; the result is LaTeX code.
12 -- You must have lp_solve installed in order for this to work.
13 --
14
15 module GArrowTikZ (tikz)
16 where
17 import System.Process
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)
25 import Unify
26 import GArrowSkeleton
27 import GArrowPortShape
28 import GHC.HetMet.Private
29
30 ------------------------------------------------------------------------------
31 -- Tracks
32
33 --
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.
41 --
42 type TrackIdentifier = Int
43
44 data Tracks = T  TrackIdentifier
45             | TU TrackIdentifier  -- a track known to be of unit type
46             | TT Tracks Tracks
47
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++")"
52
53 --
54 -- | TrackPositions maps TrackIdentifiers to actual y-axis positions;
55 -- this is what lp_solve gives us
56 -- 
57 type TrackPositions = TrackIdentifier -> Float
58
59 (!) :: TrackPositions -> TrackIdentifier -> Float
60 tp ! ti = tp ti
61
62 -- | get the uppermost TrackIdentifier in a Tracks
63 uppermost  (T x)    = x
64 uppermost  (TU x)    = x
65 uppermost  (TT x y) = uppermost x
66
67 -- | get the lowermost TrackIdentifier in a Tracks
68 lowermost (T x)    = x
69 lowermost (TU x)    = x
70 lowermost (TT x y) = lowermost y
71
72
73
74
75 ------------------------------------------------------------------------------
76 -- Diagrams
77
78 -- | A Diagram is the visual representation of a GArrowSkeleton
79 data Diagram
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
86
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
94 -- | get the input tracks of a diagram
95 getIn :: Diagram -> Tracks
96 getIn (DiagramComp f g)                      = getIn f
97 getIn (DiagramBox ptop pin q pout pbot)      = pin
98 getIn (DiagramBypassTop p f)                 = TT p (getIn f)
99 getIn (DiagramBypassBot f p)                 = TT (getIn f) p
100
101 -- | A BoxRenderer is just a routine that, given the dimensions of a
102 -- boxes-and-wires box element, knows how to spit out a bunch of TikZ
103 -- code that draws it
104 type BoxRenderer =
105     TrackPositions ->  -- resolves the TrackIdentifiers to actual y-coordinates
106     Float          ->  -- x1
107     Float          ->  -- y1
108     Float          ->  -- x2
109     Float          ->  -- y2
110     String             -- TikZ code
111
112
113
114
115
116
117 ------------------------------------------------------------------------------
118 -- Constraints
119
120 -- | a constraint (to be dealt with by lp_solve) relates two track identifiers
121 data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
122                 | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
123
124 -- instance Show Constraint where
125 --  show (C t1 LT t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
126 --  show (C t1 GT t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
127 --  show (C t1 EQ t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
128
129 instance Show Constraint where
130  show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
131  show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
132  show (C t1 EQ t2 k) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
133  show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
134                                      " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
135
136 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
137 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
138
139 -- | pull the constraints out of the monad
140 getConstraints :: ConstraintM [Constraint]
141 getConstraints = do { (_,c) <- get ; return c }
142
143 -- | add a constraint
144 constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
145 constrain t1 ord t2 k = do { (t,c) <- get
146                            ; put (t, (C t1 ord t2 k):c)
147                            ; return ()
148                            }
149
150 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
151                                          ; put (t, (EqualSpace t1a t1b t2a t2b):c)
152                                          ; return ()
153                                          }
154
155 -- | simple form for equality constraints
156 constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
157 constrainEq (T  t1     ) (T  t2     ) = constrain t1 EQ t2 0
158 constrainEq (TU t1     ) (TU t2     ) = constrain t1 EQ t2 0
159 constrainEq (TU t1     ) (T  t2     ) = constrain t1 EQ t2 0
160 constrainEq (T  t1     ) (TU t2     ) = constrain t1 EQ t2 0
161 constrainEq t1 t2                     = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
162
163 -- | allocate a TrackIdentifier
164 alloc1 :: ConstraintM Tracks
165 alloc1 = do { (t,c) <- get
166             ; put (t+1,c)
167             ; return (T t)
168             }
169
170
171 mkdiag :: GArrowPortShape m () a b -> ConstraintM Diagram
172 mkdiag (GASPortPassthrough  inp outp m) = error "not supported"
173 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
174  where
175  mkdiag' :: GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
176  
177  mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
178                              ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
179  mkdiag' (GAS_first  f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
180                              ; return $ DiagramBypassBot f' x  }
181  mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
182                              ; return $ DiagramBypassTop x f'  }
183  mkdiag' (GAS_id      ) = do { (top,    x   ,bot) <- alloc inp ; simpleDiag        "id" top x x bot        [(x,x)]      }
184  mkdiag' GAS_cancell    = do { (top,(TT x y),bot) <- alloc inp
185                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
186                                                       drawWires tp x1 y x2 y "black" ++
187                                                       drawLine  x1 (tp!lowermost x)  ((x1+x2)/2) (tp!uppermost y) "black" "dashed"
188                              ; return $ DiagramBox top (TT x y) r y bot  }
189  mkdiag' GAS_cancelr    = do { (top,(TT x y),bot) <- alloc inp
190                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
191                                                       drawWires tp x1 x x2 x "black" ++
192                                                       drawLine  x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "black" "dashed"
193                              ; return $ DiagramBox top (TT x y) r x bot  }
194  mkdiag' GAS_uncancell  = do { (top,(TT x y),bot) <- alloc outp
195                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
196                                                       drawWires tp x1 y x2 y "black" ++
197                                                       drawLine  ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "black" "dashed"
198                              ; return $ DiagramBox top y r (TT x y) bot  }
199  mkdiag' GAS_uncancelr  = do { (top,(TT x y),bot) <- alloc outp
200                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
201                                                       drawWires tp x1 x x2 x "black" ++
202                                                       drawLine  ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "black" "dashed"
203                              ; return $ DiagramBox top x r (TT x y) bot  }
204  mkdiag' GAS_drop       = do { (top,    x   ,bot) <- alloc inp ; simpleDiag      "drop" top x x bot [] }
205  mkdiag' (GAS_const i)  = do { (top,    x   ,bot) <- alloc inp
206                              ; (_,      y   ,_)   <- alloc outp
207                              ; constrainEq x y
208                              ; simpleDiag   ("const " ++ show i) top x y bot [] }
209  mkdiag' GAS_copy       = do { (top,(TT y z),bot) <- alloc outp
210                              ; (_  ,      x ,_)   <- alloc inp
211                              ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
212                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
213                                                       drawWires tp x1 x ((x1+x2)/2) x "black" ++
214                                                       drawWires tp ((x1+x2)/2) x x2 y "black" ++
215                                                       drawWires tp ((x1+x2)/2) x x2 z "black"
216                              ; return $ DiagramBox top x r (TT y z) bot
217                              }
218  mkdiag' GAS_merge      = do { (top,(TT x y),bot) <- alloc inp 
219                              ; simpleDiag     "times" top (TT x y) x bot [] }
220  mkdiag' GAS_swap       = do { (top,(TT x y),bot) <- alloc inp
221                              ; (top,(TT x' y'),bot) <- alloc outp
222                              ; constrainEq (T (lowermost x)) (T (lowermost x'))
223                              ; constrainEq (T (uppermost y)) (T (uppermost y'))
224                              ; simpleDiag'    "swap"  top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
225  mkdiag' GAS_assoc      =
226      do { (top,(TT (TT x y) z),bot) <- alloc inp
227         ; let r tp x1 y1 x2 y2
228                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
229                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
230                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
231                     drawLine  x1      y1                          x1      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
232                     drawLine  x1      ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
233                     drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
234                     drawLine (x1+0.2) ((tp ! lowermost y) + 0.5)  x1      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
235                     drawLine  x1      ((tp ! lowermost y) + 0.5)  x1      y2                         "gray!50" "-"++
236                     drawLine  x2      y2                          x2      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
237                     drawLine  x2      ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
238                     drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
239                     drawLine (x2-0.2) ((tp ! uppermost y) - 0.5)  x2      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
240                     drawLine  x2      ((tp ! uppermost y) - 0.5)  x2      y1                         "gray!50" "-"++
241                     drawWires tp x1 x x2 x "black" ++
242                     drawWires tp x1 y x2 y "black" ++
243                     drawWires tp x1 z x2 z "black"
244         ; return $ DiagramBox top (TT (TT x y) z) r (TT x (TT y z)) bot
245         }
246  mkdiag' GAS_unassoc    =
247      do { (top,(TT x (TT y z)),bot) <- alloc inp
248         ; let r tp x1 y1 x2 y2
249                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
250                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
251                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
252                     drawLine  x2      y1                          x2      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
253                     drawLine  x2      ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
254                     drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
255                     drawLine (x2-0.2) ((tp ! lowermost y) + 0.5)  x2      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
256                     drawLine  x2      ((tp ! lowermost y) + 0.5)  x2      y2                         "gray!50" "-"++
257                     drawLine  x1      y2                          x1      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
258                     drawLine  x1      ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
259                     drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
260                     drawLine (x1+0.2) ((tp ! uppermost y) - 0.5)  x1      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
261                     drawLine  x1      ((tp ! uppermost y) - 0.5)  x1      y1                         "gray!50" "-"++
262                     drawWires tp x1 x x2 x "black" ++
263                     drawWires tp x1 y x2 y "black" ++
264                     drawWires tp x1 z x2 z "black"
265         ; return $ DiagramBox top (TT x (TT y z)) r (TT (TT x y) z) bot
266         }
267  mkdiag' (GAS_loopl f)  = error "not implemented"
268  mkdiag' (GAS_loopr f)  = error "not implemented"
269  mkdiag' (GAS_misc f )  = mkdiag f
270
271  diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
272  diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin)  (-1)
273                                       ; constrain pbot GT (lowermost pin)  1
274                                       ; constrain ptop LT (uppermost pout) (-1)
275                                       ; constrain pbot GT (lowermost pout) 1
276                                       ; constrain ptop LT pbot (-1)
277                                       ; return $ DiagramBox ptop pin r pout pbot
278                                       }
279  simpleDiag  text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
280  simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
281   where
282    defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
283                            concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
284    --    ++ wires (x-1) p1  x    "green"
285    --    ++ wires  (x+w) p2 (x+w+1) "red"
286
287 -- constrain that Ports is at least Int units above the topmost portion of Diagram
288 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
289 constrainTop v i (DiagramComp d1 d2)                  = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
290 constrainTop v i (DiagramBypassTop p d)               = constrain v LT (uppermost p) (-1 * i)
291 constrainTop v i (DiagramBypassBot d p)               = constrainTop v (i+1) d
292 constrainTop v i (DiagramBox ptop pin r pout pbot)    = constrain v LT ptop (-1 * i)
293
294 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
295 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
296 constrainBot (DiagramComp d1 d2)                  i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
297 constrainBot (DiagramBypassTop p d)               i v = constrainBot d (i+1) v
298 constrainBot (DiagramBypassBot d p)               i v = constrain v GT (lowermost p) 2
299 constrainBot (DiagramBox ptop pin r pout pbot)    i v = constrain v GT pbot i
300
301 -- | The width of a box is easy to calculate
302 width :: Diagram -> Float
303 width (DiagramComp d1 d2)               = (width d1) + 1 + (width d2)
304 width (DiagramBox ptop pin x pout pbot) = 2
305 width (DiagramBypassTop p d)            = (width d) + 2
306 width (DiagramBypassBot d p)            = (width d) + 2
307
308 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
309 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
310 drawWires tp x1 (T a)    x2 (T a')     color = drawLine x1 (tp!a) x2 (tp!a') color "-"
311 drawWires tp x1 (TU a)   x2 (TU a')    color = drawLine x1 (tp!a) x2 (tp!a') color "dashed"
312 drawWires tp _ _ _ _ _                       = error "drawwires fail"
313
314 tikZ :: TrackPositions ->
315         Diagram ->
316         Float ->                -- horizontal position
317         String
318 tikZ m = tikZ'
319  where
320   tikZ'  d@(DiagramComp d1 d2)    x = tikZ' d1 x
321                                       ++ wires' (x+width d1) (getOut d1) (x+width d1+0.5) "black" "->"
322                                       ++ wires' (x+width d1+0.5) (getOut d1) (x+width d1+1) "black" "-"
323                                       ++ tikZ' d2 (x + width d1 + 1)
324   tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
325                                       let bot = getBot d' in
326                                       drawBox  x top (x+width d') bot "gray!50" "second"
327                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
328                                       ++ tikZ' d (x+1)
329                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
330                                       ++ drawWires m x p (x+1+width d+1) p "black"
331   tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
332                                       let bot = getBot d' in
333                                       drawBox  x top (x+width d') bot "gray!50" "first"
334                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
335                                       ++ tikZ' d (x+1)
336                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
337                                       ++ drawWires m x p (x+1+width d+1) p "black"
338   tikZ' d@(DiagramBox ptop pin r pout pbot) x = r m x (m ! ptop) (x + width d) (m ! pbot)
339
340   wires x1 t x2 c = wires' x1 t x2 c "-"
341
342   wires' :: Float -> Tracks -> Float -> String -> String -> String
343   wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
344   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"
345   wires' x1 (TU v)   x2 color st = drawLine x1 (m ! v) x2 (m ! v) color "dashed"
346
347   getTop :: Diagram -> Float
348   getTop (DiagramComp d1 d2)        = min (getTop d1) (getTop d2)
349   getTop (DiagramBox ptop _ _ _ _)  = m ! ptop
350   getTop (DiagramBypassTop p d)     = (m ! uppermost p) - 1
351   getTop (DiagramBypassBot d p)     = getTop d - 1
352
353   getBot :: Diagram -> Float
354   getBot (DiagramComp d1 d2)        = max (getBot d1) (getBot d2)
355   getBot (DiagramBox _ _ _ _ pbot)  = m ! pbot
356   getBot (DiagramBypassTop p d)     = getBot d + 1
357   getBot (DiagramBypassBot d p)     = (m ! lowermost p) + 1
358
359 -- allocates multiple tracks, adding constraints that they are at least one unit apart
360 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
361 alloc shape = do { tracks <- alloc' shape
362                  ; T ptop <- alloc1
363                  ; T pbot <- alloc1
364                  ; constrain ptop LT (uppermost tracks) (-1)
365                  ; constrain pbot GT (lowermost tracks) 1
366                  ; return (ptop,tracks,pbot)
367                  }
368  where
369    alloc' :: PortShape a -> ConstraintM Tracks
370    alloc' PortUnit           = do { T x <- alloc1 ; return (TU x) }
371    alloc' (PortFree _)       = do { x <- alloc1 ; return x }
372    alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
373                                   ; x2 <- alloc' p2
374                                   ; constrain (lowermost x1) LT (uppermost x2) (-1)
375                                   ; return (TT x1 x2)
376                                   }
377
378 do_lp_solve :: [Constraint] -> IO String
379 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
380                    ; putStrLn stdin
381                    ; stdout <- readProcess "lp_solve" [] stdin
382                    ; return stdout
383                    }
384
385 splitWs :: String -> [String]
386 splitWs s = splitWs' "" s
387  where
388   splitWs' [] []       = []
389   splitWs' acc []      = [acc]
390   splitWs' []  (' ':k) = splitWs' [] k
391   splitWs' acc (' ':k) = acc:(splitWs' [] k)
392   splitWs' acc (x:k)   = splitWs' (acc++[x]) k
393
394 lp_solve_to_trackpos :: String -> TrackPositions
395 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
396  where
397    grab ('x':k) = Just k
398    grab _       = Nothing
399    parse :: String -> (Int,Float)
400    parse s = case splitWs s of
401                [a,b] -> (read a, read b)
402                _     -> error "parse: should not happen"
403    toTrackPos :: [(Int,Float)] -> TrackPositions
404    toTrackPos []           tr = 0 -- error $ "could not find track "++show tr
405    toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
406
407 toTikZ :: GArrowSkeleton m a b -> IO String
408 toTikZ g = 
409     let cm = do { let g' = detectShape g
410                 ; g'' <- mkdiag g'
411                 ; return g''
412                 }
413      in do { let (_,constraints) = execState cm (0,[])
414            ; lps <- do_lp_solve $ constraints
415            ; let trackpos = lp_solve_to_trackpos lps
416            ; return $ tikZ trackpos (evalState cm (0,[])) 0
417            }
418
419 tikz :: (forall g a .
420                  (Int -> PGArrow g (GArrowUnit g) a) ->
421                  (
422                    forall b . PGArrow g (GArrowTensor g b b) b) ->
423                      PGArrow g (GArrowUnit g) a) -> IO ()
424
425 tikz x = tikz' $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }) )
426
427 tikz' example
428      = do putStrLn "\\documentclass{article}"
429           putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
430           putStrLn "\\usepackage{tikz}"
431           putStrLn "\\usepackage{amsmath}"
432           putStrLn "\\usepackage[tightpage,active]{preview}"
433           putStrLn "\\begin{document}"
434           putStrLn "\\setlength\\PreviewBorder{5pt}"
435           putStrLn "\\begin{preview}"
436           putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
437           tikz <- toTikZ example
438           putStrLn tikz
439           putStrLn "\\end{tikzpicture}"
440           putStrLn "\\end{preview}"
441           --putStrLn "\\pagebreak"
442           --putStrLn "\\begin{align*}"
443           --putStr   (toTikZ' example)
444           --putStrLn "\\end{align*}"
445           putStrLn "\\end{document}"
446
447 -- Random TikZ routines
448 textc x y text color = 
449     "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
450     "{{\\tt{"++text++"}}};\n"
451
452 drawBox x1 y1 x2 y2 color text =
453     "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
454     "{{\\tt{"++text++"}}};\n"
455     ++
456     "\\path[draw,color="++color++"]"++
457        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
458            show (x2*xscale)++","++show (y2*yscale)++");\n"
459
460 drawLine x1 y1 x2 y2 color style =
461   "\\path[draw,color="++color++","++style++"] "++
462   "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
463   "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
464
465 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
466 xscale = 1
467
468 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
469 yscale = 1