extra/tools/image-analyzer/graphviz/graphviz.factor

   1 USING: accessors alien.strings assocs classes graphviz
   2 graphviz.attributes graphviz.notation kernel math.parser sequences
   3 slots.syntax system tools.image-analyzer
   4 tools.image-analyzer.ref-fixer tools.image-analyzer.vm vocabs.parser ;
   5 IN: tools.image-analyzer.graphviz
   6 FROM: arrays => 1array 2array ;
   7 FROM: byte-arrays => >byte-array ;
   8 FROM: kernel => object ;
   9 FROM: math => - ;
  10
  11 <<
  12 ! For the two annoying structs that differ on 32 and 64 bit.
  13 cpu x86.32?
  14 "tools.image-analyzer.vm.32"
  15 "tools.image-analyzer.vm.64"
  16 ? use-vocab
  17 >>
  18
  19 GENERIC: object-references ( struct -- seq )
  20
  21 M: word object-references ( struct -- seq )
  22     slots{ def entry_point name props vocabulary } ;
  23
  24 M: code-block object-references ( struct -- seq )
  25     slots{ owner parameters relocation } ;
  26
  27 M: object object-references ( struct -- seq )
  28     drop { } ;
  29
  30 : heap-node>edges ( heap-node -- edges )
  31     [ address>> ]
  32     [
  33         object>> object-references [ 1 = ] reject
  34     ] bi [ 2array ] with map ;
  35
  36 CONSTANT: node-colors {
  37     { array "#999999" }
  38     { bignum "#cc3311" }
  39     { byte-array "#ffff00" }
  40     { code-block "#ffaaff" }
  41     { string "#aaddff" }
  42     { quotation "#449900" }
  43     { word "#00ff99" }
  44 }
  45
  46 : array>string ( array -- str )
  47     0 suffix >byte-array alien>native-string ;
  48
  49 : heap-node>label ( heap-node -- id )
  50     dup object>> dup string? [ drop payload>> array>string ] [
  51         [ address>> ] dip
  52         code-block? [ code-heap-shift - ] when number>string
  53     ] if ;
  54
  55 : heap-node>fill-color ( heap-node -- color )
  56     object>> class-of node-colors at ;
  57
  58 : heap-node>node ( heap-node -- node )
  59     dup address>> <node>
  60     over heap-node>fill-color =fillcolor
  61     swap heap-node>label =label
  62     "filled" =style ;
  63
  64 : add-edges ( graph edges -- graph )
  65     [ first2 add-edge ] each ;
  66
  67 : setup-graph ( graph -- graph )
  68     [graph "neato" =layout ];
  69     <graph-attributes> "false" >>overlap add ;
  70
  71 : make-graph ( heap-nodes -- graph )
  72     dup <digraph> setup-graph
  73     swap [ heap-node>node add ] each
  74     swap [ heap-node>edges add-edges ] each ;
  75
  76 : graph-image ( image -- graph )
  77     load-image swap dupd fix-references make-graph ;