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