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       Float 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 wid 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 "DiagramLoopTop: mismatch" }
  94 getOut (DiagramLoopBot d t)                  = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
  95
  96 -- | get the input tracks of a diagram
  97 getIn :: Diagram -> Tracks
  98 getIn (DiagramComp f g)                      = getIn f
  99 getIn (DiagramBox wid 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 "DiagramLoopTop: mismatch" }
 103 getIn (DiagramLoopBot d t)                   = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: 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 noRender :: BoxRenderer
 116 noRender _ _ _ _ _ = ""
 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)]  "gray!50"    }
 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 2 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 2 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 2 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 2 top x r (TT x y) bot  }
 207  mkdiag' GAS_drop       = do { (top,    x   ,bot) <- alloc inp
 208                              ; (_,      y   ,_)   <- alloc outp
 209                              ; constrainEq x y
 210                              ; simpleDiag   "drop" top x y bot [] }
 211  mkdiag' (GAS_const i)  = do { (top,    x   ,bot) <- alloc inp
 212                              ; (_,      y   ,_)   <- alloc outp
 213                              ; constrainEq x y
 214                              ; simpleDiag   ("const " ++ show i) top x y bot [] }
 215  mkdiag' GAS_copy       = do { (top,(TT y z),bot) <- alloc outp
 216                              ; (_  ,      x ,_)   <- alloc inp
 217                              ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
 218                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
 219                                                       drawWires tp x1 x ((x1+x2)/2) x "black" ++
 220                                                       drawWires tp ((x1+x2)/2) x x2 y "black" ++
 221                                                       drawWires tp ((x1+x2)/2) x x2 z "black"
 222                              ; return $ DiagramBox 2 top x r (TT y z) bot
 223                              }
 224  mkdiag' GAS_merge      = do { (top,(TT x y),bot) <- alloc inp
 225                              ; simpleDiag     "times" top (TT x y) x bot [] }
 226  mkdiag' GAS_swap       = do { (top,(TT x y),bot) <- alloc inp
 227                              ; (top,(TT x' y'),bot) <- alloc outp
 228                              ; constrainEq (T (lowermost x)) (T (lowermost x'))
 229                              ; constrainEq (T (uppermost y)) (T (uppermost y'))
 230                              ; simpleDiag'    "swap"  top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
 231  mkdiag' GAS_assoc      =
 232      do { (top,(TT (TT x y) z),bot) <- alloc inp
 233         ; let r tp x1 y1 x2 y2
 234                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
 235                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 236                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 237                     drawLine  x1      y1                          x1      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 238                     drawLine  x1      ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 239                     drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 240                     drawLine (x1+0.2) ((tp ! lowermost y) + 0.5)  x1      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 241                     drawLine  x1      ((tp ! lowermost y) + 0.5)  x1      y2                         "gray!50" "-"++
 242                     drawLine  x2      y2                          x2      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 243                     drawLine  x2      ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 244                     drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 245                     drawLine (x2-0.2) ((tp ! uppermost y) - 0.5)  x2      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 246                     drawLine  x2      ((tp ! uppermost y) - 0.5)  x2      y1                         "gray!50" "-"++
 247                     drawWires tp x1 x x2 x "black" ++
 248                     drawWires tp x1 y x2 y "black" ++
 249                     drawWires tp x1 z x2 z "black"
 250         ; let pin = (TT (TT x y) z)
 251         ; let pout = (TT x (TT y z))
 252         ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
 253         }
 254  mkdiag' GAS_unassoc    =
 255      do { (top,(TT x (TT y z)),bot) <- alloc inp
 256         ; let r tp x1 y1 x2 y2
 257                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
 258                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 259                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 260                     drawLine  x2      y1                          x2      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 261                     drawLine  x2      ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 262                     drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 263                     drawLine (x2-0.2) ((tp ! lowermost y) + 0.5)  x2      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 264                     drawLine  x2      ((tp ! lowermost y) + 0.5)  x2      y2                         "gray!50" "-"++
 265                     drawLine  x1      y2                          x1      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 266                     drawLine  x1      ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 267                     drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 268                     drawLine (x1+0.2) ((tp ! uppermost y) - 0.5)  x1      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 269                     drawLine  x1      ((tp ! uppermost y) - 0.5)  x1      y1                         "gray!50" "-"++
 270                     drawWires tp x1 x x2 x "black" ++
 271                     drawWires tp x1 y x2 y "black" ++
 272                     drawWires tp x1 z x2 z "black"
 273         ; let pin = (TT x (TT y z))
 274         ; let pout = (TT (TT x y) z)
 275         ; return $ if draw_assoc then DiagramBox 2 top pin r pout bot else DiagramBox 0 top pin noRender pout bot
 276         }
 277  mkdiag' (GAS_loopl  f) = do { f' <- mkdiag' f
 278                              ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
 279                              ; constrainTop (lowermost l) loopgap f'
 280                              ; return $ DiagramLoopTop l f'  }
 281  mkdiag' (GAS_loopr  f) = do { f' <- mkdiag' f
 282                              ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
 283                              ; constrainBot f' loopgap (uppermost l)
 284                              ; return $ DiagramLoopBot f' l  }
 285  mkdiag' (GAS_misc f )  = mkdiag f
 286
 287  diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
 288  diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin)  (-1)
 289                                       ; constrain pbot GT (lowermost pin)  1
 290                                       ; constrain ptop LT (uppermost pout) (-1)
 291                                       ; constrain pbot GT (lowermost pout) 1
 292                                       ; constrain ptop LT pbot (-1)
 293                                       ; return $ DiagramBox 2 ptop pin r pout pbot
 294                                       }
 295  simpleDiag  text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
 296  simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
 297   where
 298    defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
 299                            concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
 300    --    ++ wires (x-1) p1  x    "green"
 301    --    ++ wires  (x+w) p2 (x+w+1) "red"
 302
 303 --draw_assoc = False
 304 --draw_first_second = False
 305 draw_assoc = True
 306 draw_first_second = True
 307
 308 -- constrain that Ports is at least Int units above the topmost portion of Diagram
 309 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
 310 constrainTop v i (DiagramComp d1 d2)                  = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
 311 constrainTop v i (DiagramBypassTop p d)               = constrain v LT (uppermost p) (-1 * i)
 312 constrainTop v i (DiagramBypassBot d p)               = constrainTop v (i+1) d
 313 constrainTop v i (DiagramBox wid ptop pin r pout pbot)    = constrain v LT ptop (-1 * i)
 314 constrainTop v i (DiagramLoopTop p d)                 = constrain v LT (uppermost p) (-1 * i)
 315 constrainTop v i (DiagramLoopBot d p)                 = constrainTop v (i+1) d
 316
 317 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
 318 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
 319 constrainBot (DiagramComp d1 d2)                  i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
 320 constrainBot (DiagramBypassTop p d)               i v = constrainBot d (i+1) v
 321 constrainBot (DiagramBypassBot d p)               i v = constrain v GT (lowermost p) 2
 322 constrainBot (DiagramBox wid ptop pin r pout pbot)    i v = constrain v GT pbot i
 323 constrainBot (DiagramLoopTop p d)                 i v = constrainBot d (i+1) v
 324 constrainBot (DiagramLoopBot d p)                 i v = constrain v GT (lowermost p) 2
 325
 326 -- | The width of a box is easy to calculate
 327 width :: TrackPositions -> Diagram -> Float
 328 width m (DiagramComp d1 d2)               = (width m d1) + 1 + (width m d2)
 329 width m (DiagramBox wid ptop pin x pout pbot) = wid
 330 width m (DiagramBypassTop p d)            = (width m d) + (if draw_first_second then 2 else 0)
 331 width m (DiagramBypassBot d p)            = (width m d) + (if draw_first_second then 2 else 0)
 332 width m (DiagramLoopTop p d)              = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
 333 width m (DiagramLoopBot d p)              = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
 334
 335 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
 336 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
 337 drawWires tp x1 (T a)    x2 (T a')     color = drawLine x1 (tp!a) x2 (tp!a') color     "-"
 338 drawWires tp x1 (TU a)   x2 (TU a')    color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
 339 drawWires tp _ _ _ _ _                       = error "drawwires fail"
 340
 341 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
 342 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
 343 wirecos tp (T  a)   = [(tp!a,True)]
 344 wirecos tp (TU a)   = [(tp!a,False)]
 345
 346 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
 347 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
 348  where
 349   color = if b then "black" else "gray!50"
 350   style = if b then "-" else "dashed"
 351   x'    = x - (y - y1) - loopgap
 352
 353 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
 354  where
 355   color = if b then "black" else "gray!50"
 356   style = if b then "-" else "dashed"
 357   x'    = x + (y - y1) + loopgap
 358
 359 tikZ :: TrackPositions ->
 360         Diagram ->
 361         Float ->                -- horizontal position
 362         String
 363 tikZ m = tikZ'
 364  where
 365   tikZ'  d@(DiagramComp d1 d2)    x = tikZ' d1 x
 366                                       ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
 367                                       ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
 368                                       ++ tikZ' d2 (x + width m d1 + 1)
 369   tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
 370                                       then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
 371                                       else
 372                                       let top = getTop d' in
 373                                       let bot = getBot d' in
 374                                       drawBox  x top (x+width m d') bot "gray!50" "second"
 375                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 376                                       ++ tikZ' d (x+1)
 377                                       ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
 378                                       ++ drawWires m x p (x+1+width m d+1) p "black"
 379   tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
 380                                       then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
 381                                       else
 382                                       let top = getTop d' in
 383                                       let bot = getBot d' in
 384                                       drawBox  x top (x+width m d') bot "gray!50" "first"
 385                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 386                                       ++ tikZ' d (x+1)
 387                                       ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
 388                                       ++ drawWires m x p (x+1+width m d+1) p "black"
 389   tikZ' d'@(DiagramLoopTop p d) x   = let top = getTop d' in
 390                                       let bot = getBot d' in
 391                                       let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
 392                                       drawBox  x top (x+width m d') bot "gray!50" "loopl"
 393                                       ++ tikZ' d (x+1+gap)
 394                                       ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
 395                                       ++ let p'   = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
 396                                              pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
 397                                          in  concatMap (wire90  (x+1+gap) (m ! lowermost p)) pzip
 398                                       ++ let p'   = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
 399                                              pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
 400                                          in  concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
 401                                       ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
 402                                          in  drawWires m x rest (x+1+gap) rest "black"
 403                                       ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
 404                                          in  drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
 405   tikZ' d'@(DiagramLoopBot d p) x_  = error "not implemented"
 406   tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
 407
 408   wires x1 t x2 c = wires' x1 t x2 c "-"
 409
 410   wires' :: Float -> Tracks -> Float -> String -> String -> String
 411   wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
 412   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"
 413   wires' x1 (TU v)   x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
 414
 415   getTop :: Diagram -> Float
 416   getTop (DiagramComp d1 d2)        = min (getTop d1) (getTop d2)
 417   getTop (DiagramBox wid ptop _ _ _ _)  = m ! ptop
 418   getTop (DiagramBypassTop p d)     = (m ! uppermost p) - 1
 419   getTop (DiagramBypassBot d p)     = getTop d - 1
 420   getTop (DiagramLoopTop p d)       = (m ! uppermost p) - 1
 421   getTop (DiagramLoopBot d p)       = getTop d - 1
 422
 423   getBot :: Diagram -> Float
 424   getBot (DiagramComp d1 d2)        = max (getBot d1) (getBot d2)
 425   getBot (DiagramBox wid _ _ _ _ pbot)  = m ! pbot
 426   getBot (DiagramBypassTop p d)     = getBot d + 1
 427   getBot (DiagramBypassBot d p)     = (m ! lowermost p) + 1
 428   getBot (DiagramLoopTop p d)       = getBot d + 1
 429   getBot (DiagramLoopBot d p)       = (m ! lowermost p) + 1
 430
 431 -- allocates multiple tracks, adding constraints that they are at least one unit apart
 432 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
 433 alloc shape = do { tracks <- alloc' shape
 434                  ; T ptop <- alloc1
 435                  ; T pbot <- alloc1
 436                  ; constrain ptop LT (uppermost tracks) (-1)
 437                  ; constrain pbot GT (lowermost tracks) 1
 438                  ; return (ptop,tracks,pbot)
 439                  }
 440  where
 441    alloc' :: PortShape a -> ConstraintM Tracks
 442    alloc' PortUnit           = do { T x <- alloc1 ; return (TU x) }
 443    alloc' (PortFree _)       = do { x <- alloc1 ; return x }
 444    alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
 445                                   ; x2 <- alloc' p2
 446                                   ; constrain (lowermost x1) LT (uppermost x2) (-1)
 447                                   ; return (TT x1 x2)
 448                                   }
 449
 450 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
 451 -- and upside-down
 452 allocLoop :: Tracks -> ConstraintM Tracks
 453 allocLoop (TU _)       = do { T x <- alloc1 ; return (TU x) }
 454 allocLoop (T  _)       = do { x <- alloc1   ; return x }
 455 allocLoop (TT t1 t2)   = do { x1 <- allocLoop t2
 456                             ; x2 <- allocLoop t1
 457                             ; constrain (lowermost x1) LT (uppermost x2) (-1)
 458                             ; return (TT x1 x2)
 459                             }
 460
 461 do_lp_solve :: [Constraint] -> IO String
 462 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
 463                    ; putStrLn stdin
 464                    ; stdout <- readProcess "lp_solve" [] stdin
 465                    ; return stdout
 466                    }
 467
 468 splitWs :: String -> [String]
 469 splitWs s = splitWs' "" s
 470  where
 471   splitWs' [] []       = []
 472   splitWs' acc []      = [acc]
 473   splitWs' []  (' ':k) = splitWs' [] k
 474   splitWs' acc (' ':k) = acc:(splitWs' [] k)
 475   splitWs' acc (x:k)   = splitWs' (acc++[x]) k
 476
 477 lp_solve_to_trackpos :: String -> TrackPositions
 478 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
 479  where
 480    grab ('x':k) = Just k
 481    grab _       = Nothing
 482    parse :: String -> (Int,Float)
 483    parse s = case splitWs s of
 484                [a,b] -> (read a, read b)
 485                _     -> error "parse: should not happen"
 486    toTrackPos :: [(Int,Float)] -> TrackPositions
 487    toTrackPos []           tr = 0 -- error $ "could not find track "++show tr
 488    toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
 489
 490 toTikZ :: GArrowSkeleton m a b -> IO String
 491 toTikZ g =
 492     let cm = do { let g' = detectShape g
 493                 ; g'' <- mkdiag g'
 494                 ; return g''
 495                 }
 496      in do { let (_,constraints) = execState cm (0,[])
 497            ; lps <- do_lp_solve $ constraints
 498            ; let m = lp_solve_to_trackpos lps
 499            ; let d = evalState cm (0,[])
 500            ; let t = tikZ m d 1
 501            ; return (t ++ drawWires m 0             (getIn  d) 1             (getIn  d) "black"
 502                        ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
 503            }
 504
 505
 506 tikz :: forall c .
 507     (forall g .
 508              (Int -> PGArrow g (GArrowUnit g) Int) ->
 509              (PGArrow g (GArrowTensor g c c) c) ->
 510              PGArrow g c c)
 511      -> IO ()
 512 tikz x = tikz' $ beautify $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }))
 513
 514 tikz' example
 515      = do putStrLn "\\documentclass{article}"
 516           putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
 517           putStrLn "\\usepackage{tikz}"
 518           putStrLn "\\usepackage{amsmath}"
 519           putStrLn "\\usepackage[tightpage,active]{preview}"
 520           putStrLn "\\begin{document}"
 521           putStrLn "\\setlength\\PreviewBorder{5pt}"
 522           putStrLn "\\begin{preview}"
 523           putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
 524           tikz <- toTikZ example
 525           putStrLn tikz
 526           putStrLn "\\end{tikzpicture}"
 527           putStrLn "\\end{preview}"
 528           --putStrLn "\\pagebreak"
 529           --putStrLn "\\begin{align*}"
 530           --putStr   (toTikZ' example)
 531           --putStrLn "\\end{align*}"
 532           putStrLn "\\end{document}"
 533
 534 -- Random TikZ routines
 535 textc x y text color =
 536     "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
 537     "{{\\tt{"++text++"}}};\n"
 538
 539 drawBox x1 y1 x2 y2 color text =
 540     "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
 541     "{{\\tt{"++text++"}}};\n"
 542     ++
 543     "\\path[draw,color="++color++"]"++
 544        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
 545            show (x2*xscale)++","++show (y2*yscale)++");\n"
 546
 547 drawLine x1 y1 x2 y2 color style =
 548   "\\path[draw,color="++color++","++style++"] "++
 549   "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
 550   "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
 551
 552 drawLine' [] color style = ""
 553 drawLine' (xy1:xy) color style =
 554   "\\path[draw,color="++color++","++style++"] "++
 555   foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
 556   ++ ";\n"
 557    where
 558      f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
 559
 560 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 561 xscale = 1
 562
 563 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 564 yscale = 1
 565
 566 -- | extra gap placed between loopback wires and the contents of the loop module
 567 loopgap = 1