1% ===================================================================
    2% File 'graphmaster.pl'
    3% Purpose: An Implementation in SWI-Prolog of Graphmaster Index
    4% Maintainer: Douglas Miles
    5% Contact: $Author: dmiles $@users.sourceforge.net ;
    6% Version: 'graphmaster.pl' 1.0.0
    7% Revision: $Revision: 1.7 $
    8% Revised At: $Date: 2002/07/11 21:57:28 $
    9% ===================================================================
   10
   11
   12:- use_module(library(dictoo_lib)).   13:- use_module(library(globals_api)).   14%:- set_prolog_flag(generate_debug_info, false).
   15%:- cls.
   16% :- use_module(library(wam_cl/init)).
   17
   18:- include(hashmap_oo).   19
   20% ===================================================================
   21% ===================================================================
   22track_now(Graph):- track_now(Graph, inst).
   23track_now(Graph, _Type):- hashtable_get(Graph, track_id, _), !.
   24track_now(Graph, Type):- gensym(Type, I), oo_set(Graph, track_id, I).
   25
   26%%isStar0(Word1):- member(Word1, [*, '_']).
   27isStar0(X):-var(X), !, throw(isStar0(X)).
   28isStar0('*').
   29isStar0('_').
   30
   31into_path(List, NList):- notrace((is_list(List), !, maplist(into_path, List, NList))), !.
   32into_path(List, NList):- atom(List), !, upcase_atom(List, NList).
   33into_path(List, NList):- compound(List), !, =(List, NList).
   34into_path(List, NList):- throw(into_path(List, NList)).
   35
   36sameWords(Word1, Word2):-atom(Word1), atom(Word2), atoms_match0(Word1, Word2).
   37 atoms_match0(Word1, Word2):- (isStar0(Word1);isStar0(Word2)), !, fail.
   38 atoms_match0(Word1, Word1):-!.
   39 atoms_match0(Word1, Word2):-into_path(Word1, WordO), into_path(Word2, WordO), !.
   40
   41into_name(Graph, Name):- atom(Graph), !, ignore((Graph=Name)).
   42into_name(Graph, Name):- is_hashtable(Graph), !, ignore((hashtable_get(Graph, name, Name))).
   43
   44into_named_map(RB, Name, Graph, _ElseCall):- oo_get(RB, Name, Graph), !.
   45into_named_map(RB, Name, Graph, ElseCall):- hashtable_new(Graph), 
   46   call(ElseCall, Graph), oo_set(Graph, name, Name), track_now(Graph), oo_set(RB, Name, Graph).
   47
   48
   49:- nb_current('$graphs', _) -> true ; (hashtable_new( RB), nb_setval('$graphs', RB)).   50into_graph(Name):- atom(Name), into_graph(Name, _O).
   51into_graph(Graph):- into_graph(_, Graph).
   52into_graph(Name, Graph):-  is_hashtable(Graph), !, ignore((hashtable_get(Graph, name, Name))).
   53into_graph(Name, Graph):- 
   54 ignore(Name=graphmaster), 
   55 into_name(Name, GName), 
   56 nb_getval('$graphs', RB), 
   57 into_named_map(RB, GName, Graph, make_graph).
   58
   59make_graph(Graph):- hashtable_set(Graph, type, graph).
   60
   61:- nb_current('$states', _) -> true ; (hashtable_new( RB), nb_setval('$states', RB)).   62into_state(Name):- atom(Name), into_state(Name, _O).
   63into_state(State):- into_state(_, State).
   64into_state(Name, Graph):-  is_hashtable(Graph), !, ignore((hashtable_get(Graph, name, Name))).
   65into_state(Name, State):- 
   66 ignore(Name=statemaster),
   67 into_name(Name, GName), 
   68 nb_getval('$states', RB),
   69 into_named_map(RB, GName, State, make_state()).
   70
   71make_state(State):- reset_state(State).
   72reset_state(State):- hashtable_set(State, star_name, star), hashtable_set(State, star_num, 1).
   73
   74into_props(NState, Props, NPropsO):-
   75 must(cate_states(NState, NCate)),
   76 must(into_pairs(Props, Pairs)),
   77 must(append(NCate, Pairs, NProps)),
   78 flatten(NProps, NPropsO).
   79
   80cate_states(NState, NCate):-into_pairs(NState, Pairs),
   81   include(cate_state, Pairs, NCate).
   82
   83cate_state(N=_):- cate_prop(N).
   84cate_prop(pattern).
   85cate_prop(template).
   86
   87
   88
   89% ===================================================================
   90% ===================================================================
   91set_template(Path, Template, Graph):- into_state(State),
   92  dmsg("adding..."),fmt(set_template(Path, Template)),
   93  set_pathprops( State, Path, template = (Template), Graph).
   94
   95get_template(Path, Template, Graph):- into_state(State), get_pathprops( State, Path, template = (Template), Graph).
   96
   97clear_graph(Graph):- notrace((into_graph(Graph, NGraph), hashtable_clear(NGraph))).
   98
   99% ===================================================================
  100% ===================================================================
  101set_pathprops(Path, Props, Graph):- set_pathprops(_State, Path, Props, Graph).
  102
  103set_pathprops(State, Path, Props, Graph):- 
  104 must(notrace((into_state(State, NState), 
  105          into_path(Path, NPath), 
  106          into_props([pattern=Path|NState], Props, NProps),
  107          into_graph(Graph, NGraph)))), 
  108 with_name_value(NState, star_num, 1,
  109    set_pathprop_now(NState, NPath, NProps, NGraph)).
  110 
  111set_pathprop_now(_State, [], Props, Graph):- !, 
  112 must(compound(Props)), 
  113 hashtable_set_props(Graph, Props),
  114 hashtable_set(Graph, [], Props).
  115
  116
  117set_pathprop_now(State, Path, Props, Graph):-
  118  \+ ground(Path), 
  119  make_path_props_v(Path, Props, PathV, PropsV), !,
  120  must(ground(PathV)),
  121  set_pathprop_now(State, PathV, PropsV, Graph).
  122
  123
  124set_pathprop_now(State, [W0|More], Props, Graph):- 
  125 path_expand(State, W0, W1, More),
  126 functor(W1, Index, _), !, 
  127 ( hashtable_get(Graph, Index, Next) 
  128   *-> set_pathprop_now( State, More, Props, Next)
  129    ; (hashtable_new(NewNode),       
  130       set_pathprop_now( State, More, Props, NewNode),
  131       (Index==W1 -> NewNodeTerm = NewNode ; w(W1, NewNode) = NewNodeTerm ),
  132       hashtable_set(Graph, Index, NewNodeTerm))).
  133
  134
  135make_path_props_v(Path, Props, PathV, PropsV):-
  136  term_variables(Path, PathVars),
  137  make_path_props_v(PathVars, Path, Props, PathV, PropsV).
  138make_path_props_v([], Path, Props, Path, Props):-!.
  139make_path_props_v([V|PathVars], Path, Props, PathV, PropsV):-
  140  gensym('PVAR_', PV),
  141  subst(Path, V, '$VAR'(PV), PathM),
  142  subst(Props, V, '$VAR'(PV), PropsM),
  143  make_path_props_v(PathVars, PathM, PropsM, PathV, PropsV).
  144
  145
  146 revarify(State, Call, GraphMid, CallV, GraphMidV):-
  147   sub_term(Sub, Call), compound(Sub),
  148   Sub='$VAR'(_), !,
  149   subst(Call, Sub, NewVar, CallM),
  150   subst(GraphMid, Sub, NewVar, GraphMidM),
  151   revarify(State, CallM, GraphMidM, CallV, GraphMidV).
  152 revarify(State, Call, GraphMid, CallV, GraphMidV):-
  153   sub_term(Sub, Call), compound(Sub),
  154   Sub='$'(NAME), unbound_get(State, NAME, NewVar), !,
  155   subst(Call, Sub, NewVar, CallM),
  156   subst(GraphMid, Sub, NewVar, GraphMidM),
  157   revarify(State, CallM, GraphMidM, CallV, GraphMidV).
  158revarify(_State, Call, GraphMid, Call, GraphMid).
  159
  160  
  161
  162% ===================================================================
  163% ===================================================================
  164get_pathprops(Path, Props, Graph):- get_pathprops(_State, Path, Props, Graph), !.
  165
  166get_pathprops(_State, Path, Props, Graph):- is_hashtable(Graph), Path==[], !, hashtable_get_props(Graph, Props).
  167get_pathprops( State, Path, Props, Graph):-
  168 term_variables(Props, PropsV),
  169 notrace((into_state(State, NState), 
  170          into_path(Path, NPath),
  171          into_props([pattern=Path|NState], Props, NProps),          
  172          into_graph(Graph, NGraph))), 
  173 get_pathprops_now(NState, NPath, NProps, NGraph), !,
  174 ignore((PropsV==[Props], flatten(NProps, Props))).
  175
  176get_pathprops_now( State, [W1|More], Props, Graph):- !, 
  177 hashtable_get(Graph, W1, Next), 
  178 get_pathprops_now( State, More, Props, Next).
  179get_pathprops_now(_State, _, Props, Graph):-                       
  180 hashtable_get_props(Graph, Props).
  181
  182
  183% ===================================================================
  184% ===================================================================
  185path_match(Path, Result):- path_match(_State, Path, _Graph, Result).
  186
  187path_match(State, Path, Graph, Result):-
  188 must(notrace((into_state(State, NState), 
  189          =(Path, NPath), 
  190          into_graph(Graph, NGraph), 
  191          copy_term(Result, Result0),
  192          reset_state(NState)))),
  193 path_match_now(NState, NPath, NGraph, Result0),
  194 notrace((duplicate_term(Result0, Result),
  195 set_result_vars(NState, Result))), !.
  196
  197
  198set_result_vars(S, X):- 
  199  ignore((
  200     compound(X),
  201     forall(arg(N, X, E),
  202           (compound(E),
  203            ((E=get(A), hashtable_get(S, A, V))
  204             *-> nb_setarg(N, X, V)
  205             ; set_result_vars(S, E)))))).
  206
  207
  208call_with_filler(NewCall):- call(NewCall).
  209
  210
  211path_match_now(State, Path, Graph, Result):- 
  212  get_pathprops( State, Path, template = (Result), Graph).
  213
  214/*
  215Matching Priorities
  216
  217HELLO #
  218HELLO _
  219HELLO THERE
  220<set>greetings</set> = @greetings
  221HELLO ^
  222HELLO *
  223*/
  224
  225% {Call}
  226path_match_now(State, InputList, Graph, Result):- 
  227 hashtable_get(Graph, '{}', Found),
  228 must(w('{}'(Call), GraphMid)=Found),
  229 revarify(State, Call, GraphMid, CallV, GraphMidV),
  230 call_with_filler(CallV),
  231 path_match_now(State, InputList, GraphMidV, Result).
  232
  233path_match_now(_State, [], Graph, Result):- !,
  234 hashtable_get(Graph, '[]', Result). 
  235 
  236
  237% Call_Star match #,_
  238path_match_now(State, InputList, Graph, Result):- 
  239 star_n(N, CStar, _), N < 3,
  240 atom_concat(call_star_,CStar, CS),
  241 hashtable_get(Graph, CS, Found),
  242 NEW =.. [CS, Star, Call],
  243 must(w(NEW, GraphMid)=Found),
  244 star_n(_, Star, Min), 
  245 subst(Call, Star, Left, NewCall),
  246 complex_match(State, Min, InputList, Left, _Right, call_with_filler(NewCall), GraphMid, Result).
  247
  248% exact match
  249path_match_now(State, [Input|List], Graph, Result):- 
  250 into_path(Input, InputM),
  251 hashtable_get(Graph, InputM, GraphMid), 
  252 path_match_now(State, List, GraphMid, Result).
  253
  254% @DCG
  255path_match_now(State, InputList, Graph, Result):- 
  256 hashtable_get(Graph, '@', Found),
  257 must(w('@'(DCG), GraphMid)=Found),  
  258 gm_phrase(DCG, InputList, Rest),
  259 path_match_now(State, Rest, GraphMid, Result).
  260
  261% *DCG
  262path_match_now(State, InputList, Graph, Result):- fail,
  263 hashtable_get(Graph, '*', Found), \+ is_hashtable(Found),
  264 must(w('*'(DCG), GraphMid)=Found),  
  265 gm_phrase(DCG, InputList, Rest),
  266 append(Left,Rest,InputList),
  267 set_next_star(State, Left, 
  268 path_match_now(State, Rest, GraphMid, Result)).
  269
  270% $VAR
  271path_match_now(State, InputList, Graph, Result):- 
  272 hashtable_get(Graph, '$', Found),
  273 must(w('$'(NAME), GraphMid)=Found),
  274 (unbound_get(State, NAME, RequiredValue)
  275   -> gm_phrase(req(RequiredValue), InputList, Rest) 
  276   ;  gm_phrase(NAME, InputList, Rest)), 
  277 append(Left,Rest,InputList),
  278 set_next_star(State, Left, 
  279 ((atom(NAME) -> hashtable_set(State, NAME, Left) ; true),
  280 path_match_now(State, Rest, GraphMid, Result))).
  281
  282% Call_Star match ^,*
  283path_match_now(State, InputList, Graph, Result):- 
  284 star_n(N, CStar, _), N > 3,
  285 atom_concat(call_star_,CStar, CS),
  286 hashtable_get(Graph, CS, Found),
  287 NEW =.. [CS, Star, Call],
  288 must(w(NEW, GraphMid)=Found),
  289 star_n(_, Star, Min), 
  290 subst(Call, Star, Left, NewCall),
  291 complex_match(State, Min, InputList, Left, _Right, call_with_filler(NewCall), GraphMid, Result).
  292
  293
  294% Star match
  295path_match_now(State, InputList, Graph, Result):-
  296 star_n(_, Star, Min),
  297 hashtable_get(Graph, Star, GraphMid),   
  298 complex_match(State, Min, InputList, _Left, _Right, true, GraphMid, Result).
  299
  300
  301complex_match(State, Min, InputList, Left, Right, NewCall, GraphMid, Result):- 
  302 member(NextWord, InputList), 
  303 into_path(NextWord, NextWordU),
  304 hashtable_get(GraphMid, NextWordU, GraphNext), 
  305 length(Right, _),
  306 append(Left, [NextWord|Right], InputList), 
  307 length(Left, LL), LL>=Min, 
  308 set_next_star(State, Left,
  309 (call(NewCall),
  310 path_match_now(State, Right, GraphNext, Result))).
  311
  312complex_match(State, Min, InputList, Left, Right, NewCall, GraphMid, Result):- 
  313 length(InputList, Max),
  314 length(Right, RMax), 
  315 (RMax > Max 
  316  -> (!,fail) 
  317  ; (append(Left, Right, InputList), 
  318     length(Left, LL), LL>=Min,
  319     set_next_star(State, Left,
  320     (call(NewCall),
  321     path_match_now(State, Right, GraphMid, Result))))).
  322
  323
  324gm_phrase( \+ DCG, InputList, Rest):- nonvar(DCG), !, \+ gm_phrase(DCG, InputList, Rest).
  325gm_phrase(DCG, InputList, Rest):- phrase(DCG, InputList, Rest).
  326
  327
  328
  329set_next_star(State, Left, Goal):-
  330 hashtable_get(State, star_num, StarNum),
  331 hashtable_get(State, star_name, StarName),
  332 atom_concat(StarName, StarNum, StarVar),
  333 hashtable_set(State, StarVar, Left), !,
  334 StarNum2 is StarNum + 1,
  335 with_name_value(State, star_num, StarNum2, Goal).
  336
  337
  338with_name_value(State, Name, Value, Goal):-
  339 hashtable_get(State, Name, Was),
  340 hashtable_set(State, Name, Value),
  341  (Goal 
  342   *-> hashtable_set(State, Name, Was) 
  343    ; (hashtable_set(State, Name, Was), fail)).
  344
  345unbound_get(State, NAME, RequiredValue):- hashtable_get(State, NAME, RequiredValue), \+ is_unbound(RequiredValue).
  346  
  347is_unbound(RequiredValue):- \+ is_list(RequiredValue).
  348 
  349%%REAL-UNUSED set_matchit1(StarName, Pattern, Matcher, OnBind):- length(Pattern, MaxLen0), MaxLen is MaxLen0 + 2, 
  350%%REAL-UNUSED set_matchit2(StarName, Pattern, Matcher, MaxLen, OnBind).
  351
  352match_ci(H,W):- atom(H),atom(W),upcase_atom(H,U),upcase_atom(W,U).
  353
  354req([]) --> [].
  355req([H|T]) --> [W],{match_ci(H,W)},req(T).
  356
  357some([]) --> [].
  358some([H|T]) --> [H],some(T).
  359
  360cd --> [c, d].
  361color --> [red].
  362color --> [blue].
  363color --> [green].
  364
  365
  366star_n(1, '#', 0).
  367star_n(2, '_', 1).
  368% star_n('phrase', 1).
  369% star_n('@', 1).
  370star_n(5,'^', 0).
  371star_n(6,'*', 1).
  372
  373cmp_star(Star, Stuff, NEW):- atom_concat('call_star_',Star,CS), NEW =.. [CS, Star, Stuff].
  374
  375path_expand(_State, call_star(Star,Stuff), NEW, _More):- cmp_star(Star, Stuff, NEW).
  376path_expand(_State, CMP, NEW, _More):- compound(CMP), functor(CMP, Star,1), star_n(_, Star,_), % Star\=='*', 
  377   arg(1, CMP, Stuff), cmp_star(Star,phrase(Stuff,Star,[]), NEW).
  378path_expand(_State, Star, NEW, [OStar| _More]):- star_n(_, Star,_),star_n(_, OStar,_), cmp_star(Star,phrase([_],Star,[]), NEW).
  379path_expand(_State, Star, NEW, _More):- star_n(_, Star,_), cmp_star(Star,phrase(some(_),Star,[]), NEW).
  380path_expand(_State, W, W, _More).
  381
  382% ======================================================================
  383%   TEST EXPANSIONS
  384% ======================================================================
  385
  386add_test_term_expansion( (:- (add_test(G,R), More)), TEST):- 
  387  nonvar(G), TEST = (path_match(G,R), More).
  388  
  389add_test_term_expansion( (:- (add_test(G,R))), TEST):- 
  390  (nonvar(R) 
  391   -> TEST = (path_match(G,R0), dmsg(R0), R0 = R)
  392    ; TEST = (path_match(G,R), dmsg(R))).
  393
  394
  395term_expansion(I,(:- assertz(test_call(TEST)), do_test(TEST))):- 
  396  add_test_term_expansion(I,TEST),!.
  397  
  398do_test(Test):- 
  399  format(user_error, '~N~n',[]),
  400  dmsg("==="),format(user_error, '% TEST: ~q.~n',[Test]),!,
  401  with_output_to(user_error,
  402    ((call(Test)->(ansi_format([fg(green)],'~w~n~n',[pass]),dmsg("==="));(ansi_format([fg(red)],'~w~n~n',[fail]),dmsg("==="),fail)))).
  403
  404% ======================================================================
  405%   TESTS
  406% ======================================================================
  407:- into_graph(_, _).  408
  409%:- rtrace(set_template([a, b1, c], template_a_b1_c, _)).
  410%:- set_template([a, b2, c], template_a_b2_c, _).
  411%:- set_pathprops([a, b, c2, d, e], pattern([a, b, c2, d, e]), _).
  412%:- set_pathprops([a, b, c2, d, e], [a=aaaa, b=bbbb], _).
  413
  414% ======================================================================
  415:- set_template([a, b, c, d, e], abcde, _).  416:- add_test([a, b, c, d, e], abcde).  417
  418% ======================================================================
  419:- set_template([a, b, c2, d, e], abccde, _).  420:- set_template([a, b, c2, d, e], abc2de, _).  421:- add_test([a, b, c2, d, e], abc2de).  422
  423% ======================================================================
  424:- set_template([a, b, *, e], c3_fail(get(star1)), _).  425:- set_template([a, b, '_'], c3_pass(get(star1)), _).  426:- add_test([a, b, c3, d, e], c3_pass([c3, d, e])).  427
  428% ======================================================================
  429:- set_template([a, b2, *, d, e], b2_fail(get(star1)), _).  430:- set_template([a, b2, '_', e], b2_pass(get(star1)), _).  431:- add_test([a, b2, c4, d, e], b2_pass([c4, d])).  432
  433% ======================================================================
  434:- set_template([a, call_star(*, (member(*, [[b3]]))), c, d, e], b3(get(star1)), _).  435:- add_test([a, b3, c, d, e], _).  436
  437% ======================================================================
  438:- set_template([a, {X=1}, b4, c, d, e], b4(X), _).  439:- add_test([a, b4, c, d, e], b4(1)).  440
  441% ======================================================================
  442:- set_template([a, b5, @([c, d]), e], b5, _).  443:- add_test([a, b5, c, d, e], b5).  444
  445% ======================================================================
  446:- set_template([a, b6, @(cd), e], b6, _).  447:- add_test([a, b6, c, d, e], b6).  448
  449% ======================================================================
  450:- set_template([a, b7, '*'(color), d, e], b7(get(star1)), _).  451:- add_test([a, b7, green, d, e],  b7([green])).  452
  453% ======================================================================
  454:- set_template([a, b8, '$'(color), d, e], b8(get(star1), get(color)), _).  455:- add_test([a, b8, red, d, e], b8([red], [red])).  456
  457% ======================================================================
  458:- set_template([a, b9, '$'(color), '$'(color), e], b9(get(star1), get(color)), _).  459:- add_test([a, b9, red, red, e], b9([red], [red])).  460
  461% ======================================================================
  462:- set_template([a, b10, @([c1];[c2]), d, e], b10, _).  463:- add_test([a, b10, c2, d, e], _).  464:- \+ path_match([a, b10, c3, d, e], _).  465
  466% ======================================================================
  467:- set_template([a, b11, '*'([c11]), d, e], b11(get(star1)), _).  468:- add_test([a, b11, c11, d, e], _).  469
  470% ======================================================================
  471:- set_template([a, b12, '*'([c11,c12]), d, e], b12(get(star1)), _).  472:- add_test([a, b12, c11, c12, d, e], _).  473
  474% ======================================================================
  475:- set_template([a, b13, '_'([c11,c12]), d, e], b13_pass(get(star1)), _).  476:- set_template([a, b13, '*'([c11,c12]), d, e], b13_fail(get(star1)), _).  477:- add_test([a, b13, c11, c12, d, e], _).  478
  479% ======================================================================
  480:- set_template([a, b14, *, *, e], b14_pass(get(star1),get(star2)), _).  481:- add_test([a, b14, s1, s2, e], _).  482
  483% ======================================================================
  484%   RUN TESTS
  485% ======================================================================
  486:- show_name_values.  487
  488:- forall(test_call(Test),ignore(do_test(Test))).  489
  490
  491% :- clear_graph(graphmaster).