← Back to branch summary

~ubuntu-branches/ubuntu/lucid/graphviz/lucid-security

« back to all changes in this revision

Viewing changes to tcldgr/demo/ihi

  • Committer: Bazaar Package Importer
  • Author(s): Stephen M Moraco
  • Date: 2002-02-05 18:52:12 UTC
  • Revision ID: james.westby@ubuntu.com-20020205185212-8i04c70te00rc40y
Tags: upstream-1.7.16
Import upstream version 1.7.16

Show diffs side-by-side

added added

removed removed

Lines of Context:
tcldgr/demo/ihi
 
1
#!/bin/sh
 
2
# next line is a comment in tcl \
 
3
exec tclsh "$0" ${1+"$@"}
 
4
 
 
5
package require Tcl 8.3
 
6
package require Tcldgr
 
7
 
 
8
###########################################################################
 
9
#
 
10
# IHI
 
11
#
 
12
# An implementation of Inheritance Hierachies Inference (IHI)
 
13
#
 
14
# Classifies objects with varying patterns of attributes 
 
15
#
 
16
# Based on the paper:
 
17
#       "A Simple and Efficient Algorithm for Inferring Inheritance Heirarchies"
 
18
#       Ivan Moore, Tim Clement
 
19
#       Department of Computer Science, University of Manchester
 
20
#   Published in TOOLS Europe, 1996, Prentice-Hall
 
21
#
 
22
# tcl + tcldg   implementation by John Ellson  (ellson@lucent.com)
 
23
#
 
24
# usage:  ihi <file
 
25
#         ihi file
 
26
#
 
27
# where files contain one object per line each object described
 
28
# by a set of features, e.g:
 
29
#
 
30
#   a b e
 
31
#   a b f
 
32
#   a c d g i
 
33
#   a c d g h j
 
34
#   d h
 
35
#
 
36
# (contrary to this example, the features of each object do
 
37
# not have to be sorted, and the objects do not have to have unique
 
38
# feature sets)
 
39
#
 
40
#
 
41
###########################################################################
 
42
 
 
43
set options(removefeatureedges) true
 
44
set options(removefeaturenodes) true
 
45
set options(removeobjectnodes) true
 
46
set options(labelclasses) true
 
47
 
 
48
proc classify {g f} {
 
49
    while {![eof $f]} {
 
50
        set feature_set [gets $f]
 
51
        if {![string length $feature_set]} {continue}
 
52
        extract_features $g $feature_set
 
53
    }
 
54
    introduce_classes $g
 
55
    add_inheritance_edges $g
 
56
    remove_unnecessary_edges $g
 
57
    label_classes $g
 
58
    cleanup $g
 
59
}
 
60
 
 
61
proc extract_features {g object} {
 
62
        foreach feature $object {
 
63
                if {![catch {$g addnode $feature type feature shape triangle}]} {
 
64
                        lappend feature_set $feature
 
65
                }
 
66
        }
 
67
        if {![info exists feature_set]} {return}
 
68
 
 
69
        # sort feature_set so that objects with the same features but in
 
70
        #  different order are not duplicated
 
71
        set feature_set [lsort $feature_set]
 
72
        if {[catch {$g addnode $feature_set type object shape box} o]} {
 
73
                set o [$g findnode $feature_set]
 
74
        }
 
75
        foreach feature $feature_set {
 
76
                catch {$g addedge $feature $o color red}
 
77
        }
 
78
}
 
79
 
 
80
proc introduce_classes {g} {
 
81
        global options
 
82
 
 
83
        # create the mapping graph  -- introduces all the classes
 
84
        foreach feature [$g listnodes type feature] {
 
85
                set objects {}
 
86
                foreach featureedge [$feature listoutedges] {
 
87
                        lappend objects [$featureedge headof]
 
88
                        if {$options(removefeatureedges)} {
 
89
                                $featureedge delete
 
90
                        }
 
91
                }
 
92
                set objects [lsort $objects]
 
93
 
 
94
                # if the set of objects matches those of a previously added
 
95
                # class node then this addnode operation returns the handle of
 
96
                # that existing node rather than creating a new one.
 
97
                set class [$g addnode $objects type class label { }]
 
98
                $feature addedge $class
 
99
        }
 
100
        foreach class [$g listnodes type class] {
 
101
                foreach o [$class showname] {
 
102
                        $class addedge $o
 
103
                }
 
104
        }
 
105
}
 
