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 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" }
  95
  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" }
 104
 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
 108 type BoxRenderer =
 109     TrackPositions ->  -- resolves the TrackIdentifiers to actual y-coordinates
 110     Float          ->  -- x1
 111     Float          ->  -- y1
 112     Float          ->  -- x2
 113     Float          ->  -- y2
 114     String             -- TikZ code
 115
 116
 117
 118
 119
 120
 121 ------------------------------------------------------------------------------
 122 -- Constraints
 123
 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
 127
 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"
 132
 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"
 139
 140 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
 141 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
 142
 143 -- | pull the constraints out of the monad
 144 getConstraints :: ConstraintM [Constraint]
 145 getConstraints = do { (_,c) <- get ; return c }
 146
 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)
 151                            ; return ()
 152                            }
 153
 154 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
 155                                          ; put (t, (EqualSpace t1a t1b t2a t2b):c)
 156                                          ; return ()
 157                                          }
 158
 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
 166
 167 -- | allocate a TrackIdentifier
 168 alloc1 :: ConstraintM Tracks
 169 alloc1 = do { (t,c) <- get
 170             ; put (t+1,c)
 171             ; return (T t)
 172             }
 173
 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
 177  where
 178  mkdiag' :: GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
 179
 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
 210                              ; constrainEq x y
 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
 220                              }
 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" }
 228  mkdiag' GAS_assoc      =
 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
 248         }
 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
 269         }
 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
 275
 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
 283                                       }
 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
 286   where
 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"
 291
 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
 300
 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
 309
 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
 318
 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"
 324
 325 tikZ :: TrackPositions ->
 326         Diagram ->
 327         Float ->                -- horizontal position
 328         String
 329 tikZ m = tikZ'
 330  where
 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"
 339                                       ++ tikZ' d (x+1)
 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"
 346                                       ++ tikZ' d (x+1)
 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"
 353                                       ++ tikZ' d (x+1)
 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"
 360                                       ++ tikZ' d (x+1)
 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)
 364
 365   wires x1 t x2 c = wires' x1 t x2 c "-"
 366
 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"
 371
 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
 379
 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
 387
 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
 391                  ; T ptop <- alloc1
 392                  ; T pbot <- alloc1
 393                  ; constrain ptop LT (uppermost tracks) (-1)
 394                  ; constrain pbot GT (lowermost tracks) 1
 395                  ; return (ptop,tracks,pbot)
 396                  }
 397  where
 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
 402                                   ; x2 <- alloc' p2
 403                                   ; constrain (lowermost x1) LT (uppermost x2) (-1)
 404                                   ; return (TT x1 x2)
 405                                   }
 406
 407 do_lp_solve :: [Constraint] -> IO String
 408 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
 409                    ; putStrLn stdin
 410                    ; stdout <- readProcess "lp_solve" [] stdin
 411                    ; return stdout
 412                    }
 413
 414 splitWs :: String -> [String]
 415 splitWs s = splitWs' "" s
 416  where
 417   splitWs' [] []       = []
 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
 422
 423 lp_solve_to_trackpos :: String -> TrackPositions
 424 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
 425  where
 426    grab ('x':k) = Just k
 427    grab _       = Nothing
 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
 435
 436 toTikZ :: GArrowSkeleton m a b -> IO String
 437 toTikZ g =
 438     let cm = do { let g' = detectShape g
 439                 ; g'' <- mkdiag g'
 440                 ; return g''
 441                 }
 442      in do { let (_,constraints) = execState cm (0,[])
 443            ; lps <- do_lp_solve $ constraints
 444            ; let m = lp_solve_to_trackpos lps
 445            ; let d = evalState cm (0,[])
 446            ; let t = tikZ m d 1
 447            ; return (t ++ drawWires m 0             (getIn  d) 1             (getIn  d) "black"
 448                        ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
 449            }
 450
 451
 452 tikz ::
 453     (forall g .
 454              (Int -> PGArrow g (GArrowUnit g) Int) ->
 455              (forall b . PGArrow g (GArrowTensor g b b) b) ->
 456              PGArrow g b c)
 457      -> IO ()
 458 tikz x = tikz' $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }))
 459
 460 tikz' example
 461      = do putStrLn "\\documentclass{article}"
 462           putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
 463           putStrLn "\\usepackage{tikz}"
 464           putStrLn "\\usepackage{amsmath}"
 465           putStrLn "\\usepackage[tightpage,active]{preview}"
 466           putStrLn "\\begin{document}"
 467           putStrLn "\\setlength\\PreviewBorder{5pt}"
 468           putStrLn "\\begin{preview}"
 469           putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
 470           tikz <- toTikZ example
 471           putStrLn tikz
 472           putStrLn "\\end{tikzpicture}"
 473           putStrLn "\\end{preview}"
 474           --putStrLn "\\pagebreak"
 475           --putStrLn "\\begin{align*}"
 476           --putStr   (toTikZ' example)
 477           --putStrLn "\\end{align*}"
 478           putStrLn "\\end{document}"
 479
 480 -- Random TikZ routines
 481 textc x y text color =
 482     "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
 483     "{{\\tt{"++text++"}}};\n"
 484
 485 drawBox x1 y1 x2 y2 color text =
 486     "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
 487     "{{\\tt{"++text++"}}};\n"
 488     ++
 489     "\\path[draw,color="++color++"]"++
 490        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
 491            show (x2*xscale)++","++show (y2*yscale)++");\n"
 492
 493 drawLine x1 y1 x2 y2 color style =
 494   "\\path[draw,color="++color++","++style++"] "++
 495   "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
 496   "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
 497
 498 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 499 xscale = 1
 500
 501 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 502 yscale = 1