home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / AIE9009.ZIP / FRAMES.ZIP / ES2M.ARI < prev    next >
Encoding:
Text File  |  1990-07-09  |  17.0 KB  |  473 lines
  1.  
  2.  
  3. %       FRAME-BASED EXPERT SYSTEM
  4. %
  5. %                    by
  6. %
  7. %                 Instant Recall
  8. %                 P.O. Box 30134
  9. %                 Bethesda, Md. 20814
  10. %                 (301) 530-0898
  11. %                 BBS: (301) 530-2890
  12. %
  13. %                 (C) Copyright 1990 by Instant Recall
  14. %                 All Rights Reserved
  15. :- module   es2m.
  16. :- public   main_hlpr / 0                   : far    .
  17. :- extrn    get_kb /0                       : far    .
  18. :- extrn    trace_message/ 3                : far    .
  19. :- extrn    log_listing  / 1                : far    .
  20. :- extrn    init_log_file / 0               : interp .
  21. :- extrn    rule / 1                        : interp .
  22. :- extrn    goal / 1                        : interp .
  23. :- extrn    close_log_file / 0              : interp .
  24. :- extrn    retractall / 1                  : far    .
  25. :- extrn  log_put  / 1 : far .
  26. :- extrn  log_write/ 1 : far .
  27. :- extrn  log_nl   / 0 : far .
  28. :- extrn  frame_op / 2 : far .
  29. :- extrn  frame_op / 3 : far .
  30. :- extrn  frame_op / 4 : far .
  31. :- extrn  frame_op / 5 : far .
  32. :- extrn  frame_op / 6 : far .
  33. :- extrn  test     / 0 : far .
  34.  
  35. %%%%%%%% op defs %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  36.  
  37. :-     op(  450 , yfx , or ).
  38. :-     op(  440 , yfx , and ).
  39.  
  40.  
  41. main_hlpr :-
  42.    reconsult($traceflg.con$),
  43.    reconsult($newtrace.pro$),
  44.    call( init_log_file),
  45. %  test,
  46.      /*-TRACE-*/         trace_message( main_hlpr / 0 ,
  47.      /*-TRACE-*/                        $b get_data$,
  48.      /*-TRACE-*/                        $$         ),
  49.    get_kb  ,
  50.       /*-TRACE-*/         trace_message( main_hlpr / 0 ,
  51.       /*-TRACE-*/                        $b solve$,
  52.       /*-TRACE-*/                        $$         ),
  53.    setup     ,
  54.    solve     ,
  55.    log_listing(  statement  / 1 ) ,
  56.    call( close_log_file),
  57.    halt.
  58.  
  59.  
  60.  
  61. solve  :-
  62.          /*-TRACE-*/         trace_message( solve / 0 ,
  63.          /*-TRACE-*/                        $e$,
  64.          /*-TRACE-*/                        $$         ),
  65.          find_goal( GOAL ),
  66.                /*-TRACE-*/         trace_message( solve / 0 ,
  67.                /*-TRACE-*/                        $...GOAL  = $,
  68.                /*-TRACE-*/                        GOAL    ),
  69.          try(  GOAL    ).
  70.  
  71.  
  72. find_goal( GOAL ) :-
  73.      frame_op( $retrieve frame from database$,
  74.                statement( [ goal : true   ] ),
  75.                GOAL  ) .
  76.  
  77.  
  78. %%%%%%%%%%%%%%% TRYING A GOAL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  79.  
  80.  
  81. % try clause 0 : trace
  82. try( QUESTION                  ) :-
  83.       /*-TRACE-*/         trace_message( try / 1   ,
  84.       /*-TRACE-*/                        $e, QUESTION = $,
  85.       /*-TRACE-*/                        QUESTION   ),
  86.        fail.
  87.  
  88. % try clause 1 : true is true
  89. try( true       ) :- !.
  90.  
  91. % try clause 2 : Use known results
  92. try( STATEMENT  ) :-
  93.        is_ground_statement(  STATEMENT  ) ,
  94.       /*-TRACE-*/         trace_message( try / 1   ,
  95.       /*-TRACE-*/                        $...is_ground_statement succeeds $,
  96.       /*-TRACE-*/                        $$  ),
  97.        frame_op( $get slot values$,
  98.                  STATEMENT ,
  99.                  [   description : QUESTION ]  ) ,
  100.       /*-TRACE-*/         trace_message( try / 1   ,
  101.       /*-TRACE-*/                        $...QUESTION =  $,
  102.       /*-TRACE-*/                        QUESTION   ),
  103.       frame_op( $get slot value with default$,
  104.                 STATEMENT ,
  105.                 value ,
  106.                 ANSWER ,
  107.                 ANSWER ),
  108.       /*-TRACE-*/         trace_message( try / 1   ,
  109.       /*-TRACE-*/                        $...ANSWER  =  $,
  110.       /*-TRACE-*/                        ANSWER    ),
  111.       find_statement( QUESTION ,  STATEMENT_OBJECT  ),
  112.       /*-TRACE-*/         trace_message( try / 1   ,
  113.       /*-TRACE-*/                        $...STATEMENT_OBJECT  =  $,
  114.       /*-TRACE-*/                        STATEMENT_OBJECT   ),
  115.       frame_op( $get slot value$,
  116.                 STATEMENT_OBJECT,
  117.                 value ,
  118.                 ANSWER1 ),
  119.       /*-TRACE-*/         trace_message( try / 1   ,
  120.       /*-TRACE-*/                        $...ANSWER1 =  $,
  121.       /*-TRACE-*/                        ANSWER1              ),
  122.        (      ANSWER = ANSWER1,
  123.               !
  124.        ;      !,
  125.               fail
  126.        )
  127.       /*-TRACE-*/        ,trace_message( try / 1   ,
  128.       /*-TRACE-*/                        $x, succeeds : $,
  129.       /*-TRACE-*/                        STATEMENT  )
  130.        .
  131.  
  132.  
  133. % try clause 3 : don't try again goals that could not be solved
  134. try( STATEMENT    ) :-
  135.       is_ground_statement(  STATEMENT  ) ,
  136.       frame_op( $get slot value$,
  137.                 STATEMENT,
  138.                 description ,
  139.                 QUESTION ),
  140.       find_statement( QUESTION ,  STATEMENT_OBJECT  ),
  141.       frame_op( $get slot value$,
  142.                 STATEMENT_OBJECT ,
  143.                 already_tried,
  144.                 true   ),
  145.       /*-TRACE-*/         trace_message( try / 1   ,
  146.       /*-TRACE-*/                        $...FAILS , already tried : $,
  147.       /*-TRACE-*/                        STATEMENT  ),
  148.       !,
  149.       fail.
  150.  
  151.  
  152. % try clause 4 : ask user
  153. try(  STATEMENT ) :-
  154.       /*-TRACE-*/         trace_message( try / 1   ,
  155.       /*-TRACE-*/                        $e, ask rule = $,
  156.       /*-TRACE-*/                        $$         ),
  157.     is_ground_statement(  STATEMENT  ) ,
  158.       /*-TRACE-*/         trace_message( try / 1   ,
  159.       /*-TRACE-*/                        $...b frame_op$,
  160.       /*-TRACE-*/                        $$         ),
  161.     frame_op( $get slot values$,
  162.               STATEMENT,
  163.               [   description : QUESTION ,
  164.                      value  : ANSWER ]   ) ,
  165.       /*-TRACE-*/         trace_message( try / 1   ,
  166.       /*-TRACE-*/                        $...b find_statement$,
  167.       /*-TRACE-*/                        $$         ),
  168.     find_statement( QUESTION ,  STATEMENT_OBJECT  ),
  169.       /*-TRACE-*/         trace_message( try / 1   ,
  170.       /*-TRACE-*/                        $...b frame_op$,
  171.       /*-TRACE-*/                        $$         ),
  172.     frame_op( $get slot values$,
  173.               STATEMENT_OBJECT ,
  174.               [   dont_ask : optional : false  ,
  175.                   user_doesnt_know : optional : false  ]   ,
  176.               [   dont_ask :  false  ,
  177.                   user_doesnt_know : false  ]      ) ,
  178.       /*-TRACE-*/         trace_message( try / 1   ,
  179.       /*-TRACE-*/                        $....b ask$,
  180.       /*-TRACE-*/                        $$         ),
  181.     ask( STATEMENT_OBJECT, NEW_STATEMENT_OBJECT ),
  182.       /*-TRACE-*/         trace_message( try / 1   ,
  183.       /*-TRACE-*/                        $...NEW_STATEMENT_OBJECT =  $,
  184.       /*-TRACE-*/                        NEW_STATEMENT_OBJECT   ),
  185.       frame_op( $get slot value$,
  186.                 NEW_STATEMENT_OBJECT,
  187.                 value  ,
  188.                 ANSWER1  ),
  189.     (      ANSWER = ANSWER1,
  190.            !
  191.     ;      !,
  192.            fail
  193.     )
  194.       /*-TRACE-*/        ,trace_message( try / 1   ,
  195.       /*-TRACE-*/                        $x, succeeds : $,
  196.       /*-TRACE-*/                        STATEMENT  )
  197.     .
  198.  
  199. % try clause 5 : and rule for inference
  200. try(  HYPOTHESIS_1 and HYPOTHESIS_2  ) :-
  201.                     /*-TRACE-*/         trace_message( try / 1   ,
  202.                     /*-TRACE-*/                        $...and rule$,
  203.                     /*-TRACE-*/                        $$  ),
  204.        !,
  205.        try( HYPOTHESIS_1   ),
  206.        try( HYPOTHESIS_2   ).
  207.  
  208. % try clause 6 : or rule for inference
  209. try(  HYPOTHESIS_1 or HYPOTHESIS_2   ) :-
  210.                  /*-TRACE-*/         trace_message( try / 1   ,
  211.                  /*-TRACE-*/                        $...or rule$,
  212.                  /*-TRACE-*/                        $$  ),
  213.        !,
  214.        (   try( HYPOTHESIS_1  ),
  215.            !
  216.          ;
  217.             try( HYPOTHESIS_2    ) ) .
  218.  
  219.  
  220. % try clause 7 : ground clause rule for inference
  221. try( CONCLUSION     ) :-
  222.     is_ground_statement( CONCLUSION  ) ,
  223.     frame_op( $get slot value$,
  224.               CONCLUSION,
  225.               description ,
  226.               QUESTION ),
  227.                  /*-TRACE-*/         trace_message( try / 1   ,
  228.                  /*-TRACE-*/                        $...ground statement recursive rule$,
  229.                  /*-TRACE-*/                        $$  ),
  230.           % get hypothesis and conclusion
  231.     find_rule( CONCLUSION     , RULE ),
  232.                  /*-TRACE-*/         trace_message( try / 1   ,
  233.                  /*-TRACE-*/                        $...RULE = $,
  234.                  /*-TRACE-*/                        RULE ),
  235.      frame_op( $get slot values$,
  236.                RULE ,
  237.                [ hypothesis : HYPOTHESIS,
  238.                  conclusion : RULE_CONCLUSION  ] ),
  239.                   /*-TRACE-*/         trace_message( try / 1   ,
  240.                   /*-TRACE-*/                        $...HYPOTHESIS = $,
  241.                   /*-TRACE-*/                        HYPOTHESIS ),
  242.       find_statement( QUESTION ,
  243.                       STATEMENT_OBJECT0 ),
  244.       /*-TRACE-*/         trace_message( try / 1   ,
  245.       /*-TRACE-*/                        $...STATEMENT_OBJECT0     =  $,
  246.       /*-TRACE-*/                        STATEMENT_OBJECT0      ),
  247.       frame_op( $learn indexed frame update$,
  248.                 QUESTION ,
  249.                 STATEMENT_OBJECT0  ,
  250.                 [ already_tried : true ] ,
  251.                 STATEMENT_OBJECT ),
  252.       /*-TRACE-*/         trace_message( try / 1   ,
  253.       /*-TRACE-*/                        $... STATEMENT_OBJECT     =  $,
  254.       /*-TRACE-*/                        STATEMENT_OBJECT       ),
  255.       try( HYPOTHESIS  ),
  256.       /*-TRACE-*/         trace_message( try / 1   ,
  257.       /*-TRACE-*/                        $...a try$,
  258.       /*-TRACE-*/                        $$                     ),
  259.       frame_op( $get slot value$,
  260.                 RULE_CONCLUSION ,
  261.                 value ,
  262.                 RULE_CONCLUSION_VALUE ),
  263.       /*-TRACE-*/         trace_message( try / 1   ,
  264.       /*-TRACE-*/                        $... RULE_CONCLUSION_VALUE     =  $,
  265.       /*-TRACE-*/                        RULE_CONCLUSION_VALUE       ),
  266.       frame_op( $learn indexed and Prolog database frame update$,
  267.                 QUESTION ,
  268.                 statement( [ description : QUESTION ] ) ,
  269.                 STATEMENT_OBJECT  ,
  270.                 [ value : RULE_CONCLUSION_VALUE  ],
  271.                 NEW_STATEMENT_OBJECT ),
  272.       /*-TRACE-*/         trace_message( try / 1   ,
  273.       /*-TRACE-*/                        $... NEW_STATEMENT_OBJECT     =  $,
  274.       /*-TRACE-*/                        NEW_STATEMENT_OBJECT       ),
  275.       report(  NEW_STATEMENT_OBJECT ) ,
  276.       frame_op( $get slot value with default$,
  277.                 CONCLUSION ,
  278.                 value ,
  279.                 DESIRED_ANSWER ,
  280.                 DESIRED_ANSWER ),
  281.       /*-TRACE-*/         trace_message( try / 1   ,
  282.       /*-TRACE-*/                        $... DESIRED_ANSWER    =  $,
  283.       /*-TRACE-*/                        DESIRED_ANSWER        ),
  284.        (      DESIRED_ANSWER = RULE_CONCLUSION_VALUE,
  285.               !
  286.        ;      !,
  287.               fail
  288.        )
  289.       /*-TRACE-*/        ,trace_message( try / 1   ,
  290.       /*-TRACE-*/                        $X$,
  291.       /*-TRACE-*/                        $$       )
  292.             .
  293.  
  294.  
  295. %%%%%%%%%%%%% utility predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%5
  296.  
  297. is_yes_no_question( STATEMENT ) :-
  298.      frame_op( $get slot value with default$,
  299.                STATEMENT ,
  300.                value_type,
  301.                boolean,
  302.                boolean  ) .
  303.  
  304.  
  305.        % asks a question of user
  306.        % QUESTION = what to ask
  307.        % ANSWER = desired answer
  308.        % HOW_LEARNED output variable = user when predicate succeeds
  309.        % success when user answer is ANSWER
  310.        % fails otherwise.
  311.        % if user doesn't know, this is learned
  312. ask( STATEMENT_OBJECT, NEW_STATEMENT_OBJECT ) :-
  313.          /*-TRACE-*/         trace_message( ask   / 2 ,
  314.          /*-TRACE-*/                        $e$,
  315.          /*-TRACE-*/                        $$         ),
  316.        is_yes_no_question( STATEMENT_OBJECT ) ,
  317.        frame_op( $get slot value$,
  318.                  STATEMENT_OBJECT,
  319.                  description,
  320.                  QUESTION ),
  321.          /*-TRACE-*/         trace_message( ask   / 2 ,
  322.          /*-TRACE-*/                        $..b yes_no_ask$,
  323.          /*-TRACE-*/                        $$         ),
  324.        yes_no_ask(  QUESTION , ANSWER1 ),
  325.        !,
  326.        (     not ANSWER1 == dont_know,
  327.              !,
  328.             frame_op( $learn indexed and Prolog database frame update$,
  329.                       QUESTION ,
  330.                       statement( [ description : QUESTION ] ) ,
  331.                       STATEMENT_OBJECT  ,
  332.                       [ value : ANSWER1 ],
  333.                       NEW_STATEMENT_OBJECT )
  334.        ;
  335.             ANSWER1 = dont_know,
  336.             !,
  337.             frame_op( $learn indexed and Prolog database frame update$,
  338.                       QUESTION ,
  339.                       statement( [ description : QUESTION ] ) ,
  340.                       STATEMENT_OBJECT  ,
  341.                       [ user_doesnt_know  : true    ],
  342.                       NEW_STATEMENT_OBJECT ) ,
  343.             fail
  344.         ).
  345.  
  346. setup :-
  347.     setup_rules ,
  348.     setup_statements
  349.                /*-TRACE-*/        ,trace_message( setup / 0 ,
  350.                /*-TRACE-*/                        $x$,
  351.                /*-TRACE-*/                        $$   )
  352.     .
  353.  
  354. setup_rules :-
  355.                /*-TRACE-*/         trace_message( setup_rules / 0 ,
  356.                /*-TRACE-*/                        $e$,
  357.                /*-TRACE-*/                        $$   ),
  358.      TERM = rule( RULE )  ,
  359.      call( TERM  ),
  360.      frame_op( $get slot value$,
  361.                RULE ,
  362.                conclusion,
  363.                CONCLUSION ),
  364.      frame_op( $get slot value$,
  365.                CONCLUSION,
  366.                description,
  367.                DESCRIPTION ),
  368.      frame_op( $index frame into database$,
  369.                DESCRIPTION ,
  370.                TERM  ) ,
  371.      fail.
  372. setup_rules :- !.
  373.  
  374. setup_statements :-
  375.                /*-TRACE-*/         trace_message( setup_statements / 0 ,
  376.                /*-TRACE-*/                        $e$,
  377.                /*-TRACE-*/                        $$   ),
  378.      TERM = statement( STATEMENT  ),
  379.      call( TERM  ),
  380.      frame_op( $get slot value$,
  381.                STATEMENT,
  382.                description,
  383.                DESCRIPTION ),
  384.      frame_op( $index frame into database$,
  385.                DESCRIPTION ,
  386.                TERM  ) ,
  387.      fail.
  388. setup_statements :- !.
  389.  
  390. find_statement( DESCRIPTION, STATEMENT  ) :-
  391.      frame_op( $retrieve or create indexed frame$,
  392.                DESCRIPTION,
  393.                statement( [ description: DESCRIPTION ] ) ,
  394.                STATEMENT  ) .
  395.  
  396. find_rule( CONCLUSION, TERM ) :-
  397.                /*-TRACE-*/         trace_message( find_rule  / 1 ,
  398.                /*-TRACE-*/                        $e, CONCLUSION = $,
  399.                /*-TRACE-*/                        CONCLUSION   ),
  400.    frame_op( $get slot values$,
  401.              CONCLUSION,
  402.              [ description :  DESCRIPTION ]),
  403.                /*-TRACE-*/         trace_message( find_rule  / 1 ,
  404.                /*-TRACE-*/                        $...DESCRIPTION = $,
  405.                /*-TRACE-*/                        DESCRIPTION  ),
  406.    frame_op( $retrieve indexed frame$,
  407.              DESCRIPTION ,
  408.              rule( _ )  ,
  409.              TERM  )
  410.                /*-TRACE-*/        ,trace_message( find_rule  / 1 ,
  411.                /*-TRACE-*/                        $x,  TERM = $,
  412.                /*-TRACE-*/                        TERM          )
  413.               .
  414.  
  415.  
  416.  
  417. is_ground_statement( STATEMENT ) :-
  418.      frame_op( $has slot$,
  419.                STATEMENT ,
  420.                description ).
  421.  
  422. yes_no_ask(  QUESTION , ANSWER  ) :-
  423.     repeat,
  424.         log_write( QUESTION ),
  425.         log_write( $?$ ),
  426.         log_nl,
  427.         INSTRUCTIONS =
  428.               $     ( y = yes, n = no, d = don't know )  : $,
  429.         log_write( INSTRUCTIONS ),
  430.         get0_noecho( C ) ,
  431.         log_put( C ) ,
  432.         log_nl,
  433.         (
  434.                   ( C == `y
  435.                   ;
  436.                     C == `Y
  437.                   ),
  438.                   ANSWER = yes,
  439.                   !
  440.               ;
  441.                   ( C == `N
  442.                   ;
  443.                     C == `n
  444.                   ),
  445.                   ANSWER = no ,
  446.                   !
  447.               ;
  448.                   ( C == `D
  449.                   ;
  450.                     C == `d
  451.                   ),
  452.                   ! ,
  453.                   ANSWER = dont_know
  454.               ;
  455.                   log_write($Please answer with an y, n or d.$),
  456.                   log_nl,
  457.                   fail
  458.          ).
  459.  
  460.  
  461. report( GOAL  ) :-
  462.        is_ground_statement(  GOAL   ) ,
  463.        frame_op( $get slot values$,
  464.                  GOAL ,
  465.                  [   description : QUESTION ,
  466.                             value  : ANSWER ] ) ,
  467.        write( QUESTION ),
  468.        write($ = $ ),
  469.        write( ANSWER ),
  470.        nl.
  471.  
  472. %%%%%%%%%%%%%%% eof %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  473.