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
 175 mkdiag :: GArrowPortShape m () a b -> ConstraintM Diagram
 176 mkdiag (GASPortPassthrough  inp outp m) = error "not supported"
 177 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
 178  where
 179  mkdiag' :: GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
 180
 181  mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
 182                              ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
 183  mkdiag' (GAS_first  f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
 184                              ; return $ DiagramBypassBot f' x  }
 185  mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
 186                              ; return $ DiagramBypassTop x f'  }
 187  mkdiag' (GAS_id      ) = do { (top,    x   ,bot) <- alloc inp ; simpleDiag        "id" top x x bot        [(x,x)]      }
 188  mkdiag' GAS_cancell    = do { (top,(TT x y),bot) <- alloc inp
 189                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
 190                                                       drawWires tp x1 y x2 y "black" ++
 191                                                       drawLine  x1 (tp!lowermost x)  ((x1+x2)/2) (tp!uppermost y) "black" "dashed"
 192                              ; return $ DiagramBox top (TT x y) r y bot  }
 193  mkdiag' GAS_cancelr    = do { (top,(TT x y),bot) <- alloc inp
 194                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
 195                                                       drawWires tp x1 x x2 x "black" ++
 196                                                       drawLine  x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "black" "dashed"
 197                              ; return $ DiagramBox top (TT x y) r x bot  }
 198  mkdiag' GAS_uncancell  = do { (top,(TT x y),bot) <- alloc outp
 199                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
 200                                                       drawWires tp x1 y x2 y "black" ++
 201                                                       drawLine  ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "black" "dashed"
 202                              ; return $ DiagramBox top y r (TT x y) bot  }
 203  mkdiag' GAS_uncancelr  = do { (top,(TT x y),bot) <- alloc outp
 204                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
 205                                                       drawWires tp x1 x x2 x "black" ++
 206                                                       drawLine  ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "black" "dashed"
 207                              ; return $ DiagramBox top x r (TT x y) bot  }
 208  mkdiag' GAS_drop       = do { (top,    x   ,bot) <- alloc inp ; simpleDiag      "drop" top x x bot [] }
 209  mkdiag' (GAS_const i)  = do { (top,    x   ,bot) <- alloc inp
 210                              ; (_,      y   ,_)   <- alloc outp
 211                              ; constrainEq x y
 212                              ; simpleDiag   ("const " ++ show i) top x y bot [] }
 213  mkdiag' GAS_copy       = do { (top,(TT y z),bot) <- alloc outp
 214                              ; (_  ,      x ,_)   <- alloc inp
 215                              ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
 216                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
 217                                                       drawWires tp x1 x ((x1+x2)/2) x "black" ++
 218                                                       drawWires tp ((x1+x2)/2) x x2 y "black" ++
 219                                                       drawWires tp ((x1+x2)/2) x x2 z "black"
 220                              ; return $ DiagramBox top x r (TT y z) bot
 221                              }
 222  mkdiag' GAS_merge      = do { (top,(TT x y),bot) <- alloc inp
 223                              ; simpleDiag     "times" top (TT x y) x bot [] }
 224  mkdiag' GAS_swap       = do { (top,(TT x y),bot) <- alloc inp
 225                              ; (top,(TT x' y'),bot) <- alloc outp
 226                              ; constrainEq (T (lowermost x)) (T (lowermost x'))
 227                              ; constrainEq (T (uppermost y)) (T (uppermost y'))
 228                              ; simpleDiag'    "swap"  top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
 229  mkdiag' GAS_assoc      =
 230      do { (top,(TT (TT x y) z),bot) <- alloc inp
 231         ; let r tp x1 y1 x2 y2
 232                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "assoc" ++
 233                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 234                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 235                     drawLine  x1      y1                          x1      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 236                     drawLine  x1      ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 237                     drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 238                     drawLine (x1+0.2) ((tp ! lowermost y) + 0.5)  x1      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 239                     drawLine  x1      ((tp ! lowermost y) + 0.5)  x1      y2                         "gray!50" "-"++
 240                     drawLine  x2      y2                          x2      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 241                     drawLine  x2      ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 242                     drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 243                     drawLine (x2-0.2) ((tp ! uppermost y) - 0.5)  x2      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 244                     drawLine  x2      ((tp ! uppermost y) - 0.5)  x2      y1                         "gray!50" "-"++
 245                     drawWires tp x1 x x2 x "black" ++
 246                     drawWires tp x1 y x2 y "black" ++
 247                     drawWires tp x1 z x2 z "black"
 248         ; return $ DiagramBox top (TT (TT x y) z) r (TT x (TT y z)) bot
 249         }
 250  mkdiag' GAS_unassoc    =
 251      do { (top,(TT x (TT y z)),bot) <- alloc inp
 252         ; let r tp x1 y1 x2 y2
 253                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
 254                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 255                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 256                     drawLine  x2      y1                          x2      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 257                     drawLine  x2      ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 258                     drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 259                     drawLine (x2-0.2) ((tp ! lowermost y) + 0.5)  x2      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 260                     drawLine  x2      ((tp ! lowermost y) + 0.5)  x2      y2                         "gray!50" "-"++
 261                     drawLine  x1      y2                          x1      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 262                     drawLine  x1      ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 263                     drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 264                     drawLine (x1+0.2) ((tp ! uppermost y) - 0.5)  x1      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 265                     drawLine  x1      ((tp ! uppermost y) - 0.5)  x1      y1                         "gray!50" "-"++
 266                     drawWires tp x1 x x2 x "black" ++
 267                     drawWires tp x1 y x2 y "black" ++
 268                     drawWires tp x1 z x2 z "black"
 269         ; return $ DiagramBox top (TT x (TT y z)) r (TT (TT x y) z) bot
 270         }
 271  mkdiag' (GAS_loopr  f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
 272                              ; return $ DiagramLoopBot f' x  }
 273  mkdiag' (GAS_loopl  f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
 274                              ; return $ DiagramLoopTop x f'  }
 275  mkdiag' (GAS_misc f )  = mkdiag f
 276
 277  diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
 278  diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin)  (-1)
 279                                       ; constrain pbot GT (lowermost pin)  1
 280                                       ; constrain ptop LT (uppermost pout) (-1)
 281                                       ; constrain pbot GT (lowermost pout) 1
 282                                       ; constrain ptop LT pbot (-1)
 283                                       ; return $ DiagramBox ptop pin r pout pbot
 284                                       }
 285  simpleDiag  text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
 286  simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
 287   where
 288    defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
 289                            concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
 290    --    ++ wires (x-1) p1  x    "green"
 291    --    ++ wires  (x+w) p2 (x+w+1) "red"
 292
 293 -- constrain that Ports is at least Int units above the topmost portion of Diagram
 294 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
 295 constrainTop v i (DiagramComp d1 d2)                  = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
 296 constrainTop v i (DiagramBypassTop p d)               = constrain v LT (uppermost p) (-1 * i)
 297 constrainTop v i (DiagramBypassBot d p)               = constrainTop v (i+1) d
 298 constrainTop v i (DiagramBox ptop pin r pout pbot)    = constrain v LT ptop (-1 * i)
 299 constrainTop v i (DiagramLoopTop p d)                 = constrain v LT (uppermost p) (-1 * i)
 300 constrainTop v i (DiagramLoopBot d p)                 = constrainTop v (i+1) d
 301
 302 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
 303 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
 304 constrainBot (DiagramComp d1 d2)                  i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
 305 constrainBot (DiagramBypassTop p d)               i v = constrainBot d (i+1) v
 306 constrainBot (DiagramBypassBot d p)               i v = constrain v GT (lowermost p) 2
 307 constrainBot (DiagramBox ptop pin r pout pbot)    i v = constrain v GT pbot i
 308 constrainBot (DiagramLoopTop p d)                 i v = constrainBot d (i+1) v
 309 constrainBot (DiagramLoopBot d p)                 i v = constrain v GT (lowermost p) 2
 310
 311 -- | The width of a box is easy to calculate
 312 width :: Diagram -> Float
 313 width (DiagramComp d1 d2)               = (width d1) + 1 + (width d2)
 314 width (DiagramBox ptop pin x pout pbot) = 2
 315 width (DiagramBypassTop p d)            = (width d) + 2
 316 width (DiagramBypassBot d p)            = (width d) + 2
 317 width (DiagramLoopTop p d)              = (width d) + 2
 318 width (DiagramLoopBot d p)              = (width d) + 2
 319
 320 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
 321 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
 322 drawWires tp x1 (T a)    x2 (T a')     color = drawLine x1 (tp!a) x2 (tp!a') color "-"
 323 drawWires tp x1 (TU a)   x2 (TU a')    color = drawLine x1 (tp!a) x2 (tp!a') color "dashed"
 324 drawWires tp _ _ _ _ _                       = error "drawwires fail"
 325
 326 tikZ :: TrackPositions ->
 327         Diagram ->
 328         Float ->                -- horizontal position
 329         String
 330 tikZ m = tikZ'
 331  where
 332   tikZ'  d@(DiagramComp d1 d2)    x = tikZ' d1 x
 333                                       ++ wires' (x+width d1) (getOut d1) (x+width d1+0.5) "black" "->"
 334                                       ++ wires' (x+width d1+0.5) (getOut d1) (x+width d1+1) "black" "-"
 335                                       ++ tikZ' d2 (x + width d1 + 1)
 336   tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
 337                                       let bot = getBot d' in
 338                                       drawBox  x top (x+width d') bot "gray!50" "second"
 339                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 340                                       ++ tikZ' d (x+1)
 341                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
 342                                       ++ drawWires m x p (x+1+width d+1) p "black"
 343   tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
 344                                       let bot = getBot d' in
 345                                       drawBox  x top (x+width d') bot "gray!50" "first"
 346                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 347                                       ++ tikZ' d (x+1)
 348                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
 349                                       ++ drawWires m x p (x+1+width d+1) p "black"
 350   tikZ' d'@(DiagramLoopTop p d) x   = let top = getTop d' in
 351                                       let bot = getBot d' in
 352                                       drawBox  x top (x+width d') bot "gray!50" "loopl"
 353                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 354                                       ++ tikZ' d (x+1)
 355                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
 356                                       ++ drawWires m x p (x+1+width d+1) p "black"
 357   tikZ' d'@(DiagramLoopBot d p) x   = let top = getTop d' in
 358                                       let bot = getBot d' in
 359                                       drawBox  x top (x+width d') bot "gray!50" "loopr"
 360                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 361                                       ++ tikZ' d (x+1)
 362                                       ++ drawWires m (x+1+width d) (getOut d) (x+1+width d+1) (getOut d) "black"
 363                                       ++ drawWires m x p (x+1+width d+1) p "black"
 364   tikZ' d@(DiagramBox ptop pin r pout pbot) x = r m x (m ! ptop) (x + width d) (m ! pbot)
 365
 366   wires x1 t x2 c = wires' x1 t x2 c "-"
 367
 368   wires' :: Float -> Tracks -> Float -> String -> String -> String
 369   wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
 370   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"
 371   wires' x1 (TU v)   x2 color st = drawLine x1 (m ! v) x2 (m ! v) color "dashed"
 372
 373   getTop :: Diagram -> Float
 374   getTop (DiagramComp d1 d2)        = min (getTop d1) (getTop d2)
 375   getTop (DiagramBox ptop _ _ _ _)  = m ! ptop
 376   getTop (DiagramBypassTop p d)     = (m ! uppermost p) - 1
 377   getTop (DiagramBypassBot d p)     = getTop d - 1
 378   getTop (DiagramLoopTop p d)       = (m ! uppermost p) - 1
 379   getTop (DiagramLoopBot d p)       = getTop d - 1
 380
 381   getBot :: Diagram -> Float
 382   getBot (DiagramComp d1 d2)        = max (getBot d1) (getBot d2)
 383   getBot (DiagramBox _ _ _ _ pbot)  = m ! pbot
 384   getBot (DiagramBypassTop p d)     = getBot d + 1
 385   getBot (DiagramBypassBot d p)     = (m ! lowermost p) + 1
 386   getBot (DiagramLoopTop p d)       = getBot d + 1
 387   getBot (DiagramLoopBot d p)       = (m ! lowermost p) + 1
 388
 389 -- allocates multiple tracks, adding constraints that they are at least one unit apart
 390 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
 391 alloc shape = do { tracks <- alloc' shape
 392                  ; T ptop <- alloc1
 393                  ; T pbot <- alloc1
 394                  ; constrain ptop LT (uppermost tracks) (-1)
 395                  ; constrain pbot GT (lowermost tracks) 1
 396                  ; return (ptop,tracks,pbot)
 397                  }
 398  where
 399    alloc' :: PortShape a -> ConstraintM Tracks
 400    alloc' PortUnit           = do { T x <- alloc1 ; return (TU x) }
 401    alloc' (PortFree _)       = do { x <- alloc1 ; return x }
 402    alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
 403                                   ; x2 <- alloc' p2
 404                                   ; constrain (lowermost x1) LT (uppermost x2) (-1)
 405                                   ; return (TT x1 x2)
 406                                   }
 407
 408 do_lp_solve :: [Constraint] -> IO String
 409 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
 410                    ; putStrLn stdin
 411                    ; stdout <- readProcess "lp_solve" [] stdin
 412                    ; return stdout
 413                    }
 414
 415 splitWs :: String -> [String]
 416 splitWs s = splitWs' "" s
 417  where
 418   splitWs' [] []       = []
 419   splitWs' acc []      = [acc]
 420   splitWs' []  (' ':k) = splitWs' [] k
 421   splitWs' acc (' ':k) = acc:(splitWs' [] k)
 422   splitWs' acc (x:k)   = splitWs' (acc++[x]) k
 423
 424 lp_solve_to_trackpos :: String -> TrackPositions
 425 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
 426  where
 427    grab ('x':k) = Just k
 428    grab _       = Nothing
 429    parse :: String -> (Int,Float)
 430    parse s = case splitWs s of
 431                [a,b] -> (read a, read b)
 432                _     -> error "parse: should not happen"
 433    toTrackPos :: [(Int,Float)] -> TrackPositions
 434    toTrackPos []           tr = 0 -- error $ "could not find track "++show tr
 435    toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
 436
 437 toTikZ :: GArrowSkeleton m a b -> IO String
 438 toTikZ g =
 439     let cm = do { let g' = detectShape g
 440                 ; g'' <- mkdiag g'
 441                 ; return g''
 442                 }
 443      in do { let (_,constraints) = execState cm (0,[])
 444            ; lps <- do_lp_solve $ constraints
 445            ; let trackpos = lp_solve_to_trackpos lps
 446            ; return $ tikZ trackpos (evalState cm (0,[])) 0
 447            }
 448
 449 tikz :: (forall g a .
 450                  (Int -> PGArrow g (GArrowUnit g) a) ->
 451                  (
 452                    forall b . PGArrow g (GArrowTensor g b b) b) ->
 453                      PGArrow g (GArrowUnit g) a) -> IO ()
 454
 455 tikz x = tikz' $ optimize $ unG (x (\c -> PGArrowD { unG = GAS_const c }) (PGArrowD { unG = GAS_merge }) )
 456
 457 tikz' example
 458      = do putStrLn "\\documentclass{article}"
 459           putStrLn "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}"
 460           putStrLn "\\usepackage{tikz}"
 461           putStrLn "\\usepackage{amsmath}"
 462           putStrLn "\\usepackage[tightpage,active]{preview}"
 463           putStrLn "\\begin{document}"
 464           putStrLn "\\setlength\\PreviewBorder{5pt}"
 465           putStrLn "\\begin{preview}"
 466           putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
 467           tikz <- toTikZ example
 468           putStrLn tikz
 469           putStrLn "\\end{tikzpicture}"
 470           putStrLn "\\end{preview}"
 471           --putStrLn "\\pagebreak"
 472           --putStrLn "\\begin{align*}"
 473           --putStr   (toTikZ' example)
 474           --putStrLn "\\end{align*}"
 475           putStrLn "\\end{document}"
 476
 477 -- Random TikZ routines
 478 textc x y text color =
 479     "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
 480     "{{\\tt{"++text++"}}};\n"
 481
 482 drawBox x1 y1 x2 y2 color text =
 483     "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
 484     "{{\\tt{"++text++"}}};\n"
 485     ++
 486     "\\path[draw,color="++color++"]"++
 487        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
 488            show (x2*xscale)++","++show (y2*yscale)++");\n"
 489
 490 drawLine x1 y1 x2 y2 color style =
 491   "\\path[draw,color="++color++","++style++"] "++
 492   "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
 493   "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
 494
 495 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 496 xscale = 1
 497
 498 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 499 yscale = 1