El algoritmo de unificación recibe dos referencias $m y $n a los
árboles que van a ser unificados. Retorna verdadero si la unificación puede
tener lugar y falso en caso contrario.
La equivalencia se mantiene utilizando un atributo cuyo nombre es $set.
Todos los nodos en una clase de equivalencia tienen un único representante.
Los atributos $set de los nodos
en una misma clase referencian al representante
(posiblemente de forma indirecta, via los campos $set de otros nodos).
El atributo $set del representante canónico apunta a si mismo.
Inicialmente cada nodo esta en una clase única.
99 sub unify {
100 my ($m, $n) = @_;
101
102 my $s = representative($m);
103 my $t = representative($n);
104
105 return 1 if ($s == $t);
106
107 return 1 if $samebasic->($s, $t);
108
109 print "Unifying ".representative($s)->str." and ".representative($t)->str."\n" if $debug;
110 return 1 if (mergevar($s, $t));
111
112 if (ref($s) eq ref($t)) {
113 $s->{$set} = representative($t);
114 my $i = 0;
115 for ($s->children) {
116 my $tc = $t->child($i++);
117 return 0 unless unify($_, $tc);
118 }
119 return 1;
120 }
121
122 return 0;
123 }
Nótese que unificar $m y $n es unificar sus representantes canónicos
$s y $t. Los representantes serán iguales si $m y $n
ya están en la misma clase de equivalencia.
El algoritmo de unificación usa las siguientes funciones auxiliares:
representative retorna una referencia al representante ccanónico
de la clase:
83 sub representative {
84 my $t = shift;
85
86 if (@_) {
87 $t->{$set} = shift;
88 return $t;
89 }
90 $t = $t->{$set} while defined($t->{set}) && ($t != $t->{$set});
91 die "Representative ($set) not defined!".Dumper($t) unless defined($t->{set});
92 return $t;
93 }
También permite cambiar el representante.
$s y $t representan el mismo tipo básico la función
referenciada por $samebasic devolverá verdadero. La función
$samebasic es definida por medio de la función set
junto con los otros parámetros del algoritmode unificación.
203 Aho::Unify->set(
204 key => 'set',
205 isvar => sub { $_[0] =~ /^Parse::Eyapp::Node::TYPEVAR/ },
206 samebasic => sub {
207 my ($s, $t) = @_;
208
209 return (((ref($s) eq 'INT') || (ref($s) eq'STRING')) && (ref($s) eq ref($t)));
210 },
211 debug => $debug,
212 );
$s o $t es una variable la introducimos en la clase de
equivalencia de la otra. Puesto que cada variable fresca es un único nodo (estamos trabajando con un DAG)
la actualización de la clase de equivalencia será visible en todas las apariciones de esta variable.
Además representative recorre la lista de enlaces de unificación retornando
el tipo básico o constructor con el que la variable se ha unificado.
La función mergevar mezcla las clases de equivalencia cuando uno de los
representantes es una variable:
67 sub mergevar {
68 my ($s, $t) = @_;
69
70 if (isvar($s)) {
71 $s->{$set} = representative($t);
72 print $s->str." = ".representative($t)->str."\n" if $debug;
73 return 1;
74 }
75 if (isvar($t)) {
76 $t->{$set} = representative($s);
77 print $t->str." = ".representative($s)->str."\n" if $debug;
78 return 1;
79 }
80 return 0;
81 }
set
una función $isvar que permite añadir variables adicionales:
23 sub isvar {
24 my $x = $isvar->(@_);
25 return $x if $x;
26 return 1 if $_[0] =~ /^Parse::Eyapp::Node::TYPEVAR::[\w:]+$/;
27 }
El espacio de nombres Parse::Eyapp::Node::TYPEVAR
se usa para las variables.
pl@nereida:~/doc/casiano/PLBOOK/PLBOOK/code/Aho-Polymorphism/lib/Aho$ cat -n Unify.pm
1 package Aho::Unify;
2 use Data::Dumper;
3 use Parse::Eyapp::Node;
4 use base qw (Exporter);
5 our @EXPORT_OK = qw(
6 unify
7 new_var
8 fresh
9 representative
10 strunifiedtree
11 hnewunifiedtree
12 newunifiedtree
13 selfrep
14 );
15 our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK ] );
16
17 my $count = 0;
18 my $set = 'representative';
19 my $isvar = sub { };
20 my $samebasic = sub { };
21 my $debug = 0;
29 sub set {
30 my $class = shift if @_ %2;
31 $class = __PACKAGE__ unless defined($class);
32
33 my %handler = @_;
34
35 $set = 'representative';
36 $set = $handler{key} if exists($handler{key});
37 $isvar = $handler{isvar} if exists($handler{isvar});
38 $samebasic = $handler{samebasic} if exists($handler{samebasic});
39 $debug = $handler{debug} if exists($handler{debug});
40 $count = 0;
41
42 bless { key => $set, isvar => $isvar, samebasic => $samebasic, count => $count }, $class;
43 }