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