module Dvda.Vis ( previewGraph
, previewGraph'
) where
import Control.Concurrent ( threadDelay )
import Data.GraphViz ( Labellable, toLabelValue, preview )
import Data.GraphViz.Attributes.Complete ( Label )
import qualified Data.Graph.Inductive as FGL
import Dvda.Expr
import Dvda.FunGraph
previewGraph :: (Ord a, Show a) => FunGraph a -> IO ()
previewGraph fg = do
preview $ toFGLGraph fg
threadDelay 10000
previewGraph' :: (Ord a, Show a) => FunGraph a -> IO ()
previewGraph' fg = do
preview $ FGL.emap (\(FGLEdge x) -> FGLEdge' x) $ toFGLGraph fg
threadDelay 10000
toFGLGraph :: FunGraph a -> FGL.Gr (FGLNode a) (FGLEdge a)
toFGLGraph fg = FGL.mkGraph fglNodes fglEdges
where
fglNodes = map (\(k,gexpr) -> (k, FGLNode (k, gexpr))) $ fgReified fg
fglEdges = concatMap nodeToEdges $ fgReified fg
where
nodeToEdges (k,gexpr) = map (\p -> (p,k,FGLEdge (p,k,gexpr))) (getParents gexpr)
data FGLNode a = FGLNode (Int, GExpr a Int)
data FGLEdge a = FGLEdge (Int, Int, GExpr a Int)
data FGLEdge' a = FGLEdge' (Int, Int, GExpr a Int)
instance Eq a => Eq (FGLEdge a) where
(==) (FGLEdge (p0,k0,g0)) (FGLEdge (p1,k1,g1)) = (==) (p0,k0,g0) (p1,k1,g1)
instance Eq a => Eq (FGLEdge' a) where
(==) (FGLEdge' (p0,k0,g0)) (FGLEdge' (p1,k1,g1)) = (==) (p0,k0,g0) (p1,k1,g1)
instance Ord a => Ord (FGLEdge a) where
compare (FGLEdge (p0,k0,g0)) (FGLEdge (p1,k1,g1)) = compare (p0,k0,g0) (p1,k1,g1)
instance Ord a => Ord (FGLEdge' a) where
compare (FGLEdge' (p0,k0,g0)) (FGLEdge' (p1,k1,g1)) = compare (p0,k0,g0) (p1,k1,g1)
instance Labellable (FGLEdge a) where
toLabelValue (FGLEdge (p,k,_)) = toLabelValue $ show p ++ " --> " ++ show k
instance Show a => Labellable (FGLEdge' a) where
toLabelValue (FGLEdge' (_,_,gexpr)) = toLabelValue $ show gexpr
tlv :: Int -> String -> Label
tlv k s = toLabelValue $ show k ++ ": " ++ s
instance Show a => Labellable (FGLNode a) where
toLabelValue (FGLNode (k, (GSym s))) = tlv k (show s)
toLabelValue (FGLNode (k, (GConst c))) = tlv k (show c)
toLabelValue (FGLNode (k, (GNum (Mul _ _)))) = tlv k "*"
toLabelValue (FGLNode (k, (GNum (Add _ _)))) = tlv k "+"
toLabelValue (FGLNode (k, (GNum (Sub _ _)))) = tlv k "-"
toLabelValue (FGLNode (k, (GNum (Negate _)))) = tlv k "-"
toLabelValue (FGLNode (k, (GNum (Abs _)))) = tlv k "abs"
toLabelValue (FGLNode (k, (GNum (Signum _)))) = tlv k "signum"
toLabelValue (FGLNode (k, (GNum (FromInteger x)))) = tlv k (show x)
toLabelValue (FGLNode (k, (GFractional (Div _ _)))) = tlv k "/"
toLabelValue (FGLNode (k, (GFractional (FromRational x)))) = tlv k (show (fromRational x :: Double))
toLabelValue (FGLNode (k, (GFloating (Pow _ _)))) = tlv k "**"
toLabelValue (FGLNode (k, (GFloating (LogBase _ _)))) = tlv k "logBase"
toLabelValue (FGLNode (k, (GFloating (Exp _)))) = tlv k "exp"
toLabelValue (FGLNode (k, (GFloating (Log _)))) = tlv k "log"
toLabelValue (FGLNode (k, (GFloating (Sin _)))) = tlv k "sin"
toLabelValue (FGLNode (k, (GFloating (Cos _)))) = tlv k "cos"
toLabelValue (FGLNode (k, (GFloating (ASin _)))) = tlv k "asin"
toLabelValue (FGLNode (k, (GFloating (ATan _)))) = tlv k "atan"
toLabelValue (FGLNode (k, (GFloating (ACos _)))) = tlv k "acos"
toLabelValue (FGLNode (k, (GFloating (Sinh _)))) = tlv k "sinh"
toLabelValue (FGLNode (k, (GFloating (Cosh _)))) = tlv k "cosh"
toLabelValue (FGLNode (k, (GFloating (Tanh _)))) = tlv k "tanh"
toLabelValue (FGLNode (k, (GFloating (ASinh _)))) = tlv k "asinh"
toLabelValue (FGLNode (k, (GFloating (ATanh _)))) = tlv k "atanh"
toLabelValue (FGLNode (k, (GFloating (ACosh _)))) = tlv k "acosh"