Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE9009.ZIP/FRAMES.ZIP/NEWFRAME.ARI

Text File | 1990-07-09 | 16.7 KB | 693 lines

%                 FRAME LIBRARY
%
%                    by
%
%                 Instant Recall
%                 P.O. Box 30134
%                 Bethesda, Md. 20814
%                 [phone]
%                 BBS: [phone]
%
%                 (C) Copyright 1990 by Instant Recall
%                 All Rights Reserved
:- module  newframe.
:- segment(libseg).

/*
* get slot value
* get slot value with default
* get slot values
* has slot
* index frame into database
* learn indexed frame update
* retrieve frame from database
* retrieve indexed frame
* retrieve or create indexed frame
satisfies pattern,
types match$,
*/

:- public frame_op / 2 : far .
:- public frame_op / 3 : far .
:- public frame_op / 4 : far .
:- public frame_op / 5 : far .
:- public frame_op / 6 : far .
:- visible frame_op / 2       .
:- visible frame_op / 3       .
:- visible frame_op / 4       .
:- visible frame_op / 5       .
:- visible frame_op / 6       .
:- extrn append / 3 : far .
:- extrn trace_message / 3 : far .
:- extrn frame_op      / 0 : interp .

%%%%%%%%%%%%%%%%% IMPLEMENTATIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


%%%%%%%%%%%%%%%%% frame_op / 2    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%% frame_op / 2    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- mode frame_op( +,+).

frame_op( KEY,
          FRAME2  ) :-
     ARGS =  FRAME2  ,
     frame_op( $trace$,
               KEY,
               ARGS ) ,
     fail.

frame_op( $purge database$,
          PATTERN ) :-
     frame_op( $retrieve frame from database$,
               PATTERN,
               RETRIEVED_FRAME ) ,
     retract( RETRIEVED_FRAME ),
     fail.
frame_op( $purge database$,
          _       ) :-!.

%%%%%%%%%%%%%%%%% frame_op / 3    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%% frame_op / 3    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- mode frame_op( +,+,?).

% cl 0

frame_op( $trace$,
          KEY,
          ARGS ) :-
  !,
  (   call( frame_op ),
      !,
      concat( [$e $, KEY , $ args = $], MSG ),
      trace_message( frame_op,
                     MSG,
                     ARGS)
  ;
      true
  ).

frame_op( $x trace$,
          KEY,
          ARG  ) :-
  !,
  (   call( frame_op ),
      !,
      concat( [$x $, KEY , $ RESULT = $], MSG ),
      trace_message( frame_op,
                     MSG,
                     ARG)
  ;
      true
  ).

frame_op( KEY,
          FRAME1 ,
          FRAME2  ) :-
     ARGS = [ FRAME1, FRAME2 ],
     frame_op( $trace$,
               KEY,
               ARGS ) ,
     fail.


frame_op( $learn prolog database frame update$,
          PATTERN,
          NEW_FRAME ) :-
    frame_op( $purge database$,
              PATTERN ) ,
    asserta( NEW_FRAME ) .

% cl 1
frame_op( $types match$,
          FRAME1 ,
          FRAME2  ) :-
      frame_op( $frame info$,
                FRAME1  ,
                FUNCTOR1,
                _     ) ,
      frame_op( $frame info$,
                FRAME2  ,
                FUNCTOR2,
                _     ) ,
      frame_op( $unify types$,
                FUNCTOR1,
                FUNCTOR2,
                _  ),
      frame_op( $x trace$,
                $types match$,
                true ) .



% cl 2
frame_op( $satisfies pattern$,
          FRAME,
          PATTERN ) :-
     frame_op( $types match$,
               FRAME,
               PATTERN ) ,
     frame_op( $get slot values$,
               FRAME,
               PATTERN ,
               _ ) ,
      frame_op( $x trace$,
                $satisfies pattern$,
                true ) .


% cl 3
frame_op( $retrieve frame from database$,
          PATTERN,
          RETRIEVED_FRAME ) :-
       PATTERN =.. [ FUNCTOR , SLOTS ] ,
       RETRIEVED_FRAME =.. [ FUNCTOR, _  ],
       call( RETRIEVED_FRAME ),
       frame_op( $get slot values$,
                 RETRIEVED_FRAME ,
                 SLOTS ),
      frame_op( $x trace$,
                $retrieve frame from database$,
                RETRIEVED_FRAME  ) .

% cl 4
frame_op( $index frame into database$,
          KEY,
          FRAME ) :-
      recordz( KEY, FRAME , _ ) ,
      frame_op( $x trace$,
                $index frame into database$,
                FRAME  ) .

