ExpandedView.hs

-- 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) 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

type Printer a = Int -> Int -> SExpr a -> String

expandedView :: Handle -> Config -> Int -> [SExpr Pos] -> [Preskel] -> IO ()
expandedView h conf margin cmts ps =
    do
      hPutList h (header (scripts conf) cmts ps)
      let pp = printer conf
      comments h margin pp cmts
      let f = forest ps
      case f of
        [t] ->
            tdrawer h conf margin pp False t
        _ ->
            do
              toc h f
              mapM_ (tdrawer h conf margin pp True) f
      hPutList h closer
      hClose h

header :: Bool -> [SExpr Pos] -> [Preskel] -> [String]
header False cmts ps =
    ["<html xmlns=\"http://www.w3.org/1999/xhtml\">",
     "<head>",
     " <meta http-equiv=\"content-type\"" ++
     " content=\"application/xhtml+xml; charset=UTF-8\" />",
     " <title>" ++ title cmts ps ++ "</title>",
     "</head>",
     "<body>"]
header True cmts ps =
    ["<html xmlns=\"http://www.w3.org/1999/xhtml\">",
     "<head>",
     " <meta http-equiv=\"content-type\"" ++
     " content=\"application/xhtml+xml; charset=UTF-8\" />",
     " <title>" ++ title cmts ps ++ "</title>",
     "  <script>"]
    ++ sliders ++
    ["  </script>",
     "</head>",
     "<body onload=\"init()\">"]

-- Find title in a herald form, but if absent use a protocol name.
title :: [SExpr Pos] -> [Preskel] -> String
title [] ps = protocolTitle ps
title ((L _ (S _ "herald" : S _ title : _)) : _) _ = title
title ((L _ (S _ "herald" : Q _ title : _)) : _) _ = title
title (_ : cmts) ps = title cmts ps

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 =
    ["", "</body>", "</html>"]

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 $ "<p id=\"" ++ topid ++ "\">Trees:"
      mapM_ (anchor h treeid . label . vertex) f
      hPutStrLn h ".</p>"

topid :: String
topid = "top"

anchor :: Handle -> (Int -> String) -> Int -> IO ()
anchor h id n =
    hPutStr h $ " <a href=\"#" ++ id n ++ "\">" ++ show n ++ "</a>"

-- Generates an SVG document root and puts in 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" dattrs [ec "svg" attrs elems]
    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
      dattrs = if scripts conf then [("class", "scalable")] else []
      elems = if scripts conf then [ec "g" [] es] else es

-- 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 $ "<p id=\"" ++ treeid id ++ "\">Tree"
      case toc of
        True -> anchor h (\_ -> topid) id
        False -> hPutStr h $ " " ++ show id
      hPutStrLn h ".</p>"
      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 pp (protSrc (vertex t))
      mapM_ (kdrawer h conf margin pp 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 -> Printer Pos -> Int -> Tree -> IO ()
kdrawer h conf margin pp tid t =
    do
      hPutStrLn h ""
      let k = vertex t
      let id = label k
      hPutStr h $ "<p id=\"" ++ itemid id ++ "\">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 ".</p>"
      hPutStrLn h ""
      let (width, height, e) = kdraw conf 0 0 k
      hPutStrLn h $ show $ docRoot conf width height [defs conf, e]
      hPutSExpr h margin pp (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 -> 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

-- Encoded from src/sliders.js using src/js2hs
sliders :: [String]
sliders =
    ["<![CDATA[",
     "// Slider support for use with cpsagraph and option --scalers",
     "",
     "// Check to see if HTML5 sliders are available.",
     "function have_input_type(t) {",
     "    var ns = document.documentElement.namespaceURI;",
     "    var i = document.createElementNS(ns, \"input\");",
     "    i.setAttribute(\"type\", t);",
     "    return i.type !== \"text\";",
     "}",
     "",
     "var have_sliders = have_input_type(\"range\");",
     "",
     "// Create an element that controls scaling",
     "function scaler(ns) {",
     "    if (have_sliders) ",
     "        return slider(ns);",
     "    else",
     "        return selector(ns);",
     "}",
     "",
     "// Create an HTML5 slider for scaling",
     "function slider(ns) {",
     "    var i = document.createElementNS(ns, \"input\");",
     "    i.setAttribute(\"type\", \"range\");",
     "    i.setAttribute(\"min\", 0.2);",
     "    i.setAttribute(\"max\", 1.0);",
     "    i.setAttribute(\"step\", 0.2);",
     "    i.setAttribute(\"value\", 1.0);",
     "    i.addEventListener(\"change\", zoom, false);",
     "    return i;",
     "}",
     "",
     "// Create an old style select element for scaling",
     "function selector(ns) {",
     "    var s = document.createElementNS(ns, \"select\");",
     "    s.appendChild(option(ns, \"1.0\"));",
     "    s.appendChild(option(ns, \"0.8\"));",
     "    s.appendChild(option(ns, \"0.6\"));",
     "    s.appendChild(option(ns, \"0.4\"));",
     "    s.appendChild(option(ns, \"0.2\"));",
     "    s.addEventListener(\"change\", zoom, false);",
     "    return s;",
     "}",
     "",
     "// Create one option for use within a select element",
     "function option(ns, val) {",
     "    var o = document.createElementNS(ns, \"option\");",
     "    o.setAttribute(\"value\", val);",
     "    o.appendChild(document.createTextNode(val));",
     "    return o;",
     "}",
     "",
     "// At load time, insert browser appropriate scaler",
     "function init() {",
     "    var ns = document.documentElement.namespaceURI;",
     "    var nodes = document.getElementsByClassName(\"scalable\");",
     "    var i;",
     "    for (i = 0; i < nodes.length; i++) {",
     "        var n = nodes.item(i);",
     "        var b = document.createElementNS(ns, \"br\");",
     "        n.insertBefore(b, n.firstChild);",
     "        n.insertBefore(scaler(ns), n.firstChild);",
     "    }",
     "}",
     "",
     "// Find the g element within a near by svg element and apply a transform",
     "function zoom(evt) {",
     "    var g = evt.target.parentNode.lastElementChild.firstElementChild;",
     "    g.setAttribute(\"transform\", \"scale(\"+evt.target.value+\")\");",
     "}",
     "]]>"]