a3/code/Gast/Graphviz.icl

   1 // Péter Diviánszky, 2007
   2 // Code extended and adapted for using generics by Peter Achten, 2007
   3
   4 implementation module Graphviz
   5
   6 import StdArray, StdOverloaded, StdList, StdOrdList, StdTuple, StdString, StdBool, StdMisc
   7 import StdMaybe, StdListExtensions
   8 import GenLib
   9 import ESMSpec
  10
  11 derive gEq    EdgeStyle, NodeStyle, DirType, NodeShape, Side, ArrowShape, Maybe, ArrowType, Arrow, Color
  12 derive gPrint EdgeStyle, NodeStyle, DirType, NodeShape, Side, ArrowShape, Maybe, CompassPoint, StartStyle,
  13               ClusterMode, OutputMode, PageDir, RankDir, RankType
  14 derive printNameValuePair GraphAttribute, NodeAttribute, EdgeAttribute
  15
  16 //      Almost regular toString instances:
  17 instance toString EdgeStyle      where toString es  =  /*quote*/ (skipXXX_InConstructorName (printToString es))
  18 instance toString NodeStyle      where toString ns  = quote (skipXXX_InConstructorName (printToString ns))
  19 instance toString DirType        where toString dir = quote (skipXXX_InConstructorName (printToString dir))
  20 instance toString NodeShape      where toString ns  = skipXXX_InConstructorName (printToString ns)
  21 instance toString Side           where toString s   = skipXXX_InConstructorName (printToString s)
  22 instance toString ArrowShape     where toString s   = skipXXX_InConstructorName (printToString s)
  23 instance toString CompassPoint   where toString cp  = quote (skipXXX_InConstructorName (printToString cp))
  24 instance toString ClusterMode    where toString cm  = quote (skipXXX_InConstructorName (printToString cm))
  25 instance toString OutputMode     where toString om  = quote (skipXXX_InConstructorName (printToString om))
  26 instance toString PageDir        where toString pd  = skipXXX_InConstructorName (printToString pd)
  27 instance toString RankDir        where toString rd  = skipXXX_InConstructorName (printToString rd)
  28 instance toString RankType       where toString rt  = skipXXX_InConstructorName (printToString rt)
  29 instance toString StartStyle     where toString ss  = skipXXX_InConstructorName (printToString ss)
  30 instance toString NodeAttribute  where toString na  = printNameValuePair{|*|} na
  31 instance toString EdgeAttribute  where toString ea  = printNameValuePair{|*|} ea
  32 instance toString GraphAttribute where toString ga  = printNameValuePair{|*|} ga
  33 //      Less regular toString instances:
  34 instance toString Arrow where
  35         toString {open,side,shape}      = if open "o" "" +++ if (isJust side) (toString (fromJust side)) "" +++ toString shape
  36 instance toString ArrowType where
  37         toString {closest,furthest}     = quote (toString closest +++ if (isJust furthest) (toString (fromJust furthest)) "")
  38 instance toString Color where
  39         toString (Color name)           = name
  40
  41         toString (HSV h s v)            = "\"" $> toS h $> " " $> toS s $> " " $> toS v $> "\""
  42         where
  43                 toS x
  44                         | x<0.0 || x>1.0        = abort "HSV value out of range.\n"
  45                         | otherwise                     = toString (toReal (toInt (1000.0*x)) / 1000.0)
  46
  47         toString (RGB r g b)            = "\"#" $> toS r $> toS g $> toS b $> "\""
  48         where
  49                 toS x
  50                         | x<0 || x>255          = abort "RGB value out of range.\n"
  51                         | otherwise                     = toString [toC (x/16), toC (x rem 16)]
  52                 toC x
  53                         | x < 10                        = toChar (x + fromChar '0')
  54                         | otherwise                     = toChar (x - 10 + fromChar 'A')
  55 instance toString DotPoint where
  56         toString (DotPoint x y fix)     = x >$ "," >$ y >$ if fix "!" ""
  57 instance toString LayerId where
  58         toString layerid                        = case layerid of
  59                                                                         LayerAll      = "all"
  60                                                                         LayerNr   nr  = toString nr
  61                                                                         LayerName str = str
  62 instance toString LayerList where
  63         toString (LayerList names)      = foldr (\next before -> before $> layersep $> next) "" names
  64 instance toString LayerRange where
  65         toString (LayerRange id ids)= foldr (\next before -> before $> layersep $> next) (toString id) ids
  66 instance toString Margin where
  67         toString margin                         = case margin of
  68                                                                         SingleMargin a   = toString a
  69                                                                         DoubleMargin a b = a >$ "," $> b
  70 instance toString Pad where
  71         toString pad                            = case pad of
  72                                                                         SinglePad a   = toString a
  73                                                                         DoublePad a b = a >$ "," $> b
  74 instance toString Pointf where
  75         toString (Pointf x y)           = quote (x >$ "," $> y)
  76 instance toString Ratio where
  77         toString ratio                          = case ratio of
  78                                                                         AspectRatio r = quote (toString r)
  79                                                                         R_fill        = quote "fill"
  80                                                                         R_compress    = quote "compress"
  81                                                                         R_expand      = quote "expand"
  82                                                                         R_auto        = quote "auto"
  83 instance toString Rect where
  84         toString {llx,lly,urx,ury}      = llx >$ "," $> lly >$ "," $> urx >$ "," $> ury
  85 instance toString Sizef where                   // PA++
  86         toString (Sizef x y True)       = "\"" +++ toString x +++ "," +++ toString y +++ "!\""
  87         toString (Sizef x y False)      = "\"" +++ toString x +++ "," +++ toString y +++ "\""
  88 instance toString StartType where
  89         toString {startStyle,startSeed}
  90                                                                 = if (isJust startStyle) (toString (fromJust startStyle)) "" +++
  91                                                                   if (isJust startSeed)  (toString (fromJust startSeed )) ""
  92 instance toString ViewPort where
  93         toString {vp_W,vp_H,vp_Z,vp_xy}
  94                                                                 = (vp_W >$ "," $> vp_H)                          +++
  95                                                                   if (isJust vp_Z ) ("," $> (fromJust vp_Z )) "" +++
  96                                                                   if (isJust vp_xy) ("," $> (fromJust vp_xy)) ""
  97
  98 //      Print name=value pairs for algebraic data types with unary data constructors in XXX_name constructor name format.
  99 generic printNameValuePair a :: a -> String
 100 printNameValuePair{|Int|}          x                    = toString x
 101 printNameValuePair{|Real|}         x                    = toString x
 102 printNameValuePair{|Char|}         x                    = toString x
 103 printNameValuePair{|String|}       x                    = quote    x
 104 printNameValuePair{|Bool|}         x                    = firstCharLowerCase (toString x)
 105 printNameValuePair{|UNIT|}         x                    = ""
 106 printNameValuePair{|PAIR|}   px py (PAIR x y)   = px x +++ " " +++ py y
 107 printNameValuePair{|EITHER|} pl pr (LEFT   x)   = pl x
 108 printNameValuePair{|EITHER|} pl pr (RIGHT  y)   = pr y
 109 printNameValuePair{|OBJECT|} px    (OBJECT x)   = px x
 110 printNameValuePair{|CONS of d|} px (CONS   x)   = skipXXX_InConstructorName d.gcd_name +++ "=" +++ px x
 111 // Specializations of printNameValuePair:
 112 printNameValuePair{|ArrowType|}    x                    = toString x
 113 printNameValuePair{|Color|}        x                    = toString x
 114 printNameValuePair{|ClusterMode|}  x                    = toString x
 115 printNameValuePair{|CompassPoint|} x                    = toString x
 116 printNameValuePair{|DirType|}      x                    = toString x
 117 printNameValuePair{|DotPoint|}     x                    = toString x
 118 printNameValuePair{|EdgeStyle|}    x                    = toString x
 119 printNameValuePair{|LayerList|}    x                    = toString x
 120 printNameValuePair{|LayerRange|}   x                    = toString x
 121 printNameValuePair{|Margin|}       x                    = toString x
 122 printNameValuePair{|NodeShape|}    x                    = toString x
 123 printNameValuePair{|NodeStyle|}    x                    = toString x
 124 printNameValuePair{|OutputMode|}   x                    = toString x
 125 printNameValuePair{|Pad|}          x                    = toString x
 126 printNameValuePair{|PageDir|}      x                    = toString x
 127 printNameValuePair{|Pointf|}       x                    = toString x
 128 printNameValuePair{|RankDir|}      x                    = toString x
 129 printNameValuePair{|RankType|}     x                    = toString x
 130 printNameValuePair{|Ratio|}        x                    = toString x
 131 printNameValuePair{|Rect|}         x                    = toString x
 132 printNameValuePair{|Sizef|}        x                    = toString x            // PA++
 133 printNameValuePair{|StartType|}    x                    = toString x
 134 printNameValuePair{|ViewPort|}     x                    = toString x
 135
 136 instance == EdgeStyle where (==) a b                    = gEq{|*|} a b
 137 instance == NodeStyle where (==) a b                    = gEq{|*|} a b
 138 instance == DirType   where (==) a b                    = gEq{|*|} a b
 139 instance == NodeShape where (==) a b                    = gEq{|*|} a b
 140 instance == ArrowType where (==) a b                    = gEq{|*|} a b
 141 instance == Color     where (==) a b                    = gEq{|*|} a b
 142
 143
 144 digraphTitle :: !Digraph -> String
 145 digraphTitle (Digraph title _ _ _)                              = title
 146
 147 digraphAtts :: !Digraph -> [GraphAttribute]
 148 digraphAtts (Digraph _ atts _ _)                                = atts
 149
 150 digraphNodes :: !Digraph -> [NodeDef]
 151 digraphNodes (Digraph _ _ nodes _)                              = nodes
 152
 153 digraphSelectedItem :: !Digraph -> Maybe SelectedItem
 154 digraphSelectedItem (Digraph _ _ _ selected)    = selected
 155
 156 pointNode :: [NodeAttribute]
 157 pointNode                                                                               =: [NAtt_shape NShape_point]
 158
 159 hiddenNode :: [NodeAttribute]
 160 hiddenNode                                                                              =: [NAtt_shape NShape_point,NAtt_style NStyle_invis]
 161
 162 commaseparatedlist :: [String] -> String
 163 commaseparatedlist []                                                   = ""
 164 commaseparatedlist l                                                    = "[" +++ (foldr (+++) "" (intersperse "," l)) +++ "]"
 165
 166 printDigraph :: !Digraph -> [String]
 167 //printDigraph (Digraph title atts nodes _)             = map (\x->x+++"\n") (prelude title (graphAtts atts) (contents nodes))
 168 printDigraph digraph                                                    = case includeChanges digraph of
 169                                                                                                         Digraph title atts nodes _ -> map (\x->x+++"\n") (prelude title (graphAtts atts) (contents nodes))
 170
 171 includeChanges :: !Digraph -> Digraph
 172 includeChanges dg=:(Digraph _ _ _ Nothing)              = dg
 173 includeChanges (Digraph title atts nodes change)= Digraph title atts (map includeNodeChange nodes) Nothing
 174 where
 175         (Node nr`)                                                                      = fromJust change
 176
 177         includeNodeChange :: !NodeDef -> NodeDef
 178         includeNodeChange (NodeDef nr st atts edges)
 179                 | nr==nr`                                                               = NodeDef nr st (map replaceNodeAtt atts) edges
 180                 | otherwise                                                             = NodeDef nr st (map defaultNodeAtt atts) edges
 181         where
 182                 all_edges_found                                                 = not (isEmpty [s \\ s=:(NStAllEdgesFound True) <- st])
 183
 184                 replaceNodeAtt (NAtt_fillcolor _)               = NAtt_fillcolor (fst (active_state_color 1))
 185                 replaceNodeAtt (NAtt_fontcolor _)               = NAtt_fontcolor (snd (active_state_color 1))
 186                 replaceNodeAtt att                                              = att
 187
 188                 defaultNodeAtt (NAtt_fillcolor c)               = NAtt_fillcolor (if all_edges_found (fst finished_state_color) (fst default_state_color))
 189                 defaultNodeAtt (NAtt_fontcolor c)               = NAtt_fontcolor (if all_edges_found (snd finished_state_color) (snd default_state_color))
 190                 defaultNodeAtt att                                              = att
 191
 192 createGraphName :: !String -> String
 193 createGraphName ""                                                              = "G"
 194 createGraphName x                                                               = x
 195
 196 prelude :: !String ![String] ![String] -> [String]
 197 prelude title graphAtts contents                                = [ "digraph " +++ createGraphName title +++ " {"
 198                                                                                                   , "label="   +++ quote title
 199                                                                                                   ]            ++
 200                                                                                                   graphAtts    ++
 201                                                                                                   contents     ++
 202                                                                                                   [ "}" ]
 203
 204 graphAtts :: ![GraphAttribute] -> [String]
 205 graphAtts graphAtts                                                             = map printNameValuePair{|*|} graphAtts
 206
 207 contents :: ![NodeDef] -> [String]
 208 contents nodeDefs                                                               = map snd (mergeBy (\(x,_) (y,_)= x<y) nodes` edges`)
 209 where
 210         (nodes,edges)                                                           = unzip (mapSt f nodeDefs 1)
 211         where
 212                 f (NodeDef id st na edges) num                  = (     ((num,id,na)
 213                                                                                                     ,[(n,id,id`,ea) \\ (id`,ea)<- edges & n<-[num+1..]]
 214                                                                                                         )
 215                                                                                                   , num + 1 + length edges
 216                                                                                                   )
 217
 218         nodes` = map (\(num, id, atts) = (num, id >$ commaseparatedlist (map toString atts))) nodes
 219         edges` = map (\(num,source,target,atts) = (num,source >$ "->" $> target >$ commaseparatedlist (map toString atts))) (flatten edges)
 220
 221
 222 mkDigraph :: String (KnownAutomaton s i o,s,[s],[s],[SeenTrans s i o],[SeenTrans s i o]) -> Digraph | render, gEq{|*|} s & render, gEq{|*|} i & render, gEq{|*|} o
 223 mkDigraph name (automaton,s_0,init_states,finished,issues,trace)
 224         = Digraph
 225                 (remove_spaces name)
 226                 graphAttributes
 227                 (if (isEmpty automaton.trans)
 228                         [NodeDef 0                  [NStAllEdgesFound (gisMember s_0 finished)] (nodeAttributes s_0 init_states (gisMember s_0 finished)) []]
 229                         [NodeDef (nrOf automaton n) [NStAllEdgesFound (gisMember n   finished)] (nodeAttributes n   init_states (gisMember n   finished))
 230                                  [ let (s,i,o,t) = trans in
 231                                    (nrOf automaton t    , [ EAtt_label (render i+++"/"+++showList ("[","]",",") o)
 232                                                         , EAtt_fontname "Helvetica"
 233                                                         , EAtt_fontsize fontsize
 234                                                         , EAtt_labelfontname "Helvetica"
 235                                                         , EAtt_labelfontsize fontsize
 236                                                         , EAtt_color
 237                                                                                  (if (gisMember trans issues)
 238                                                                                                         (Color "red")
 239                                                                                  (if (gisMember trans trace)
 240                                                                                                         (Color "blue")
 241                                                                                                         (Color "black")))
 242                                                         , EAtt_arrowsize (if (gisMember trans trace) 2.0 1.2)
 243                                                      //   , EAtt_style (if (isMember trans trace) EStyle_bold EStyle_solid)
 244                                                         ])
 245                                  \\ trans <- edgesFrom n automaton
 246                                  ]
 247                         \\ n <- let nodes = nodesOf automaton in if (gisMember s_0 nodes && hd nodes =!= s_0) [s_0:filter ((=!=) s_0) nodes] nodes
 248                         ]
 249                 ) Nothing
 250 where
 251         graphAttributes                         = [ GAtt_rankdir  RD_LR
 252                                                                   , GAtt_size                   (Sizef 10.0 6.0 True)
 253                                                                   , GAtt_bgcolor                (Color "lightsteelblue")
 254                                                                   , GAtt_ordering               "out"
 255                                                                   , GAtt_outputorder    OM_nodesfirst   // OM_edgesfirst        //  PK
 256                                                                   ]
 257         nodeAttributes n init_states finished
 258                                                                 = (if (gisMember n init_states) [ NAtt_fillcolor act_backgr, NAtt_fontcolor act_txt ]
 259                                                                   (if finished                 [ NAtt_fillcolor done_backgr,NAtt_fontcolor done_txt]
 260                                                                                                    [ NAtt_fillcolor def_backgr, NAtt_fontcolor def_txt ]
 261                                                                   )) ++
 262                                                           [ NAtt_label     (render n)
 263                                                           , NAtt_style     NStyle_filled
 264                                                           , NAtt_shape     (if (n === s_0) NShape_doublecircle NShape_circle)
 265                                                           , NAtt_fontname  "Helvetica"
 266                                                           , NAtt_fontsize  fontsize
 267                                                           , NAtt_fixedsize True
 268                                                           , NAtt_width 1.0, NAtt_height 1.0
 269                                                           ]
 270         where
 271                 ( act_backgr, act_txt)  = active_state_color (length init_states)
 272                 (done_backgr,done_txt)  = finished_state_color
 273                 ( def_backgr, def_txt)  = default_state_color
 274
 275 active_state_color :: !Int -> (!Color,!Color)
 276 active_state_color nr   = (RGB 255 dim dim,Color "white")
 277 where
 278         dim                                     = min 250 (255 - 255 / nr)
 279
 280 finished_state_color :: (!Color,!Color)
 281 finished_state_color    = (Color "blue", Color "white")
 282
 283 default_state_color :: (!Color,!Color)
 284 default_state_color             = (Color "grey90",Color "black")
 285
 286 fontsize = 11.0
 287
 288 //      Utility functions:
 289
 290 mapSt :: (a b -> (c,b)) [a] b -> [c]
 291 mapSt f [] st                   = []
 292 mapSt f [h:t] st
 293         #! (x, st)                      = f h st
 294         = [x : mapSt f t st]
 295
 296 quote :: !String -> String
 297 quote a                                 = "\"" $> (flatten (map f (fromString a))) >$ "\""
 298 where
 299         f '\"'                          = ['\\\"']
 300         f x                                     = [x]
 301
 302 skipXXX_InConstructorName :: !String -> String
 303 skipXXX_InConstructorName str
 304         = case dropWhile ((<>) '_') [c \\ c<-:str] of
 305                 []                              = str
 306                 underscoreName  = str % (n-length underscoreName+1,n-1)
 307 where
 308         n                                       = size str
 309
 310 firstCharLowerCase :: !String -> String
 311 firstCharLowerCase str
 312         | size str > 0          = str := (0,toLower str.[0])
 313         | otherwise                     = str
 314
 315 ($>) infixr 5 :: !String !a -> String | toString a
 316 ($>) str arg                    = str +++ toString arg
 317
 318 (>$) infixr 5 :: !a !String -> String | toString a
 319 (>$) arg str                    = toString arg +++ str
 320
 321 showList :: !(!String,!String,!String) ![a] -> String | render a
 322 showList (open,close,delimit) []  = open +++ close
 323 showList (open,close,delimit) [x] = open +++ render x +++ close
 324 showList (open,close,delimit) xs  = open +++ foldr (\x str->render x+++delimit+++str) "" (init xs) +++ render (last xs) +++ close
 325
 326 remove_spaces :: !String -> String
 327 remove_spaces str               = {c \\ c<-:str | not (isSpace c)}