<html><body><pre>
#!/usr/bin/perl -w
# fis; encadenamiento regresivo (tipo PROLOG) en PERL
# autores: Ruben Rusiles, Isela Gonzalez
# DATOS
# afirmaciones
# [["deedee","tiene","pelo"],[["bozo","es","mamifero"],["vacio"]]]
# reglas
# [["identifica",["?animal","tiene","pelo"],["?animal","es","mamifero"]],
# ["vacio"]]
# VARIABLES GLOBALES
my $afirmaciones;
my $reglas;
my $c = 0; # contador variables unicas
# sub LISTAS Y ATOMOS ------------------------------------------------------
# --------------------------------------------------------------------------
# regresa una lista con los argumentos
sub list {
my $res=[];
my $valor;
my $c=0;
while ($valor=shift) {
$res->[$c]=$valor;
$c++;
}
return $res;
}
# inserta un atomo o lista dentro de una lista
sub cons {
my $valor=shift;
my $lista=shift;
my $res;
for $i (0 .. $#{$lista})
{
$res->[$i+1]=$lista->[$i];
}
$res->[0]=$valor;
return $res;
}
# determina la igualdad de 2 atomos y/o listas
sub equal {
my $list1 = shift;
my $list2 = shift;
if (!$list1 && !$list2)
{
return 1;
}
if (!$list1 || !$list2)
{
return 0;
}
if (atom($list1) && atom($list2))
{
return eql($list1,$list2) ? 1: 0;
}
if (equal(car($list1),car($list2)))
{
return equal(cdr($list1),cdr($list2));
}
return 0;
}
# regresa la copia de una lista
sub copia {
my $list = shift;
my $i;
my $res;
if (null($list))
{
$res = [];
}
if (!null($list))
{
for $i (0..$#{$list})
{
$res->[$i] = $list->[$i] ;
}
}
return $res;
}
# une dos listas
sub append {
my $list1 = shift;
my $list2 = shift;
my $i;
my $j;
my $res;
if (null($list1) && null($list2))
{
$res = [];
}
if (!null($list1))
{
for $i (0..$#{$list1})
{
$res->[$i] = $list1->[$i] ;
}
}
if (!null($list2))
{
$i=$#{$list1}+1;
for $j (0..$#{$list2})
{
$res->[$i+$j] = $list2->[$j] ;
}
}
return $res;
}
# regreso 1 si la lista es []
# regresa 0 otro caso
sub null {
my $valor = shift;
return $#{$valor}==-1 && substr($valor,0,5) eq "ARRAY" ? 1 : 0;
}
# imprime una lista en forma recursiva
sub v {
my $valor = shift;
my $res;
if (! $valor) {
return "0";
}
if(null($valor))
{
return "[]";
}
if (atom($valor))
{
return "\"$valor\"" ;
}
else {
$res = "[" . v($valor->[0]) ;
for $i (1 .. $#{$valor})
{
$res .= "," . v($valor->[$i]);
}
$res .= "]";
return $res;
}
}
#determina si un valor es lista
sub listp {
my $valor = shift;
if (null($valor)) { return 1;} # ??? [] es lista
else { return !atom($valor) ? 1 : 0;}
}
#determina si un valor es atomico
sub atom {
my $valor = shift;
return ($#{$valor}==-1 && substr($valor,0,5) ne "ARRAY")
|| null($valor) ? 1 : 0 ;
}
#determina el car de una lista
sub car {
my $valor = shift;
if (null($valor)) {
return;
}
else {
if (atom($valor)) {return;}
else {return $valor -> [0];}
}
}
#regresa el cdr de una lista
sub cdr {
my $valor = shift;
my $res;
if (atom($valor) && !null($valor))
{
return;
}
if (length1($valor)<=1) # ??? se agrego < para []
{
return [];
}
else
{
for $m (1 .. length1($valor)-1)
{
# ??? NO USAR cons
$res->[$m-1]=$valor->[$m];
}
return $res;
}
}
# !!! length es predefinida
# regresa la longitud de una lista
sub length1{
my $valor=shift;
if (atom($valor)==1 || null($valor)==1) {
return 0;
}
else {
return $#{$valor}+1;
}
}
# !!! last es predefinida
# devuelve el ultimo elemento de una lista
sub last1 {
my $lista=shift;
my $n;
if (null($lista)) {
return;
}
$n = length1($lista)-1;
return $lista->[$n];
}
# devuelve toda la lista, menos el ultimo elemento
sub butlast {
my $lista = shift;
my $res;
for $j ( 0 .. length1($lista)-2 )
{
$res->[$j]=$lista->[$j]
}
return $res;
}
sub eql{
my $at1=shift;
my $at2=shift;
return atom($at1) && atom($at2) &&
( ($at1 eq $at2) || (null($at1) && null($at2))) ? 1 : 0;
}
sub member {
my $list1 = shift;
my $list2 = shift;
if (&null($list2) || &null($list1))
{
return 0;
}
if (&equal($list1,$list2))
{
return 1;
}
else
{
if (&equal($list1,&car($list2)))
{
return 1;
}
else
{
return &member($list1,&cdr($list2));
}
}
}
# sub LIGADURAS ------------------------------------------------------------
# --------------------------------------------------------------------------
# pag 373
# agrega una ligadura, dada expresion_var "?X", y dato para ligar
sub agrega_ligadura {
my $expresion_var = shift;
my $dato = shift;
my $ligaduras = shift;
my $ultimo;
if ( extrae_variable($expresion_var) eq "_" )
{
return $ligaduras;
}
else
{
if (null($ligaduras))
{
return cons([extrae_variable($expresion_var),$dato],$ligaduras);
}
else
{
$ultimo = length1($ligaduras); # agregar como ultimo
$ligaduras->[$ultimo] = [&extrae_variable($expresion_var),$dato];
return $ligaduras;
}
}
}
# pag 373
# regresa el nombre de una variable
sub extrae_variable {
my $expresion_var = shift;
return substr($expresion_var,1);
}
# pag 373
# regresa la llave de una ligadura
sub extrae_llave {
my $ligadura = shift;
return car($ligadura);
}
# pag 373
# regresa el valor de una ligadura
sub extrae_valor {
my $ligadura = shift;
return $ligadura->[1];
}
# pag 374
# recibe una expresion_var "?X" y busca la var X en ligaduras
# si la encuentra, regresa ligadura
# si no, regresa NADA
sub encuentra_ligadura {
my $expresion_var = shift;
my $ligaduras= shift;
my $i=0;
#print " ";
#print "encuentra_ligadura: ";
#print v($expresion_var) . " " . v($ligaduras);
#print "\n";
if (null($expresion_var)) # ??? checa ligaduras
{
return;
}
# la variable "_" NO se liga
if (&extrae_variable($expresion_var) eq "_" || null($ligaduras))
{
# la variable "_" no se liga
return;
}
else
{
for $i (0 .. length1($ligaduras)-1)
{
if (extrae_variable($expresion_var) eq extrae_llave($ligaduras->[$i]))
{
return $ligaduras->[$i];
}
}
}
return;
}
# sub CORRESPONDE ----------------------------------------------------------
# --------------------------------------------------------------------------
# pag 378
# determina si los 2 parametros son atomicos
sub elementos_p{
my $p = shift;
my $d = shift;
return atom($p) && !variable_p($p)
&& atom($d) && !variable_p($d);
}
# pag 378
# determina si el patron $p es una variable
sub variable_p {
my $p = shift;
if (! $p) { return 0; } # ??? llegan valores nulos
return atom($p)==1 && substr($p,0,1) eq "?" ? 1 : 0 ;
}
# pag 378
# determina si patron $p y dato $d son listas
sub recursivos_p {
my $p = shift;
my $d = shift;
return listp($p) && listp($d) ? 1 : 0;
}
# pag 377
sub corresponde_atomos {
my $p = shift;
my $d = shift;
my $ligaduras =shift;
if (eql($p,$d) || (null($p) && null($d)))
{
return $ligaduras;
}
else
{
# "falla";
return;
}
}
# pag 377
sub corresponde_variable {
my $p = shift;
my $d = shift;
my $ligaduras = shift; # $p no debe ser arreglo, sino variable
my $ligadura;
$ligadura = encuentra_ligadura($p,$ligaduras);
if ($ligadura)
{
return corresponde(extrae_valor($ligadura),$d,$ligaduras);
}
else
{
return agrega_ligadura($p,$d,$ligaduras);
}
}
# pag 377
sub corresponde_partes {
my $p = shift;
my $d = shift;
my $ligaduras = shift;
my $res;
$res = corresponde(car($p),car($d),$ligaduras);
if (! $res )
{
# "NADA"
return;
}
else
{
return corresponde(cdr($p),cdr($d),$res);
}
}
# pag 373
sub corresponde {
my $p=shift;
my $d=shift;
# { &opt $ligaduras
my $ligaduras=shift;
if (! $ligaduras)
{
$ligaduras = [];
}
# }
if (elementos_p($p, $d))
{
return corresponde_atomos($p,$d,$ligaduras);
}
if (variable_p($p))
{
return corresponde_variable($p, $d, $ligaduras);
}
if (recursivos_p($p,$d))
{
return corresponde_partes($p,$d,$ligaduras);
}
# "NADA";
return;
}
# sub UNIFICA --------------------------------------------------------------
# --------------------------------------------------------------------------
# pag 380
sub unifica {
my $p1 = shift;
my $p2 = shift;
my $ligaduras = shift;
# { &opt $ligaduras
if (! $ligaduras)
{
$ligaduras = [];
}
# }
if (elementos_p($p1,$p2))
{
return unifica_atomos($p1,$p2,$ligaduras);
}
if (variable_p($p1))
{
return unifica_variable($p1,$p2,$ligaduras);
}
if (variable_p($p2))
{
return unifica_variable($p2,$p1,$ligaduras);
}
if (recursivos_p($p1,$p2))
{
return unifica_partes($p1,$p2,$ligaduras);
}
# "NADA";
return;
}
# pag 380
sub unifica_atomos {
my $p1 = shift;
my $p2 = shift;
my $ligaduras = shift;
if (eql($p1,$p2)) {return $ligaduras;}
else {return}
}
# pag 380
sub unifica_partes {
my $p1 = shift;
my $p2 = shift;
my $ligaduras = shift;
my $res;
if (null($p1) && null($p2))
{
return $ligaduras;
}
if (null($p1) || null($p2))
{
return;
}
$res = unifica(car($p1),car($p2), $ligaduras);
if (!$res) {return;}
else {return unifica(cdr($p1),cdr($p2),$res);} # ???
}
# pag 381
sub unifica_variable {
my $p1 = shift;
my $p2 = shift;
my $ligaduras = shift;
my $ligadura;
$ligadura = &encuentra_ligadura($p1,$ligaduras);
if ($ligadura)
{
return &unifica(&extrae_valor($ligadura),$p2,$ligaduras);
}
else
{
if (&contenido_p($p1,$p2,$ligaduras))
{
# "falla";
return;
}
else
{
return agrega_ligadura($p1,$p2,$ligaduras);
}
}
}
# sub VARIABLES ------------------------------------------------------------
# --------------------------------------------------------------------------
# pag 381
sub contenido_p {
my $variable = shift;
my $expresion = shift;
my $ligaduras = shift;
if (equal($variable,$expresion))
{
return 0;
}
else
{
return &contenido_o_igual_p($variable,$expresion,$ligaduras);
}
}
# pag 382
sub contenido_o_igual_p {
my $variable = shift;
my $expresion = shift;
my $ligaduras = shift;
my $ligadura;
if (equal($variable,$expresion))
{ # t
return 1;
}
if (&variable_p($expresion)) # ??? debe ir antes, por ser atomo
{
$ligadura = &encuentra_ligadura($expresion,$ligaduras);
if ($ligadura)
{
return &contenido_o_igual_p($variable,
extrae_valor($ligadura),
$ligaduras);
}
}
if (!$expresion || atom($expresion))
{ # nil
return 0;
}
return &contenido_o_igual_p($variable,car($expresion),$ligaduras) ||
&contenido_o_igual_p($variable,cdr($expresion),$ligaduras) ? 1 : 0;
}
# pag 419
sub particulariza_variables {
my $patron = shift;
my $lista_a = shift;
my $t1;
my $t2;
my $t;
if (variable_p($patron))
{
$ligadura = encuentra_ligadura($patron,$lista_a);
if ($ligadura)
{
$t1= particulariza_variables( extrae_valor($ligadura),
$lista_a
);
return $t1;
}
else
{
return $patron;
}
}
else {
if (atom($patron))
{
return $patron;
}
else
{
return cons(particulariza_variables(car($patron),$lista_a),
particulariza_variables(cdr($patron),$lista_a));
}
}
}
# pag 420
# genera variables temporales unicas # ??? se devuelve con ?, como ?X3
sub gentemp {
my $valor = shift;
$c ++;
return "?" . $valor .$c;
}
# sub FLUJOS ---------------------------------------------------------------
# --------------------------------------------------------------------------
# pag 384
sub final_del_flujo_p {
my $flujo = shift;
return (equal($flujo,["vacio"])) ? 1: 0 ;
}
# pag 384
sub principio_del_flujo {
my $flujo= shift;
return car($flujo);
}
# pag 384
sub resto_del_flujo {
my $flujo = shift;
#if ( equal($flujo->[1],"registro(\$sth)"))
#{
# eval $flujo->[1];
#}
#else
#{
# return $flujo->[1];
#}
return car(cdr($flujo));
}
# pag 384
sub construye_flujo {
my $objeto = shift;
my $flujo = shift;
return list($objeto,$flujo);
}
# pag 384
# regresa la "concatenacion" de 2 flujos
sub agrega_flujo {
my $flujo1 = shift;
my $flujo2 = shift;
if (final_del_flujo_p($flujo1))
{
return $flujo2;
}
else
{
return &construye_flujo(&principio_del_flujo($flujo1),&agrega_flujo(&resto_del_flujo($flujo1),$flujo2));
}
}
# pag 385
# regresa la concatenacion de un flujo de flujos
sub concatena_flujo {
my $flujos = shift;
if (final_del_flujo_p($flujos))
{
return ["vacio"];
}
else
{
if (&final_del_flujo_p(&principio_del_flujo($flujos)))
{
return &concatena_flujo(&resto_del_flujo($flujos));
}
else
{
return &construye_flujo(
&principio_del_flujo(&principio_del_flujo($flujos)),
&concatena_flujo(&construye_flujo(&resto_del_flujo(&principio_del_flujo($flujos)),
&resto_del_flujo($flujos)
)
)
);
}
}
}
# pag 385
# regresa un flujo transformado mediante una funcion
sub transforma_flujo {
my $procedimiento = shift;
my $flujo = shift;
my $patron = shift;
my $ligaduras = shift;
if (&final_del_flujo_p($flujo))
{
return ["vacio"];
}
else
{
return construye_flujo(
&$procedimiento(principio_del_flujo($flujo),$patron,$ligaduras),
transforma_flujo($procedimiento,resto_del_flujo($flujo),$patron,$ligaduras));
}
}
# pag 385
sub miembro_de_flujo {
my $objeto = shift;
my $flujo = shift;
if (final_del_flujo_p($flujo))
{
return 0;
}
if (equal($objeto,principio_del_flujo($flujo)))
{
return 1;
}
return miembro_de_flujo($objeto,resto_del_flujo($flujo));
}
# pag 385
# agrega un elemento al flujo, MODIFICANDO la variable de entrada $flujo
# regresa el elemento agregado o NADA si esta en el flujo
sub recuerda_flujo {
my $valor = shift;
my $flujo = shift;
my $res;
if (miembro_de_flujo($valor,$flujo)==1)
{
return; # NADA
}
else
{
$res=agrega_flujo($flujo,construye_flujo($valor,["vacio"]));
$flujo->[0] = $res->[0]; # paso de parametros por referencia ???
$flujo->[1] = $res->[1];
return $valor;
}
}
# sub ENCADENAMIENTO -------------------------------------------------------
# --------------------------------------------------------------------------
# sub AFIRMACIONES ---------------------------------------------------------
# pag 409
# $afirmaciones es global
# agrega afirmacion al flujo de $afirmaciones
sub recuerda_afirmacion{
my $afirmacion = shift;
return &recuerda_flujo($afirmacion,$afirmaciones);
}
# pag 414
sub intenta_afirmacion {
my $patron = shift;
my $afirmacion = shift;
my $ligaduras = shift;
my $res;
# no habia el car
# no habia copia
$res= corresponde($patron,$afirmacion,$ligaduras);
# eq "falla" ?
if (!$res)
{
return ["vacio"];
}
else
{
return construye_flujo($res,["vacio"]);
}
}
# pag 414, pag 401
sub corresponde_patron_afirmaciones {
my $patron = shift;
my $ligaduras = shift;
my $afirma =
sub
{ my $afirmacion = shift;
my $patron = shift;
my $ligaduras = shift; # !!! copia($ligaduras)
return intenta_afirmacion($patron,$afirmacion,copia($ligaduras))
};
return concatena_flujo(transforma_flujo($afirma,
$afirmaciones,$patron,$ligaduras)
);
}
# sub REGLAS ---------------------------------------------------------------
# pag 410
# $reglas es global
# v(recuerda_regla("es azul")) -> ["es azul",["vacio"]]
sub recuerda_regla{
my $regla = shift;
return &recuerda_flujo($regla,$reglas);
}
# pag 415
sub corresponde_patron_reglas {
my $patron = shift;
my $ligaduras = shift;
my $cpr_sub = sub {
my $regla = shift;
my $patron = shift;
my $ligaduras = shift;
return prueba_regla($patron,$regla,$ligaduras);
};
return concatena_flujo(transforma_flujo($cpr_sub,
$reglas,$patron,$ligaduras)
);
}
# pag 415
sub antecedentes_de_la_regla{
my $regla = shift;
return &butlast(cdr($regla));
}
# pag 415
sub nombre_de_la_regla {
my $regla=shift;
return &car($regla);
}
# pag 415
sub consecuente_de_la_regla {
my $regla = shift;
return &last1(&cdr($regla));
}
# pag 415
sub prueba_regla {
my $patron = shift;
my $regla = shift;
my $ligaduras = shift;
my $regla2;
$regla2 = haz_variables_unicas($regla);
$res = unifica( $patron,
&consecuente_de_la_regla($regla2),
$ligaduras
);
# eq "falla" ?
if (!$res)
{
return ["vacio"];
}
else
{
return &aplica_filtros( &antecedentes_de_la_regla($regla2),
&construye_flujo($res,["vacio"])
);
}
}
# pag 420
sub haz_variables_unicas {
my $regla = shift;
my $variables;
$variables = &lista_variables($regla);
for $j (0..length1($variables)-1)
{ $regla=particulariza_variables(
$regla,
list(list($variables->[$j],gentemp($variables->[$j]))));
}
return $regla;
}
# pag 419
sub lista_variables {
my $arbol = shift;
my $nombres = shift;
my $nomb;
if (! $nombres )
{
$nombres = [];
}
# variable_p antes de atom, ya que ?X es atom.
if (variable_p($arbol))
{
if (member(extrae_variable($arbol),$nombres))
{
return $nombres;
}
else
{
return append($nombres,list(extrae_variable($arbol)));
}
}
if (atom($arbol))
{
return $nombres;
}
return &lista_variables( cdr($arbol),
lista_variables(car($arbol),$nombres)
);
}
# sub ENCADENAMIENTO -------------------------------------------------------
# pag 413
sub aplica_filtros {
my $patrones = shift;
my $flujo_inicial = shift;
if (null($patrones))
{
return $flujo_inicial;
}
else
{
return aplica_filtros( cdr($patrones),
filtra_flujo(car($patrones),$flujo_inicial)
);
}
}
# pag 414
sub filtra_flujo {
my $patron = shift;
my $flujo = shift;
my $ff_sub = sub
{
my $ligaduras = shift;
my $patron = shift;
my $cpa;
my $cpr;
return concatena_flujo(
construye_flujo($cpa=corresponde_patron_afirmaciones($patron,$ligaduras),
construye_flujo($cpr=corresponde_patron_reglas($patron,$ligaduras),
["vacio"]
)
) );
};
return concatena_flujo(transforma_flujo($ff_sub,$flujo,$patron));
}
# pag 418
# recibe una lista de listas como argumento, es decir, recibe una lista de
#listas en $patrones ejem. [["bozo","es","mamifero"]]
sub encreg {
my $patrones = shift;
my $flujo_ligaduras;
my $variables;
my $resp_mostradas;
my $f;
$flujo_ligaduras =&aplica_filtros( $patrones,
&construye_flujo([],["vacio"])
);
# print v($flujo_ligaduras)."\n";
$variables = &lista_variables($patrones);
$resp_mostradas = [];
if (&null($variables))
{
if (&final_del_flujo_p($flujo_ligaduras))
{
# print "no\n";
return "no";
}
else
{
# print "si\n";
return "si";
}
# como incremento $f, resto_del_flujo flujo_de_ligaduras
}
else
{
# como incremento $f, resto_del_flujo flujo_de_ligaduras
for ( $f=$flujo_ligaduras; ! &final_del_flujo_p($f); $f=&resto_del_flujo($f)
)
{
$respuesta = &haz_respuesta( $variables, &principio_del_flujo($f));
if (!&member($respuesta,$resp_mostradas))
{
# &muestra_respuestas($respuesta);
$resp_mostradas=cons($respuesta,$resp_mostradas);
}
}
# print "no_mas \n";
# return "no_mas";
return $resp_mostradas;
}
}
# sub RESPUESTAS -----------------------------------------------------------
# pag 420
sub muestra_respuestas {
my $respuestas = shift;
for $i (0 .. $#{$respuestas})
{
print "--> ". $respuestas->[$i][0] . " = ". $respuestas->[$i][1] ."\n";
}
}
# pag 419
sub haz_respuesta {
my $variables = shift;
my $ligaduras = shift;
my $Resp;
for $i (0..$#{$variables})
{
$Resp->[$i][0] = $variables->[$i];
$Resp->[$i][1]="?" .$variables->[$i];
}
return &particulariza_variables($Resp,$ligaduras);
}
# sub mSQL -----------------------------------------------------------------
# --------------------------------------------------------------------------
sub er {
my $p=shift;
my $BDD;
my $Tabla;
my $patron;
my $dbh;
$BDD = car($p);
$Tabla = car((cdr($p)));
$p=cdr(cdr($p));
$patron= [$p];
$sth=principio_de_la_base($BDD,$Tabla);
print "$sth \n";
$afirmaciones=registro($sth);
encreg($patron);
}
sub principio_de_la_base {
my $BDD = shift;
my $Tabla = shift;
my $lineas;
my $nombres;
use Msql;
$dbh= Connect Msql "127.0.0.1",$BDD;
$sth= ListFields $dbh $Tabla;
# !!! @nombres= @{$sth->name};
$sth= Query $dbh "select * from $Tabla";
$lineas = $sth->numrows;
return $sth;
}
sub registro {
my $sth = shift;
my $resultado;
@arr = FetchRow $sth;
@nombres= @{$sth->name};
if (! @arr)
{
return ["vacio"];
}
else
{
for ($i=0;$i<=$#arr;$i++)
{
# print "\n".$nombres[$i]."=".$arr[$i]."\t";
$resultado->[$i]=[$nombres[$i],$arr[$i]];
}
}
return construye_flujo($resultado,'registro($sth)');
}
# sub DATOS ----------------------------------------------------------------
# --------------------------------------------------------------------------
sub datos_pag397 { # NO FUNCIONA, EXISTE UN CICLO RECURSIVO
# POR TENER ?animal es ?especie
# ANTES DE ?animal es ?padre de ?cria
$reglas = ["vacio"];
$afirmaciones=["vacio"];
&recuerda_afirmacion(["bozo","es","perro"]);
&recuerda_afirmacion(["deedee","es","caballo"]);
&recuerda_afirmacion(["deedee","es","padre","de","sugar"]);
recuerda_afirmacion(["deedee","es","padre","de","brassy"]);
&recuerda_regla(["identifica",["?animal","es","?especie"],
["?animal","es","padre","de","?cria"],
["?cria","es","?especie"]]);
return 1;
}
sub datos_pag397A { # YA FUNCIONA
# POR TENER ?animal es ?especie
# DESPUES DE ?animal es ?padre de ?cria
$reglas = ["vacio"];
$afirmaciones=["vacio"];
&recuerda_afirmacion(["bozo","es","perro"]);
&recuerda_afirmacion(["deedee","es","caballo"]);
&recuerda_afirmacion(["deedee","es","padre","de","sugar"]);
recuerda_afirmacion(["deedee","es","padre","de","brassy"]);
&recuerda_regla(["identifica",["?animal","es","padre","de","?cria"],
["?animal","es","?especie"],
["?cria","es","?especie"]]);
return 1;
}
sub datos_pag410 {
$reglas = ["vacio"];
$afirmaciones=["vacio"];
recuerda_afirmacion(["deedee","tiene","pelo"]);
recuerda_afirmacion(["bozo","es","mamifero"]);
recuerda_regla(["identifica",
["?animal","tiene","pelo"],["?animal","es","mamifero"]]);
return 1;
}
sub datos_pag420 {
$afirmaciones=["vacio"];
recuerda_afirmacion(["robbie","tiene","manchas","oscuras"]);
recuerda_afirmacion(["robbie","tiene","color","leonado"]);
recuerda_afirmacion(["robbie","come","carne"]);
recuerda_afirmacion(["robbie","tiene","pelo"]);
recuerda_afirmacion(["suzie","tiene","plumas"]);
recuerda_afirmacion(["suzie","vuela","bien"]);
$reglas = ["vacio"];
recuerda_regla(["identifica1",
["?animal","tiene","pelo"],
["?animal","es","mamifero"]]);
recuerda_regla(["identifica3",
["?animal","tiene","plumas"],
["?animal","es","ave"]]);
recuerda_regla(["identifica5",
["?animal","come","carne"],
["?animal","es","carnivoro"]]);
recuerda_regla(["identifica9",
["?animal","es","mamifero"],
["?animal","es","carnivoro"],
["?animal","tiene","color","leonado"],
["?animal","tiene","manchas","oscuras"],
["?animal","es","leopardo"]]);
recuerda_regla(["identifica15",
["?animal","es","ave"],
["?animal","vuela","bien"],
["?animal","es","albatros"]]);
return 1;
}
# sub INTERPRETE -----------------------------------------------------------
# --------------------------------------------------------------------------
sub inter{
$InPuT = 'no salir';
for (;;) {
print '(',join(', ',@ReSuLt),') ?';
$InPuT = <STDIN>;
chop $InPuT;
$? = 0; $@ = ''; $! = 0;
@ReSuLt = eval $InPuT;
# if ($ReSuLt[0] eq "salir") die "Bye";
if ($?) { print 'status=',$?,' ' }
if ($@) { print 'errmsg=',$@,' ' }
if ($!) { print 'errno=',$!+0,': ',$!,' ' }
}
}
# sub PRUEBAS --------------------------------------------------------------
# --------------------------------------------------------------------------
my $n=1187; # linea inicial de pruebas
sub p {
my $pru=shift;
my $res=shift;
if (equal(v($pru),v($res))) {
print $n . " OK ";
}
else {
print "\n" . $n . "->" . v($pru) . "\n < > " . v($res) ."\n";
}
$n=$n+2;
}
p( list("uno",["dos"],[["tres"]],[]),
["uno",["dos"],[["tres"]],[]]);
p( cons("uno",[]),
["uno"]);
p( cons("uno",[[]]),
["uno",[]]);
p( equal([["uno"],[["dos"]]],[["uno"],[["dos"]]]),
1);
p( equal("uno","dos"),
0);
p( equal([],[]),
1);
p( equal("uno","uno"),
1);
p( copia(["uno",[["dos"]]]),
["uno",[["dos"]]]);
p( copia([]),
[]);
p( append(["uno","dos",["tres"]],["cuatro",[["cinco"]]]),
["uno","dos",["tres"],"cuatro",[["cinco"]]]);
p( $a=append([],[]),
[]);
p( null([]),
1);
p( null(["uno"]),
0);
p( null([[]]),
0);
p( [],
[]);
p( ["uno",[["dos"]]],
["uno",[["dos"]]]);
p( cdr([]),
[]);
p( cdr(["uno"]),
[]);
p( cdr(["uno","dos"]),
["dos"]);
p( length1("a"),
0);
p( length1([]),
0);
p( length1(["uno","dos"]),
2);
p( last1(["uno","dos"]),
"dos");
p( last1(["uno",["dos"]]),
["dos"]);
p( last1([]),
0);
p( butlast(["uno","dos","tres"]),
["uno","dos"]);
p( butlast(["uno","dos"]),
["uno"]);
p( butlast(["uno",["dos"]]),
["uno"]);
p( agrega_ligadura("?X","gato",[["Y","perro"]]),
[["Y","perro"],["X","gato"]]);
p( extrae_variable("?X"),
"X");
p( extrae_llave(["X","perro"]),
"X");
p( extrae_valor(["X","perro"]),
"perro");
p( elementos_p("perro",[]),
1);
p( elementos_p([],[]),
1);
p( elementos_p("perro","gato"),
1);
p( variable_p("?X"),
1);
p( variable_p("X"),
0);
p( recursivos_p(["uno"],"dos"),
0);
p( recursivos_p(["uno"],[]),
1);
p( encuentra_ligadura("?X",[["X","algo"],["Y","NO"]]),
["X","algo"]);
p( encuentra_ligadura("?Z",[["X","algo"],["Y","NO"]]),
0);
p( corresponde_atomos("uno","uno",[["X","perro"],["Y","gato"]]),
[["X","perro"],["Y","gato"]]);
p( corresponde_atomos("uno","dos",[["X","perro"],["Y","gato"]]),
0);
p( corresponde_variable("?X","perro",[["X","perro"]]),
[["X","perro"]]);
p( corresponde_variable("?Y","gato",[["X","perro"]]),
[["X","perro"],["Y","gato"]]);
p( corresponde_variable("?X","gato",[["X","perro"]]),
0);
p( corresponde_partes(["?X","?Y"],["perro","gato"],[["X","perro"]]),
[["X","perro"],["Y","gato"]]);
p( corresponde(["?X","?Y"],["perro","gato"],[["X","perro"]]),
[["X","perro"],["Y","gato"]]);
p( corresponde(["?X","?Y"],["perro","gato"],[["X","burro"]]),
0);
p( corresponde(["?X","?Y"],["perro","gato"],[["Z","burro"]]),
[["Z","burro"],["X","perro"],["Y","gato"]]);
p( corresponde(["perro","?Y"],["perro","gato"],[["Z","burro"]]),
[["Z","burro"],["Y","gato"]]);
p( unifica(["?X","gato"],["perro","?Y"],[["X","perro"]]),
[["X","perro"],["Y","gato"]]);
p( unifica(["?X","?Y"],["perro","gato"],[["X","burro"]]),
0);
p( unifica(["?X","gato"],["perro","?Y"],[["Z","burro"]]),
[["Z","burro"],["X","perro"],["Y","gato"]]);
p( unifica(["perro","?Z"],["perro","gato"],[["X","?Y"],["Y","?Z"]]),
[["X","?Y"],["Y","?Z"],["Z","gato"]]);
p( unifica_atomos("uno","uno",[["X","perro"],["Y","gato"]]),
[["X","perro"],["Y","gato"]]);
p( unifica_atomos("uno","dos",[["X","perro"],["Y","gato"]]),
0);
p( unifica_partes(["?X","gato"],["perro","?Y"],[["X","perro"]]),
[["X","perro"],["Y","gato"]]);
p( contenido_p("?X", ["algo",[["?Y"]]],[["Y","?Z"],["Z","?X"]]),
1);
p( contenido_p("?X",["?X"],[]),
1);
p( contenido_p("?X","?X",[]),
0);
p (construye_flujo("algo",["vacio"]),
["algo",["vacio"]]);
p (agrega_flujo(["algo",["vacio"]],["otro",["vacio"]]),
["algo",["otro",["vacio"]]]);
p (agrega_flujo(["objeto-A",["objeto-B",["vacio"]]],["objeto-X",["objeto-Y",["vacio"]]]),
["objeto-A",["objeto-B",["objeto-X",["objeto-Y",["vacio"]]]]]);
p (concatena_flujo([["objeto-A",["objeto-B",["vacio"]]],[["objeto-X",["objeto-Y",["vacio"]]],["vacio"]]]),
["objeto-A",["objeto-B",["objeto-X",["objeto-Y",["vacio"]]]]]);
p (miembro_de_flujo("objeto-A",["objeto-A",["objeto-B",["vacio"]]]),
1);
p (miembro_de_flujo("ObjetoA",["objeto-A",["objeto-B",["vacio"]]]),
0);
p ($flujo=["objeto-A",["objeto-B",["objeto-X",["objeto-Y",["vacio"]]]]],
["objeto-A",["objeto-B",["objeto-X",["objeto-Y",["vacio"]]]]]);
p (recuerda_flujo("otro_mas",$flujo),
"otro_mas");
p ($flujo,
["objeto-A",["objeto-B",["objeto-X",["objeto-Y",["otro_mas",["vacio"]]]]]]);
p (recuerda_flujo("objeto-Y",$flujo),
0);
p ($flujo=["objeto-A",["vacio"]],
["objeto-A",["vacio"]]);
p (recuerda_flujo("otro_mas",$flujo),
"otro_mas");
p ($flujo,
["objeto-A",["otro_mas",["vacio"]]]);
p (recuerda_flujo("objeto-A",$flujo),
0);
p ($flujo=["vacio"],
["vacio"]);
p (recuerda_flujo("objeto-Y",$flujo),
"objeto-Y");
p ($flujo,
["objeto-Y",["vacio"]]);
p (datos_pag410(),
1);
p ($afirmaciones,
[["deedee","tiene","pelo"],[["bozo","es","mamifero"],["vacio"]]]);
p ($reglas,
[["identifica",["?animal","tiene","pelo"],["?animal","es","mamifero"]],["vacio"]]);
p (aplica_filtros([["?animal","tiene","pelo"]],[[["animal","bozo"]],["vacio"]]),
["vacio"]);
p (aplica_filtros([["?animal","tiene","pelo"]],[[["animal","deedee"]],["vacio"]]),
[[["animal","deedee"]],["vacio"]]);
p (datos_pag410(),
1);
p ($afirmaciones,
[["deedee","tiene","pelo"],[["bozo","es","mamifero"],["vacio"]]]);
p ($reglas,
[["identifica",["?animal","tiene","pelo"],["?animal","es","mamifero"]],["vacio"]]);
p (corresponde_patron_afirmaciones(["bozo","es","mamifero"],[]),
[[],["vacio"]]); # SI ES CIERTO
p (corresponde_patron_afirmaciones(["?X","es","mamifero"],[]),
[[["X","bozo"]],["vacio"]]);
p (corresponde_patron_afirmaciones(["?X","es","mamifero"],[["X","otro"]]),
["vacio"]);
p (datos_pag397(),
1);
p ($afirmaciones,
[["bozo","es","perro"],[["deedee","es","caballo"],[["deedee","es","padre","de","sugar"],[["deedee","es","padre","de","brassy"],["vacio"]]]]]);
p ($reglas,
[["identifica",["?animal","es","?especie"],["?animal","es","padre","de","?cria"],["?cria","es","?especie"]],["vacio"]]);
p (corresponde_patron_afirmaciones(["?animal","es","?especie"],[]),
[[["animal","bozo"],["especie","perro"]], [[["animal","deedee"],["especie","caballo"]],["vacio"]]]);
p (corresponde_patron_afirmaciones(["?animal","es","padre","de","?cria"],[["especie","caballo"],["animal","deedee"]]),
[[["especie","caballo"],["animal","deedee"],["cria","sugar"]],[[["especie","caballo"],["animal","deedee"],["cria","brassy"]],["vacio"]]]);
p (datos_pag410(),
1);
p ($afirmaciones,
[["deedee","tiene","pelo"],[["bozo","es","mamifero"],["vacio"]]]);
p ($reglas,
[["identifica",["?animal","tiene","pelo"],["?animal","es","mamifero"]],["vacio"]]);
p (intenta_afirmacion(["bozo","es","mamifero"],["bozo","es","mamifero"],[]),
[[],["vacio"]]);
p (intenta_afirmacion(["bozo","es","mamifero"],["deedee","tiene","pelo"],[]),
["vacio"]);
p (corresponde_patron_reglas(["bozo","no","hace match"],["vacio"]),
["vacio"]);
p (corresponde_patron_reglas(["bozo","es","mamifero"],[]),
["vacio"]);
p (corresponde_patron_reglas(["otro","es","mamifero"],[]),
["vacio"]);
p (corresponde_patron_reglas(["deedee","es","mamifero"],[]),
[[["animal8","deedee"]],["vacio"]]);
p (car($reglas),
["identifica",["?animal","tiene","pelo"],["?animal","es","mamifero"]]);
p (nombre_de_la_regla(car($reglas)),
"identifica");
p (antecedentes_de_la_regla(car($reglas)),
[["?animal","tiene","pelo"]]);
p (consecuente_de_la_regla(car($reglas)),
["?animal","es","mamifero"]);
p (haz_variables_unicas(car($reglas)),
["identifica",["?animal10","tiene","pelo"],["?animal10","es","mamifero"]]);
p (lista_variables(["?X"],[]),
["X"]);
p (lista_variables(["?X","?Y",[["?Z","es",[[["?W","?A"]]]]]],["A"]),
["A","X","Y","Z","W"]);
p (haz_respuesta(["x"],[["animal","deedee"],["x","?animal"]]),
[["x","deedee"]]);
p (particulariza_variables(["?uno","dos","tres"],[["uno","one"]]),
["one","dos","tres"]);
p (particulariza_variables(["X","?X"],[["animal","deedee"],["X","?animal"]]),
["X","deedee"]);
p (particulariza_variables("?animal",[["animal","deedee"]]),
"deedee");
p (particulariza_variables("X",[["animal","deedee"],["X","?animal"]]),
"X");
p (gentemp("X"),
"?X11");
p (datos_pag410(),
1);
p (encreg([["bozo","es","mamifero"]]),
"si");
p (encreg([["bozo","no","hace match"]]),
"no");
p (encreg([["otro","es","mamifero"]]),
"no");
p (encreg([["?x","es","mamifero"]]),
[[["x","deedee"]],[["x","bozo"]]]);
p (datos_pag420(),
1);
p (encreg([["?q","es","?a"]]),
[[["q","suzie"],["a","albatros"]],[["q","robbie"],["a","leopardo"]],[["q","robbie"],["a","carnivoro"]],[["q","suzie"],["a","ave"]],[["q","robbie"],["a","mamifero"]]]);
p (datos_pag397A(),
1);
p (encreg([["?q","es","padre","de","brassy"]]),
[[["q","deedee"]]]);
p (encreg([["?q","es","padre","de","?o"]]),
[[["q","deedee"],["o","brassy"]],[["q","deedee"],["o","sugar"]]]);
p (encreg([["bozo","es","perro"]]),
"si");
p (encreg([["?q","es","perro"]]),
[[["q","bozo"]]]);
p (encreg([["?q","es","caballo"]]),
[[["q","brassy"]],[["q","sugar"]],[["q","deedee"]]]);
p (encreg([["deedee","es","padre","?x"]]),
[]);
p (encreg([["deedee","es","padre","de","?x"]]),
[[["x","brassy"]],[["x","sugar"]]]);
print "\n";
inter();
</pre></body></html>