-- Generates an expanded view of CPSA output as a compound document -- that contains SVG within XHTML. -- Copyright (c) 2009 The MITRE Corporation -- -- This program is free software: you can redistribute it and/or -- modify it under the terms of the BSD License as published by the -- University of California. module CPSA.Graph.ExpandedView (expandedView, treelessView) where import Data.List (intersperse) import System.IO import CPSA.Lib.SExpr import CPSA.Lib.Printer (pp) import CPSA.Graph.XMLOutput import CPSA.Graph.Config import CPSA.Graph.SVG import CPSA.Graph.Loader import CPSA.Graph.Preskeleton import CPSA.Graph.Tree type Printer a = Int -> Int -> SExpr a -> String expandedView :: Handle -> Config -> Int -> [SExpr Pos] -> [Preskel] -> IO () expandedView h conf margin cmts ks = do hPutList h (header (scripts conf) cmts ks) comments h margin pp cmts case forest ks of [t] -> tdrawer h conf margin pp False t f -> do toc h f mapM_ (tdrawer h conf margin pp True) f hPutList h closer hClose h header :: Bool -> [SExpr Pos] -> [Preskel] -> [String] header addScript cmts ks = ["", "", " " ++ title cmts ks ++ "", " ", " "] ++ maybeScript addScript ++ ["", ""] maybeScript :: Bool -> [String] maybeScript False = [] maybeScript True = [ " "] -- Find title in a herald form, but if absent use a protocol name. title :: [SExpr Pos] -> [Preskel] -> String title [] ks = protocolTitle ks title ((L _ (S _ "herald" : S _ title : _)) : _) _ = title title ((L _ (S _ "herald" : Q _ title : _)) : _) _ = title title (_ : cmts) ks = title cmts ks protocolTitle :: [Preskel] -> String protocolTitle [] = "CPSA" protocolTitle (k : _) = protocol k comments :: Handle -> Int -> Printer Pos -> [SExpr Pos] -> IO () comments h margin pp cmts = do hPutStrLn h "" let xs = concat $ intersperse "\n" $ map (pp margin indent) cmts hPutStrLn h $ show $ mc "pre" [] xs closer :: [String] closer = ["", "", ""] hPutList :: Handle -> [String] -> IO () hPutList h xs = mapM_ (hPutStrLn h) xs -- Generates a list of trees within the document when there are more -- than one. toc :: Handle -> Forest -> IO () toc h f = do hPutStrLn h "" hPutStr h $ "

Trees:" mapM_ (anchor h treeid . label . vertex) f hPutStrLn h ".

" topid :: String topid = "top" anchor :: Handle -> (Int -> String) -> Int -> IO () anchor h id n = hPutStr h $ " " ++ show n ++ "" -- Generates an SVG document root and puts it into a div element. -- When scripting is enabled, it places all elements into a g element -- that is used as the target of scaling actions. docRoot :: Config -> Float -> Float -> [Element] -> Element docRoot conf w h es = ec "div" [] div where attrs = [("class", "diagram"), ("width", showL w ++ units conf), ("height", showL h ++ units conf), ("xmlns", "http://www.w3.org/2000/svg"), ("version", "1.1"), ("viewBox", viewbox), ("font-size", showL (font conf))] viewbox = "0 0 " ++ showL w ++ " " ++ showL h svg = ec "svg" attrs (if scripts conf then [ec "g" [] es] else es) div = if scripts conf then [zoomControl, br, svg] else [svg] br = ec "br" [] [] zoomControl :: Element zoomControl = ec "select" [("onchange", "zoom(event)")] [mc "option" [("value", "1.0")] "1.0", mc "option" [("value", "0.8")] "0.8", mc "option" [("value", "0.6")] "0.6", mc "option" [("value", "0.4")] "0.4", mc "option" [("value", "0.2")] "0.2"] -- Draws one tree tdrawer :: Handle -> Config -> Int -> Printer Pos -> Bool -> Tree -> IO () tdrawer h conf margin pp toc t = do hPutStrLn h "" let id = label (vertex t) hPutStr h $ "

