{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-} ---------------------------------------------------------------------------------------------------- -- This module includes visualization code which has numerous extra -- dependencies compared to the rest of the spec tool's code. ---------------------------------------------------------------------------------------------------- module Intel.Cnc.Spec.CncViz where import Intel.Cnc.Spec.TraceVacuum import Intel.Cnc.Spec.CncGraph -- import Intel.Cnc.Spec.Curses () -- Disabling for now to avoid build deps [2011.08.12]; not used yet. import Intel.Cnc.Spec.Util import qualified Intel.Cnc.Spec.Passes.ReadHarch as H import qualified Data.Graph.Inductive as G import Data.Graph.Inductive.Query.DFS import Data.Maybe import Data.Char import qualified Data.ByteString.Char8 as B import qualified Data.Map as M import qualified Data.IntMap as IM import qualified Data.Set as S import qualified Data.List as L import qualified StringTable.AtomSet as AS import qualified StringTable.AtomMap as AM import StringTable.Atom import Control.Monad import qualified Control.Monad.Reader as R import Graphics.Ubigraph as Ub import qualified Data.GraphViz as Gv import System.Posix.Unistd import System.Posix.Env -- There are various options for trying to improve the stringmaps used in this program: -- --import qualified Data.Map.StringMap as SM -- from TernaryTrees --import qualified Data.Map.TernaryMap as TM -- from TernaryTrees --import qualified Data.ListTrie.Patricia.Map as PM import qualified Data.Map as SM -- Data.Map serves as StringMap for now. import Debug.Trace default_server_url = "http://127.0.0.1:20738/RPC2" ---------------------------------------------------------------------------------------------------- -- Graph Visualization -- Draw a cnc spec through graphviz: cncGraphviz = -- This is easy because the graphviz wrapper uses fgl. error "TODO: IMPLEMENT ME" -------------------------------------------------------------------------------- -- Display a cncgraph through ubigraph: cncUbigraph :: Bool -> CncGraph -> IO () cncUbigraph interactive gr = do server_url <- getEnvDefault "UBIGRAPH_SERVER" default_server_url putStrLn$ "DRAWING UBIGRAPH, total nodes "++ show (length sorted) initHubigraph server_url >>= runHubigraph go --r $ mkRing 10 where r x = initHubigraph default_server_url >>= runHubigraph x sorted = topsort gr contexts = map (G.context gr) sorted go = do clear stepstyle <- newVStyle 0 itemstyle <- newVStyle 0 tagstyle <- newVStyle 0 mapM_ (flip setVStyleAttr stepstyle) (defaultStepAttr) mapM_ (flip setVStyleAttr itemstyle) (defaultItemAttr) mapM_ (flip setVStyleAttr tagstyle) (defaultTagAttr) --let eshared = [EOriented True, ESpline True, EStrength 1.0] --let eshared = [EOriented True, ESpline True, EStrength 0.001] let eshared = [EOriented True] -- EArrow True baseEstyle <- newEStyle 0 mapM_ (flip setEStyleAttr baseEstyle) eshared producestyle <- newEStyle baseEstyle consumestyle <- newEStyle baseEstyle prescribestyle <- newEStyle baseEstyle mapM_ (flip setEStyleAttr producestyle)$ [EColor "#ff4444", EWidth 2.5] mapM_ (flip setEStyleAttr consumestyle)$ [EColor "#44ff44", EWidth 2.5] mapM_ (flip setEStyleAttr prescribestyle)$ [EColor "#666666"] ++ eshared -- Currently doing a two-phased add, but I don't actually like this: -- (I want to see it appear with the dataflow.) forM_ contexts $ \ (prev, id, label, _) -> do newVertexWithID id case label of CGSteps atom -> do changeVStyle stepstyle id setVAttr (VLabel$ fromAtom atom) id if fromAtom atom == special_environment_name then do setVAttr (VColor "#ffff00") id setVAttr (VLabel "env IN") id newVertexWithID (-1) changeVStyle stepstyle (-1) setVAttr (VLabel "env OUT") (-1) setVAttr (VColor "#ffff00") (-1) else return False CGItems atom -> do changeVStyle itemstyle id setVAttr (VLabel$ fromAtom atom) id CGTags atom -> do changeVStyle tagstyle id setVAttr (VLabel$ fromAtom atom) id -- FIXME!!! DOUBLE CHECK.. do GET edges flow from the ITEM to the STEP? (re: gravity) forM_ contexts $ \ (prev, id, label, _) -> forM_ prev $ \ (_,p) -> case label of CGSteps a | fromAtom a == special_environment_name -> do edge <- newEdge (p,-1) changeEStyle consumestyle edge _ -> do edge <- newEdge (p,id) (flip changeEStyle edge) (case fromJust$ G.lab gr p of (CGSteps _) -> producestyle (CGItems _) -> consumestyle (CGTags _) -> prescribestyle) -- ABSTRACTION VIOLATION? Is the hubigraph monad supposed to be opaque? -- In interactive mode we bring up a prompt... should do this with ncurses: R.lift$ putStrLn "Going into interactive CnC/Ubigraph visualization shell:" -- | Visualize any FGL graph in a window using GraphViz. simple_graphviz :: (nd1 -> String) -> G.Gr nd1 edge -> IO Gv.RunResult simple_graphviz lablNode gr = -- runGraphvizCanvas Dot dot Gtk Gv.runGraphvizCanvas Gv.Dot dot Gv.Xlib where dot = Gv.graphToDot params gr --params :: GraphvizParams String Int () String --params :: GraphvizParams String unknown () String --params :: GraphvizParams nd1 edge () nd1 --params = defaultParams { fmtNode= nodeAttrs } params = Gv.nonClusteredParams { Gv.fmtNode= nodeAttrs } nodeAttrs (node, x) = [ Gv.Label $ Gv.StrLabel $ lablNode x , Gv.Shape Gv.Circle -- , Color [colors !! a] -- , FillColor $ colors !! a , Gv.Style [Gv.SItem Gv.Filled []] ] -- | Using GraphViz, display a CnC graph with Harch partitioning info. harch_graphviz :: (H.HarchNode -> String) -> H.HarchSpec -> IO Gv.RunResult harch_graphviz lablNode (H.HarchSpec gr tree) = Gv.runGraphvizCanvas Gv.Dot (Gv.graphToDot params gr) Gv.Xlib where params :: Gv.GraphvizParams H.HarchNode () [Int] H.HarchNode params = Gv.defaultParams { Gv.fmtNode= nodeAttrs , Gv.clusterBy = lookup_clusters , Gv.clusterID = \ ls -> Just$ Gv.Str (show ls) , Gv.fmtCluster = clusterAttrs } -- We must take care here... there are two different numbering -- schemes. The FGL graph has a node ID, an the HarchNode has the -- number from the original harch file. It would be nice to -- guarantee these are the same, or to make them disjoint so that -- confusion is impossible. lookup_clusters :: (G.LNode H.HarchNode) -> Gv.LNodeCluster [Int] H.HarchNode lookup_clusters (ind, nd) = case IM.lookup (H.num nd) all_clusters of Nothing -> error$ "harch_graphviz: node that did not appear in the harch tree: "++ show nd Just set -> -- Convert the set using the C/N constructors: S.fold (Gv.C) (Gv.N (ind,nd)) set all_clusters = walk_tree [] tree -- Walk over the tree to build a map from nodes -> partitions. -- Partitions are named by the tree-index. walk_tree :: [Int] -> H.HarchTreeOrdered -> IM.IntMap (S.Set [Int]) walk_tree ind (H.HT part children) = let chldmaps = L.zipWith (\ i -> walk_tree (ind++[i]) ) [0..] children combined = L.foldl' (IM.unionWith S.union) IM.empty chldmaps insert acc node = IM.insertWith S.union node (S.singleton ind) acc in L.foldl' insert combined part clusterAttrs intls = [ Gv.GraphAttrs [Gv.Label$ Gv.StrLabel$ H.showTreePath intls ] ] nodeAttrs (node, x) = [ Gv.Label $ Gv.StrLabel $ lablNode x , Gv.Shape Gv.Circle -- , Color [colors !! a] -- , FillColor $ colors !! a , Gv.Style [Gv.SItem Gv.Filled []] ] ---------------------------------------------------------------------------------------------------- -- Rewind/fast-forward support -- What's the best way to create a reversible transaction log? -- Should I create Data.Sequence of some kind of actions and interpret it? data GUIAction = ChangeV NameTag [VAttr] | ChangeE Atom Atom EAttr | AddV NameTag | AddE NameTag NameTag | WaitAction -- We don't sleep between ALL actions, let's make them explicit. deriving Show -- This is a little more involved than I would like, but we may need -- to track the whole state of the drawing at each point in time. -- -- The GUI state also lets us know what's in the graph at any given point. data GUIState = GS { nodes :: AM.AtomMap GUINodeState, edges :: AM.AtomMap (AM.AtomMap GUIEdgeState), -- Map steps to the tag collections that prescribe them. prescribedBy :: AM.AtomMap Atom } -- The V/EAttr types are sum types that we wish to convert to a product type here... {- data GUINodeState = GNS { color :: String, label :: String, shape :: Ub.Shape, size :: Float -- ... } -} -- We could get into SYB generic programming here, but easier is to -- use the toPair function provided by the ubigraph library. --type GUINodeState = SM.StringMap (String) type StringMap a = M.Map String a -- The following StringMaps map the name ("size", "label") of each attribute onto its value. type GUIEdgeState = StringMap EAttr -- I also add a "count" to nodes to track how many instances they contain. data GUINodeState = GNS { count :: Int, props :: StringMap VAttr } deriving Show --type LogEvent = (GUIAction, GUIState) instance Show VAttr where -- show vat = show (toPair vat) show vat = let (hd:tl,b) = toPair vat in "V"++ (toUpper hd : tl) ++" "++ b instance Show EAttr where show eat = show (toPair eat) -------------------------------------------------------------------------------- -- foo :: SM.StringMap Int -- foo = SM.fromList [("foo",3), ("bar", 4)] -- bar = TM.lookup "foo" foo scale = 3.0 defaultStepMap = SM.fromList [("color", VColor "#3333ff"), ("shape", VShape Sphere), ("size", VSize (1.0 * scale)), ("shapedetail", VShapedetail 10), ("visible", VVisible True)] defaultItemMap = SM.fromList [("color", VColor "#008800"), ("shape", VShape Cube), ("size", VSize (0.75 * scale)), ("visible", VVisible True)] defaultTagMap = SM.fromList [("color", VColor "#555555"), ("shape", VShape Octahedron), ("size", VSize (0.4 * scale)), ("visible", VVisible True)] -- For convenience, here are the default attributes as lists: defaultStepAttr = map snd$ SM.toList defaultStepMap defaultItemAttr = map snd$ SM.toList defaultItemMap defaultTagAttr = map snd$ SM.toList defaultTagMap -- The environment appears as a tweaked step: defaultEnvAttr = map snd $ SM.toList $ SM.insert "color" (VColor "#ffff00") $ SM.insert "label" (VLabel "env IN") $ defaultStepMap named def nm = SM.insert "label" vlab $ -- This is a property of my own that I add for future reference: --SM.insert "origname" vlab $ def where vlab = VLabel$ fromAtom nm namedStep = named defaultStepMap emptyGUIState = GS AM.empty AM.empty AM.empty --pump_size = False pump_size = True -------------------------------------------------------------------------------- -- Convert a parsed trace into a series of GUI actions: -- Two distinct behaviors. -- -- Drawing collections (): -- Steps are indexed with an empty ("") tag. Each additional -- instance added to a collection may change its appearance but -- will not add a new node. -- -- Drawing instances (full_dynamic_graph): -- Draw the "dynamic graph" of step instances. Instances are -- identified by a pair of their collection name and a string -- representing a tag value. traceToGUI :: [CncTraceEvent] -> [GUIAction] traceToGUI trace = AddV envpr : ChangeV envpr defaultEnvAttr : loop emptyGUIState trace where envpr = (toAtom special_environment_name, B.pack "") loop _ [] = [] loop state0@GS{..} (hd:tl) = let -- When drawing step collections we may "pump them up" as we get more instances: -- (This function also continues the loop, so it's called as a continuation.) pump_up_instance (nm,tag) gns@GNS{..} = if full_dynamic_graph then keep_going else ChangeV (nm,tag) [VLabel$ oldlab ++" #"++ show (count+1), newsize] : keep_going where keep_going = loop state0{ nodes= newnodes } tl newnodes = AM.insert nm gns{count=count+1, props=props'} nodes VLabel oldlab = props SM.! "label" -- Experimenting with growing the size too: VSize oldsize = props SM.! "size" newsize = VSize$ oldsize + 0.1 props' = if pump_size then SM.insert "size" newsize props else props newstate nm attrs = state0{ nodes = AM.insert nm (GNS 1 attrs) nodes } in case hd of Prescribe tags step -> let state1 = state0{ prescribedBy= AM.insert step tags prescribedBy } in -- When drawing if full_dynamic_graph then loop state1 tl else AddV (step, B.pack "") : loop state1 tl ------------------------------------------------------------ StartStep pr@(nm,tg) -> case AM.lookup nm prescribedBy of Nothing -> error$ "traceToGUI: no Prescribe relation corresponding to step "++show nm Just tags -> -- Add an edge connecting the tag [collection] to the step [collection]: let edge = AddE (tags,tg) pr vertedge = [AddV pr, edge, ChangeV pr defaultStepAttr, WaitAction] in (if full_dynamic_graph then vertedge else []) ++ case AM.lookup nm nodes of Nothing -> loop (newstate nm$ namedStep nm) tl Just gns -> pump_up_instance pr gns ------------------------------------------------------------ PutT (stepnm,stag) tpr@(tgnm,_) -> let edge = AddE (stepnm,stag) tpr vertedge = [AddV tpr, edge, ChangeV tpr defaultTagAttr, WaitAction] in case AM.lookup tgnm nodes of Nothing -> vertedge ++ loop (newstate tgnm$ named defaultTagMap tgnm) tl Just gns -> (if full_dynamic_graph then vertedge else []) ++ pump_up_instance tpr gns ------------------------------------------------------------ PutI (stepnm,stag) ipr@(inm,_) -> let edge = AddE (stepnm,stag) ipr vertedge = [AddV ipr, edge, ChangeV ipr defaultItemAttr, WaitAction] in case AM.lookup inm nodes of Nothing -> vertedge ++ loop (newstate inm$ named defaultItemMap inm) tl Just gns -> (if full_dynamic_graph then vertedge else []) ++ pump_up_instance ipr gns ------------------------------------------------------------ GetI (stepnm,stag) ipr@(inm,_) -> let edge = AddE (stepnm,stag) ipr in case AM.lookup inm nodes of Nothing -> --AddV ipr : --ChangeV ipr defaultItemAttr : edge : loop (newstate inm$ named defaultItemMap inm) tl _ -> edge : loop state0 tl _ -> loop state0 tl -- EndStep NameTag -- FAIL String t29 = traceToGUI $ parseCncTrace sample_trace t30 = playback emptyGUIState t29 ---------------------------------------------------------------------------------------------------- -- Another way to do it would be to construct a reverse-log as we go, -- for each attribute set, store a command which woud set it back to -- the old attribute. ---------------------------------------------------------------------------------------------------- -- playback takes a forward and reverse sequence of actions. To play -- forward it reads from one tape, and reverse the other. -- It also must model the state of the GUI to be able to reverse actions. --playback :: GUIState -> [GUIAction] -> [GUIAction] -> IO () playback :: GUIState -> [GUIAction] -> IO () -- Should we actually create a node for every dynamic instance? full_dynamic_graph = False playback state fwd = do server_url <- getEnvDefault "UBIGRAPH_SERVER" default_server_url putStrLn$ cnctag++"Visualizing trace using ubigraph." initHubigraph server_url >>= runHubigraph initialize where r x = initHubigraph default_server_url >>= runHubigraph x initialize = do clear setVStyleAttr (VVisible False) 0 setVStyleAttr (VColor "#ff0000") 0 stepstyle <- newVStyle 0 itemstyle <- newVStyle 0 tagstyle <- newVStyle 0 mapM_ (flip setVStyleAttr stepstyle) (defaultStepAttr) mapM_ (flip setVStyleAttr itemstyle) (defaultItemAttr) mapM_ (flip setVStyleAttr tagstyle) (defaultTagAttr) --let eshared = [EOriented True, ESpline True, EStrength 0.001] let eshared = [EOriented True, ESpline True, EStrength 0.0] --let eshared = [EOriented True] baseEstyle <- newEStyle 0 mapM_ (flip setEStyleAttr baseEstyle) eshared producestyle <- newEStyle baseEstyle consumestyle <- newEStyle baseEstyle prescribestyle <- newEStyle baseEstyle mapM_ (flip setEStyleAttr producestyle)$ [EColor "#ff4444", EWidth 2.5] mapM_ (flip setEStyleAttr consumestyle)$ [EColor "#44ff44", EWidth 2.5] mapM_ (flip setEStyleAttr prescribestyle)$ [EColor "#666666"] ++ eshared -------------------------------------------------------------------------------- -- Main loop -------------------------------------------------------------------------------- let step_forward idmap fwd = case fwd of [] -> do R.lift$ putStrLn "playback finished: no more actions!" return idmap hd:tl -> case hd of AddV pr@(atom, tag) -> do id <- newVertex -- setVAttr (VLabel$ B.concat [fromAtom atom, B.pack " ", tag]) id setVAttr (VLabel$ fromAtom atom ++ " " ++ B.unpack tag) id return$ M.insert pr id idmap ChangeV pr updates -> do let id = idmap M.! pr mapM_ (flip setVAttr id) updates return idmap AddE from to -> do --R.lift$ putStrLn$ "ADDING EDGE "++ show from ++" "++ show to let from' = M.lookup from idmap to' = M.lookup to idmap case (M.lookup from idmap, M.lookup to idmap) of (Just from', Just to') -> do id <- newEdge (from', to') changeEStyle producestyle id return idmap (Nothing,_) -> do R.lift$ putStrLn$ ("Warning: Missing source of AddE edge! "++show from) return idmap (_,Nothing) -> do R.lift$ putStrLn$ ("Warning: Missing destination of AddE edge! "++show to) return idmap WaitAction -> do R.lift$ usleep (300 * 1000) -- 0.1 second sleep. return idmap _ -> return idmap --x -> error$ "playback: unhandled GUIAction: "++ show x -- For now just play forward, maximum speed: let loop idmap state rvrs fwd = do newidmap <- step_forward idmap fwd --R.lift$ usleep (100 * 1000) --Control.Concurrent.threadDelay loop newidmap (error "no state atm") --(updateState state hd) (error "no rev action") --(buildRevAction state hd : rvrs) (tail fwd) loop (M.fromList [((toAtom special_environment_name, B.pack ""), envID)]) state [] fwd -- This simply needs to not conflict with the auto-assigned Ubigraph ids: envID = 1 deJust msg Nothing = error msg deJust _ (Just x) = x updateState = error "updateState" buildRevAction = error "buildRevAction" -- It also must model the state -- loop state