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