CPSA

-- Generates an expanded view of CPSA S-expressions 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) where import qualified Data.Set as S import Data.List (intersperse) import System.IO import CPSA.Lib.CPSA import CPSA.Graph.XMLOutput import CPSA.Graph.Config import CPSA.Graph.SVG import CPSA.Graph.Loader import CPSA.Graph.Preskeleton import CPSA.Graph.Tree expandedView :: Handle -> Config -> Int -> [SExpr Pos] -> [Preskel] -> IO () expandedView h conf margin cmts ps = do hPutList h (header ps) comments h margin cmts let f = forest ps case f of [t] -> tdrawer h conf margin False t _ -> do toc h f mapM_ (tdrawer h conf margin True) f hPutList h closer hClose h header :: [Preskel] -> [String] header ps = ["", "", " ", title ps, "", ""] where title [] = " CPSA" title (k : _) = " CPSA " ++ protocol k ++ "" comments :: Handle -> Int -> [SExpr Pos] -> IO () comments h margin 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 in into a div element. docRoot :: Config -> Float -> Float -> [Element] -> Element docRoot conf w h es = ec "div" [] [ec "svg" attrs es] where attrs = [("width", showL w ++ units conf), ("height", showL h ++ units conf), ("xmlns", "http://www.w3.org/2000/svg"), ("xmlns:xlink", "http://www.w3.org/1999/xlink"), ("version", "1.1"), ("viewBox", viewbox), ("font-size", showL (font conf))] viewbox = "0 0 " ++ showL w ++ " " ++ showL h -- Draws one tree tdrawer :: Handle -> Config -> Int -> Bool -> Tree -> IO () tdrawer h conf margin 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 hPutStrLn h ".

" hPutStrLn h "" let (width, height, es) = tree conf t hPutStrLn h $ show $ docRoot conf width height $ rect conf 0 0 width height : es hPutSExpr h margin (protSrc (vertex t)) mapM_ (kdrawer h conf margin id) (collectPreskels t) treeid :: Int -> String treeid label = "t" ++ show label -- Collects the preskeletons within a tree and sorts them by label. collectPreskels :: Tree -> [Tree] collectPreskels t = S.toAscList $ f S.empty t where f s t = foldl f (S.insert t s) (children t) -- Draws one item in the tree--a preskeleton. kdrawer :: Handle -> Config -> Int -> Int -> Tree -> IO () kdrawer h conf margin tid t = 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, e) = kdraw conf 0 0 k hPutStrLn h $ show $ docRoot conf width height [defs conf, e] hPutSExpr h margin (preskelSrc k) itemid :: Int -> String itemid label = "i" ++ 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 -> SExpr Pos -> IO () hPutSExpr h margin sexpr = do hPutStrLn h "" hPutStrLn h $ show $ mc "pre" [] (pp margin indent sexpr) -- S-expression pretty print parameters indent :: Int indent = 2