% cl 5
frame_op( $has slot$,
          FRAME,
          SLOT ) :-
      frame_op( $get slot value$,
                FRAME,
                SLOT,
                _  ) ,
      frame_op( $x trace$,
                $has slot$,
                true   ) .


        % this less elabaorate form can not have the
        % optional and unacceptable modifiers in the
        % SLOTS TO GET
% cl 7
frame_op( $get slot values$,
          _ , % SOURCE_FRAME,
          []  ):- !,
   frame_op( $x trace$,
             $get slot values$,
             []   ) .

frame_op( $get slot values$,
          SOURCE_FRAME,
          OUTPUT       ):-
    OUTPUT =  [S : V | R ] ,
    frame_op( $get slot value$,
              SOURCE_FRAME,
              S,
              V),
    frame_op( $get slot values$,
              SOURCE_FRAME,
              R  ) ,
   frame_op( $x trace$,
             $get slot values$,
             OUTPUT   ) .


% cl 8
frame_op( $get pair slot$,
          PAIR ,
          SLOT   )         :-
       PAIR = SLOT : _ ,
   frame_op( $x trace$,
             $get pair slot$,
             SLOT     ) .

%%%%%%%%%%%%%%%%% frame_op / 4    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%% frame_op / 4    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


:- mode frame_op( +,+,+,?).


%%%%%%%%%%%%%%%%%%% retrieve or create indexed frame %%%%%%%%%%%%


frame_op( KEY,
          FRAME1 ,
          FRAME1a ,
          FRAME2  ) :-
     ARGS = [ FRAME1, FRAME1a, FRAME2  ],
     frame_op( $trace$,
               KEY,
               ARGS ) ,
     fail.

% cl 1
frame_op( $retrieve or create indexed frame$,
          KEY ,
          PATTERN  ,
          FRAME ) :-
     frame_op( $retrieve indexed frame$,
               KEY ,
               PATTERN  ,
               FRAME ) ,
     !,
   frame_op( $x trace$,
             $retrieve or create indexed frame$,
             FRAME  ) .

% cl 2
frame_op( $retrieve or create indexed frame$,
          KEY ,
          PATTERN  ,
          PATTERN ) :-
     recorda( KEY, PATTERN , _ ),
   frame_op( $x trace$,
             $retrieve or create indexed frame$,
             PATTERN    ) .


% cl 3
frame_op( $retrieve indexed frame$,
          KEY ,
          PATTERN  ,
          RETRIEVED_FRAME ) :-
       PATTERN =.. [ FUNCTOR , SLOTS ] ,
       RETRIEVED_FRAME =.. [ FUNCTOR, _ ],
       recorded( KEY, RETRIEVED_FRAME, _ ),
       frame_op( $get slot values$,
                 RETRIEVED_FRAME ,
                 SLOTS ),
   frame_op( $x trace$,
             $retrieve indexed frame$,
             RETRIEVED_FRAME    ) .

% cl 4
frame_op( $frame info$,
          FRAME   ,
          FUNCTOR ,
          SLOTS ) :-
     (   (  FRAME = [ _ | _ ]
         ;
            FRAME = []
         ),
         !,
         SLOTS = FRAME,
         FUNCTOR = untyped
     ;
         FRAME =.. [ FUNCTOR , SLOTS ]
     ),
     !,
   frame_op( $x trace$,
             $frame info$,
             SLOTS  ) .

%%%%%%%%%%%%%%%%%%% get slot value %%%%%%%%%%%%%%%%%%%

% cl 5
frame_op( $get slot value$,
          [ SLOT : VALUE | _   ],
          SLOT,
          VALUE ) :- !,
   frame_op( $x trace$,
             $get slot value$,
             VALUE  ) .

% cl 6
frame_op( $get slot value$,
          [ _ | REST  ],
          SLOT,
          VALUE ) :-
      !,
      frame_op( $get slot value$,
                REST  ,
                SLOT,
                VALUE ) ,
   frame_op( $x trace$,
             $get slot value$,
             VALUE  ) .

% cl 7
frame_op( $get slot value$,
          TERM ,
          SLOT,
          VALUE ) :-
      TERM =..[ _ , SLOTS ],
      !,
      frame_op( $get slot value$,
                SLOTS  ,
                SLOT,
                VALUE ) ,
   frame_op( $x trace$,
             $get slot value$,
             VALUE  ) .

%%%%%%%%%%%%%%%%%%% get slot values %%%%%%%%%%%%%%%%%%%


frame_op( $get slot values$,
          SOURCE_FRAME,
          SLOTS_TO_GET,
          RESULTING_SLOT_LIST ) :-
     var( SLOTS_TO_GET ),
     !,
     frame_op( $frame info$,
               SOURCE_FRAME,
               _,
               RESULTING_SLOT_LIST ),
   frame_op( $x trace$,
             $get slot values$,
             RESULTING_SLOT_LIST  ) .

