! Logik og sprog, Modul 2, datalogi RUC      Henning Christiansen
!
! 
! En fortolker for Datalog i Java
!
! Appendix B i "Sprog og abstrakte maskiner"
!
! (c) 2000, Henning Christiansen
;

begin

!*********************************************
    S y n t a x   o f   D a t a l o g
 *********************************************;

  class CATEGORY;

    ! The class of syntactic objects in
      the Datalog programming language;
    virtual: procedure read, pretty_print;
             ref(CATEGORY) procedure new_copy;
             ! the latter used by the interpreter;
  begin
  end CATEGORY;

  CATEGORY class PROGRAM;

    ! Datalog programs;

  begin
    ! A list of CLAUSEs;
    ref(CLAUSE) first;
    ref(PROGRAM) rest;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      first:- new CLAUSE; first.read(source);
      if not source.look_ahead is END_OF_FILE then
        begin rest:- new PROGRAM; rest.read(source) end
    end read;

    procedure pretty_print;
    begin
      first.pretty_print;
      if rest =/= none then
        rest.pretty_print
    end pretty_print;

  end PROGRAM;


  CATEGORY class CLAUSE;

    ! Datalog clauses;

  begin
    ref(GOAL) head;
    ref(GOAL_LIST) body; ! Empty body signifies a fact;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      head:- new GOAL; head.read(source);
      inspect source.look_ahead
        when COLON_DASH do
          begin
            source.read_symbol;
            body:- new GOAL_LIST;
            body.read(source)
          end
        when PERIOD do
      otherwise error(":- or . expected");
      if source.look_ahead is PERIOD then
        source.read_symbol
      else
        error(". expected")
    end read;

    procedure pretty_print;
    begin
      outimage;
      head.pretty_print;
      if body =/= none then
        begin outtext(":-"); body.pretty_print end;
      outtext(".")
    end pretty_print;

    ! The following used by the interpreter;

    ref(CLAUSE) procedure new_copy(level);
      integer level;
    begin
      ref(CLAUSE) cl; cl:- new CLAUSE;
      cl.head:- head.new_copy(level);
      cl.body:- if body == none then none
                else body.new_copy(level);
      new_copy:- cl
    end new_copy;

  end CLAUSE;


  CATEGORY class GOAL;

    ! Datalog goals;

  begin
    ref(ATOM) predicate;
    ref(ARGUMENT_LIST) parameters;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      predicate:- new ATOM;
      predicate.read(source);
      if source.look_ahead is BEGIN_PAR then
        source.read_symbol
      else error("( expected");
      parameters:- new ARGUMENT_LIST;
      parameters.read(source);
      if source.look_ahead is END_PAR then
        source.read_symbol
      else error(") expected")
    end read;

    procedure pretty_print;
    begin
      predicate.pretty_print;
      outtext("(");
      parameters.pretty_print;
      outtext(")")
    end pretty_print;

    ! The following used by the interpreter;

    ref(GOAL) procedure new_copy(level);
      integer level;
    begin
      ref(GOAL) g; g:- new GOAL;
      g.predicate:- predicate.new_copy(level);
      g.parameters:- parameters.new_copy(level);
      new_copy:- g
    end new_copy;

  end GOAL;


  CATEGORY class GOAL_LIST;

  begin
    ref(GOAL) first;
    ref(GOAL_LIST) rest;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      first:- new GOAL;
      first.read(source);
      if source.look_ahead is COMMA then
        begin
          source.read_symbol;
          rest:- new GOAL_LIST;
          rest.read(source)
        end
    end read;

    procedure pretty_print;
    begin
      outimage;
      outtext(blanks(4));
      first.pretty_print;
      if rest =/= none then
        begin
          outtext(",");
          rest.pretty_print
        end
    end pretty_print;

    ! The following used by the interpreter;

    ref(GOAL_LIST) procedure new_copy(level);
      integer level;
    begin
      ref(GOAL_LIST) gl; gl:- new GOAL_LIST;
      gl.first:- first.new_copy(level);
      gl.rest:- if rest == none then none
                else rest.new_copy(level);
      new_copy:- gl
    end new_copy;

  end GOAL_LIST;


  CATEGORY class ARGUMENT;

    ! Arguments in Datalog goals;

    ! The following used by the interpreter;
    virtual: boolean procedure equal;
  begin
    ! An ATOM or a VARIABLE;
  end ARGUMENT;


  CATEGORY class ARGUMENT_LIST;

  begin
    ref(ARGUMENT) first;
    ref(ARGUMENT_LIST) rest;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      inspect source.look_ahead
        when ATOM_LEX do
          begin
            first:- new ATOM;
            first.read(source)
          end
        when VARIABLE_LEX do
          begin
            first:- new VARIABLE;
            first.read(source)
          end
      otherwise error("argument expected");
      if source.look_ahead is COMMA then
        begin
          source.read_symbol;
          rest:- new ARGUMENT_LIST;
          rest.read(source)
        end
    end read;

    procedure pretty_print;
    begin
      first.pretty_print;
      if rest =/= none then
        begin
          outtext(", ");
          rest.pretty_print
        end
    end pretty_print;

    ! The following used by the interpreter;

    ref(ARGUMENT_LIST) procedure new_copy(level);
      integer level;
    begin
      ref(ARGUMENT_LIST) al; al:- new ARGUMENT_LIST;
      al.first:- first.new_copy(level);
      al.rest:- if rest == none then none
                else rest.new_copy(level);
      new_copy:- al
    end new_copy;

  end ARGUMENT_LIST;


  ARGUMENT class ATOM;

    ! Atomic constant in Datalog;

  begin
    text id;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      if source.look_ahead is ATOM_LEX then
        id:- source.read_symbol qua ATOM_LEX.lex
      else
        error("atom expected")
    end read;

    procedure pretty_print;
      outtext(id);

    ! The following used by the interpreter;

    boolean procedure equal(arg);
      ref(ARGUMENT) arg;
    equal:= arg is ATOM and then id = arg qua ATOM.id;

    ref(ATOM) procedure new_copy(level);
      integer level;
    begin
      ref(ATOM) atm; atm:- new ATOM;
      atm.id:- id;
      new_copy:- atm
    end new_copy;

  end ATOM;

  ARGUMENT class VARIABLE;

    ! Variables in Datalog;

  begin
    text id;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      if source.look_ahead is VARIABLE_LEX then
        id:- source.read_symbol qua VARIABLE_LEX.lex
      else
        error("variable expected")
    end read;

    procedure pretty_print;
    begin
      outtext(id);
      if level <> 0 then
        begin
          outtext("/");
          outint(level,0)
        end
    end pretty_print;

    ! The following used by the interpreter;

    integer level;

    boolean procedure equal(arg);
      ref(ARGUMENT) arg;
    equal:= arg is VARIABLE
              and then id = arg qua VARIABLE.id
              and then level = arg qua VARIABLE.level;

    ref(VARIABLE) procedure new_copy(level);
      integer level;
    begin
      ref(VARIABLE) v; v:- new VARIABLE;
      v.level:= level;
      v.id:- id;
      new_copy:- v
    end new_copy;

  end VARIABLE;

  CATEGORY class QUERY;

    ! Query in Datalog;

  begin
    ref(GOAL_LIST) goals;

    procedure read(source);
      ref(LEXICAL_SCANNER) source;
    begin
      goals:- new GOAL_LIST;
      goals.read(source);
      if not source.look_ahead is PERIOD then
        error(". expected")
      else source.read_symbol
    end read;

    procedure pretty_print;
    begin
      goals.pretty_print;
      outtext(".");
      outimage
    end pretty_print;

  end QUERY;

