This commit was generated by cvs2svn to compensate for changes in r4,

which included commits to RCS files with non-trunk default branches.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

CHR/chr/matching.pl

@@ -0,0 +1,102 @@
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%  Constraint Handling Rules			      version 2.2 %
+%								  %
+%  (c) Copyright 1996-98					  %
+%  LMU, Muenchen						  %
+%								  %
+%  File:   matching.pl						  %
+%  Author: Christian Holzbaur		christian@ai.univie.ac.at %
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%
+% Head matching for SICStus
+% ch, Aug. 95
+%
+
+:- module( matching, []).
+
+:- op( 1200, xfx, ?-).
+
+:- use_module( library(assoc),
+	[
+	    empty_assoc/1,
+	    get_assoc/3,
+	    put_assoc/4
+	]).
+
+:- multifile
+	user:term_expansion/2,
+	user:goal_expansion/3.
+
+:- dynamic
+	user:term_expansion/2,
+	user:goal_expansion/3.
+%
+user:term_expansion( ?-(M:H0,B), (M:H1 :- Body)) :- !,
+	functor( H0, N, A),
+	functor( H1, N, A),
+	subs( H0, H1, Code, [B]),
+	l2conj( Code, Body).
+user:term_expansion( ?-(H0,B), (H1 :- Body)) :-
+	functor( H0, N, A),
+	functor( H1, N, A),
+	subs( H0, H1, Code, [B]),
+	l2conj( Code, Body).
+
+%
+user:goal_expansion( inline_matching(Pattern,Datum), _, Exp) :-
+	code( Pattern, Datum, Exp).
+
+code( Pattern, Datum, Code) :-
+	subs( Pattern, Datum, L, []),
+	l2conj( L, Code).
+
+%
+% partial evaluation of subsumes( H0, H1)
+%
+subs( Pattern, Datum, L, Lt) :-
+	empty_assoc( Dict),
+	subs( Pattern, Datum, Dict,_, L, Lt).
+
+subs( Pattern, Datum, D0,D1) --> {var(Pattern)}, !,
+	{var(Datum)},
+	( {get_assoc( Pattern, D0, _),D0=D1} -> % subsequent occ
+	     [ Pattern == Datum ]
+	;					% first occ
+	     {
+		 Pattern = Datum,
+		 put_assoc( Pattern, D0, _, D1)
+	     }
+	).
+subs( Pattern, Datum, D0,D1) --> {var(Datum)}, !,
+	{
+	    functor( Pattern, N, A),
+	    functor( Skel, N, A)
+	},
+	[
+	    nonvar( Datum),
+	    Datum = Skel
+	],
+	subs( 1, A, Pattern, Skel, D0,D1).
+subs( Pattern, Datum, D0,D1) -->
+	{
+	    functor( Pattern, N, A),
+	    functor( Datum, N, A)
+	},
+	subs( 1, A, Pattern, Datum, D0,D1).
+
+subs( N, M, _, _, D0,D0) --> {N>M}, !.
+subs( N, M, G, S, D0,D2) -->
+	{
+	    arg( N, G, Ga),
+	    arg( N, S, Sa),
+	    N1 is N+1
+	},
+	subs( Ga, Sa, D0,D1),
+	subs( N1, M, G, S, D1,D2).
+
+l2conj( [],	true).
+l2conj( [X|Xs], Conj) :-
+  ( Xs = [], Conj = X
+  ; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc)
+  ).