1 {-# OPTIONS_GHC -XModalTypes -XMultiParamTypeClasses -XNoMonoPatBinds -XKindSignatures -XGADTs -XFlexibleContexts -XFlexibleInstances -XTypeOperators -XUndecidableInstances -XTypeFamilies #-}
2 module GArrowTikZ (tikz, tikz', GArrowTikZ(..))
4 import Prelude hiding ( id, (.), lookup )
5 import Control.Category
6 import GHC.HetMet.GArrow
7 import Data.List hiding (lookup, insert)
8 import Data.Map hiding (map, (!))
10 import GHC.HetMet.Private
14 - have "resolve" turn a (Diagram UnifVal) into (Diagram Int)
16 - bias right now is for all edges to be uppermost; try for bias
17 towards smallest nodes?
18 - curvy boxes (like XOR gates)
22 -- a unification value is basically a LISP-ish expression
27 instance Unifiable UVal where
28 unify' (UVVal vl1) (UVVal vl2)
29 | length vl1 /= length vl2 = error "length mismatch during unification"
30 | otherwise = foldr mergeU emptyUnifier (map (\(x,y) -> unify x y) $ zip vl1 vl2)
31 unify' _ _ = error "impossible"
33 project (UVVar v) = Just v
35 occurrences (UVVar v) = [v]
36 occurrences (UVVal vl) = concatMap occurrences vl
38 -- | Resolves a unification variable; the answer to this query will change if subsequent unifications are performed
39 getU' :: Unifier UVal -> UVal -> UVal
40 getU' u (UVVal vl) = UVVal $ map (getU' u) vl
41 getU' u x@(UVVar v) = case Unify.getU u v of
49 -- | Render a fully-polymorphic GArrow term as a boxes-and-wires diagram using TikZ
52 type Constraints = [(UVal, Int, UVal)]
54 -- the unification monad
55 data UyM t a = UyM (([UVar],Unifier UVal,Constraints) -> ([UVar],Unifier UVal,Constraints,a))
56 instance Monad (UyM t)
58 return x = UyM $ \(i,u,k) -> (i,u,k,x)
59 (UyM f) >>= g = UyM $ \(i,u,k) -> let (i',u',k',x) = f (i,u,k) in let UyM g' = g x in g' (i',u',k')
62 getU = UyM $ \(i,u,k) -> (i,u,k,u)
63 getM v = UyM $ \(i,u,k) -> (i,u,k,getU' u v)
64 occursU v x = UyM $ \(i,u,k) -> (i,u,k,occurs u v x)
65 unifyM :: Eq t => UVal -> UVal -> UyM t ()
66 unifyM v1 v2 = UyM $ \(i,u,k) -> (i,mergeU u (unify v1 v2),k,())
68 freshU = UyM $ \(i:is,u,k) -> (is,u,k,i)
69 constrain :: UVal -> Int -> UVal -> UyM t ()
70 constrain v1 d v2 = UyM $ \(i,u,k) -> (i,u,((v1,d,v2):k),())
71 getK :: UyM t [(UVal, Int, UVal)]
72 getK = UyM $ \(i,u,k) -> (i,u,k,k)
73 runU :: UyM t a -> ([UVar],Unifier UVal,Constraints,a)
74 runU (UyM f) = (f (uvarSupply,emptyUnifier,[]))
76 data GArrowTikZ :: * -> * -> *
78 TikZ_const :: Int -> GArrowTikZ () Int
79 TikZ_id :: GArrowTikZ x x
80 TikZ_comp :: GArrowTikZ y z -> GArrowTikZ x y -> GArrowTikZ x z
81 TikZ_first :: GArrowTikZ x y -> GArrowTikZ (x**z) (y**z)
82 TikZ_second :: GArrowTikZ x y -> GArrowTikZ (z**x) (z**y)
83 TikZ_cancell :: GArrowTikZ (()**x) x
84 TikZ_cancelr :: GArrowTikZ (x**()) x
85 TikZ_uncancell :: GArrowTikZ x (()**x)
86 TikZ_uncancelr :: GArrowTikZ x (x**())
87 TikZ_assoc :: GArrowTikZ ((x**y)**z) (x**(y**z))
88 TikZ_unassoc :: GArrowTikZ (x**(y**z)) ((x**y)**z)
89 TikZ_drop :: GArrowTikZ x ()
90 TikZ_copy :: GArrowTikZ x (x**x)
91 TikZ_swap :: GArrowTikZ (x**y) (y**x)
92 TikZ_merge :: GArrowTikZ (x**y) z
93 TikZ_loopl :: GArrowTikZ (x**z) (y**z) -> GArrowTikZ x y
94 TikZ_loopr :: GArrowTikZ (z**x) (z**y) -> GArrowTikZ x y
97 -- Technically this instance violates the laws (and RULEs) for
98 -- Control.Category; the compiler might choose to optimize (f >>> id)
99 -- into f, and this optimization would produce a change in behavior
100 -- below. In practice this means that the user must be prepared for
101 -- the rendered TikZ diagram to be merely *equivalent to* his/her
102 -- term, rather than structurally exactly equal to it.
104 instance Category GArrowTikZ where
108 instance GArrow GArrowTikZ (**) () where
109 ga_first = TikZ_first
110 ga_second = TikZ_second
111 ga_cancell = TikZ_cancell
112 ga_cancelr = TikZ_cancelr
113 ga_uncancell = TikZ_uncancell
114 ga_uncancelr = TikZ_uncancelr
115 ga_assoc = TikZ_assoc
116 ga_unassoc = TikZ_unassoc
118 instance GArrowDrop GArrowTikZ (**) () where
121 instance GArrowCopy GArrowTikZ (**) () where
124 instance GArrowSwap GArrowTikZ (**) () where
127 instance GArrowLoop GArrowTikZ (**) () where
128 ga_loopl = TikZ_loopl
129 ga_loopr = TikZ_loopr
131 type instance GArrowTensor GArrowTikZ = (,)
132 type instance GArrowUnit GArrowTikZ = ()
133 type instance GArrowExponent GArrowTikZ = (->)
135 instance GArrowSTKC GArrowTikZ
138 name :: GArrowTikZ a b -> String
140 name (TikZ_const i) = "const " ++ show i
141 name (TikZ_comp _ _) = "comp"
142 name (TikZ_first _ ) = "first"
143 name (TikZ_second _ ) = "second"
144 name TikZ_cancell = "cancell"
145 name TikZ_cancelr = "cancelr"
146 name TikZ_uncancell = "uncancell"
147 name TikZ_uncancelr = "uncancelr"
148 name TikZ_drop = "drop"
149 name TikZ_copy = "copy"
150 name TikZ_swap = "swap"
151 name (TikZ_loopl _ ) = "loopl"
152 name (TikZ_loopr _ ) = "loopr"
153 name TikZ_assoc = "assoc"
154 name TikZ_unassoc = "unassoc"
156 fresh1 :: UyM () Ports
157 fresh1 = do { x <- freshU
161 fresh2 :: UyM () (Ports,Ports)
162 fresh2 = do { x <- freshU
164 ; constrain (UVVar x) 1 (UVVar y)
165 ; return $ (UVVar x,UVVar y)
168 fresh3 :: UyM () (Ports,Ports,Ports)
169 fresh3 = do { x <- freshU
172 ; constrain (UVVar x) 1 (UVVar y)
173 ; constrain (UVVar y) 1 (UVVar z)
174 ; return $ (UVVar x,UVVar y,UVVar z)
177 fresh4 :: UyM () (Ports,Ports,Ports,Ports)
178 fresh4 = do { x1 <- freshU
182 ; constrain (UVVar x1) 1 (UVVar x2)
183 ; constrain (UVVar x2) 1 (UVVar x3)
184 ; constrain (UVVar x3) 1 (UVVar x4)
185 ; return $ (UVVar x1,UVVar x2,UVVar x3,UVVar x4)
188 fresh5 :: UyM () (Ports,Ports,Ports,Ports,Ports)
189 fresh5 = do { x1 <- freshU
194 ; constrain (UVVar x1) 1 (UVVar x2)
195 ; constrain (UVVar x2) 1 (UVVar x3)
196 ; constrain (UVVar x3) 1 (UVVar x4)
197 ; constrain (UVVar x4) 1 (UVVar x5)
198 ; return $ (UVVar x1,UVVar x2,UVVar x3,UVVar x4,UVVar x5)
204 --example = ga_first ga_drop >>> ga_cancell >>> ga_first id >>> ga_swap >>> ga_first id >>> TikZ_merge
205 --example :: forall x y z. forall g. (GArrow g (,) (), GArrowCopy g (,) (), GArrowSwap g (,) ()) => g x ((x,x),x)
206 --example = ga_copy >>> ga_second ga_copy >>> ga_second (ga_first id) >>> ga_unassoc >>> ga_first ga_swap
207 --example = ga_copy >>> ga_second ga_copy >>> ga_second (ga_second id) >>> ga_unassoc >>> ga_first id >>> ga_first ga_swap
208 --example :: forall x. forall g. (GArrow g (,) (), GArrowCopy g (,) (), GArrowSwap g (,) ()) => g x x
209 --example = id >>> id
211 data Diagram p = DiagramComp (Diagram p) (Diagram p)
212 | DiagramPrim String p p p p (String -> Int -> Int -> Int -> p -> p -> Int -> String)
213 | DiagramBypassTop p (Diagram p)
214 | DiagramBypassBot (Diagram p) p
215 -- | DiagramLoopTop Diagram
216 -- | DiagramLoopBot Diagram
220 getOut :: Diagram Ports -> Ports
221 getOut (DiagramComp f g) = getOut g
222 getOut (DiagramPrim s ptop pin pout pbot _) = pout
223 getOut (DiagramBypassTop p f) = UVVal [p, (getOut f)]
224 getOut (DiagramBypassBot f p) = UVVal [(getOut f), p]
226 getIn :: Diagram Ports -> Ports
227 getIn (DiagramComp f g) = getIn f
228 getIn (DiagramPrim s ptop pin pout pbot _) = pin
229 getIn (DiagramBypassTop p f) = UVVal [p, (getIn f)]
230 getIn (DiagramBypassBot f p) = UVVal [(getIn f), p]
232 -- constrain that Ports is at least Int units above the topmost portion of Diagram
233 constrainTop :: Ports -> Int -> Diagram Ports -> UyM () ()
234 constrainTop v i (DiagramComp d1 d2) = do { constrainTop v i d1 ; constrainTop v i d2 ; return () }
235 constrainTop v i (DiagramBypassTop p d) = constrain v 2 p
236 constrainTop v i (DiagramBypassBot d p) = constrainTop v (i+1) d
237 constrainTop v i (DiagramPrim s ptop pin pout pbot _) = constrain v i ptop
239 -- constrain that Ports is at least Int units below the bottommost portion of Diagram
240 constrainBot :: Diagram Ports -> Int -> Ports -> UyM () ()
241 constrainBot (DiagramComp d1 d2) i v = do { constrainBot d1 i v ; constrainBot d2 i v ; return () }
242 constrainBot (DiagramBypassTop p d) i v = constrainBot d (i+1) v
243 constrainBot (DiagramBypassBot d p) i v = constrain p 2 v
244 constrainBot (DiagramPrim s ptop pin pout pbot _) i v = constrain pbot i v
246 ga2diag :: GArrowTikZ a b -> UyM () (Diagram Ports)
247 ga2diag (TikZ_id ) = do { (top,x,bot) <- fresh3 ; return $ DiagramPrim "id" top x x bot defren }
248 ga2diag (TikZ_comp g f) = do { f' <- ga2diag f
250 ; unifyM (getOut f') (getIn g')
251 ; return $ DiagramComp f' g' }
252 ga2diag (TikZ_first f) = do { x <- fresh1; f' <- ga2diag f ; constrainBot f' 1 x ; return $ DiagramBypassBot f' x }
253 ga2diag (TikZ_second f) = do { x <- fresh1; f' <- ga2diag f ; constrainTop x 1 f' ; return $ DiagramBypassTop x f' }
254 ga2diag TikZ_cancell = do { (top,x,y ,bot) <- fresh4 ; return $ DiagramPrim "cancell" top (UVVal [x,y]) y bot defren }
255 ga2diag TikZ_cancelr = do { (top,x,y ,bot) <- fresh4 ; return $ DiagramPrim "cancelr" top (UVVal [x,y]) x bot defren }
256 ga2diag TikZ_uncancell = do { (top,x,y ,bot) <- fresh4 ; return $ DiagramPrim "uncancell" top y (UVVal [x,y]) bot defren }
257 ga2diag TikZ_uncancelr = do { (top,x,y ,bot) <- fresh4 ; return $ DiagramPrim "uncancelr" top x (UVVal [x,y]) bot defren }
258 ga2diag TikZ_drop = do { (top,x ,bot) <- fresh3 ; return $ DiagramPrim "drop" top x x bot defren }
259 ga2diag (TikZ_const i) = do { (top,x ,bot) <- fresh3 ; return $ DiagramPrim ("const " ++ show i) top x x bot defren }
260 ga2diag TikZ_copy = do { (top,x,y,z,bot) <- fresh5
261 ; return $ DiagramPrim "copy" top y (UVVal [x,z]) bot defren }
262 ga2diag TikZ_merge = do { (top,x,y,z,bot) <- fresh5
263 ; return $ DiagramPrim "merge" top (UVVal [x,z]) y bot defren }
264 ga2diag TikZ_swap = do { (top,x,y ,bot) <- fresh4
265 ; return $ DiagramPrim "swap" top (UVVal [x,y]) (UVVal [x,y]) bot defren }
266 ga2diag TikZ_assoc = do { (top,x,y,z,bot) <- fresh5
267 ; return $ DiagramPrim "assoc" top (UVVal [UVVal [x,y],z])(UVVal [x,UVVal [y,z]]) bot defren }
268 ga2diag TikZ_unassoc = do { (top,x,y,z,bot) <- fresh5
269 ; return $ DiagramPrim "unassoc" top (UVVal [x,UVVal [y,z]])(UVVal [UVVal [x,y],z]) bot defren }
270 ga2diag (TikZ_loopl f) = error "not implemented"
271 ga2diag (TikZ_loopr f) = error "not implemented"
273 defren :: String -> Int -> Int -> Int -> Ports -> Ports -> Int -> String
274 defren s x w top p1 p2 bot
275 = drawBox x top (x+w) bot "black" s
276 -- ++ wires (x-1) p1 x "green"
277 -- ++ wires (x+w) p2 (x+w+1) "red"
282 textc x y text color =
283 "\\node[anchor=center,color="++color++"] at ("++show (x*xscale)++"cm,"++show (y*yscale)++"cm) "++
284 "{{\\tt{"++text++"}}};\n"
286 drawBox x1 y1 x2 y2 color text =
287 "\\node[anchor=north west] at ("++show (x1*xscale)++"cm,"++show (y1*yscale)++"cm) "++
288 "{{\\tt{"++text++"}}};\n"
290 "\\path[draw,color="++color++"]"++
291 " ("++show (x1*xscale)++","++show (y1*yscale)++") rectangle ("++
292 show (x2*xscale)++","++show (y2*yscale)++");\n"
294 drawLine x1 y1 x2 y2 color style =
295 "\\path[draw,color="++color++","++style++"] "++
296 "("++show (x1*xscale)++","++show (y1*yscale)++") -- " ++
297 "("++show (x2*xscale)++","++show (y2*yscale)++");\n"
299 width :: Diagram Ports -> Int
300 width (DiagramComp d1 d2) = (width d1) + 1 + (width d2)
301 width (DiagramPrim s _ p1 p2 _ _) = 2
302 width (DiagramBypassTop p d) = (width d) + 2
303 width (DiagramBypassBot d p) = (width d) + 2
305 (!) :: Map UVar Int -> UVar -> Int
306 m ! x = case lookup x m of
310 tikZ :: Map UVar Int ->
312 Int -> -- horizontal position
316 tikZ' d@(DiagramComp d1 d2) x = tikZ' d1 x
317 ++ wires (x+width d1) (getOut d1) (x+width d1+1) "black"
318 ++ tikZ' d2 (x + width d1 + 1)
319 tikZ' d'@(DiagramBypassTop p d) x = let top = getTop d' in
320 let bot = getBot d' in
321 drawBox x top (x+width d') bot "gray!50" "second"
322 ++ drawLine x (top+1) (x+width d') (top+1) "black" "->"
323 ++ wires x (getIn d) (x+1) "black"
325 ++ wires (x+1+width d) (getOut d) (x+1+width d+1) "black"
326 tikZ' d'@(DiagramBypassBot d p) x = let top = getTop d' in
327 let bot = getBot d' in
328 drawBox x top (x+width d') bot "gray!50" "first"
329 ++ drawLine x (bot-1) (x+width d') (bot-1) "black" "->"
330 ++ wires x (getIn d) (x+1) "black"
332 ++ wires (x+1+width d) (getOut d) (x+1+width d+1) "black"
333 tikZ' d@(DiagramPrim s (UVVar top) p1 p2 (UVVar bot) r) x = r s x (width d) (m ! top) p1 p2 (m ! bot)
335 wires :: Int -> Ports -> Int -> String -> String
336 wires x1 (UVVar v) x2 color = drawLine x1 (m ! v) x2 (m ! v) color "->"
337 -- ++ textc ((x1+x2) `div` 2) (m!v) (show v) "purple"
338 wires x1 (UVVal vl) x2 color = foldr (\x y -> x ++ " " ++ y) [] (map (\v -> wires x1 v x2 color) vl)
340 getTop :: Diagram Ports -> Int
341 getTop (DiagramComp d1 d2) = min (getTop d1) (getTop d2)
342 getTop (DiagramBypassTop p d) = (m ! getleft p) - 1
343 getTop (DiagramBypassBot d p) = getTop d - 1
344 getTop (DiagramPrim s (UVVar ptop) _ _ _ _) = m ! ptop
346 getBot :: Diagram Ports -> Int
347 getBot (DiagramComp d1 d2) = max (getBot d1) (getBot d2)
348 getBot (DiagramBypassTop p d) = getBot d + 1
349 getBot (DiagramBypassBot d p) = (m ! getright p) + 1
350 getBot (DiagramPrim s _ _ _ (UVVar pbot) _) = m ! pbot
352 resolve' (DiagramComp d1 d2) = do { d1' <- resolve' d1 ; d2' <- resolve' d2 ; return $ DiagramComp d1' d2' }
353 resolve' (DiagramBypassTop p d) = do { p' <- getM p ; d' <- resolve' d ; return $ DiagramBypassTop p' d' }
354 resolve' (DiagramBypassBot d p) = do { p' <- getM p ; d' <- resolve' d ; return $ DiagramBypassBot d' p' }
355 resolve' (DiagramPrim s ptop pin pout pbot r)
356 = do { ptop' <- getM ptop
360 ; return $ DiagramPrim s ptop' pin' pout' pbot' r }
362 getleft (UVVar v) = v
363 getleft (UVVal vl) = getleft (head vl)
365 getright (UVVar v) = v
366 getright (UVVal vl) = getright (last vl)
368 strip :: [(Ports,Int,Ports)] -> [(UVar,Int,UVar)]
369 strip = map (\(v1,x,v2) -> (getright v1, x, getleft v2))
372 -- must use bubblesort because the ordering isn't transitive
373 sortit :: [(UVar,Int,UVar)] -> [(UVar,Int,UVar)]
374 sortit x = stupidSort x []
377 stupidSort (h:t) x = stupidSort t (stupidInsert h x)
379 stupidInsert t [] = [t]
380 stupidInsert t@(_,_,t') ((a@(_,_,a')):b) = if cmp' x t' a' == LT
382 else a:(stupidInsert t b)
384 cmp' :: [(UVar,Int,UVar)] -> UVar -> UVar -> Ordering
385 cmp' [] a b = EQ -- compare a b
386 cmp' ((v1,_,v2):r) a b = if a == v1 && b==v2
388 else if a == v2 && b==v1
392 lookup'' :: Map UVar Int -> UVar -> Int
393 lookup'' m x = case lookup x m of
397 valuatit :: Map UVar Int -> [(UVar,Int,UVar)] -> Map UVar Int
399 valuatit m ((v1,k,v2):r) = valuatit m' r
402 v2' = max (lookup'' m v2) (k+(lookup'' m v1))
404 resolve'k :: UyM () [(Ports,Int,Ports)]
405 resolve'k = do { k <- getK
406 ; k' <- mapM (\(v1,x,v2) -> do { v1' <- getM v1 ; v2' <- getM v2 ; return (v1',x,v2') }) k
410 toTikZ :: GArrowTikZ a b -> String
411 toTikZ g = tikZ m d 0
413 (_,_,_,(d,k)) = runU $ do { d <- ga2diag g
419 toTikZ' :: GArrowTikZ a b -> String
420 toTikZ' g = foldr (\x y -> x++"\\\\\n"++y) [] (map foo s)
422 (_,_,_,k) = runU $ ga2diag g >>= resolve' >>= \_ -> resolve'k
423 foo (v1,v,v2) = "x_{"++show v1++"} + "++show v++" \\leq x_{"++show v2++"} = " ++ (show $ lookup'' m v2)
427 tikz' :: (forall g a . PGArrow g (GArrowUnit g) a -> PGArrow g (GArrowUnit g) a) -> IO ()
428 tikz' x = tikz $ unG (x (PGArrowD { unG = TikZ_const 12 }))
429 main = do putStrLn "hello"
431 = do putStrLn "\\documentclass{article}"
432 putStrLn "\\usepackage[landscape,paperheight=20in,textwidth=19in]{geometry}"
433 putStrLn "\\usepackage{tikz}"
434 putStrLn "\\usepackage{amsmath}"
435 putStrLn "\\begin{document}"
436 putStrLn $ "\\begin{tikzpicture}[every on chain/.style={join=by ->},yscale=-1]"
437 putStrLn (toTikZ example)
438 putStrLn "\\end{tikzpicture}"
439 -- putStrLn "\\begin{align*}"
440 -- putStr (toTikZ' example)
441 -- putStrLn "\\end{align*}"
442 putStrLn "\\end{document}"