!***************************************************************
   L e x i c a l   s y n t a x   f o r   D a t a l o g
 ***************************************************************;

  class LEXICAL_SYMBOL;
    ! The smallest syntactically and semantically
      significant objects;
  begin
  end LEXICAL_SYMBOL;

  LEXICAL_SYMBOL class ATOM_LEX(lex);
    text lex;
    ! The lexical symbol denoting an ATOM;
  begin
  end ATOM_LEX;

  LEXICAL_SYMBOL class VARIABLE_LEX(lex);
    text lex;
    ! The lexical symbol denoting a VARIABLE;
  begin
  end VARIABLE_LEX;

  LEXICAL_SYMBOL class COLON_DASH;
    ! The symbol ":-" ;
  begin
  end COLON_DASH;

  LEXICAL_SYMBOL class COMMA;
    ! The symbol "," ;
  begin
  end COMMA;

  LEXICAL_SYMBOL class PERIOD;
    ! The symbol "." ;
  begin
  end PERIOD;

  LEXICAL_SYMBOL class BEGIN_PAR;
    ! The symbol "(" ;
  begin
  end BEGIN_PAR;

  LEXICAL_SYMBOL class END_PAR;
    ! The symbol ")" ;
  begin
  end ENDPAR;

  LEXICAL_SYMBOL class END_OF_FILE;
    ! Signals the end of a Datalog program file;
  begin
  end END_OF_FILE;