106
 
 
107
proc add_inheritance_edges {g} {
 
108
        #sort the classes into buckets according to number of subclasses
 
109
        # this aids the finding of subclasses which are proper subsets of 
 
110
        # superclasses since the subclass must have at least one less member
 
111
        set max 0
 
112
        foreach class [$g listnodes type class] {
 
113
                set count [$class countoutedges]
 
114
                lappend classes($count) [$class showname]
 
115
                if {$count > $max} {set max $count}
 
116
        }
 
117
 
 
118
        # add inheritance edges
 
119
        for {set i $max} {$i > 1} {incr i -1} {
 
120
                for {set j [expr $i -1]} {$j} {incr j -1} {
 
121
                        if {! [info exists classes($j)]} {continue}
 
122
                        foreach sub $classes($j) {
 
123
                                if {! [info exists classes($i)]} {continue}
 
124
                                set nsub [$g findnode $sub]
 
125
                                foreach sup $classes($i) {
 
126
                                        # compare till mismatch
 
127
                                        set index 0
 
128
                                        set length [llength $sup]
 
129
                                        foreach object $sub {
 
130
                                                set found 0
 
131
                                                for {set k $index} {$k < $length} {incr k} {
 
132
                                                        if {[string equal $object [lindex $sup $k]} {
 
133
                                                                set found 1
 
134
                                                                break
 
135
                                                        }
 
136
                                                }
 
137
                                                if {! $found} {break}
 
138
                                                set index [incr k]
 
139
                                        }
 
140
                                        if {$found} {
 
141
                                                set nsup [$g findnode $sup]
 
142
                                                $nsup addedge $nsub
 
143
                                        }
 
144
                                }
 
145
                        }
 
146
                }
 
147
        }
 
148
}
 
149
 
 
150
proc remove_unnecessary_edges {g} {
 
151
        # remove inheritance edges that are unnecessary due to transtivity
 
152
        foreach class [$g listnodes type class] {
 
153
                set subs {}
 
154
                foreach sub [$class listoutedges] {
 
155
                        lappend subs [$sub headof]
 
156
                }
 
157
                foreach sub $subs {
 
158
                        remove_transitive_recurse $class $sub
 
159
                }
 
160
        }
 
161
}
 
162
 
 
163
proc remove_transitive_recurse {sup sub} {
 
164
        set subsubs {}
 
165
        foreach subsub [$sub listoutedges] {
 
166
                lappend subsubs [$subsub headof]
 
167
        }
 
168
        foreach subsub $subsubs {
 
169
                remove_transitive_recurse $sup $subsub
 
170
                foreach supsubsub [$subsub listinedges] {
 
171
                        if {[string equal [$supsubsub tailof] $sup]} {
 
172
                                $supsubsub delete
 
173
                        }
 
174
                }
 
175
        }
 
176
}
 
177
 
 
178
proc label_classes {g} {
 
179
        global options
 
180
 
 
181
        # label classes with their aggregate feature set
 
182
        #   i.e. the features they add plus the ones they inherit
 
183
        if {$options(labelclasses)} {
 
184
                foreach class [$g listnodes type class] {
 
185
                        foreach name [array names features] {unset features($name)}
 
186
                        foreach feature [list_features_recurse $class] {
 
187
                                set features($feature) 1
 
188
                        }
 
189
                        $class set label [lsort [array names features]]
 
190
                }
 
191
        }
 
192
}
 
193
 
 
194
proc list_features_recurse {sup} {
 
195
        if {[string equal [$sup set type] feature]} {
 
196
                set result [$sup showname]
 
197
        } {
 
198
                set result {}
 
199
                foreach sup [$sup listinedges] {
 
200
                        set result [concat $result [list_features_recurse [$sup tailof]]]
 
201
                }
 
202
        }
 
203
        return $result
 
204
}
 
205
 
 
206
proc cleanup {g} {
 
207
        global options
 
208
 
 
209
        # remove feature nodes
 
210
        if {$options(removefeaturenodes)} {
 
211
                foreach feature [$g listnodes type feature] {
 
212
                        $feature delete
 
213
                }
 
214
        }
 
215
 
 
216
        # remove objects and mark instantiable classes
 
217
        if {$options(removeobjectnodes)} {
 
218
                foreach object [$g listnodes type object] {
 
219
                        set sup [$object listinedges]
 
220
                        if {[llength $sup] > 1} {
 
221
                                error "object has more than one class"
 
222
                        }
 
223
                        if {![string length $sup]} {
 
224
                                $object setattributes peripheries 2 shape {}
 
225
                        } {
 
226
                                [$sup tailof] set peripheries 2
 
227
                                $object delete
 
228
                        }
 
229
                }
 
230
        }
 
231
}
 
232
 
 
233
#######################
 
234
# display code
 
235
 
 
236
#package require Tk
 
237
#set c [canvas .c]
 
238
#pack $c
 
239
#set v [dgview dynadag]
 
240
 
 
241
 
 
242
#######################
 
243
 
 
244
if {[string length $argv]} {
 
245
    set f [open $argv r]
 
246
} {
 
247
    set f stdin
 
248
}
 
249
 
 
250
#set g [dgnew digraphstrict]
 
251
set g [dgnew digraph]
 
252
 
 
253
classify $g $f
 
254
 
 
255
# display graph
 
256
set display "dot -Tps | gv -"
 
257
set f [open |$display w]
 
258
$g write $f