Tree" case toc of True -> anchor h (\_ -> topid) id False -> hPutStr h $ " " ++ show id hPutStr h ", POV" anchor h (\_ -> itemid id) id hPutStrLn h ".

" hPutStrLn h "" let (width, height, es) = tree conf t hPutStrLn h $ show $ docRoot conf width height es hPutSExpr h margin pp (protSrc (vertex t)) kdrawer h conf margin pp id [t] treeid :: Int -> String treeid label = tid (show label) -- Draws the first item in the queue kdrawer :: Handle -> Config -> Int -> Printer Pos -> Int -> [Tree] -> IO () kdrawer _ _ _ _ _ [] = return () kdrawer h conf margin pp tid (t:ts) = do hPutStrLn h "" let k = vertex t let id = label k hPutStr h $ "

Item" anchor h (\_ -> treeid tid) id case parent k of Nothing -> return () Just p -> do hPutStr h ", Parent:" anchor h itemid p titledList h "Child" "Children" $ map (label . vertex) (children t) titledList h "Seen Child" "Seen Children" $ seen k hPutStrLn h ".

" hPutStrLn h "" let (width, height, es) = skel conf k hPutStrLn h $ show $ docRoot conf width height (defs conf : es) hPutSExpr h margin pp (purgeTraces conf $ preskelSrc k) -- Use a breadth first ordering by appending children to the queue kdrawer h conf margin pp tid (ts ++ children t) itemid :: Int -> String itemid label = kid (show label) -- Handle singular vs. plural. titledList :: Handle -> String -> String -> [Int] -> IO () titledList _ _ _ [] = return () titledList h singular _ [id] = do hPutStr h $ ", " ++ singular ++ ":" anchor h itemid id titledList h _ plural ls = do hPutStr h $ ", " ++ plural ++ ":" mapM_ (anchor h itemid) ls hPutSExpr :: Handle -> Int -> Printer Pos -> SExpr Pos -> IO () hPutSExpr h margin pp sexpr = do hPutStrLn h "" hPutStrLn h $ show $ mc "pre" [] (pp margin indent sexpr) -- S-expression pretty print parameters indent :: Int indent = 2 purgeTraces :: Config -> SExpr Pos -> SExpr Pos purgeTraces conf x | purge conf = strip "traces" x purgeTraces _ x = x strip :: String -> SExpr Pos -> SExpr Pos strip key (L p xs) = L p (filter f xs) where f (L _ (S _ s : _)) | s == key = False f _ = True strip _ x = x -- Encoded from src/zoom.js using src/js2hs javascript :: [String] javascript = [""] -- Treeless View -- fast because we don't generated derivation trees. treelessView :: Handle -> Config -> Int -> [SExpr Pos] -> Preskel -> State -> IO () treelessView h conf margin cmts k s = do hPutList h (header (scripts conf) cmts [k]) comments h margin pp cmts body h conf margin pp k s body :: Handle -> Config -> Int -> Printer Pos -> Preskel -> State -> IO () body h conf margin pp k s = do case parent k of Nothing -> do hPutStrLn h "" hPutStrLn h $ show $ mc "p" [] ("Tree " ++ show (label k)) hPutSExpr h margin pp (protSrc k) Just _ -> return () hPutStrLn h "" hPutStrLn h $ show $ mc "p" [] ("Item " ++ show (label k)) hPutStrLn h "" let (width, height, es) = skel conf k hPutStrLn h $ show $ docRoot conf width height (defs conf : es) hPutSExpr h margin pp (purgeTraces conf $ preskelSrc k) n <- loadNext s case n of Nothing -> -- EOF do hPutList h closer hClose h Just (k, s) -> body h conf margin pp k s