!*****************************************
   T h e   l e x i c a l   s c a n n e r
 *****************************************;

  class LEXICAL_SCANNER(file_name);
    value file_name; text file_name;
  begin
    ref(LEXICAL_SYMBOL) look_ahead;
    character character_look_ahead;
    ref(infile) file;

    character procedure character_read;
    begin
      character_read:= character_look_ahead;
      if not file.endfile then
        character_look_ahead:= file.inchar
    end character_read;

    ref(LEXICAL_SYMBOL) procedure read_symbol;
    begin
      read_symbol:- look_ahead;
      ! set look_ahead to the next LEXICAL_SYMBOL;
      while character_look_ahead = ' ' and not file.endfile do
        character_read;
      if file.endfile then
        look_ahead:- new END_OF_FILE
      else if 'a' <= character_look_ahead and
               character_look_ahead <= 'z' then
        begin
          text string; string:- blanks(100);
          while letter(character_look_ahead) do
            string.putchar(character_read);
          look_ahead:- new ATOM_LEX(string.strip)
        end
      else if 'A' <= character_look_ahead and
              character_look_ahead <= 'Z' then
        begin
          text string; string:- blanks(100);
          while letter(character_look_ahead) do
            string.putchar(character_read);
          look_ahead:- new VARIABLE_LEX(string.strip)
        end
      else if character_look_ahead = ',' then
        begin
          look_ahead:- new COMMA;
          character_read
        end
      else if character_look_ahead = '.' then
        begin
          look_ahead:- new PERIOD;
          character_read
        end
      else if character_look_ahead = '(' then
        begin
          look_ahead:- new BEGIN_PAR;
          character_read
        end
      else if character_look_ahead = ')' then
        begin
          look_ahead:- new END_PAR;
          character_read
        end
      else if character_look_ahead = ':' then
        begin
          character_read;
          if character_look_ahead = '-' then
            begin
              character_read;
              look_ahead:- new COLON_DASH
            end
          else
            error("- expected after :")
        end
      else error("illegal character")
    end read_symbol;

    ! Initialize file:  ;
    file:- new infile(file_name);
    file.open(blanks(100));

    ! Initialize look_ahead:  ;
    character_read;
    read_symbol
  end LEXICAL_SCANNER;

