a3/code/Gast/Graphviz.dcl

   1 // Péter Diviánszky, 2007
   2 // Code extended and adapted by Peter Achten, 2007
   3
   4 definition module Graphviz
   5
   6 //from   StdOverloaded import class ==, class toString
   7 from   StdOverloaded import class toString
   8 import StdMaybe
   9 import ESMSpec
  10 import GenEq
  11
  12 // A digraph contains a title and a list of node definitions
  13 :: Digraph
  14     = Digraph String [GraphAttribute] [NodeDef] (Maybe SelectedItem)
  15 :: SelectedItem
  16         = Node Int
  17
  18 digraphTitle            :: !Digraph -> String
  19 digraphAtts                     :: !Digraph -> [GraphAttribute]
  20 digraphNodes            :: !Digraph -> [NodeDef]
  21 digraphSelectedItem     :: !Digraph -> Maybe SelectedItem
  22
  23 // A node definition contains a unique identifier (an integer), a list of node attributes and a list of edge definitions.
  24 // An edge definition contains an identifier (the id of the end node and edge attributes).
  25 :: NodeDef
  26     = NodeDef !Int ![NodeState] ![NodeAttribute] [EdgeDef]
  27 :: EdgeDef
  28     :== (!Int,![EdgeAttribute])
  29 :: NodeState
  30         = NStAllEdgesFound !Bool                // all edges of this node are known
  31
  32 // Convert digraph into list of strings.
  33 // The strings are lines of the graphviz representation of the graph.
  34 printDigraph :: !Digraph -> [String]
  35
  36 :: GraphAttribute
  37         = GAtt_Damping        Real
  38         | GAtt_K              Real
  39         | GAtt_URL            String
  40         | GAtt_bb             Rect
  41         | GAtt_bgcolor        Color
  42         | GAtt_center         Bool
  43         | GAtt_charset        String
  44         | GAtt_clusterrank    ClusterMode
  45         | GAtt_colorscheme    String
  46         | GAtt_comment        String
  47         | GAtt_compound       Bool
  48         | GAtt_concentrate    Bool
  49         | GAtt_defaultdist    Real
  50         | GAtt_dim            Int
  51 //      | GAtt_diredgeconstraints ... PA: ignored, neato only
  52         | GAtt_dpi            Real
  53         | GAtt_epsilon        Real
  54         | GAtt_esep           Real
  55         | GAtt_fontcolor      Color
  56         | GAtt_fontname       String
  57         | GAtt_fontnames      String
  58         | GAtt_fontpath       String
  59         | GAtt_fontsize       Real
  60         | GAtt_label          String
  61         | GAtt_labeljust      String
  62         | GAtt_labelloc       String
  63         | GAtt_landscape      Bool
  64         | GAtt_layers         LayerList
  65         | GAtt_layersep       String
  66         | GAtt_levelsgap      Real
  67         | GAtt_lp             DotPoint
  68         | GAtt_margin         Margin
  69         | GAtt_maxiter        Int
  70         | GAtt_mclimit        Real
  71         | GAtt_mindist        Real
  72         | GAtt_mode           String
  73         | GAtt_model          String
  74         | GAtt_mosek          Bool
  75         | GAtt_nodesep        Real
  76         | GAtt_nojustify      Bool
  77         | GAtt_normalize      Bool
  78         | GAtt_nslimit        Real
  79         | GAtt_nslimit1       Real
  80         | GAtt_ordering       String
  81         | GAtt_orientation    String
  82         | GAtt_outputorder    OutputMode
  83         | GAtt_pad            Pad
  84         | GAtt_page           Pointf
  85         | GAtt_pagedir        PageDir
  86         | GAtt_quantum        Real
  87         | GAtt_rank           RankType
  88         | GAtt_rankdir        RankDir
  89         | GAtt_ranksep        Real
  90         | GAtt_ratio          Ratio
  91         | GAtt_remincross     Bool
  92         | GAtt_resolution     Real
  93         | GAtt_root           String
  94         | GAtt_rotate         Int
  95         | GAtt_searchsize     Int
  96         | GAtt_showboxes      Int
  97         | GAtt_size           Sizef //Pointf            // PA++
  98 //      | GAtt_splines        PA: skipped for the time being
  99         | GAtt_start          StartType
 100         | GAtt_stylesheet     String
 101         | GAtt_target         String
 102         | GAtt_truecolor      Bool
 103         | GAtt_viewport       ViewPort
 104         | GAtt_voro_margin    Real
 105 :: NodeAttribute
 106     = NAtt_URL            String
 107     | NAtt_color          Color
 108     | NAtt_colorscheme    String
 109     | NAtt_comment        String
 110     | NAtt_distortion     Real
 111     | NAtt_fillcolor      Color
 112     | NAtt_fixedsize      Bool
 113     | NAtt_fontcolor      Color
 114     | NAtt_fontname       String
 115     | NAtt_fontsize       Real
 116     | NAtt_group          String
 117     | NAtt_height         Real
 118     | NAtt_label          String
 119     | NAtt_layer          LayerRange
 120     | NAtt_margin         Margin
 121     | NAtt_nojustify      Bool
 122     | NAtt_orientation    Real
 123     | NAtt_peripheries    Int
 124     | NAtt_pin            Bool
 125 //  | NAtt_pos ...        PA: ignored for the time being
 126     | NAtt_rects          Rect
 127     | NAtt_regular        Bool
 128     | NAtt_samplepoints   Int
 129     | NAtt_shape          NodeShape
 130     | NAtt_shapefile      String
 131     | NAtt_showboxes      Int
 132     | NAtt_sides          Int
 133     | NAtt_skew           Real
 134     | NAtt_style          NodeStyle
 135     | NAtt_target         String
 136     | NAtt_tooltip        String
 137     | NAtt_width          Real
 138     | NAtt_z              Real
 139 :: EdgeAttribute
 140     = EAtt_URL            String
 141     | EAtt_arrowhead      ArrowType
 142     | EAtt_arrowsize      Real
 143     | EAtt_arrowtail      ArrowType
 144     | EAtt_color          Color
 145     | EAtt_colorscheme    String
 146     | EAtt_comment        String
 147     | EAtt_constraint     Bool
 148     | EAtt_decorate       Bool
 149     | EAtt_dir            DirType
 150     | EAtt_edgeURL        String
 151     | EAtt_edgehref       String
 152     | EAtt_edgetarget     String
 153     | EAtt_edgetooltip    String
 154     | EAtt_fontcolor      Color
 155     | EAtt_fontname       String
 156     | EAtt_fontsize       Real
 157     | EAtt_headURL        String
 158     | EAtt_headclip       Bool
 159     | EAtt_headhref       String
 160     | EAtt_headlabel      String
 161     | EAtt_headport       PortPos
 162     | EAtt_headtarget     String
 163     | EAtt_headtooltip    String
 164     | EAtt_href           String
 165     | EAtt_label          String
 166     | EAtt_labelURL       String
 167     | EAtt_labelangle     Real
 168     | EAtt_labeldistance  Real
 169     | EAtt_labelfloat     Bool
 170     | EAtt_labelfontcolor Color
 171     | EAtt_labelfontname  String
 172     | EAtt_labelfontsize  Real
 173     | EAtt_labelhref      String
 174     | EAtt_labeltarget    String
 175     | EAtt_labeltooltip   String
 176     | EAtt_layer          LayerRange
 177     | EAtt_len            Real
 178     | EAtt_lhead          String
 179     | EAtt_lp             DotPoint
 180     | EAtt_ltail          String
 181     | EAtt_minlen         Int
 182     | EAtt_nojustify      Bool
 183 //  | EAtt_pos                  PA: ignored for the time being
 184         | EAtt_samehead       String
 185         | EAtt_sametail       String
 186         | EAtt_showboxes      Int
 187         | EAtt_style          EdgeStyle
 188         | EAtt_tailURL        String
 189         | EAtt_tailclip       Bool
 190         | EAtt_tailhref       String
 191         | EAtt_taillabel      String
 192         | EAtt_tailport       PortPos
 193         | EAtt_tailtarget     String
 194         | EAtt_tailtooltip    String
 195         | EAtt_target         String
 196         | EAtt_tooltip        String
 197         | EAtt_weight         Real
 198 :: ClusterMode
 199         = CM_local | CM_global | CM_none
 200 :: CompassPoint
 201         = CP_n | CP_ne | CP_e | CP_se | CP_s | CP_sw | CP_w | CP_nw
 202 :: DotPoint
 203         = DotPoint Real Real Bool
 204 :: LayerId
 205     = LayerAll
 206     | LayerNr   Int
 207     | LayerName String
 208 :: LayerList
 209         = LayerList [String]
 210 :: LayerRange
 211     = LayerRange LayerId [LayerId]
 212 :: Margin
 213     = SingleMargin Real
 214     | DoubleMargin Real Real
 215 :: OutputMode
 216         = OM_breadthfirst | OM_nodesfirst | OM_edgesfirst
 217 :: Pad
 218         = SinglePad Real
 219         | DoublePad Real Real
 220 :: PageDir
 221         = PD_BL | PD_BR | PD_TL | PD_TR | PD_RB | PD_RT | PD_LB | PD_LT
 222 :: Pointf
 223         = Pointf Real Real
 224 :: PortPos                              // PA: for now only compass points are supported
 225         :== CompassPoint
 226 :: RankDir
 227         = RD_TB | RD_LR | RD_BT | RD_RL
 228 :: RankType
 229         = RT_same | RT_min | RT_source | RT_max | RT_sink
 230 :: Ratio
 231         = AspectRatio Real
 232         | R_fill
 233         | R_compress
 234         | R_expand
 235         | R_auto
 236 :: Rect
 237     = {llx :: Int,lly :: Int, urx :: Int, ury :: Int}
 238 :: Sizef                // PA++
 239         = Sizef Real Real Bool
 240 :: StartStyle
 241         = SS_regular | SS_self | SS_random
 242 :: StartType
 243         = { startStyle :: Maybe StartStyle
 244           , startSeed  :: Maybe Int
 245           }
 246 :: ViewPort
 247         = { vp_W       :: Real
 248           , vp_H       :: Real
 249           , vp_Z       :: Maybe Real
 250           , vp_xy      :: Maybe Pointf
 251           }
 252
 253 pointNode           :: [NodeAttribute] // attributes of a point-shaped node
 254 hiddenNode          :: [NodeAttribute] // attributes of a hidden node
 255
 256
 257 :: NodeShape
 258     = NShape_box
 259     | NShape_circle
 260     | NShape_diamond
 261     | NShape_doublecircle
 262     | NShape_doubleoctagon
 263     | NShape_egg
 264     | NShape_ellipse
 265     | NShape_hexagon
 266     | NShape_house
 267     | NShape_invtriangle
 268     | NShape_invtrapezium
 269     | NShape_invhouse
 270     | NShape_octagon
 271     | NShape_Mdiamond
 272     | NShape_Msquare
 273     | NShape_Mcircle
 274     | NShape_parallelogram
 275     | NShape_pentagon
 276     | NShape_plainText
 277     | NShape_polygon
 278     | NShape_point
 279     | NShape_rect
 280     | NShape_rectangle
 281     | NShape_septagon
 282     | NShape_trapezium
 283     | NShape_triangle
 284     | NShape_tripleoctagon
 285     | NShape_none
 286 instance toString NodeShape
 287 instance ==       NodeShape
 288 derive gEq NodeShape // PK++
 289
 290 ::  NodeStyle
 291     = NStyle_filled
 292     | NStyle_invis
 293     | NStyle_diagonals
 294     | NStyle_rounded
 295     | NStyle_dashed
 296     | NStyle_dotted
 297     | NStyle_solid
 298     | NStyle_bold
 299 instance toString NodeStyle
 300 instance ==       NodeStyle
 301 derive gEq NodeStyle // PK++
 302
 303 :: EdgeStyle
 304     = EStyle_solid
 305     | EStyle_bold
 306     | EStyle_dashed
 307     | EStyle_dotted
 308     | EStyle_invis
 309 instance toString EdgeStyle
 310 instance ==       EdgeStyle
 311 derive gEq EdgeStyle // PK++
 312
 313 :: Color
 314     = RGB   Int  Int  Int
 315     | HSV   Real Real Real
 316     | Color String          // X11 1.2 color names; see rgb.txt
 317
 318 C_black   :== Color "black"
 319 C_white   :== Color "white"
 320 C_gray    :== Color "gray"
 321 C_red     :== Color "red"
 322 C_green   :== Color "green"
 323 C_blue    :== Color "blue"
 324 C_yellow  :== Color "yellow"
 325
 326 instance toString Color
 327 instance ==       Color
 328 derive gEq Color // PK++
 329
 330 :: ArrowType =
 331     { closest       :: Arrow
 332     , furthest      :: Maybe Arrow
 333     }
 334 :: Arrow =
 335     { open          :: Bool
 336     , side          :: Maybe Side
 337     , shape         :: ArrowShape
 338     }
 339 :: Side
 340     = Side_l
 341     | Side_r
 342 :: ArrowShape
 343     = AShape_box
 344     | AShape_crow
 345     | AShape_diamond
 346     | AShape_dot
 347     | AShape_inv
 348     | AShape_none
 349     | AShape_normal
 350     | AShape_tee
 351     | AShape_vee
 352 instance toString ArrowType
 353 instance ==       ArrowType
 354 derive gEq ArrowType // PK++
 355
 356
 357 // direction of the edge
 358 :: DirType
 359     = DT_forward
 360     | DT_back
 361     | DT_both
 362     | DT_none
 363 instance toString DirType
 364 instance ==       DirType
 365 derive gEq DirType // PK++
 366
 367 layersep :== ":\t"
 368
 369 mkDigraph :: String (KnownAutomaton s i o,s,[s],[s],[SeenTrans s i o],[SeenTrans s i o]) -> Digraph | render, gEq{|*|} s
 370                                                                                                                                                                                                         & render, gEq{|*|} i
 371                                                                                                                                                                                                         & render, gEq{|*|} o