% cl 8
frame_op( $get slot values$,
          _ , % SOURCE_FRAME,
          SLOTS_TO_GET,
          RESULTING_SLOT_LIST ) :-
     SLOTS_TO_GET = [],
     !,
     RESULTING_SLOT_LIST  = [],
   frame_op( $x trace$,
             $get slot values$,
             RESULTING_SLOT_LIST  ) .

% cl 9
frame_op( $get slot values$,
          SOURCE_FRAME,
          SLOTS_TO_GET,
          RESULTING_SLOT_LIST ) :-
     SLOTS_TO_GET = [ PAIR | REST ],
     frame_op( $get pair slot$,
               PAIR ,
               SLOT   ) ,
     frame_op( $get pair value$,
               SOURCE_FRAME,
               SLOT ,
               PAIR ,
               VALUE  ) ,
     RESULTING_SLOT_LIST = [ SLOT : VALUE | REST1 ],
     frame_op( $get slot values$,
               SOURCE_FRAME,
               REST ,
               REST1 ),
   frame_op( $x trace$,
             $get slot values$,
             RESULTING_SLOT_LIST  ) .


% cl 10


% cl 11
frame_op( $unify frames$,
          FRAME1    ,
          FRAME2    ,
          NEW_FRAME ) :-
      frame_op( $frame info$,
                FRAME1  ,
                FUNCTOR1,
                SLOTS1) ,
      frame_op( $frame info$,
                FRAME2  ,
                FUNCTOR2,
                SLOTS2) ,
      frame_op( $unify types$,
                FUNCTOR1,
                FUNCTOR2,
                NEW_TYPE ),
      frame_op( $unify slots in frame1$,
                SLOTS1  ,
                SLOTS2  ,
                NEW_SLOTS1 ),
      frame_op( $unify slots in frame2$,
                SLOTS1  ,
                SLOTS2  ,
                NEW_SLOTS2 ),
      append(   NEW_SLOTS1  ,
                NEW_SLOTS2  ,
                NEW_SLOTS   ),
      (      NEW_TYPE == untyped ,
             !,
             NEW_FRAME = NEW_SLOTS
      ;
             NEW_FRAME =..[ NEW_TYPE,  NEW_SLOTS ]
      ),
   frame_op( $x trace$,
             $unify frames$,
             NEW_FRAME   ) .

% cl 12
frame_op( $unify types$,
          untyped ,
          FUNCTOR2,
          FUNCTOR2 ) :- !,
   frame_op( $x trace$,
             $unify types$,
             FUNCTOR2    ) .

% cl 13
frame_op( $unify types$,
          FUNCTOR1,
          untyped ,
          FUNCTOR1 ) :- !,
   frame_op( $x trace$,
             $unify types$,
             FUNCTOR1    ) .

% cl 14
frame_op( $unify types$,
          FUNCTOR1,
          FUNCTOR1,
          FUNCTOR1 ) :- !,
   frame_op( $x trace$,
             $unify types$,
             FUNCTOR1    ) .

% cl 15
frame_op( $unify slots in frame1$,
          SLOTS1  ,
          _       ,
          NEW_SLOTS1 ) :-
      SLOTS1  = [] ,
      !,
      NEW_SLOTS1 = [] ,
   frame_op( $x trace$,
             $unify slots in frame1$,
             NEW_SLOTS1  ) .

% cl 16
frame_op( $unify slots in frame1$,
          SLOTS1  ,
          SLOTS2  ,
          NEW_SLOTS1 ) :-
      SLOTS1  = [ SLOT : VALUE1 | REST ],
      frame_op( $get slot value with default$,
                SLOTS2  ,
                SLOT,
                VALUE1  ,
                VALUE2 ) ,
      VALUE2 = VALUE1 ,
      NEW_SLOTS1 = [ SLOT : VALUE1 | REST1 ],
      frame_op( $unify slots in frame1$,
                REST    ,
                SLOTS2  ,
                REST1  ) ,
   frame_op( $x trace$,
             $unify slots in frame1$,
             NEW_SLOTS1  ) .


% cl 17
frame_op( $unify slots in frame2$,
          _   ,
          SLOTS2  ,
          NEW_SLOTS2 ) :-
      SLOTS2  = [],
      !,
      NEW_SLOTS2 = [] ,
   frame_op( $x trace$,
             $unify slots in frame2$,
             NEW_SLOTS2  ) .

