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,Opaque(..),toTikZ,tikz_header,tikz_footer,skelify',skelify'')
  16 where
  17 import System.Process
  18 import Prelude hiding ( id, (.), lookup )
  19 import Control.Category
  20 import Control.Monad.State
  21 import Control.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 skelify' :: (forall g . (GArrowCopy g (,) (), GArrowDrop g (,) (), GArrowSwap g (,) (), GArrowLoop g (,) ()) => g x y) ->
  31             GArrowSkeleton Opaque x y
  32 skelify' = \g -> g
  33
  34 skelify'' :: GArrowSkeleton Opaque x y -> GArrowSkeleton Opaque x y
  35 skelify'' = \g -> g
  36
  37 ------------------------------------------------------------------------------
  38 -- Tracks
  39
  40 --
  41 -- Figuring out the x-coordinates of the boxes is easy, but we'll need
  42 -- to use lp_solve to get a nice layout for the y-coordinates of the
  43 -- wires.  A @Track@ is basically just a y-axis position for one of
  44 -- the horizontal wires in the boxes-and-wires diagram; we will assign
  45 -- a unique Int to each visual element that has a y-coordinate, then
  46 -- generate a big pile of constraints on these y-coordinates and have
  47 -- lp_solve find a solution.
  48 --
  49 type TrackIdentifier = Int
  50
  51 data Tracks = T  TrackIdentifier
  52             | TU TrackIdentifier  -- a track known to be of unit type
  53             | TT Tracks Tracks
  54
  55 instance Show Tracks where
  56  show (T  ti   ) = "(T "++show ti++")"
  57  show (TU ti   ) = "(TU "++show ti++")"
  58  show (TT t1 t2) = "(TT "++show t1++" "++show t2++")"
  59
  60 --
  61 -- | TrackPositions maps TrackIdentifiers to actual y-axis positions;
  62 -- this is what lp_solve gives us
  63 --
  64 type TrackPositions = TrackIdentifier -> Float
  65
  66 (!) :: TrackPositions -> TrackIdentifier -> Float
  67 tp ! ti = tp ti
  68
  69 -- | get the uppermost TrackIdentifier in a Tracks
  70 uppermost  (T x)    = x
  71 uppermost  (TU x)    = x
  72 uppermost  (TT x y) = uppermost x
  73
  74 -- | get the lowermost TrackIdentifier in a Tracks
  75 lowermost (T x)    = x
  76 lowermost (TU x)    = x
  77 lowermost (TT x y) = lowermost y
  78
  79
  80 class ToDiagram g where
  81   toDiagram :: GArrowPortShape g () x y -> ConstraintM Diagram
  82
  83 instance (Detect m, ToDiagram m) => ToDiagram (GArrowSkeleton m) where
  84   toDiagram s = mkdiag s
  85
  86 data Opaque x y where
  87   MkOpaque :: String -> DetectM (GArrowPortShape Opaque UVar x y) -> Opaque x y
  88
  89 instance Detect Opaque where
  90   detect' (MkOpaque _ dm) = dm
  91
  92 instance ToDiagram Opaque where
  93   toDiagram (GASPortPassthrough  inp outp (MkOpaque s _)) =
  94     do { (top,    x   ,bot) <- alloc inp
  95        ; (_,      y   ,_)   <- alloc outp
  96        --; constrainEq x y
  97        ; simpleDiag''   s top x y bot [] "black" }
  98   toDiagram q = mkdiag q
  99
 100 --    do (top,    x   ,bot) <- alloc inp
 101 --       simpleDiag' s top x x bot        [(x,x)]  "gray!50"
 102
 103
 104 ------------------------------------------------------------------------------
 105 -- Diagrams
 106
 107 -- | A Diagram is the visual representation of a GArrowSkeleton
 108 data Diagram
 109   = DiagramComp      Diagram Diagram
 110   | DiagramBox       Float TrackIdentifier Tracks BoxRenderer Tracks TrackIdentifier
 111   | DiagramBypassTop Tracks Diagram
 112   | DiagramBypassBot        Diagram Tracks
 113   | DiagramLoopTop   Tracks Diagram
 114   | DiagramLoopBot          Diagram Tracks
 115
 116 -- | get the output tracks of a diagram
 117 getOut :: Diagram -> Tracks
 118 getOut (DiagramComp f g)                     = getOut g
 119 getOut (DiagramBox wid ptop pin q pout pbot)     = pout
 120 getOut (DiagramBypassTop p f)                = TT p (getOut f)
 121 getOut (DiagramBypassBot f p)                = TT (getOut f) p
 122 getOut (DiagramLoopTop t d)                  = case getOut d of { TT z y -> y ; _ -> error "DiagramLoopTop: mismatch" }
 123 getOut (DiagramLoopBot d t)                  = case getOut d of { TT y z -> y ; _ -> error "DiagramLoopBot: mismatch" }
 124
 125 -- | get the input tracks of a diagram
 126 getIn :: Diagram -> Tracks
 127 getIn (DiagramComp f g)                      = getIn f
 128 getIn (DiagramBox wid ptop pin q pout pbot)      = pin
 129 getIn (DiagramBypassTop p f)                 = TT p (getIn f)
 130 getIn (DiagramBypassBot f p)                 = TT (getIn f) p
 131 getIn (DiagramLoopTop t d)                   = case getIn d of { TT z x -> x ; _ -> error "DiagramLoopTop: mismatch" }
 132 getIn (DiagramLoopBot d t)                   = case getIn d of { TT x z -> x ; _ -> error "DiagramLoopBot: mismatch" }
 133
 134 -- | A BoxRenderer is just a routine that, given the dimensions of a
 135 -- boxes-and-wires box element, knows how to spit out a bunch of TikZ
 136 -- code that draws it
 137 type BoxRenderer =
 138     TrackPositions ->  -- resolves the TrackIdentifiers to actual y-coordinates
 139     Float          ->  -- x1
 140     Float          ->  -- y1
 141     Float          ->  -- x2
 142     Float          ->  -- y2
 143     String             -- TikZ code
 144 noRender :: BoxRenderer
 145 noRender _ _ _ _ _ = ""
 146
 147
 148
 149
 150 ------------------------------------------------------------------------------
 151 -- Constraints
 152
 153 -- | a constraint (to be dealt with by lp_solve) relates two track identifiers
 154 data Constraint = C TrackIdentifier Ordering TrackIdentifier {- plus -} Float
 155                 | EqualSpace TrackIdentifier TrackIdentifier TrackIdentifier TrackIdentifier
 156
 157 -- instance Show Constraint where
 158 --  show (C t1 LT t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
 159 --  show (C t1 GT t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
 160 --  show (C t1 EQ t2 k s) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
 161
 162 instance Show Constraint where
 163  show (C t1 LT t2 k) = "x"++(show t1)++" <= x"++(show t2)++" + "++(show k) ++ ";\n"
 164  show (C t1 GT t2 k) = "x"++(show t1)++" >= x"++(show t2)++" + "++(show k) ++ ";\n"
 165  show (C t1 EQ t2 k) = "x"++(show t1)++"  = x"++(show t2)++" + "++(show k) ++ ";\n"
 166  show (EqualSpace t1a t1b t2a t2b) = "x"++(show t1a)++" = x"++(show t1b)++
 167                                      " + x"++(show t2a)++" - x"++(show t2b)++ ";\n"
 168
 169 -- | a monad to accumulate constraints and track the largest TrackIdentifier allocated
 170 type ConstraintM a = State (TrackIdentifier,[Constraint]) a
 171
 172 -- | pull the constraints out of the monad
 173 getConstraints :: ConstraintM [Constraint]
 174 getConstraints = do { (_,c) <- get ; return c }
 175
 176 -- | add a constraint
 177 constrain :: TrackIdentifier -> Ordering -> TrackIdentifier {- plus -} -> Float -> ConstraintM ()
 178 constrain t1 ord t2 k = do { (t,c) <- get
 179                            ; put (t, (C t1 ord t2 k):c)
 180                            ; return ()
 181                            }
 182
 183 constrainEqualSpace t1a t1b t2a t2b = do { (t,c) <- get
 184                                          ; put (t, (EqualSpace t1a t1b t2a t2b):c)
 185                                          ; return ()
 186                                          }
 187
 188 -- | simple form for equality constraints
 189 constrainEq (TT t1a t1b) (TT t2a t2b) = do { constrainEq t1a t2a ; constrainEq t1b t2b ; return () }
 190 constrainEq (T  t1     ) (T  t2     ) = constrain t1 EQ t2 0
 191 constrainEq (TU t1     ) (TU t2     ) = constrain t1 EQ t2 0
 192 constrainEq (TU t1     ) (T  t2     ) = constrain t1 EQ t2 0
 193 constrainEq (T  t1     ) (TU t2     ) = constrain t1 EQ t2 0
 194 constrainEq t1 t2                     = error $ "constrainEq mismatch: " ++ show t1 ++ " and " ++ show t2
 195
 196 -- | allocate a TrackIdentifier
 197 alloc1 :: ConstraintM Tracks
 198 alloc1 = do { (t,c) <- get
 199             ; put (t+1,c)
 200             ; return (T t)
 201             }
 202
 203 mkdiag :: ToDiagram m => GArrowPortShape m () a b -> ConstraintM Diagram
 204 mkdiag (GASPortPassthrough  inp outp m) = toDiagram (GASPortPassthrough  inp outp m)
 205 mkdiag (GASPortShapeWrapper inp outp x) = mkdiag' x
 206  where
 207  mkdiag' :: ToDiagram m => GArrowSkeleton (GArrowPortShape m ()) a b -> ConstraintM Diagram
 208
 209  mkdiag' (GAS_comp f g) = do { f' <- mkdiag' f; g' <- mkdiag' g
 210                              ; constrainEq (getOut f') (getIn g') ; return $ DiagramComp f' g' }
 211  mkdiag' (GAS_first  f) = do { (top,(TT _ x),bot) <- alloc inp; f' <- mkdiag' f ; constrainBot f' 1 (uppermost x)
 212                              ; return $ DiagramBypassBot f' x  }
 213  mkdiag' (GAS_second f) = do { (top,(TT x _),bot) <- alloc inp; f' <- mkdiag' f ; constrainTop (lowermost x) 1 f'
 214                              ; return $ DiagramBypassTop x f'  }
 215  mkdiag' (GAS_id      ) = do { (top,    x   ,bot) <- alloc inp ; simpleDiag'        "id" top x x bot        [(x,x)]  "gray!50"    }
 216  mkdiag' GAS_cancell    = do { (top,(TT x y),bot) <- alloc inp
 217                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancell" ++
 218                                                       drawWires tp x1 y x2 y "black" ++
 219                                                       drawLine  x1 (tp!lowermost x)  ((x1+x2)/2) (tp!uppermost y) "gray!50" "dashed"
 220                              ; return $ DiagramBox 2.4 top (TT x y) r y bot  }
 221  mkdiag' GAS_cancelr    = do { (top,(TT x y),bot) <- alloc inp
 222                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "cancelr" ++
 223                                                       drawWires tp x1 x x2 x "black" ++
 224                                                       drawLine  x1 (tp!uppermost y) ((x1+x2)/2) (tp!lowermost x) "gray!50" "dashed"
 225                              ; return $ DiagramBox 2.4 top (TT x y) r x bot  }
 226  mkdiag' GAS_uncancell  = do { (top,(TT x y),bot) <- alloc outp
 227                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancell" ++
 228                                                       drawWires tp x1 y x2 y "black" ++
 229                                                       drawLine  ((x1+x2)/2) (tp!uppermost y) x2 (tp!lowermost x) "gray!50" "dashed"
 230                              ; return $ DiagramBox 2.8 top y r (TT x y) bot  }
 231  mkdiag' GAS_uncancelr  = do { (top,(TT x y),bot) <- alloc outp
 232                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "uncancelr" ++
 233                                                       drawWires tp x1 x x2 x "black" ++
 234                                                       drawLine  ((x1+x2)/2) (tp!lowermost x) x2 (tp!uppermost y) "gray!50" "dashed"
 235                              ; return $ DiagramBox 2.8 top x r (TT x y) bot  }
 236  mkdiag' GAS_drop       = do { (top,    x   ,bot) <- alloc inp
 237                              ; (_,      y   ,_)   <- alloc outp
 238                              ; constrainEq x y
 239                              ; simpleDiag   "drop" top x y bot [] }
 240  mkdiag' GAS_copy       = do { (top,(TT y z),bot) <- alloc outp
 241                              ; (_  ,      x ,_)   <- alloc inp
 242                              ; constrainEqualSpace (lowermost y) (uppermost x) (lowermost x) (uppermost z)
 243                              ; let r tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 "gray!50" "copy" ++
 244                                                       drawWires tp x1 x ((x1+x2)/2) x "black" ++
 245                                                       drawWires tp ((x1+x2)/2) x x2 y "black" ++
 246                                                       drawWires tp ((x1+x2)/2) x x2 z "black"
 247                              ; return $ DiagramBox defaultWidth top x r (TT y z) bot
 248                              }
 249  mkdiag' GAS_swap       = do { (top,(TT x y),bot) <- alloc inp
 250                              ; (top,(TT x' y'),bot) <- alloc outp
 251                              ; constrainEq (T (lowermost x)) (T (lowermost x'))
 252                              ; constrainEq (T (uppermost y)) (T (uppermost y'))
 253                              ; simpleDiag'    "swap"  top (TT x y) (TT x' y') bot [(x,y'),(y,x')] "gray!50" }
 254  mkdiag' GAS_assoc      =
 255      do { (top,(TT (TT x 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" "assoc" ++
 258                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 259                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 260                     drawLine  x1      y1                          x1      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 261                     drawLine  x1      ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 262                     drawLine (x1+0.2) ((tp ! uppermost x) - 0.5) (x1+0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 263                     drawLine (x1+0.2) ((tp ! lowermost y) + 0.5)  x1      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 264                     drawLine  x1      ((tp ! lowermost y) + 0.5)  x1      y2                         "gray!50" "-"++
 265                     drawLine  x2      y2                          x2      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 266                     drawLine  x2      ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 267                     drawLine (x2-0.2) ((tp ! lowermost z) + 0.5) (x2-0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 268                     drawLine (x2-0.2) ((tp ! uppermost y) - 0.5)  x2      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 269                     drawLine  x2      ((tp ! uppermost y) - 0.5)  x2      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 (TT x y) z)
 274         ; let pout = (TT x (TT y z))
 275         ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
 276         }
 277  mkdiag' GAS_unassoc    =
 278      do { (top,(TT x (TT y z)),bot) <- alloc inp
 279         ; let r tp x1 y1 x2 y2
 280                   = drawBox (x1+0.2*xscale) y1 (x2-0.2*xscale) y2 "white" "unassoc" ++
 281                     drawLine x1 y1 x2 y1 "gray!50" "-" ++
 282                     drawLine x1 y2 x2 y2 "gray!50" "-" ++
 283                     drawLine  x2      y1                          x2      ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 284                     drawLine  x2      ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! uppermost x) - 0.5) "gray!50" "-"++
 285                     drawLine (x2-0.2) ((tp ! uppermost x) - 0.5) (x2-0.2) ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 286                     drawLine (x2-0.2) ((tp ! lowermost y) + 0.5)  x2      ((tp ! lowermost y) + 0.5) "gray!50" "-"++
 287                     drawLine  x2      ((tp ! lowermost y) + 0.5)  x2      y2                         "gray!50" "-"++
 288                     drawLine  x1      y2                          x1      ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 289                     drawLine  x1      ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! lowermost z) + 0.5) "gray!50" "-"++
 290                     drawLine (x1+0.2) ((tp ! lowermost z) + 0.5) (x1+0.2) ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 291                     drawLine (x1+0.2) ((tp ! uppermost y) - 0.5)  x1      ((tp ! uppermost y) - 0.5) "gray!50" "-"++
 292                     drawLine  x1      ((tp ! uppermost y) - 0.5)  x1      y1                         "gray!50" "-"++
 293                     drawWires tp x1 x x2 x "black" ++
 294                     drawWires tp x1 y x2 y "black" ++
 295                     drawWires tp x1 z x2 z "black"
 296         ; let pin = (TT x (TT y z))
 297         ; let pout = (TT (TT x y) z)
 298         ; return $ if draw_assoc then DiagramBox defaultWidth top pin r pout bot else DiagramBox 0 top pin noRender pout bot
 299         }
 300  mkdiag' (GAS_loopl  f) = do { f' <- mkdiag' f
 301                              ; l <- allocLoop (case (getIn f') of (TT z _) -> z ; _ -> error "GAS_loopl: mismatch")
 302                              ; constrainTop (lowermost l) loopgap f'
 303                              ; return $ DiagramLoopTop l f'  }
 304  mkdiag' (GAS_loopr  f) = do { f' <- mkdiag' f
 305                              ; l <- allocLoop (case (getIn f') of (TT _ z) -> z ; _ -> error "GAS_loopr: mismatch")
 306                              ; constrainBot f' loopgap (uppermost l)
 307                              ; return $ DiagramLoopBot f' l  }
 308  mkdiag' (GAS_misc f )  = mkdiag f
 309
 310 defaultWidth = 2
 311
 312 diagramBox :: TrackIdentifier -> Tracks -> BoxRenderer -> Tracks -> TrackIdentifier -> ConstraintM Diagram
 313 diagramBox ptop pin r pout pbot = do { constrain ptop LT (uppermost pin)  (-1)
 314                                       ; constrain pbot GT (lowermost pin)  1
 315                                       ; constrain ptop LT (uppermost pout) (-1)
 316                                       ; constrain pbot GT (lowermost pout) 1
 317                                       ; constrain ptop LT pbot (-1)
 318                                       ; return $ DiagramBox defaultWidth ptop pin r pout pbot
 319                                       }
 320 simpleDiag  text ptop pin pout pbot conn = simpleDiag' text ptop pin pout pbot conn "black"
 321 simpleDiag' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
 322   where
 323    defren tp x1 y1 x2 y2 = drawBox x1 y1 x2 y2 color text ++
 324                            concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
 325    --    ++ wires (x-1) p1  x    "green"
 326    --    ++ wires  (x+w) p2 (x+w+1) "red"
 327 simpleDiag'' text ptop pin pout pbot conn color = diagramBox ptop pin defren pout pbot
 328   where
 329    defren tp x1 y1 x2 y2 = drawBoxC x1 y1 x2 y2 color text ++
 330                            concat (map (\(x,y) -> drawWires tp x1 x x2 y "black") conn)
 331    --    ++ wires (x-1) p1  x    "green"
 332    --    ++ wires  (x+w) p2 (x+w+1) "red"
 333
 334 draw_assoc = False
 335 draw_first_second = False
 336 --draw_assoc = True
 337 --draw_first_second = True
 338
 339 -- constrain that Ports is at least Int units above the topmost portion of Diagram
 340 constrainTop :: TrackIdentifier -> Float -> Diagram -> ConstraintM ()
 341 constrainTop v i (DiagramComp d1 d2)                  = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
 342 constrainTop v i (DiagramBypassTop p d)               = constrain v LT (uppermost p) (-1 * i)
 343 constrainTop v i (DiagramBypassBot d p)               = constrainTop v (i+1) d
 344 constrainTop v i (DiagramBox wid ptop pin r pout pbot)    = constrain v LT ptop (-1 * i)
 345 constrainTop v i (DiagramLoopTop p d)                 = constrain v LT (uppermost p) (-1 * i)
 346 constrainTop v i (DiagramLoopBot d p)                 = constrainTop v (i+1) d
 347
 348 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
 349 constrainBot :: Diagram -> Float -> TrackIdentifier -> ConstraintM ()
 350 constrainBot (DiagramComp d1 d2)                  i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
 351 constrainBot (DiagramBypassTop p d)               i v = constrainBot d (i+1) v
 352 constrainBot (DiagramBypassBot d p)               i v = constrain v GT (lowermost p) 2
 353 constrainBot (DiagramBox wid ptop pin r pout pbot)    i v = constrain v GT pbot i
 354 constrainBot (DiagramLoopTop p d)                 i v = constrainBot d (i+1) v
 355 constrainBot (DiagramLoopBot d p)                 i v = constrain v GT (lowermost p) 2
 356
 357 -- | The width of a box is easy to calculate
 358 width :: TrackPositions -> Diagram -> Float
 359 width m (DiagramComp d1 d2)               = (width m d1) + 1 + (width m d2)
 360 width m (DiagramBox wid ptop pin x pout pbot) = wid
 361 width m (DiagramBypassTop p d)            = (width m d) + (if draw_first_second then 2 else 0)
 362 width m (DiagramBypassBot d p)            = (width m d) + (if draw_first_second then 2 else 0)
 363 width m (DiagramLoopTop p d)              = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
 364 width m (DiagramLoopBot d p)              = (width m d) + 2 + 2 * (loopgap + (m ! lowermost p) - (m ! uppermost p))
 365
 366 drawWires :: TrackPositions -> Float -> Tracks -> Float -> Tracks -> String -> String
 367 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
 368 drawWires tp x1 (T a)    x2 (T a')     color = drawLine x1 (tp!a) x2 (tp!a') color     "-"
 369 drawWires tp x1 (TU a)   x2 (TU a')    color = drawLine x1 (tp!a) x2 (tp!a') "gray!50" "dashed"
 370 drawWires tp _ _ _ _ _                       = error "drawwires fail"
 371
 372 wirecos :: TrackPositions -> Tracks -> [(Float,Bool)]
 373 wirecos tp (TT a b) = wirecos tp a ++ wirecos tp b
 374 wirecos tp (T  a)   = [(tp!a,True)]
 375 wirecos tp (TU a)   = [(tp!a,False)]
 376
 377 wire90 :: Float -> Float -> (Float,Float,Bool) -> String
 378 wire90 x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
 379  where
 380   color = if b then "black" else "gray!50"
 381   style = if b then "-" else "dashed"
 382   x'    = x - (y - y1) - loopgap
 383
 384 wire90' x y (y1,y2,b) = drawLine' [(x,y1),(x',y1),(x',y2),(x,y2)] color (style++",rounded corners")
 385  where
 386   color = if b then "black" else "gray!50"
 387   style = if b then "-" else "dashed"
 388   x'    = x + (y - y1) + loopgap
 389
 390 tikZ :: TrackPositions ->
 391         Diagram ->
 392         Float ->                -- horizontal position
 393         String
 394 tikZ m = tikZ'
 395  where
 396   tikZ'  d@(DiagramComp d1 d2)    x = tikZ' d1 x
 397                                       ++ wires' (x+width m d1) (getOut d1) (x+width m d1+0.5) "black" "->"
 398                                       ++ wires' (x+width m d1+0.5) (getOut d1) (x+width m d1+1) "black" "-"
 399                                       ++ tikZ' d2 (x + width m d1 + 1)
 400   tikZ' d'@(DiagramBypassTop p d) x = if not draw_first_second
 401                                       then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
 402                                       else
 403                                       let top = getTop d' in
 404                                       let bot = getBot d' in
 405                                       drawBox  x top (x+width m d') bot "gray!50" "second"
 406                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 407                                       ++ tikZ' d (x+1)
 408                                       ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
 409                                       ++ drawWires m x p (x+1+width m d+1) p "black"
 410   tikZ' d'@(DiagramBypassBot d p) x = if not draw_first_second
 411                                       then drawWires m x p (x+width m d) p "black" ++ tikZ' d x
 412                                       else
 413                                       let top = getTop d' in
 414                                       let bot = getBot d' in
 415                                       drawBox  x top (x+width m d') bot "gray!50" "first"
 416                                       ++ drawWires m x (getIn d) (x+1) (getIn d) "black"
 417                                       ++ tikZ' d (x+1)
 418                                       ++ drawWires m (x+1+width m d) (getOut d) (x+1+width m d+1) (getOut d) "black"
 419                                       ++ drawWires m x p (x+1+width m d+1) p "black"
 420   tikZ' d'@(DiagramLoopTop p d) x   = let top = getTop d' in
 421                                       let bot = getBot d' in
 422                                       let gap = loopgap + (m ! lowermost p) - (m ! uppermost p) in
 423                                       drawBox  x top (x+width m d') bot "gray!50" "loopl"
 424                                       ++ tikZ' d (x+1+gap)
 425                                       ++ drawWires m (x+1+gap) p (x+1+gap+width m d) p "black"
 426                                       ++ let p'   = case getIn d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
 427                                              pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
 428                                          in  concatMap (wire90  (x+1+gap) (m ! lowermost p)) pzip
 429                                       ++ let p'   = case getOut d of TT z _ -> z ; _ -> error "DiagramLoopTop: mismatch"
 430                                              pzip = map (\((y,b),(y',_)) -> (y,y',b)) $ zip (wirecos m p) (reverse $ wirecos m p')
 431                                          in  concatMap (wire90' (x+1+gap+width m d) (m ! lowermost p)) pzip
 432                                       ++ let rest = case getIn d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
 433                                          in  drawWires m x rest (x+1+gap) rest "black"
 434                                       ++ let rest = case getOut d of TT _ z -> z ; _ -> error "DiagramLoopTop: mismatch"
 435                                          in  drawWires m (x+1+gap+width m d) rest (x+width m d') rest "black"
 436   tikZ' d'@(DiagramLoopBot d p) x_  = error "not implemented"
 437   tikZ' d@(DiagramBox wid ptop pin r pout pbot) x = r m x (m ! ptop) (x + width m d) (m ! pbot)
 438
 439   wires x1 t x2 c = wires' x1 t x2 c "-"
 440
 441   wires' :: Float -> Tracks -> Float -> String -> String -> String
 442   wires' x1 (TT x y) x2 color st = wires' x1 x x2 color st ++ wires' x1 y x2 color st
 443   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"
 444   wires' x1 (TU v)   x2 color st = drawLine x1 (m ! v) x2 (m ! v) "gray!50" "dashed"
 445
 446   getTop :: Diagram -> Float
 447   getTop (DiagramComp d1 d2)        = min (getTop d1) (getTop d2)
 448   getTop (DiagramBox wid ptop _ _ _ _)  = m ! ptop
 449   getTop (DiagramBypassTop p d)     = (m ! uppermost p) - 1
 450   getTop (DiagramBypassBot d p)     = getTop d - 1
 451   getTop (DiagramLoopTop p d)       = (m ! uppermost p) - 1
 452   getTop (DiagramLoopBot d p)       = getTop d - 1
 453
 454   getBot :: Diagram -> Float
 455   getBot (DiagramComp d1 d2)        = max (getBot d1) (getBot d2)
 456   getBot (DiagramBox wid _ _ _ _ pbot)  = m ! pbot
 457   getBot (DiagramBypassTop p d)     = getBot d + 1
 458   getBot (DiagramBypassBot d p)     = (m ! lowermost p) + 1
 459   getBot (DiagramLoopTop p d)       = getBot d + 1
 460   getBot (DiagramLoopBot d p)       = (m ! lowermost p) + 1
 461
 462 -- allocates multiple tracks, adding constraints that they are at least one unit apart
 463 alloc :: PortShape a -> ConstraintM (TrackIdentifier,Tracks,TrackIdentifier)
 464 alloc shape = do { tracks <- alloc' shape
 465                  ; T ptop <- alloc1
 466                  ; T pbot <- alloc1
 467                  ; constrain ptop LT (uppermost tracks) (-1)
 468                  ; constrain pbot GT (lowermost tracks) 1
 469                  ; return (ptop,tracks,pbot)
 470                  }
 471  where
 472    alloc' :: PortShape a -> ConstraintM Tracks
 473    alloc' PortUnit           = do { T x <- alloc1 ; return (TU x) }
 474    alloc' (PortFree _)       = do { x <- alloc1 ; return x }
 475    alloc' (PortTensor p1 p2) = do { x1 <- alloc' p1
 476                                   ; x2 <- alloc' p2
 477                                   ; constrain (lowermost x1) LT (uppermost x2) (-1)
 478                                   ; return (TT x1 x2)
 479                                   }
 480
 481 -- allocates a second set of tracks identical to the first one but constrained only relative to each other (one unit apart)
 482 -- and upside-down
 483 allocLoop :: Tracks -> ConstraintM Tracks
 484 allocLoop (TU _)       = do { T x <- alloc1 ; return (TU x) }
 485 allocLoop (T  _)       = do { x <- alloc1   ; return x }
 486 allocLoop (TT t1 t2)   = do { x1 <- allocLoop t2
 487                             ; x2 <- allocLoop t1
 488                             ; constrain (lowermost x1) LT (uppermost x2) (-1)
 489                             ; return (TT x1 x2)
 490                             }
 491
 492 do_lp_solve :: [Constraint] -> IO String
 493 do_lp_solve c = do { let stdin = "min: x1;\n" ++ (foldl (++) "" (map show c)) ++ "\n"
 494 --                   ; putStrLn stdin
 495                    ; stdout <- readProcess "lp_solve" [] stdin
 496                    ; return stdout
 497                    }
 498
 499 splitWs :: String -> [String]
 500 splitWs s = splitWs' "" s
 501  where
 502   splitWs' [] []       = []
 503   splitWs' acc []      = [acc]
 504   splitWs' []  (' ':k) = splitWs' [] k
 505   splitWs' acc (' ':k) = acc:(splitWs' [] k)
 506   splitWs' acc (x:k)   = splitWs' (acc++[x]) k
 507
 508 lp_solve_to_trackpos :: String -> TrackPositions
 509 lp_solve_to_trackpos s = toTrackPos $ map parse $ catMaybes $ map grab $ lines s
 510  where
 511    grab ('x':k) = Just k
 512    grab _       = Nothing
 513    parse :: String -> (Int,Float)
 514    parse s = case splitWs s of
 515                [a,b] -> (read a, read b)
 516                _     -> error "parse: should not happen"
 517    toTrackPos :: [(Int,Float)] -> TrackPositions
 518    toTrackPos []           tr = 0 -- error $ "could not find track "++show tr
 519    toTrackPos ((i,f):rest) tr = if (i==tr) then f else toTrackPos rest tr
 520
 521
 522 toTikZ :: (ToDiagram m, Detect m) => GArrowSkeleton m a b -> IO String
 523 toTikZ g =
 524     let cm = do { let g' = detectShape g
 525                 ; g'' <- mkdiag g'
 526                 ; return g''
 527                 }
 528      in do { let (_,constraints) = execState cm (0,[])
 529            ; lps <- do_lp_solve $ constraints
 530            ; let m = lp_solve_to_trackpos lps
 531            ; let d = evalState cm (0,[])
 532            ; let t = tikZ m d 1
 533            ; return (t ++ drawWires m 0             (getIn  d) 1             (getIn  d) "black"
 534                        ++ drawWires m (width m d+1) (getOut d) (width m d+2) (getOut d) "black")
 535            }
 536
 537 tikz_header =
 538   "\\documentclass{article}\n" ++
 539   "\\usepackage[paperwidth=\\maxdimen,paperheight=\\maxdimen]{geometry}\n" ++
 540   "\\usepackage{tikz}\n" ++
 541   "\\usepackage{amsmath}\n" ++
 542   "\\usepackage[tightpage,active]{preview}\n" ++
 543   "\\begin{document}\n" ++
 544   "\\setlength\\PreviewBorder{5pt}\n" ++
 545   "\\begin{preview}\n" ++
 546   "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]\n"
 547
 548 tikz_footer =
 549   "\\end{tikzpicture}\n" ++
 550   "\\end{preview}\n" ++
 551   "\\end{document}\n"
 552
 553 tikz example =
 554    do putStrLn tikz_header
 555       tikz <- toTikZ example
 556       putStrLn tikz
 557       putStrLn tikz_footer
 558
 559 -- Random TikZ routines
 560 textc x y text color =
 561     "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
 562     "{{\\tt{"++text++"}}};\n"
 563
 564 drawBox x1 y1 x2 y2 color text =
 565     "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
 566     "{{\\tt{"++text++"}}};\n"
 567     ++
 568     "\\path[draw,color="++color++"]"++
 569        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
 570            show (x2*xscale)++","++show (y2*yscale)++");\n"
 571
 572 drawBoxC x1 y1 x2 y2 color text =
 573     "\\node[anchor=center] at ("++show ((x1+x2)*xscale/2)++"cm,"++show ((y1+y2)*yscale/2)++"cm) "++
 574     "{{\\tt{"++text++"}}};\n"
 575     ++
 576     "\\path[draw,color="++color++"]"++
 577        " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
 578            show (x2*xscale)++","++show (y2*yscale)++");\n"
 579
 580 drawLine x1 y1 x2 y2 color style =
 581   "\\path[draw,color="++color++","++style++"] "++
 582   "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
 583   "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
 584
 585 drawLine' [] color style = ""
 586 drawLine' (xy1:xy) color style =
 587   "\\path[draw,color="++color++","++style++"] "++
 588   foldl (\x y -> x ++ " -- " ++ y) (f xy1) (map f xy)
 589   ++ ";\n"
 590    where
 591      f = (\(x,y) -> "("++show (x*xscale)++","++show (y*yscale)++")")
 592
 593 -- | x scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 594 xscale = 1
 595
 596 -- | y scaling factor for the entire diagram, since TikZ doesn't scale font sizes
 597 yscale = 1
 598
 599 -- | extra gap placed between loopback wires and the contents of the loop module
 600 loopgap = 1