!*********************************
   T h e   i n t e r p r e t e r
 *********************************;

  class BINDING_SET;
    ! Bindings of Datalog variables;
  begin
  end BINDING_SET;

  BINDING_SET class OK_BINDING_SET(var, val, rest);
    ref(VARIABLE) var;
    ref(ARGUMENT) val;
    ref(OK_BINDING_SET) rest;
  begin
  end OK_BINDING_SET;

  OK_BINDING_SET class EMPTY_BINDING_SET;
    ! An empty or initial binding set;
  begin
    ! Attributes are ignored;
  end EMPTY_BINDING_SET;

  BINDING_SET class FAIL;
    ! The result of an unsuccesful matching;
  begin
  end FAIL;

  ref(ARGUMENT) procedure dereference(param, bindings);
    ref(ARGUMENT) param;
    ref(OK_BINDING_SET) bindings;
    ! returns the deepest value of param;
  inspect param
    when ATOM do dereference:- param
    when VARIABLE do
      begin
        ref(OK_BINDING_SET) rest_bindings;
        rest_bindings:- bindings;
        while not rest_bindings is EMPTY_BINDING_SET do
          if rest_bindings.var.equal(param) then
            begin
              dereference:- dereference(rest_bindings.val, bindings);
              go to exit_dereference
            end
          else rest_bindings:- rest_bindings.rest;
        dereference:- param; ! uninstantiated variable;
  exit_dereference:
      end;

  ref(BINDING_SET) procedure bind(old_bindings, the_var, the_val);
    ref(OK_BINDING_SET) old_bindings;
    ref(VARIABLE) the_var;
    ref(ARGUMENT) the_val;
    ! produces an extension of this BINDING_SET,
      the_var is expected not to be previously bound and
      the_val is expected to be an atom or an unbound variable;
  begin
    if the_val is VARIABLE and then the_val qua VARIABLE.equal(the_var) then
      bind:- old_bindings
    else
      bind:- new OK_BINDING_SET(the_var, the_val, old_bindings)
  end bind;

  ref(BINDING_SET) procedure unify_goals(goal1, goal2, old_bindings);
    ref(GOAL) goal1, goal2;
    ref(OK_BINDING_SET) old_bindings;
    ! Match goal1 and goal2 in old_bindings,
      producing an extended OK_BINDING_SET or FAIL;
  begin
    ref(ARGUMENT_LIST) param_list1, param_list2;
    ref(BINDING_SET) current_bindings;
    current_bindings:- if goal1.predicate.equal(goal2.predicate) then
                         old_bindings
                       else new FAIL;
    param_list1:- goal1.parameters;
    param_list2:- goal2.parameters;
    while param_list1 =/= none and param_list2 =/= none
          and not current_bindings is FAIL do
      begin
        current_bindings:- unify_arguments(param_list1.first,
                                  param_list2.first,
                                  current_bindings qua OK_BINDING_SET);
        param_list1:- param_list1.rest;
        param_list2:- param_list2.rest
      end;
    unify_goals:- if param_list1 =/= none or param_list2 =/= none then
                    new FAIL
                  else current_bindings;
  end unify_goals;

  ref(BINDING_SET) procedure unify_arguments(arg1, arg2, old_bindings);
    ref(ARGUMENT) arg1, arg2;
    ref(OK_BINDING_SET) old_bindings;
  begin
    arg1:- dereference(arg1, old_bindings);
    arg2:- dereference(arg2, old_bindings);
    if arg1 is ATOM and arg2 is ATOM then
      unify_arguments:- if arg1.equal(arg2) then
                          old_bindings
                        else new FAIL
    else if arg1 is VARIABLE then
      unify_arguments:- bind(old_bindings, arg1, arg2)
    else
      unify_arguments:- bind(old_bindings, arg2, arg1)
  end unify_arguments;

  procedure print_out_solution(bindings, exit_label);
    ref(OK_BINDING_SET) bindings;
    label exit_label;
  begin
    character answer;
    ref(OK_BINDING_SET) rest_bindings;
    rest_bindings:- bindings;
    while not rest_bindings is EMPTY_BINDING_SET do
      begin
        if rest_bindings.var.level = 0 then
          begin
            outtext("    ");
            rest_bindings.var.pretty_print;
            outtext(" = ");
            dereference(rest_bindings.val, bindings).pretty_print; outimage
          end;
        rest_bindings:- rest_bindings.rest
      end;
    outtext("yes"); outimage;
  try_again:
    outtext("more solutions? (y/n)"); outimage;
    if not lastitem then
      answer:= inchar;
    if answer='y' then
      !proceed;
    else if answer='n' then
      go to exit_label
    else
      go to try_again
  end print_out_solution;

  procedure prove(list_of_goals, bindings, prog, level, exit_label);
    ref(OK_BINDING_SET) bindings;
    ref(GOAL_LIST) list_of_goals;
    ref(PROGRAM) prog;
    integer level;
    label exit_label;
  begin
    ref(PROGRAM) rules_left;
    if list_of_goals == none then
      begin
        print_out_solution(bindings, exit_label);
        go to exit_prove
      end;
    rules_left:- prog;
    while rules_left =/= none do
      begin
        ref(BINDING_SET) bindings1; ref(CLAUSE) rule;
        rule:- rules_left.first.new_copy(level);
        rules_left:- rules_left.rest;
        bindings1:- unify_goals(list_of_goals.first, rule.head, bindings);
        inspect bindings1 when OK_BINDING_SET do
          prove(append_goals(rule.body, list_of_goals.rest), bindings1,
                               prog, level + 1, exit_label)
      end while;
  exit_prove:
  end prove;

  procedure execute(question, prog);
    ref(QUERY) question; ref(PROGRAM) prog;
    ! The top-level prove procedure;
  begin
    ref(OK_BINDING_SET) initial_state;
    initial_state:- new EMPTY_BINDING_SET(none, none, none);
    prove(question.goals, initial_state, prog, 1, exit_execute);
  exit_execute:
    outtext("no (more) solutions"); outimage
  end prove;

!***** Auxiliary procedure used in the interpreter: ;

  ref(GOAL_LIST) procedure append_goals(goals1, goals2);
    ref(GOAL_LIST) goals1, goals2;
  if goals1 == none then
    append_goals:- goals2
  else begin ref(GOAL_LIST) result; result:- new GOAL_LIST;
         result.first:- goals1.first;
         result.rest:- append_goals(goals1.rest, goals2);
         append_goals:- result
       end;

!****************
   Main program
 ****************;

ref(LEXICAL_SCANNER) source;
ref(PROGRAM) datalog_program;
ref(QUERY) question;

outimage;
outtext("Reading program from file TESTPROGRAM");
source:- new LEXICAL_SCANNER("testprogram");
datalog_program:- new PROGRAM;
datalog_program.read(source);
datalog_program.pretty_print;

outimage; outimage;
outtext("Reading program from file TESTQUERY");
source:- new LEXICAL_SCANNER("testquery");
question:- new QUERY;
question.read(source);
question.pretty_print;

outimage;
outtext("Executing..."); outimage;

execute(question, datalog_program)

end  Datalog interpreter;