# File : OAA.pm # Author : Adam Cheyer # Purpose : Contains Perl version of library for the Open Agent Architecture # Updated : 10/15/99 # # Copyright (C) 1999 SRI International. All rights reserved. # # "Open Agent Architecture" and "OAA" are trademarks of SRI International. # package OAA; require Exporter; @ISA = qw(Exporter); # symbols to export by default @EXPORT = qw(oaa_setup_communication oaa_find_host_port oaa_disconnect oaa_delay_solution oaa_return_delayed_solutions oaa_add_context_params oaa_functor oaa_func oaa_args oaa_term oaa_nth_elt oaa_argument oaa_is_atom oaa_is_var oaa_is_group oaa_is_list oaa_is_int oaa_param_value oaa_double_quotes oaa_undouble_quotes oaa_remove_quotes oaa_trim oaa_list_len oaa_group_to_terms oaa_list_to_terms oaa_unify oaa_send_data oaa_post_event oaa_get_event oaa_solve oaa_write_bb oaa_write_replace_bb oaa_write_once_bb oaa_retract_bb oaa_replace_bb oaa_read_bb oaa_can_solve oaa_add_trigger oaa_add_trigger_on_ks oaa_process_all_events oaa_loop oaa_interpret oaa_ready tcp_select oaa_set_timeout ); # symbols to export on request # @EXPORT_OK = qw(); use strict; use Socket; use FileHandle; # *************************************************************************** # * Private variables # ****************************************************************************/ # Table of delayed events my @delay_table; my @delayed_contect_table; # Used for variable bindings during unification my %bindings; # Stores delayed events my %delay_table; # Stack for contexts my @ContextStack; my $KSname = ""; # symbolic name for agent my $KSid; # Internal ID for agent my $Fhost = ""; # Facilitator host my $Fport = 0; # Facilitator port my $TRUE = 1; my $FALSE = 0; my $DELAY_PRED = "delayed_event"; my $TIMEOUT_EVENT = "timeout"; my $SETUP_FILE_NAME = "setup.pl"; my $GlobalEventBuffer = ""; # Trace my $TcpTraceOn = $TRUE; my $TraceOn = $TRUE; my $DebugOn = $FALSE; my $GoalCounter = 0; # If TimeOutMode = 0, ignores TimeOut value # Otherwise uses timeout value my $TimeOutMode = 0; my $TimeOut = 0; #Timeouts # **************************************************************************** # Initialization and connection functions # **************************************************************************** # **************************************************************************** # * name: init_vars # * purpose: Initialize global variables # *************************************************************************** sub init_vars { $TcpTraceOn = $FALSE; $TraceOn = $FALSE; $DebugOn = $FALSE; $GoalCounter = 0; } #/**************************************************************************** # * name: oaa_set_timeout # * purpose: allow an agent to dynamically change its timeout variables # * inputs: # * - double TimeOut: Timeout value in seconds # * - int Mode: If mode = 0, TimeOut is not used # * Otherwise, TimeOut is used. # ****************************************************************************/ sub oaa_set_timeout { my ($T, $TMode) = @_; $TimeOutMode = $TMode; $TimeOut = $T; } # **************************************************************************** # * name: read_setup_file # * purpose: Finds a setup file and reads the OAA host and port values # * outputs: # * - char *Host: Host for the server process # * - int *Port: Port for the server process # * remarks: # * Host and/or Port are only set if they do not already contain a legal # * value. This way, the values can be set first through command line args # * or environment variables (see read_env_vars). # *************************************************************************** sub read_setup_file { my $fname = ""; my $host = ""; my $port = 0; # first test locally if (-r $SETUP_FILE_NAME) { $fname = $SETUP_FILE_NAME; } elsif (-r "c:\\".$SETUP_FILE_NAME) { $fname = "c:\\".$SETUP_FILE_NAME; } elsif (-r $ENV{"HOME"}."/".$SETUP_FILE_NAME) { $fname = $ENV{"HOME"}."/".$SETUP_FILE_NAME; } if ($fname) { my $s; open(INFILE, $fname); while ($s = ) { $s = oaa_trim($s); unless (substr($s, 0, 1) eq "%") { if (index($s, "rootdata") >= 0) { $port = oaa_argument($s, 1); $host = oaa_remove_quotes(oaa_argument($s, 2)); } } } close(INFILE); } return ($host, $port); } # /**************************************************************************** # * name: read_cmd_line # * purpose: looks for host and port on command line # * -oaa_host -oaa_port # * returns: ($host, $port) # * As a side effect, sets global $KSname if -oaa_name is read # /**************************************************************************** sub read_cmd_line { my $i; my $host = ""; my $port = 0; for ($i = 0; $i < $#ARGV; $i++) { if ($ARGV[$i] eq "-oaa_host") { $i++; $host = $ARGV[$i]; } elsif ($ARGV[$i] eq "-oaa_port") { $i++; $port = $ARGV[$i]; } elsif ($ARGV[$i] eq "-oaa_name") { $i++; $KSname = $ARGV[$i]; } } return ($host, $port); } # /**************************************************************************** # * name: read_env_vars # * purpose: looks for host and port on in environment vars # * OAA_HOST= OAA_PORT= # * returns: ($host, $port) # /**************************************************************************** sub read_env_vars { return ($ENV{"OAA_HOST"}, $ENV{"OAA_PORT"}); } # /**************************************************************************** # * name: oaa_find_host_port # * purpose: Finds host and port by looking on command line, env # * vars, and setup file (in that order of priority). # * returns: # * - ($host, $port) # * example: # * ($host, $port) = oaa_find_host_port(); # ****************************************************************************/ sub oaa_find_host_port { my $host = ""; my $port = 0; ($host, $port) = read_cmd_line(); if (!$host) { ($host, $port) = read_env_vars(); } if (!$host) { ($host, $port) = read_setup_file(); } return ($host, $port); } # **************************************************************************** # * name: oaa_setup_communication # * purpose: Establishes tcp connections to the Server and registers agent # * inputs: # * - char *KS: Name for the KS # * - char *host: host to connect to # * - int port: port to connect to # * - char *Solvable: Prolog-formatted list of solvables provided by the KS # * return value: TRUE if connection made; exits otherwise # * example: # * oaa_setup_communication("myagent", "trestle", 3366, "[a(X)]"); # ****************************************************************************/ sub oaa_setup_communication { my ($ksname, $host, $port, $solvables) = @_; # Initialize OAA global variables init_vars; # If global KSName not already set by read_cmd_args(), set it if ($KSname eq "") { $KSname = $ksname; } print "agent_connect to Facilitator: $host:$port\n"; my $iaddr = inet_aton($host) || die "no host: $host"; my $paddr = sockaddr_in($port, $iaddr); my $proto = getprotobyname('tcp'); socket(Connection, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; connect(Connection, $paddr) || die "connect: $!"; # print "connected\n"; Connection->autoflush($TRUE); # DG # select(Connection); $| = 1; select(STDOUT); $| = 1; # Remember host and port $Fhost = $host; $Fport = $port; # Write host information my $myhostname = `hostname`; # CHANGED BY FHJ, 3/1/2000... # if ($myhostname) { if ($myhostname ne "") { oaa_write_bb("kshost", $myhostname); }; # Write language information immediately so any communication from # server will be in correct format oaa_write_bb("language", "perl"); oaa_write_bb("oaa_version", "2.0"); # Make sure solvables instanciated # CHANGED BY FHJ, 3/1/2000... # if (!$solvables) { if ($solvables eq "") { $solvables = "[]"; } oaa_post_event("register_solvable_goals($solvables, '$KSname')"); return 1; } # **************************************************************************** # * name: oaa_disconnect # * purpose: Disconnects client from Facilitator # **************************************************************************** sub oaa_disconnect { shutdown(Connection, 2); Connection->close; } # **************************************************************************** # * name: oaa_delay_solution(Id) # * purpose: Defer solving a do_event request until a later time. # * This procedure should be called in do_event() when a programmer # * wants to return from do_event() without returning an immediate # * solution. "answers" will be given an appropriate variable, and # * an ID is returned by this function, which should be used to call # * oaa_return_delayed_solutions(Id,Solutions) when ready. # * inputs: # * In C, oaa_delay_solution calculates an ID automatically. In # * this perl library, we ask the user to pass in an identifier # * that represents the solution that is delayed. This ID will # * later be used to return solutions to the delayed task, when ready. # * returns: # * returns an appropriate result such that answers can be deferred until # * a later time. # * implementation: # * answers will contain "DELAY_PRED(i)": since usually answers must # * contain a list, the Interpret function will know that this is a # * special case, and the event to be solved can be added to the delay_table # * at index id. # * example: # * # * sub do_event { # * my ($ks, $func, $args) = @_; # * my $answers = "[]"; # * # * # a(X) # * if ($func eq "a") { # * # don't know answer yet, wait until later to send response # * $answers = oaa_delay_solution("a_1"); # * } # * return $answers; # * } # ****************************************************************************/ sub oaa_delay_solution { my $delay_id = shift; return "$DELAY_PRED($delay_id)"; } # **************************************************************************** # * name: oaa_return_delayed_solutions # * purpose: Sends the solutions to a delayed event to the Facilitator, # * and removes the event from the delay table. # * inputs: # * - char *id: * Index into the delay table, indicating which event is solved # * - char* answer: The solution list for the delayed event # * returns: # * True if successful # * remarks: # * If answer=NULL, a failed event ([]) is sent to the Facilitator. # * example: # * oaa_return_delayed_solutions("a_1", "[a(1), a(2)]"); # * ************************************************************************* sub oaa_return_delayed_solutions { my ($delay_id, $answers) = @_; my $ev = $delay_table{$delay_id}; # CHANGED BY FHJ, 3/1/2000... # if (!defined($ev) || !$ev) { if (!defined($ev) || ($ev eq "")) { print("ERROR: return_delayed_solutions called for non-delayed event.\n"); print(" $ev\n\n"); return $FALSE; } # CHANGED BY FHJ, 3/1/2000... # if (!defined($answers) || !$answers) { if (!defined($answers) || ($answers eq "")) { $answers = "[]"; } $ev = $ev . $answers . ")"; oaa_post_event($ev); return $TRUE; } #*************************************************************************** # * name: oaa_AddContextParams # * purpose: Adds contexts to params, checking for duplicates. # * remarks: NOT implemented yet in perl library. # *****************************************************************************/ sub oaa_add_context_params { my ($params) = @_; return $params; } # **************************************************************************** # * Prolog parsing predicates # **************************************************************************** # *************************************************************************** # * name: oaa_functor # * purpose: Splits a string containing a prolog-style term into a functor # * and arguments # * see also: oaa_func returns just the functor # * oaa_args returns the arg part of a structure # * example: # * ($func, $args) = oaa_functor("a(1,2,3)"); # func = "a", args = "1,2,3" # *************************************************************************** sub oaa_functor { my $predicate = shift; my $func = ""; my $args = ""; # If predicate is just a string, list or other compound term, # or an atom, just return the term, don't search for "(" if ((index('{(["', substr($predicate, 0, 1)) >= 0) || oaa_is_atom($predicate)) { ($func, $args) = oaa_term($predicate); $args = ""; } else { my $p = index($predicate, "("); if ($p < 0) { # no arguments in term $func = $predicate; # chop off trailing '.' if (substr($func, length($func) -1, 1) eq ".") { $func = substr($func, 0, length($func)-1); } } else { $func = substr($predicate, 0, $p); $args = substr($predicate, $p+1); # chop off everything up to and including trailing ")" while ($args && (substr($args, length($args)-1, 1) ne ")")) { $args = substr($args, 0, length($args)-1); } $args = substr($args, 0, length($args)-1); } } return ($func, $args); } # *************************************************************************** # * name: oaa_func # * purpose: Splits a string containing a prolog-style term into a functor # * and arguments, and returns the functor part # * see also: oaa_functor returns the functor and args # oaa_args returns the arg part of a structure # * example: # * $func = oaa_func("a(1,2,3)"); # func = "a" # *************************************************************************** sub oaa_func { my ($func, $args); ($func, $args) = oaa_functor(shift); return $func; } # *************************************************************************** # * name: oaa_args # * purpose: Splits a string containing a prolog-style term into a functor # * and arguments, and returns the args part # * see also: oaa_functor returns the functor part of a structure # * example: # * $args = oaa_args("a(1,2,3)"); # args = "1,2,3" # *************************************************************************** sub oaa_args { my ($func, $args); ($func, $args) = oaa_functor(shift); return $args; } # **************************************************************************** # * name: oaa_term # * purpose: takes a list of terms (comma separated) and returns the first (car) # * and rest (cdr) of the list. # * inputs: # * - char *terms: a list of prolog terms # * outputs: ($aterm, $restterm) # * - char *aterm: the first term in the list # * - char *restterms: the rest of the terms # * remarks: # * - Terms may be nested arbitrarily deep (eg. a(b(c(d,1)), X). # * - Term can correctly parse expression with embedded arguments using # * Japanese JIS7 format. JIS7 is the Japanese encoding standard chosen # * for use with the OAA. Three reasons for this choice: 1) it's the # * most popular standard on UNIX machines. 2) 7-bit encoding should # * be TCP/IP and modem friendly. 3) it's easy to parse: JIS7 embeds # * Japanese characters in a quotation-like wrapper, using ESC$B for the # * opening marker and ESC(B for the closing. # * - If only one term is read, restterms will be "" # * example: # * # loop over list of "1,2,3" # * while ($list) { # * ($elt, $list) = oaa_term($list) # * print $elt."\n"; # * } # ****************************************************************************/ sub oaa_term { my $terms = shift; my $i = -1; my $n = 0; my $len = 0; my $done = 0; my $inquotes = 0; my $inJIS7 = 0; my $parens = 0; my $seen_something = 0; my ($aterm, $restterms); $len = length($terms); while (($i < $len-1) && !$done) { $i++; if ((substr($terms, $i, 1) eq "\x1B") && # CHR(27) (substr($terms, $i+1, 1) eq '$') && (substr($terms, $i+2, 1) eq 'B')) { $inJIS7 = $TRUE; } elsif ((substr($terms, $i, 1) eq "\x1B") && # CHR(27) (substr($terms, $i+1, 1) eq '(') && (substr($terms, $i+2, 1) eq 'B')) { $inJIS7 = $FALSE; } $_ = substr($terms, $i, 1); # If we are not looking at Japanese chars, try to parse input if ($inJIS7 == $FALSE) { SWITCH: { /^[\(\[\{]/ && do { $parens = $parens + 1; last SWITCH;}; /^[\)\]\}]/ && do { $parens = $parens - 1; if ($parens == 0) { $done = $TRUE; } last SWITCH; }; /^\'/ && do { $inquotes = !$inquotes; last SWITCH;}; /^,/ && do { if (($parens == 0) && ($inquotes == 0)) { $done = $TRUE; } last SWITCH; }; /^[\n\t\s]/ && do { if (($parens == 0) && ($inquotes == 0) && $seen_something) { $done = $TRUE; } last SWITCH; }; $seen_something = $TRUE; } } } if (($i >= 0) && !$parens && !$inquotes) { if (substr($terms, $i, 1) eq ",") { $n = $i; } else { $n = $i + 1; } # grab first term $aterm = substr($terms, 0, $n); # skip any spaces after , $n = $n + 1; while (($n < $len) && (substr($terms, $n, 1) eq " ")) { $n = $n + 1; } if ($n < $len) { $restterms = substr($terms, $n); return (oaa_trim($aterm), $restterms); } else { return (oaa_trim($aterm), ""); } } else { return ("", ""); } } # **************************************************************************** # * name: oaa_nth_elt # * purpose: Returns the Nth term in a list of terms # * inputs: # * - char *list: a string containing a comma-separated list of terms # * - int n: index into a list (nth term) # * returns: # * - char *elt: the nth term in the list. # * remarks: # * 1-based! # * example: # * $a3 = oaa_nth_elt("1,2,3", 3); # $a3 = "3" # **************************************************************************** sub oaa_nth_elt { my ($list, $n) = @_; my $elt; # CHANGED BY FHJ, 3/1/2000: I THINK THIS IS THE ZERO BUG... # while ($list && ($n > 0)) { while (($list ne "") && ($n > 0)) { $n = $n - 1; ($elt, $list) = oaa_term($list); } return $elt; } # **************************************************************************** # * name: oaa_argument # * purpose: Returns the nth argument in a term # * inputs: # * - char *predicate: a prolog-style term: eg func(a1,a2,...) # * - int n: index into a list (nth term) # * returns: # * - char *argument: the nth argument in the term. eg (a2 if n = 2 # * remarks: # * 1-based! # * example: # * $a3 = oaa_argument("func(1,2,3)", 3); # $a3 = "3" # **************************************************************************** sub oaa_argument { my ($list, $n) = @_; return oaa_nth_elt(oaa_args($list), $n); } # **************************************************************************** # * name: oaa_is_atom # * purpose: Returns true if the term is an atom # **************************************************************************** sub oaa_is_atom { my $term = shift; # 4 special cases if (($term eq "!") || ($term eq ";") || ($term eq "[]") || ($term eq "{}")) { return $TRUE; } # Any sequence of characters delimited by single quotes if ((substr($term, 0, 1) eq "'") && (substr($term, length($term)-2,1) eq "'")) { return $TRUE; } # Anything starting with lower case if ($term =~ /^[a-z](\w+)$/) { return $TRUE; } return $FALSE; } # **************************************************************************** # * name: oaa_is_var # * purpose: Returns true if the term is a var # **************************************************************************** sub oaa_is_var { my $term = shift; # Anything starting with "_" or Uppercase if ($term =~ /^[A-Z_](.*)/) { return 1; } return $FALSE; } # **************************************************************************** # * name: oaa_is_group # * purpose: Returns true if the term is a group # * remarks: Examples of groups are [1,2,3], (1,2,3), or {1,2,3} # **************************************************************************** sub oaa_is_group { my $s = shift; my $len = length($s); # Anything starting and ending with [ ] if ((index('{([', substr($s, 0, 1)) >= 0) && (index('})]', substr($s, $len-1, 1)) >= 0)) { return $TRUE; } return $FALSE; } # **************************************************************************** # * name: oaa_is_list # * purpose: Returns true if the term is a list # * remarks: Lists start and end with "[" and "]" # **************************************************************************** sub oaa_is_list { my $term = shift; # Anything starting and ending with [ ] if ((substr($term, 0, 1) eq "[") && (substr($term, length($term)-1, 1) eq "]")) { return $TRUE; } return $FALSE; } # **************************************************************************** # * name: oaa_is_int # * purpose: Returns true if the term is an int # **************************************************************************** sub oaa_is_int { my $term = shift; my $i; for ($i=0; $i < length($term); $i++) { $_ = substr($term, $i, 1); /^[\s0-9]/ || return $FALSE; } return $TRUE; } # **************************************************************************** # * name: oaa_param_value # * purpose: Extracts the value from a parameter list # * inputs: # * - aList: a parameter list, in the form "[attr1(Value),attr2(Value2)]" # * - param: parameter to extract (e.g. attr1) # * returns: # * - char **Value: value of parameter or NULL if not found # * remarks: # * - most parameter lists should be in the form [p(Val), p2(Val2)]... # * If p has more than one argument, the list is returned # * If p has no arguments, "true" is returned as the value # * examples: # * $p = oaa_param_value("[parallel, num_solutions(3)]", "num_solutions") # * # $p = "3" # ****************************************************************************/ sub oaa_param_value { my ($list, $param) = @_; my $value = 0; $list = oaa_list_to_terms($list); # CHANGED BY FHJ, 3/1/2000... # while ($list) { while ($list ne "") { my ($elt, $func, $args); ($elt, $list) = oaa_term($list); ($func, $args) = oaa_functor($elt); if ($func eq $param) { if ($args) { $value = $args; } else { $value = "true"; } } } return $value; } # **************************************************************************** # * Special string functions # **************************************************************************** # **************************************************************************** # * name: oaa_double_quotes # * purpose: Doubles any "'" in the string, to prepare the string to # * be enclosed by "'". # * returns: The modified string # * see also: oaa_undouble_quotes # **************************************************************************** sub oaa_double_quotes { my $s = shift; my $ret; my $i; $ret = ""; while (($i = index($s, "'")) > -1) { my $sub = substr($s, 0, $i); $ret = $ret . $sub . "''"; $s = substr($s, $i+1); } $ret = $ret . $s; return $ret; } # **************************************************************************** # * name: oaa_undouble_quotes # * purpose: Converts any "''" in the string to just ' # * returns: The modified string # * see also: oaa_double_quotes # **************************************************************************** sub oaa_undouble_quotes { my $s = shift; my $ret; my $i; $ret = ""; # CHANGED BY FHJ, 3/1/2000... # if ($s) { if ($s ne "") { while (($i = index($s, "''")) > -1) { my $sub = substr($s, 0, $i); $ret = $ret . $sub . "'"; $s = substr($s, $i+2); } $ret = $ret . $s; } return $ret; } # **************************************************************************** # * name: oaa_remove_quotes # * purpose: Removes leading and trailing ' and " marks # * returns: The modified string # **************************************************************************** sub oaa_remove_quotes { my $s = shift; my $len; # CHANGED BY FHJ, 3/1/2000... # if ($s) { if ($s ne "") { # chop off leading quote mark if (index("'\"", substr($s, 0, 1)) >= 0) { $s = substr($s, 1); } $len = length($s); # chop off trailing quote mark if (index("'\"", substr($s, $len-1, 1)) >= 0) { $s = substr($s, 0, $len - 1); } } return $s; } # **************************************************************************** # * name: oaa_trim # * purpose: Removes whitespace surrounding string # * returns: The modified string # **************************************************************************** sub oaa_trim { my $s = shift; my $len; # CHANGED BY FHJ, 3/1/2000... # if ($s) { if ($s ne "") { # chop off leading quote mark while ($s =~ /^\s/) { $s = substr($s, 1); } # chop off trailing quote mark while ($s =~ /\s$/) { $len = length($s); $s = substr($s, 0, $len - 1); } } return $s; } # **************************************************************************** # * name: oaa_list_len # * purpose: Returns the length of a comma separated list of terms # * returns: The length # **************************************************************************** sub oaa_list_len { my $list = shift; my $count; my $elt; $count = 0; # CHANGED BY FHJ, 3/1/2000: I THINK THIS IS THE ZERO BUG... # while ($list) { while ($list ne "") { ($elt, $list) = oaa_term($list); $count = $count + 1; } return $count; } # **************************************************************************** # * name: oaa_group_to_terms # * purpose: Converts an incoming prolog group [elt1, elt2, elt3] form) into # * a list of terms, on which we can use list_len, NthElt, etc. # * i.e. a comma-separated list "elt1, elt2, etl3". # * Basically, just removes the brackets... # * Groups are any pair that starts with [ or ( or { # * returns: The list without brackets # **************************************************************************** sub oaa_group_to_terms { my $s = shift; # CHANGED BY FHJ, 3/1/2000... # if (!$s) { if ($s eq "") { return $s; } # chop off leading group marker if (index('{([', substr($s, 0, 1)) >= 0) { $s = substr($s, 1); } my $len = length($s); # chop off trailing group marker if (index('})]', substr($s, $len-1, 1)) >= 0) { $s = substr($s, 0, $len - 1); } return $s; } # **************************************************************************** # * name: oaa_list_to_terms # * purpose: Converts an incoming prolog list [elt1, elt2, elt3] form) into # * a list of terms, on which we can use list_len, NthElt, etc. # * i.e. a comma-separated list "elt1, elt2, etl3". # * Basically, just removes the brackets... # * returns: The list without brackets # **************************************************************************** sub oaa_list_to_terms { my $s = shift; # CHANGED BY FHJ, 3/1/2000... # if (!$s) { if ($s eq "") { return $s; } # chop off leading quote mark if (substr($s, 0, 1) eq "[") { $s = substr($s, 1); } my $len = length($s); # chop off trailing quote mark if (substr($s, $len-1, 1) eq "]") { $s = substr($s, 0, $len - 1); } return $s; } # **************************************************************************** # * Unification-related functions # **************************************************************************** #**************************************************************************** #* name: deref #* purpose: See if a variable can be resolved using existing var bindings #* returns: value for var if one can be found, otherwise just var #**************************************************************************** sub deref { my $term = shift; # CHANGED BY FHJ, 3/1/2000... # if ($bindings{$term}) { if (defined($bindings{$term})) { $term = $bindings{$term}; } return $term; } #**************************************************************************** #* name: print_bindings #* purpose: Print out hash table of bindings #**************************************************************************** sub print_bindings { my ($key, $val); while (($key, $val) = each %bindings) { print "$key=$val\n"; } } #**************************************************************************** #* name: deref_term #* purpose: replace all variables in a term by their bindings #* inputs: #* - char *t, t2: terms to match (unify) #* - char ***vars: a string list where variable bindings will be stored #* during unification. If vars is NULL, no var bindings are kept, #* acting as a simple match instead of a true unify. #* #**************************************************************************** sub deref_term { my $term = shift; my ($openp, $closep); my $answer = ""; my $elt; my ($fun1, $args1) = oaa_functor($term); $fun1 = deref($fun1); if (oaa_is_list($fun1) && !($fun1 eq "[]")) { $args1 = oaa_list_to_terms($fun1); $openp = "["; $closep = "]"; } else { $answer = $answer . $fun1; $openp = "("; $closep = ")"; } # treat arguments # CHANGED BY FHJ, 3/1/2000: I THINK THIS IS THE ZERO BUG... # if ($args1) { if ($args1 ne "") { $answer = $answer . $openp; # CHANGED BY FHJ, 3/1/2000: I THINK THIS IS THE ZERO BUG... # while ($args1) { while ($args1 ne "") { ($elt, $args1) = oaa_term($args1); $elt = deref_term($elt); $answer = $answer . $elt; # CHANGED BY FHJ, 3/1/2000: I THINK THIS IS THE ZERO BUG... # if ($args1) { if ($args1 ne "") { $answer = $answer . ","; } } $answer = $answer . $closep; } return $answer; } # **************************************************************************** # * name: match_terms # * purpose: Returns true if Term1 matches Term2, saving variable bindings # * as it goes (if requested) # **************************************************************************** sub match_terms { my ($t1, $t2) = @_; my ($fun1, $fun2, $args1, $args2, $elt1, $elt2); my $result = $TRUE; # print "Unify: '$t1' '$t2'\n"; ($fun1, $args1) = oaa_functor($t1); ($fun2, $args2) = oaa_functor($t2); $fun1 = oaa_trim($fun1); $fun2 = oaa_trim($fun2); if (length(%bindings) > 0) { $fun1 = deref($fun1); $fun2 = deref($fun2); } if (oaa_is_var($fun1)) { # print "is var $fun1\n"; # Anonymous variable "_" never gets bound if (!($fun1 eq "_") && !($fun1 eq $fun2)) { $bindings{$fun1} = $fun2; } } elsif (oaa_is_var($fun2)) { # print "is var $fun2\n"; # Anonymous variable "_" never gets bound if (!($fun2 eq "_") && !($fun1 eq $fun2)) { $bindings{$fun2} = $fun1; } } else { # If both are [A,B,C] style lists, remove brakets and # start unifying args. functors are set to "." if (oaa_is_group($fun1) && oaa_is_group($fun2)) { $args1 = oaa_group_to_terms($fun1); $args2 = oaa_group_to_terms($fun2); $fun1 = '.'; $fun2 = '.'; } $fun1 = oaa_remove_quotes($fun1); $fun2 = oaa_remove_quotes($fun2); if ($fun1 eq $fun2) { # match all elements in each list # CHANGED BY FHJ 3/1/2000 # while ($result && $args1 && $args2) { while ($result && ($args1 ne "") && ($args2 ne "")) { ($elt1, $args1) = oaa_term($args1); ($elt2, $args2) = oaa_term($args2); if (!match_terms($elt1, $elt2)) { $result = $FALSE; } } # One of lists isn't empty # CHANGED BY FHJ, 3/1/2000... # if ($args1 || $args2) { if (($args1 ne "") || ($args2 ne "")) { $result = $FALSE; } } else { $result = $FALSE; } } return $result; } # **************************************************************************** # * name: oaa_unify # * purpose: Perform true unification and return resulting term # * returns: if the two terms unify, returns unified term with all vars # * instantiated. Otherwise return false. # * remarks: # * All variable bindings are stored in global var %bindings # **************************************************************************** sub oaa_unify { my ($term1, $term2) = @_; %bindings = (); if (match_terms($term1, $term2)) { # print("matches:\n"); $term1 = deref_term($term1); # print " $term1\n\n"; # print_bindings; return $term1; } else { # print("Terms $term1 $term2 do not match.\n"); return $FALSE; } } # **************************************************************************** # * name: if_trace_on # * purpose: print a trace message if TraceOn is set # **************************************************************************** sub if_trace_on { my ($msg) = @_; if ($TraceOn) { print $msg; } } # **************************************************************************** # * name: if_tcp_trace_on # * purpose: print a trace message if TcpTraceOn is set # **************************************************************************** sub if_tcp_trace_on { my ($msg) = @_; if ($TcpTraceOn) { print $msg; } } # **************************************************************************** # * Sending, receiving data # **************************************************************************** # **************************************************************************** # * name: oaa_send_data # * purpose: Sends raw data to the server (Facilitator # **************************************************************************** sub oaa_send_data { my ($ev) = @_; Connection->print("$ev.\n") or die "SendData: error writing to server"; } # **************************************************************************** # * name: oaa_post_event # * purpose: Sends an event to the server (Facilitator # **************************************************************************** sub oaa_post_event { my ($ev) = @_; Connection->print("term($ev).\n") or die "PostEvent: error writing to server"; } # **************************************************************************** # * name: extract_event # * purpose: Reads one event from buffer stream and returns (KS,Event) # * remarks: event will be in form "term(Result)." or "term(KS,Result)." # or term(event(KS,Ev)). # **************************************************************************** sub extract_event { my ($one_event) = @_; my ($func, $args); ($func, $args) = oaa_functor($one_event); if ($func eq "term") { my $ks = "unknownks"; my $ev = ""; my $arity = oaa_list_len($args); # term(event(KS,Result)) if (index($args, "event(") == 0) { $ks = oaa_argument($args, 1); $ev = oaa_argument($args, 2); } elsif ($arity == 1) { $ev = $args; } elsif ($arity == 2) { $ks = oaa_nth_elt($args, 1); $ev = oaa_nth_elt($args, 2); } # print "KS: $ks\nEv: $ev\n"; return ($ks, $ev); } else { print "\nError: Event not wrapped in 'term().':\n $one_event\n"; return ("unknownks",""); } } # **************************************************************************** # * name: tcp_select # * purpose: Checks an socket link for readability. # * Waits during a specified period of time. (timeout) # * returns: ($NbChar) # **************************************************************************** sub tcp_select { my ($timeout) = @_; my $rin = ''; my $rout = ''; vec($rin,fileno(Connection),1) = 1; my $result = select($rout = $rin, undef, undef, $timeout); # DEBUG # print("Select $result \n"); return $result; } # **************************************************************************** # * name: oaa_get_event # * purpose: Reads an event from the TCP stream. # * returns: ($KS, $Event) # **************************************************************************** sub oaa_get_event { my $ks = "Server"; my $buffer = ""; my $finished_transmission = $FALSE; my $n = 0; my $one_event; my $result = ""; my $tcp_select_result = 0; # /* ------------------------------------------------------------------- */ # /* Read events from the TCP socket. Events can be bigger than the read */ # /* buffer, so a loop is used until at least one entire event is read */ # /* into GlobalEventBuffer. */ # /* When reading data into buffer, more than one event can arrive at a */ # /* time. If more than one event arrives, the first event is removed */ # /* from the buffer and returned. The next event is stored in memory */ # /* (in GlobalEventBuffer), and will be immediately executed the next */ # /* time get_event is called, before reading from TCP socket. */ # /* ------------------------------------------------------------------- */ # # NOTE: "E" means GlobalEventBuffer # # /* If E contains some text, use Term() to get first event to process */ # /* If Term() succeeds, a complete event was read, if it fails, the */ # /* event was only partially read and we must read some more. */ # /* Notes: one_event only needs to be OAA_FREE'd if Term succeeds, rest */ # /* never needs to be OAA_FREE'd. */ # /* 3-11-97 HB: added a check that E has an open paren, since sometimes */ # /* it held just the "t" of "term(", which caused Term() to */ # /* succeed, but caused a failure further down, since really*/ # /* there was more to read */ # CHANGED BY FHJ, 3/1/2000... # if ($GlobalEventBuffer && (index($GlobalEventBuffer,'(') >= 0)) { if (($GlobalEventBuffer ne "") && (index($GlobalEventBuffer,'(') >= 0)) { ($one_event, $GlobalEventBuffer) = oaa_term($GlobalEventBuffer); # CHANGED BY FHJ, 3/1/2000... # if ($one_event) { if ($one_event ne "") { $finished_transmission = $TRUE; # TCP read not needed # Extract sending KS (if supplied) and event to process ($ks, $result) = extract_event($one_event); # Skip over trailing '.' if (substr($GlobalEventBuffer,0,1) eq '.') { $GlobalEventBuffer = substr($GlobalEventBuffer, 1); } } } # First, if TimeOutMode applies, checks if there is something to be # read from the socket. if ($TimeOutMode>0) { $tcp_select_result = tcp_select($TimeOut); if ($tcp_select_result == 0) { return ($KSname, $TIMEOUT_EVENT); } } # If no complete event found in memory, attempts to read TCP socket # until event while (!$finished_transmission) { # If event is bigger than buffer, # loop until event is read # $buffer = ; # reads by line, doesn't seem to work $n = sysread(Connection, $buffer, 4096); # print "READ: ($n) $buffer\n"; $GlobalEventBuffer = $GlobalEventBuffer . $buffer; # Use Term() to get first event to process # If Term() succeeds, a complete event was read, if it fails, the # event was only partially read and we must read some more. # CHANGED BY FHJ, 3/1/2000... # if ($GlobalEventBuffer && (index($GlobalEventBuffer,'(') >= 0)) { if (($GlobalEventBuffer ne "") && (index($GlobalEventBuffer,'(') >= 0)) { ($one_event, $GlobalEventBuffer) = oaa_term($GlobalEventBuffer); # CHANGED BY FHJ, 3/1/2000... # if ($one_event) { if ($one_event ne "") { $finished_transmission = $TRUE; # TCP read not needed # Extract sending KS (if supplied) and event to process ($ks, $result) = extract_event($one_event); # Skip over trailing '.' if (substr($GlobalEventBuffer,0,1) eq '.') { $GlobalEventBuffer = substr($GlobalEventBuffer, 1); } } } } # while: go read more data if event not yet found return ($ks, $result); } # **************************************************************************** # * name: poll_until_event # * purpose: Waits until a matching event is returned from server # **************************************************************************** sub poll_until_event { my ($wait_event) = @_; my $event_returned = $FALSE; while (!$event_returned) { my ($ks, $event) = oaa_get_event(); my $ans; #DEBUG #print("Result of get_event ($ks, $event)\n"); # CHANGED BY FHJ, 3/1/2000... # if ($event) { if ($event ne "") { if ($ans = oaa_unify($event, $wait_event)) { $event_returned = $TRUE; return $ans; } else { # an unexpected event: execute it anyway if ($event eq $TIMEOUT_EVENT) { &main::idle(); } else { if_tcp_trace_on("\n[TCP received from $ks] :\n $event.\n"); my $answers = oaa_interpret($ks, $event); } } } else { print("ERROR: get_event returned EMPTY event!\n"); } } } # *************************************************************************** # * name: oaa_solve # * purpose: requests data or actions from distributed agents # * inputs: # * - char *goal: an ICL goal to be solve/performed # * - char *params: control parameters describing how the goal should be # * sent/resolved (see below). # * outputs: # * - Answers: a list containing solutions to the requested goal. # * The answer value "[]" constitutes failure of the goal. # * parameters: # * The params argument is a list which may contain: # * # * cache : cache all solutions locally # * level_limit(N) : highest number of levels to climb for # * solutions. # * address(KS) : ask a specific KS to solve goal # * and_parallel : and-parallel solve of Goal list # * or_parallel : or-parallel solve of Goal list # * test(Test) : only solve goal on blackboards where Test # * succeeds locally. # * broadcast : just disseminate message, do not request # * results. # * asynchronous : solve will not block until solution returns, # * the solutions will be returned asynchronously # * in solved(FromKs,Goal,Params,Solutions) messages # * which should be handled by in do_event() # * solution_limit(N): limits the number of solutions found to # * N. Currently only works for 1... # * time_limit(N) : Waits a maximum of N seconds before # * returning (failure if no solution). # * # * remarks: # * If "broadcast" is sent in the parameter list, Ans may be sent as # * NULL. Otherwise, solve will return anwers in a new space which # * should be deallocated using OAA_FREE() when no longer needed. # ****************************************************************************/ sub oaa_solve { my ($goal, $params) = @_; # if (length(@ContextStack) > 0) { # $params = oaa_add_context_params($params); # } oaa_post_event("post_query($goal, $params)"); if ((index($params, "broadcast") < 0) && (index($params, "asynchronous") < 0)) { my $solved_event = poll_until_event("solved(_FromKS, $goal, _Params, _Solutions)"); # FHJ 3/1/2000 #!!! what can poll_until_event return? If it returns what gets returned from # oaa_unify, we may have another part of the zero problem. This is because # oaa_unify returns the unifying EXPRESSION, which could be 0. If this is the # case, then poll_until_event could return 0 even if it hasn't failed, which # will generate the error case. if ($solved_event) { return oaa_argument($solved_event, 4); } else { print "ERROR: problem in poll_until_event return value\n"; return "[]"; } } else { return "[]"; } } # **************************************************************************** # * Global data management # ****************************************************************************/ # **************************************************************************** # * name: oaa_write_bb # * purpose: Add information to global data stored on blackboard server # * example: # * write_bb(name, "Adam Cheyer") adds name("Adam Cheyer") on blackboard # **************************************************************************** sub oaa_write_bb { my ($item, $data) = @_; oaa_post_event("write_bb($item, $data)"); } # **************************************************************************** # * name: oaa_write_replace_bb # * purpose: Add information to global data stored on blackboard server # * replacing old information with new information # **************************************************************************** sub oaa_write_replace_bb { my ($item, $data) = @_; oaa_post_event("write_replace_bb($item, $data)"); } # **************************************************************************** # * name: oaa_write_once_bb # * purpose: Add information to global data stored on blackboard server # * at most one times (if exists, doesn't write). # **************************************************************************** sub oaa_write_once_bb { my ($item, $data) = @_; oaa_post_event("write_once_bb($item, $data)"); } # **************************************************************************** # * name: oaa_retract_bb # * purpose: Remove information from global data stored on blackboard server # **************************************************************************** sub oaa_retract_bb { my ($item, $data) = @_; oaa_post_event("retract_bb($item, $data)"); my $s = poll_until_event("return_read_bb(Solutions)"); return oaa_argument($s, 1); } # **************************************************************************** # * name: oaa_replace_bb # * purpose: Changes item value from Old to New # **************************************************************************** sub oaa_replace_bb { my ($item, $olddata, $newdata) = @_; oaa_post_event("replace_bb($item, $olddata, $newdata)"); } # **************************************************************************** # * name: oaa_read_bb # * purpose: Retrieves information from Facilitator's global data store # * returns: list containing retults # **************************************************************************** sub oaa_read_bb { my ($item, $data) = @_; oaa_post_event("read_bb($item, $data)"); my $s = poll_until_event("return_read_bb(Solutions)"); return oaa_argument($s, 1); } # **************************************************************************** # * name: oaa_can_solve # * purpose: Asks the Facilitator for a list of agents who can solve a Goal # * returns: list containing agent ids # **************************************************************************** sub oaa_can_solve { my ($goal) = @_; oaa_post_event("can_solve($goal)"); my $s = poll_until_event("return_can_solve($goal,Solutions)"); return oaa_argument($s, 2); } # **************************************************************************** # * name: oaa_add_trigger # * purpose: Adds a trigger to the appropriate agent. # * inputs: # * - char *Kind: may be 'test', 'data', or 'alarm' # * - char *Type: may be 'when', 'if' (single), 'whenever' (permanent) # * - char *OpMask: on_write, on_replace, on_retract, on_write_replace, # * or a list combining several of these # * - char *Template: template against which to match the trigger # * (e.g. data, or test) # * - char *Action: action to be performed if Condition succeeds # * remarks: # * add_trigger/6 does not require a KS to be specified, because the # * KS will be determined automatically: # * data: always installed on Server # * test: installed on appropriate agent by solvable # * alarm: installed on alarm agent # * For 'event' triggers, use add_trigger_on_ks() # **************************************************************************** sub oaa_add_trigger { my ($kind, $type, $opmask, $template, $moreConds, $action) = @_; if ($kind eq "test") { oaa_post_event("post_trigger($kind,$type,$opmask,$template,$moreConds,$action)"); } elsif ($kind eq "data") { oaa_post_event("post_trigger($kind,$type,$opmask,$template,$moreConds,$action)"); } if ($kind eq "alarm") { oaa_post_event("add_alarm_trigger(alarm,$type,$template,task($action))"); } } # **************************************************************************** # * name: oaa_add_trigger_on_ks # * purpose: Adds a trigger to the specified agent. # * inputs: # * - char *KS: KS on which the trigger should be installed # * - char *Kind: may be 'test', 'data', or 'alarm' # * - char *Type: may be 'when', 'if' (single), 'whenever' (permanent) # * - char *Condition: Test condition # * - char *Action: action to be performed if Condition succeeds # * remarks: # * Cannot install a data trigger because data triggers always go on the # * Server agent which is not a valid KS. # **************************************************************************** sub oaa_add_trigger_on_ks { my ($kind, $type, $opmask, $template, $moreConds, $action) = @_; if ($kind eq "test") { oaa_post_event("post_trigger($kind,$type,$opmask,$template,$moreConds,$action)"); } elsif ($kind eq "data") { oaa_post_event("post_trigger($kind,$type,$opmask,$template,$moreConds,$action)"); } if ($kind eq "alarm") { oaa_post_event("add_alarm_trigger(alarm,$type,$template,task($action))"); } } # ************************************************************************* # * name: oaa_process_all_events # * purpose: Provides the get_event-interpret loop for a non-XWindows # * application. # * remarks: Loops over all events in queue, executing them. # * If timeout is not set (see set_timeout), get_event() blocks # * forever until a new event arrives, so this is an infinite # * loop # * If timeout is set to some value, if no event arrives in the given # * amount of time, TIMEOUT_EVENT is returned and # * oaa_process_all_events returns. # ************************************************************************* sub oaa_process_all_events { my $done = $FALSE; my ($ks, $event); while (!$done) { ($ks, $event) = oaa_get_event(); if ($event) { if ($event ne $TIMEOUT_EVENT) { #DEBUG print("Result of get_event ($ks, $event)\n"); if_tcp_trace_on("\n[TCP received from $ks] :\n $event.\n"); my $answers = oaa_interpret($ks, $event); } else { $done = $TRUE; } } else { print("\nERROR: get_event returned EMPLY event!\n"); } } } # ************************************************************************* # * name: oaa_loop # * purpose: Provides the get_event-interpret loop for a non-XWindows # * application. # * remarks: If a timeout occurs, user-defined hook idle() is called. # ************************************************************************* sub oaa_loop { my ($print_ready) = @_; oaa_ready($print_ready); while ($TRUE) { oaa_process_all_events(); &main::idle(); } } # ************************************************************************* # * name: oaa_ready # * purpose: Informs the Facilitator that the agent is ready to # * receive events. # ************************************************************************* sub oaa_ready { my ($print_ready) = @_; my $ans = oaa_read_bb("ksdata", "[KSId, open, Solvables, '$KSname']"); # CHANGED BY FHJ, 3/1/2000... # if ($ans && ($ans ne "[]")) { if (($ans ne "") && ($ans ne "[]")) { my $rest; # [read_bb(ksdata,[5,open,[a(_6655)],test])] $ans = oaa_list_to_terms($ans); ($ans, $rest) = oaa_term($ans); $ans = oaa_argument($ans, 2); $ans = oaa_list_to_terms($ans); $KSid = oaa_nth_elt($ans, 1); oaa_replace_bb("ksdata", "[$KSid, open, Solvables, '$KSname']", "[$KSid, ready, Solvables, '$KSname']"); if ($print_ready) { print("Connected to Facilitator on ($Fhost,$Fport)\n"); print("Ready.\n"); } } else { print "ERROR: couldn't update status to 'ready'.\n"; } } # **************************************************************************** # * Interpret: handling incoming events # **************************************************************************** # **************************************************************************** # * name: oaa_interpret # * purpose: Executes standard events for all agents, or calls agent-specific # * do_event procedure. # * inputs: # * - char *KS: KS sending the event to be executed # * - char *event: event to be executed # * returns: # * answers: a list of answers. Should be "[]" for failure, or a list # * containing the event with variables replaced with values. # * example: a query "a(X) could return "[a(1),a(2),a(3)]" # **************************************************************************** sub oaa_interpret { my ($ks, $event) = @_; my ($func, $args) = oaa_functor($event); my $arity = oaa_list_len($args); my $goalanswers; # Assume success my $answers = "[" . $event . "]"; $_ = $func; SWITCH: { /^debug_on$/ && ($arity == 0) && do { $DebugOn = $TRUE; print "\nDebug on.\n"; last SWITCH; }; /^debug_off$/ && ($arity == 0) && do { $DebugOn = $FALSE; print "\nDebug off.\n"; last SWITCH; }; /^trace_on$/ && ($arity == 0) && do { $TraceOn = $TRUE; print "\nTrace on.\n"; last SWITCH; }; /^trace_off$/ && ($arity == 0) && do { $TraceOn = $FALSE; print "\nTrace off.\n"; last SWITCH; }; /^tcp_trace_on$/ && ($arity == 0) && do { $TcpTraceOn = $TRUE; print "\nTcp Trace on.\n"; last SWITCH; }; /^tcp_trace_off$/ && ($arity == 0) && do { $TcpTraceOn = $FALSE; print "\nTcp Trace off.\n"; last SWITCH; }; /^halt$/ && ($arity == 0) && do { &main::app_done(); oaa_disconnect(); die "\nReceived halt command: exiting...\n"; }; /^solve$/ && ($arity == 3) && do { my $goalid = oaa_nth_elt($args, 1); my $goal = oaa_nth_elt($args, 2); my $params = oaa_nth_elt($args, 3); #push_context_stack(oaa_extract_contents($params)); if_trace_on("\nAttempting to solve: $goal...\n"); $goalanswers = oaa_interpret($ks, $goal, $params); if (index($params, "broadcast") < 0) { if ($TraceOn) { print("\nSolutions found for $goal:\n $goalanswers"); } # in case no answers returned... if (!$goalanswers) { $goalanswers = "[]"; } # Answers should be a list of answers to # return to Facilitator. Exception is # delayed solution request... if (oaa_is_list($goalanswers)) { oaa_post_event("solved($goalid,$KSname,$goal,$params,$goalanswers)"); } # Delay request elsif (index($goalanswers, $DELAY_PRED) >= 0) { # Add delay request to delay table my $delay_id = oaa_argument($goalanswers); $delay_table{$delay_id} = "solved($goalid,$KSname,$goal,$params,"; } else { print "ERROR: non-list returned as solutions from oaa_interpret:\n $goalanswers\n"; } } # Broadcast else { print "\nGoal completed (broadcast):\n $goal\n"; } last SWITCH; }; # Call user callback if ($goalanswers = &main::do_event($ks, $func, $args)) { $answers = $goalanswers; } else { # an untreated event, return failure $answers = "[]" } } return $answers; } return 1; # Module must return true value