% cl 18
frame_op( $unify slots in frame2$,
          SLOTS1  ,
          SLOTS2  ,
          NEW_SLOTS2 ) :-
    SLOTS2  = [ SLOT : VALUE1 | REST ],
    (      frame_op( $has slot$,
                     SLOTS1  ,
                     SLOT ),
           !,
           frame_op( $unify slots in frame2$,
                     SLOTS1  ,
                     REST    ,
                     NEW_SLOTS2 )
    ;
           NEW_SLOTS2  = [ SLOT : VALUE1 | COMPUTED_REST ],
           frame_op( $unify slots in frame2$,
                     SLOTS1  ,
                     REST    ,
                     COMPUTED_REST  )
    ),
   frame_op( $x trace$,
             $unify slots in frame2$,
             NEW_SLOTS2  ) .



%%%%%%%%%%%%%%%%% frame_op / 5    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%% frame_op / 5    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- mode frame_op( +,+,+,+,?).


frame_op( KEY,
          FRAME1 ,
          FRAME1a ,
          FRAME1b ,
          FRAME2  ) :-
     ARGS = [ FRAME1, FRAME1a , FRAME1b ,  FRAME2 ],
     frame_op( $trace$,
               KEY,
               ARGS ) ,
     fail.

frame_op( $get pair value$,
          SOURCE_FRAME,
          SLOT ,
          PAIR ,
          VALUE  ) :-
    PAIR = _ : REST ,
               /*-TRACE-*/         trace_message( frame_op   ,
               /*-TRACE-*/                        $...REST = $,
               /*-TRACE-*/                        REST  ),
    (
         var( REST ),
         !,
         frame_op( $get slot value$,
                   SOURCE_FRAME,
                   SLOT,
                   VALUE )
    ;
                % PAIR =  SLOT : unacceptable : BAD_VALUE ,
         REST =   unacceptable : BAD_VALUE ,
         !,
         (
                  frame_op( $get slot value$,
                            SOURCE_FRAME,
                            SLOT,
                            VALUE ) ,
                  !,
                  not BAD_VALUE = VALUE
         ;
                  true
         )
    ;
                %   PAIR =  SLOT : optional : VALUE
         REST =   optional : GOOD_VALUE ,
         ! ,
         (
                  frame_op( $get slot value$,
                            SOURCE_FRAME,
                            SLOT,
                            VALUE ) ,
                  !,
                  GOOD_VALUE = VALUE
         ;
                  true
         )
    ) ,
   frame_op( $x trace$,
             $get pair value$,
             VALUE  ) .


%%%%%%%%%%%%%%%%%%% learn indexed frame update  %%%%%%%%%%%%%%%%%%%

% cl 1
frame_op( $learn indexed frame update$,
          KEY  ,
          OLD_FRAME ,
          NEW_SLOTS ,
          NEW_FRAME ) :-

      frame_op( $unify frames$,
                OLD_FRAME ,
                NEW_SLOTS ,
                NEW_FRAME ) ,
      recorded( KEY, OLD_FRAME, REF ),
      replace( REF, NEW_FRAME ),
   frame_op( $x trace$,
             $learn indexed frame update$,
             NEW_FRAME   ) .

%%%%%%%%%%%%%%%%%%% get slot value with default %%%%%%%%%%%%%%%%%%%

% cl 2
frame_op( $get slot value with default$,
          FRAME,
          SLOT,
          _ , % DEFAULT,
          VALUE ) :-
      frame_op( $get slot value$,
                FRAME,
                SLOT,
                VALUE ) ,
      !,
   frame_op( $x trace$,
             $get slot value with default$,
             VALUE       ) .

% cl 3
frame_op( $get slot value with default$,
          _    ,
          _   ,
          DEFAULT,
          DEFAULT ) :- !,
   frame_op( $x trace$,
             $get slot value with default$,
             DEFAULT     ) .

%%%%%%%%%%%%%%%%% frame_op / 6    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%% frame_op / 6    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- mode frame_op( +,+,+,+,+,?).


frame_op( KEY,
          FRAME1 ,
          FRAME1a ,
          FRAME1b ,
          FRAME1C ,
          FRAME2  ) :-
     ARGS = [ FRAME1, FRAME1a , FRAME1b ,   FRAME1C ,  FRAME2 ],
     frame_op( $trace$,
               KEY,
               ARGS ) ,
     fail.

frame_op( $learn indexed and Prolog database frame update$,
          KEY      ,
          PATTERN ,
          OLD_OBJECT  ,
          SLOTS ,
          NEW_STATEMENT_OBJECT )   :-
      frame_op( $learn indexed frame update$,
                KEY      ,
                OLD_OBJECT  ,
                SLOTS ,
                NEW_STATEMENT_OBJECT ),
       frame_op( $learn prolog database frame update$,
                 PATTERN,
                 NEW_STATEMENT_OBJECT ) .
%%%%%%%%%%%%%%%%%%%%%%%%%% eof %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%