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