diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
vsc
2001-04-09 19:54:03 +00:00
parent 9a8ee05f1f
commit e5f4633c39
457 changed files with 189536 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

129
library/assoc.yap Normal file
View File

@@ -0,0 +1,129 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
% File : ASSOC.PL
% Author : R.A.O'Keefe
% Updated: 9 November 1983
% Purpose: Binary tree implementation of "association lists".
% Note : the keys should be ground, the associated values need not be.
:- module(assoc, [
assoc_to_list/2,
gen_assoc/3,
get_assoc/3,
get_assoc/5,
list_to_assoc/2,
map_assoc/3,
ord_list_to_assoc/2,
put_assoc/4,
empty_assoc/1
]).
:- meta_predicate map_assoc(:, ?, ?).
/*
:- mode
assoc_to_list(+, -),
assoc_to_list(+, -, +),
gen_assoc(+, ?, ?),
get_assoc(+, +, ?),
get_assoc(+, +, +, +, +, ?),
list_to_assoc(+, -),
list_to_assoc(+, +, -, +),
map_assoc(+, +, -),
put_assoc(+, +, +, -),
put_assoc(+, +, +,+,+,+, +, -).
*/
empty_assoc(t).
assoc_to_list(Assoc, List) :-
assoc_to_list(Assoc, List, []).
assoc_to_list(t(Key,Val,L,R), List, Rest) :-
assoc_to_list(L, List, [Key-Val|More]),
assoc_to_list(R, More, Rest).
assoc_to_list(t, List, List).
gen_assoc(t(_,_,L,_), Key, Val) :-
gen_assoc(L, Key, Val).
gen_assoc(t(Key,Val,_,_), Key, Val).
gen_assoc(t(_,_,_,R), Key, Val) :-
gen_assoc(R, Key, Val).
get_assoc(Key, t(K,V,L,R), Val) :-
compare(Rel, Key, K),
get_assoc(Rel, Key, V, L, R, Val).
get_assoc(=, _, Val, _, _, Val).
get_assoc(<, Key, _, Tree, _, Val) :-
get_assoc(Key, Tree, Val).
get_assoc(>, Key, _, _, Tree, Val) :-
get_assoc(Key, Tree, Val).
get_assoc(Key, t(K,V,L,R), Val, t(K,NV,NL,NR), NVal) :-
compare(Rel, Key, K),
get_assoc(Rel, Key, V, L, R, Val, NV, NL, NR, NVal).
get_assoc(=, _, Val, L, R, Val, NVal, L, R, NVal).
get_assoc(<, Key, V, L, R, Val, V, NL, R, NVal) :-
get_assoc(Key, L, Val, NL, NVal).
get_assoc(>, Key, V, L, R, Val, V, L, NR, NVal) :-
get_assoc(Key, R, Val, NR, NVal).
list_to_assoc(List, Assoc) :-
list_to_assoc(List, t, Assoc).
list_to_assoc([], Assoc, Assoc).
list_to_assoc([Key-Val|List], Assoc0, Assoc) :-
put_assoc(Key, Assoc0, Val, AssocI),
list_to_assoc(List, AssocI, Assoc).
ord_list_to_assoc(Keys, Assoc) :-
list_to_assoc(Keys, Assoc).
/*
length(Keys,L),
list_to_assoc(N, Keys, Assoc, []).
ord_list_to_assoc(0, List, t, List).
ord_list_to_assoc(N, List, t(Key,Val,L,R), Rest) :-
A is (N-1)//2,
Z is (N-1)-A,
ord_list_to_assoc(A, List, L, [Key-Val|More]),
ord_list_to_assoc(Z, More, R, Rest).
*/
map_assoc(Pred, t(Key,Val,L0,R0), t(Key,Ans,L1,R1)) :- !,
map_assoc(Pred, L0, L1),
assoc_apply(Pred, [Val,Ans]),
map_assoc(Pred, R0, R1).
map_assoc(_, t, t).
assoc_apply(Pred,Args) :-
G =.. [Pred,Args],
call(G), !.
put_assoc(Key, t(K,V,L,R), Val, New) :-
compare(Rel, Key, K),
put_assoc(Rel, Key, K, V, L, R, Val, New).
put_assoc(Key, t, Val, t(Key,Val,t,t)).
put_assoc(=, Key, _, _, L, R, Val, t(Key,Val,L,R)).
put_assoc(<, Key, K, V, L, R, Val, t(K,V,Tree,R)) :-
put_assoc(Key, L, Val, Tree).
put_assoc(>, Key, K, V, L, R, Val, t(K,V,L,Tree)) :-
put_assoc(Key, R, Val, Tree).

192
library/atts.yap Normal file
View File

@@ -0,0 +1,192 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: atts.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: attribute support for Prolog *
* *
*************************************************************************/
:- sequential.
:- module(attributes, []).
:- op(1150, fx, attribute).
:- multifile
user:goal_expansion/3.
:- multifile
user:term_expansion/2.
:- dynamic_predicate(existing_attribute/3,logical).
:- dynamic_predicate(modules_with_attributes/1,logical).
:- user_defined_directive(attribute(G), attributes:new_attribute(G)).
modules_with_attributes([]).
user:goal_expansion(get_atts(Var,AccessSpec), Mod, Gs) :- !,
expand_get_attributes(AccessSpec,Mod,Var,[],GL),
convert_to_goals(GL,Gs).
user:goal_expansion(put_atts(Var,AccessSpec), Mod, Gs) :- !,
expand_put_attributes(AccessSpec,Mod,Var,[],GL),
convert_to_goals(GL,Gs).
%
% defining a new attribute is just a question of establishing a
% Functor, Mod -> INT mappings
%
new_attribute(V) :- var(V), !,
throw(error(instantiation_error,attribute(V))).
new_attribute((At1,At2)) :-
new_attribute(At1),
new_attribute(At2).
new_attribute(Na/Ar) :-
source_module(Mod),
functor(S,Na,Ar),
existing_attribute(S,Mod,_) , !.
new_attribute(Na/Ar) :-
source_module(Mod),
inc_n_of_atts(Key),
functor(S,Na,Ar),
store_new_module(Mod),
assertz(existing_attribute(S,Mod,Key)).
store_new_module(Mod) :-
existing_attribute(_,Mod,_), !.
store_new_module(Mod) :-
retract(modules_with_attributes(Mods)),
assertz(modules_with_attributes([Mod|Mods])).
expand_get_attributes(V,Mod,Var,GL0,GL) :- var(V), !,
GL = [attributes:get_atts_at_run_time(Var,V,Mod)|GL0].
expand_get_attributes([],_,_,LG,LG) :- !.
expand_get_attributes([Att|Atts],Mod,Var,L0,LF) :- !,
expand_get_attributes(Att,Mod,Var,L0,L1),
expand_get_attributes(Atts,Mod,Var,L1,LF).
expand_get_attributes(+Att,Mod,Var,L0,LF) :- !,
expand_get_attributes(Att,Mod,Var,L0,LF).
expand_get_attributes(-Att,Mod,Var,L0,[attributes:free_att(Var,Key)|L0]) :- !,
existing_attribute(Att,Mod,Key).
expand_get_attributes(Att,Mod,Var,L0,[attributes:get_att(Var,Key,Att)|L0]) :-
% searching for an attribute
existing_attribute(Att,Mod,Key).
get_atts_at_run_time(Var,Atts,Module) :-
var(Atts), !,
get_all_atts(Var,LAtts),
fetch_interesting_attributes(LAtts, Module, Atts).
get_atts_at_run_time(Var,Atts,Module) :-
expand_get_attributes(Atts,Module,Var,[],GL),
convert_to_goals(GL,Gs),
call(Gs).
fetch_interesting_attributes([], _, []).
fetch_interesting_attributes([[I|Att]|LAtts], Module, Atts) :-
fetch_interesting_attribute(Att, Module, I, Atts, AttsI),
fetch_interesting_attributes(LAtts, Module, AttsI).
%
% only output attributes if they are for the current module.
%
fetch_interesting_attribute(Att, Module, Key, [Att|Atts], Atts) :-
existing_attribute(Att, Module, Key), !.
fetch_interesting_attribute(_, _, _, Atts, Atts).
expand_put_attributes(V,Mod,Var,G0,GF) :- var(V), !,
GF = [attributes:put_atts_at_run_time(Var,V,Mod)|G0].
expand_put_attributes([],_,_,G,G) :- !.
expand_put_attributes([Att|Atts],Mod,Var,G0,GF) :- !,
expand_put_attributes(Att,Mod,Var,G0,GI),
expand_put_attributes(Atts,Mod,Var,GI,GF).
expand_put_attributes(+Att,Mod,Var,G0,GF) :- !,
expand_put_attributes(Att,Mod,Var,G0,GF).
expand_put_attributes(-Att,Mod,Var,G0,[attributes:rm_att(Var,Key)|G0]) :- !,
existing_attribute(Att,Mod,Key).
expand_put_attributes(Att,Mod,Var,G0,[attributes:put_att(Var,Key,Att)|G0]) :-
% searching for an attribute
existing_attribute(Att,Mod,Key).
put_atts_at_run_time(Var,Atts,_) :-
var(Atts), !,
throw(error(instantiation_error,put_atts(Var,Atts))).
put_atts_at_run_time(Var,Atts,Module) :-
expand_put_attributes(Atts,Module,Var,[],GL),
convert_to_goals(GL,Gs),
call(Gs).
woken_att_do(AttVar, Binding) :-
modules_with_attributes(Mods),
do_verify_attributes(Mods, AttVar, Binding, Goals),
bind_attvar(AttVar),
lcall(Goals).
do_verify_attributes([], _, _, []).
do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :-
existing_attribute(_,Mod,Key),
get_att(AttVar,Key,_),
Mod:current_predicate(verify_attributes, verify_attributes(_,_,_)), !,
do_verify_attributes(Mods, AttVar, Binding, Goals),
Mod:verify_attributes(AttVar, Binding, Goal).
do_verify_attributes([_|Mods], AttVar, Binding, Goals) :-
do_verify_attributes(Mods, AttVar, Binding, Goals).
lcall([]).
lcall([Mod:Gls|Goals]) :-
lcall2(Gls,Mod),
lcall(Goals).
lcall2([], _).
lcall2([Goal|Goals], Mod) :-
call(Mod:Goal),
lcall2(Goals, Mod).
convert_att_var(V, Gs) :-
modules_with_attributes(LMods),
fetch_att_goals(LMods,V,Gs0), !,
simplify_trues(Gs0, Gs).
convert_att_var(_, true).
fetch_att_goals([Mod], Att, G1) :-
call_module_attributes(Mod, Att, G1), !.
fetch_att_goals([_], _, true) :- !.
fetch_att_goals([Mod|LMods], Att, (G1,LGoal)) :-
call_module_attributes(Mod, Att, G1), !,
fetch_att_goals(LMods, Att, LGoal).
fetch_att_goals([_|LMods], Att, LGoal) :-
fetch_att_goals(LMods, Att, LGoal).
%
% if there is an active attribute for this module call attribute_goal.
%
call_module_attributes(Mod, AttV, G1) :-
existing_attribute(_,Mod,Key),
get_att(AttV,Key,_), !,
Mod:current_predicate(attribute_goal, attribute_goal(AttV,G1)),
Mod:attribute_goal(AttV, G1).
simplify_trues((A,B), NG) :- !,
simplify_trues(A, NA),
simplify_trues(B, NB),
simplify_true(NA, NB, NG).
simplify_trues(G, G).
simplify_true(true, G, G) :- !.
simplify_true(G, true, G) :- !.
simplify_true(A, B, (A,B)).
convert_to_goals([G],G) :- !.
convert_to_goals([A|G],(A,Gs)) :-
convert_to_goals(G,Gs).

80
library/avl.yap Normal file
View File

@@ -0,0 +1,80 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.yap *
* Last rev: 5/15/2000 *
* mods: *
* comments: AVL trees in YAP (from code by M. van Emden, P. Vasey) *
* *
*************************************************************************/
:- module(avl, [
avl_insert/4,
avl_lookup/3
]).
avl_insert(Key, Value, T0, TF) :-
insert(T0, Key, Value, TF, _).
insert([], Key, Value, avl([],Key,Value,-,[]), yes).
insert(avl(L,Root,RVal,Bl,R), E, Value, NewTree, WhatHasChanged) :-
E @< Root, !,
insert(L, E, Value, NewL, LeftHasChanged),
adjust(avl(NewL,Root,RVal,Bl,R), LeftHasChanged, left, NewTree, WhatHasChanged).
insert(avl(L,Root,RVal,Bl,R), E, Val, NewTree, WhatHasChanged) :-
% E @>= Root, currently we allow duplicated values, although
% lookup will only fetch the first.
insert(R, E, Val,NewR, RightHasChanged),
adjust(avl(L,Root,RVal,Bl,NewR), RightHasChanged, right, NewTree, WhatHasChanged).
adjust(Oldtree, no, _, Oldtree, no).
adjust(avl(L,Root,RVal,Bl,R), yes, Lor, NewTree, WhatHasChanged) :-
table(Bl, Lor, Bl1, WhatHasChanged, ToBeRebalanced),
rebalance(avl(L, Root, RVal, Bl, R), Bl1, ToBeRebalanced, NewTree).
% balance where balance whole tree to be
% before inserted after increased rebalanced
table(- , left , < , yes , no ).
table(- , right , > , yes , no ).
table(< , left , - , no , yes ).
table(< , right , - , no , no ).
table(> , left , - , no , no ).
table(> , right , - , no , yes ).
rebalance(avl(Lst, Root, RVal, _Bl, Rst), Bl1, no, avl(Lst, Root, RVal, Bl1,Rst)).
rebalance(OldTree, _, yes, NewTree) :-
avl_geq(OldTree,NewTree).
avl_geq(avl(Alpha,A,VA,>,avl(Beta,B,VB,>,Gamma)),
avl(avl(Alpha,A,VA,-,Beta),B,VB,-,Gamma)).
avl_geq(avl(avl(Alpha,A,VA,<,Beta),B,VB,<,Gamma),
avl(Alpha,A,VA,-,avl(Beta,B,VB,-,Gamma))).
avl_geq(avl(Alpha,A,VA,>,avl(avl(Beta,X,VX,Bl1,Gamma),B,VB,<,Delta)),
avl(avl(Alpha,A,VA,Bl2,Beta),X,VX,-,avl(Gamma,B,VB,Bl3,Delta))) :-
table2(Bl1,Bl2,Bl3).
avl_geq(avl(avl(Alpha,A,VA,>,avl(Beta,X,VX,Bl1,Gamma)),B,VB,<,Delta),
avl(avl(Alpha,A,VA,Bl2,Beta),X,VX,-,avl(Gamma,B,VB,Bl3,Delta))) :-
table2(Bl1,Bl2,Bl3).
table2(< ,- ,> ).
table2(> ,< ,- ).
table2(- ,- ,- ).
avl_lookup(Key, Value, avl(L,Key0,KVal,_,R)) :-
compare(Cmp, Key, Key0),
avl_lookup(Cmp, Value, L, R, Key, KVal).
avl_lookup(=, Value, _, _, _, Value).
avl_lookup(<, Value, L, _, Key, _) :-
avl_lookup(Key, Value, L).
avl_lookup(>, Value, _, R, Key, _) :-
avl_lookup(Key, Value, R).

120
library/charsio.yap Normal file
View File

@@ -0,0 +1,120 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: charsio.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: I/O on character strings *
* *
*************************************************************************/
:- module(charsio, [
format_to_chars/3,
format_to_chars/4,
write_to_chars/3,
write_to_chars/2,
atom_to_chars/3,
atom_to_chars/2,
number_to_chars/3,
number_to_chars/2,
read_from_chars/2,
open_chars_stream/2,
with_output_to_chars/2,
with_output_to_chars/3,
with_output_to_chars/4
]).
format_to_chars(Form, Args, OUT) :-
format_to_chars(Form, Args, [], OUT).
format_to_chars(Form, Args, L0, OUT) :-
open_mem_write_stream(Stream),
format(Stream,Form,Args),
peek_mem_write_stream(Stream, L0, OUT),
close(Stream).
write_to_chars(Term, OUT) :-
write_to_chars(Term, [], OUT).
write_to_chars(Term, L0, OUT) :-
open_mem_write_stream(Stream),
write(Stream, Term),
peek_mem_write_stream(Stream, L0, OUT),
close(Stream).
atom_to_chars(Atom, OUT) :-
atom_to_chars(Atom, [], OUT).
atom_to_chars(Atom, L0, OUT) :-
var(Atom), !,
throw(error(instantiation_error,atom_to_chars(Atom, L0, OUT))).
atom_to_chars(Atom, L0, OUT) :-
atom(Atom), !,
open_mem_write_stream(Stream),
write(Stream, Atom),
peek_mem_write_stream(Stream, L0, OUT),
close(Stream).
atom_to_chars(Atom, L0, OUT) :-
throw(error(type_error(atom,Atom),atom_to_chars(Atom, L0, OUT))).
number_to_chars(Number, OUT) :-
number_to_chars(Number, [], OUT).
number_to_chars(Number, L0, OUT) :-
var(Number), !,
throw(error(instantiation_error,number_to_chars(Number, L0, OUT))).
number_to_chars(Number, L0, OUT) :-
number(Number), !,
open_mem_write_stream(Stream),
write(Stream, Number),
peek_mem_write_stream(Stream, L0, OUT),
close(Stream).
number_to_chars(Number, L0, OUT) :-
throw(error(type_error(number,Number),number_to_chars(Number, L0, OUT))).
read_from_chars(Chars, Term) :-
open_mem_read_stream(Chars, Stream),
read(Stream, Term),
close(Stream).
open_chars_stream(Chars, Stream) :-
open_mem_read_stream(Chars, Stream).
with_output_to_chars(Goal, Chars) :-
with_output_to_chars(Goal, [], Chars).
with_output_to_chars(Goal, L0, Chars) :-
with_output_to_chars(Goal, Stream, L0, Chars),
close(Stream).
with_output_to_chars(Goal, Stream, L0, Chars) :-
open_mem_write_stream(Stream),
current_output(SO),
set_output(Stream),
do_output_to_chars(Goal, Stream, L0, Chars, SO).
do_output_to_chars(Goal, Stream, L0, Chars, SO) :-
catch(Goal, Exception, handle_exception(Exception,Stream,SO)),
!,
set_output(SO),
peek_mem_write_stream(Stream, L0, Chars).
do_output_to_chars(_Goal, Stream, _L0, _Chars, SO) :-
set_output(SO),
close(Stream),
fail.
handle_exception(Exception, Stream, SO) :-
close(Stream),
current_output(SO),
throw(Exception).

229
library/heaps.yap Normal file
View File

@@ -0,0 +1,229 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
% File : HEAPS.PL
% Author : R.A.O'Keefe
% Updated: 29 November 1983
% Purpose: Implement heaps in Prolog.
/* A heap is a labelled binary tree where the key of each node is less
than or equal to the keys of its sons. The point of a heap is that
we can keep on adding new elements to the heap and we can keep on
taking out the minimum element. If there are N elements total, the
total time is O(NlgN). If you know all the elements in advance, you
are better off doing a merge-sort, but this file is for when you
want to do say a best-first search, and have no idea when you start
how many elements there will be, let alone what they are.
A heap is represented as a triple t(N, Free, Tree) where N is the
number of elements in the tree, Free is a list of integers which
specifies unused positions in the tree, and Tree is a tree made of
t terms for empty subtrees and
t(Key,Datum,Lson,Rson) terms for the rest
The nodes of the tree are notionally numbered like this:
1
2 3
4 6 5 7
8 12 10 14 9 13 11 15
.. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
The idea is that if the maximum number of elements that have been in
the heap so far is M, and the tree currently has K elements, the tree
is some subtreee of the tree of this form having exactly M elements,
and the Free list is a list of K-M integers saying which of the
positions in the M-element tree are currently unoccupied. This free
list is needed to ensure that the cost of passing N elements through
the heap is O(NlgM) instead of O(NlgN). For M say 100 and N say 10^4
this means a factor of two. The cost of the free list is slight.
The storage cost of a heap in a copying Prolog (which Dec-10 Prolog is
not) is 2K+3M words.
*/
:- module(heaps,[
add_to_heap/4, % Heap x Key x Datum -> Heap
get_from_heap/4, % Heap -> Key x Datum x Heap
heap_size/2, % Heap -> Size
heap_to_list/2, % Heap -> List
list_to_heap/2, % List -> Heap
min_of_heap/3, % Heap -> Key x Datum
min_of_heap/5 % Heap -> (Key x Datum) x (Key x Datum)
]).
/*
:- mode
add_to_heap(+, +, +, -),
add_to_heap(+, +, +, +, -),
add_to_heap(+, +, +, +, +, +, -, -),
sort2(+, +, +, +, -, -, -, -),
get_from_heap(+, ?, ?, -),
repair_heap(+, +, +, -),
heap_size(+, ?),
heap_to_list(+, -),
heap_tree_to_list(+, -),
heap_tree_to_list(+, +, -),
list_to_heap(+, -),
list_to_heap(+, +, +, -),
min_of_heap(+, ?, ?),
min_of_heap(+, ?, ?, ?, ?),
min_of_heap(+, +, ?, ?).
*/
% add_to_heap(OldHeap, Key, Datum, NewHeap)
% inserts the new Key-Datum pair into the heap. The insertion is
% not stable, that is, if you insert several pairs with the same
% Key it is not defined which of them will come out first, and it
% is possible for any of them to come out first depending on the
% history of the heap. If you need a stable heap, you could add
% a counter to the heap and include the counter at the time of
% insertion in the key. If the free list is empty, the tree will
% be grown, otherwise one of the empty slots will be re-used. (I
% use imperative programming language, but the heap code is as
% pure as the trees code, you can create any number of variants
% starting from the same heap, and they will share what common
% structure they can without interfering with each other.)
add_to_heap(t(M,[],OldTree), Key, Datum, t(N,[],NewTree)) :- !,
N is M+1,
add_to_heap(N, Key, Datum, OldTree, NewTree).
add_to_heap(t(M,[H|T],OldTree), Key, Datum, t(N,T,NewTree)) :-
N is M+1,
add_to_heap(H, Key, Datum, OldTree, NewTree).
add_to_heap(1, Key, Datum, _, t(Key,Datum,t,t)) :- !.
add_to_heap(N, Key, Datum, t(K1,D1,L1,R1), t(K2,D2,L2,R2)) :-
E is N mod 2,
M is N/2,
% M > 0, % only called from list_to_heap/4,add_to_heap/4
sort2(Key, Datum, K1, D1, K2, D2, K3, D3),
add_to_heap(E, M, K3, D3, L1, R1, L2, R2).
add_to_heap(0, N, Key, Datum, L1, R, L2, R) :- !,
add_to_heap(N, Key, Datum, L1, L2).
add_to_heap(1, N, Key, Datum, L, R1, L, R2) :- !,
add_to_heap(N, Key, Datum, R1, R2).
sort2(Key1, Datum1, Key2, Datum2, Key1, Datum1, Key2, Datum2) :-
Key1 @< Key2,
!.
sort2(Key1, Datum1, Key2, Datum2, Key2, Datum2, Key1, Datum1).
% get_from_heap(OldHeap, Key, Datum, NewHeap)
% returns the Key-Datum pair in OldHeap with the smallest Key, and
% also a New Heap which is the Old Heap with that pair deleted.
% The easy part is picking off the smallest element. The hard part
% is repairing the heap structure. repair_heap/4 takes a pair of
% heaps and returns a new heap built from their elements, and the
% position number of the gap in the new tree. Note that repair_heap
% is *not* tail-recursive.
get_from_heap(t(N,Free,t(Key,Datum,L,R)), Key, Datum, t(M,[Hole|Free],Tree)) :-
M is N-1,
repair_heap(L, R, Tree, Hole).
repair_heap(t(K1,D1,L1,R1), t(K2,D2,L2,R2), t(K2,D2,t(K1,D1,L1,R1),R3), N) :-
K2 @< K1,
!,
repair_heap(L2, R2, R3, M),
N is 2*M+1.
repair_heap(t(K1,D1,L1,R1), t(K2,D2,L2,R2), t(K1,D1,L3,t(K2,D2,L2,R2)), N) :- !,
repair_heap(L1, R1, L3, M),
N is 2*M.
repair_heap(t(K1,D1,L1,R1), t, t(K1,D1,L3,t), N) :- !,
repair_heap(L1, R1, L3, M),
N is 2*M.
repair_heap(t, t(K2,D2,L2,R2), t(K2,D2,t,R3), N) :- !,
repair_heap(L2, R2, R3, M),
N is 2*M+1.
repair_heap(t, t, t, 1) :- !.
% heap_size(Heap, Size)
% reports the number of elements currently in the heap.
heap_size(t(Size,_,_), Size).
% heap_to_list(Heap, List)
% returns the current set of Key-Datum pairs in the Heap as a
% List, sorted into ascending order of Keys. This is included
% simply because I think every data structure foo ought to have
% a foo_to_list and list_to_foo relation (where, of course, it
% makes sense!) so that conversion between arbitrary data
% structures is as easy as possible. This predicate is basically
% just a merge sort, where we can exploit the fact that the tops
% of the subtrees are smaller than their descendants.
heap_to_list(t(_,_,Tree), List) :-
heap_tree_to_list(Tree, List).
heap_tree_to_list(t, []) :- !.
heap_tree_to_list(t(Key,Datum,Lson,Rson), [Key-Datum|Merged]) :-
heap_tree_to_list(Lson, Llist),
heap_tree_to_list(Rson, Rlist),
heap_tree_to_list(Llist, Rlist, Merged).
heap_tree_to_list([H1|T1], [H2|T2], [H2|T3]) :-
H2 @< H1,
!,
heap_tree_to_list([H1|T1], T2, T3).
heap_tree_to_list([H1|T1], T2, [H1|T3]) :- !,
heap_tree_to_list(T1, T2, T3).
heap_tree_to_list([], T, T) :- !.
heap_tree_to_list(T, [], T).
% list_to_heap(List, Heap)
% takes a list of Key-Datum pairs (such as keysort could be used to
% sort) and forms them into a heap. We could do that a wee bit
% faster by keysorting the list and building the tree directly, but
% this algorithm makes it obvious that the result is a heap, and
% could be adapted for use when the ordering predicate is not @<
% and hence keysort is inapplicable.
list_to_heap(List, Heap) :-
list_to_heap(List, 0, t, Heap).
list_to_heap([], N, Tree, t(N,[],Tree)) :- !.
list_to_heap([Key-Datum|Rest], M, OldTree, Heap) :-
N is M+1,
add_to_heap(N, Key, Datum, OldTree, MidTree),
list_to_heap(Rest, N, MidTree, Heap).
% min_of_heap(Heap, Key, Datum)
% returns the Key-Datum pair at the top of the heap (which is of
% course the pair with the smallest Key), but does not remove it
% from the heap. It fails if the heap is empty.
% min_of_heap(Heap, Key1, Datum1, Key2, Datum2)
% returns the smallest (Key1) and second smallest (Key2) pairs in
% the heap, without deleting them. It fails if the heap does not
% have at least two elements.
min_of_heap(t(_,_,t(Key,Datum,_,_)), Key, Datum).
min_of_heap(t(_,_,t(Key1,Datum1,Lson,Rson)), Key1, Datum1, Key2, Datum2) :-
min_of_heap(Lson, Rson, Key2, Datum2).
min_of_heap(t(Ka,Da,_,_), t(Kb,Db,_,_), Kb, Db) :-
Kb @< Ka, !.
min_of_heap(t(Ka,Da,_,_), _, Ka, Da).
min_of_heap(t, t(Kb,Db,_,_), Kb, Db).

269
library/lists.yap Normal file
View File

@@ -0,0 +1,269 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
%
% This file includes code from Bob Welham, Lawrence Byrd, and R. A. O'Keefe.
%
:- module(lists,[append/3,
delete/3,
is_list/1,
last/2,
member/2,
memberchk/2,
nextto/3,
nth/3,
nth/4,
nth0/3,
nth0/4,
permutation/2,
prefix/2,
remove_duplicates/2,
reverse/2,
same_length/2,
select/3,
sublist/2,
substitute/4,
suffix/2,
sumlist/2
]).
% append(Prefix, Suffix, Combined)
% is true when all three arguments are lists, and the members of Combined
% are the members of Prefix followed by the members of Suffix. It may be
% used to form Combined from a given Prefix and Suffix, or to take a given
% Combined apart. E.g. we could define member/2 (from SetUtl.Pl) as
% member(X, L) :- append(_, [X|_], L).
append([], L, L).
append([H|T], L, [H|R]) :-
append(T, L, R).
% delete(List, Elem, Residue)
% is true when List is a list, in which Elem may or may not occur, and
% Residue is a copy of List with all elements identical to Elem deleted.
delete([], _, []).
delete([Head|List], Elem, Residue) :-
Head == Elem, !,
delete(List, Elem, Residue).
delete([Head|List], Elem, [Head|Residue]) :-
delete(List, Elem, Residue).
% is_list(List)
% is true when List is a proper List
%
is_list(L) :- var(L), !, fail.
is_list([]).
is_list([_|List]) :- is_list(List).
% last(List, Last)
% is true when List is a List and Last is identical to its last element.
% This could be defined as last(L, X) :- append(_, [X], L).
last([H|List], Last) :-
last(List, H, Last).
last([], Last, Last).
last([H|List], _, Last) :-
last(List, H, Last).
% member(?Element, ?Set)
% is true when Set is a list, and Element occurs in it. It may be used
% to test for an element or to enumerate all the elements by backtracking.
% Indeed, it may be used to generate the Set!
member(Element, [Element|_]).
member(Element, [_|Rest]) :-
member(Element, Rest).
% memberchk(+Element, +Set)
% means the same thing, but may only be used to test whether a known
% Element occurs in a known Set. In return for this limited use, it
% is more efficient when it is applicable.
memberchk(Element, [Element|_]) :- !.
memberchk(Element, [_|Rest]) :-
memberchk(Element, Rest).
% nextto(X, Y, List)
% is true when X and Y appear side-by-side in List. It could be written as
% nextto(X, Y, List) :- append(_, [X,Y], List).
% It may be used to enumerate successive pairs from the list.
nextto(X,Y, [X,Y|_]).
nextto(X,Y, [_|List]) :-
nextto(X,Y, List).
% nth0(+N, +List, ?Elem) is true when Elem is the Nth member of List,
% counting the first as element 0. (That is, throw away the first
% N elements and unify Elem with the next.) It can only be used to
% select a particular element given the list and index. For that
% task it is more efficient than nmember.
% nth(+N, +List, ?Elem) is the same as nth0, except that it counts from
% 1, that is nth(1, [H|_], H).
nth0(0, [Head|_], Head) :- !.
nth0(N, [_|Tail], Elem) :-
nonvar(N),
M is N-1,
nth0(M, Tail, Elem).
nth0(N,[_|T],Item) :- % Clause added KJ 4-5-87 to allow mode
var(N), % nth0(-,+,+)
nth0(M,T,Item),
N is M + 1.
nth(1, [Head|_], Head) :- !.
nth(N, [_|Tail], Elem) :-
nonvar(N),
M is N-1, % should be succ(M, N)
nth(M, Tail, Elem).
nth(N,[_|T],Item) :- % Clause added KJ 4-5-87 to allow mode
var(N), % nth(-,+,+)
nth(M,T,Item),
N is M + 1.
% nth0(+N, ?List, ?Elem, ?Rest) unifies Elem with the Nth element of List,
% counting from 0, and Rest with the other elements. It can be used
% to select the Nth element of List (yielding Elem and Rest), or to
% insert Elem before the Nth (counting from 1) element of Rest, when
% it yields List, e.g. nth0(2, List, c, [a,b,d,e]) unifies List with
% [a,b,c,d,e]. nth is the same except that it counts from 1. nth
% can be used to insert Elem after the Nth element of Rest.
nth0(0, [Head|Tail], Head, Tail) :- !.
nth0(N, [Head|Tail], Elem, [Head|Rest]) :-
nonvar(N),
M is N-1,
nth0(M, Tail, Elem, Rest).
nth0(N, [Head|Tail], Elem, [Head|Rest]) :- % Clause added KJ 4-5-87
var(N), % to allow mode
nth0(M, Tail, Elem, Rest), % nth0(-,+,+,?).
N is M+1.
nth(1, [Head|Tail], Head, Tail) :- !.
nth(N, [Head|Tail], Elem, [Head|Rest]) :-
nonvar(N),
M is N-1,
nth(M, Tail, Elem, Rest).
nth(N, [Head|Tail], Elem, [Head|Rest]) :- % Clause added KJ 4-5-87
var(N), % to allow mode
nth(M, Tail, Elem, Rest), % nth(-,+,+,?).
N is M+1.
% permutation(List, Perm)
% is true when List and Perm are permutations of each other. Of course,
% if you just want to test that, the best way is to keysort/2 the two
% lists and see if the results are the same. Or you could use list_to_bag
% (from BagUtl.Pl) to see if they convert to the same bag. The point of
% perm is to generate permutations. The arguments may be either way round,
% the only effect will be the order in which the permutations are tried.
% Be careful: this is quite efficient, but the number of permutations of an
% N-element list is N!, even for a 7-element list that is 5040.
permutation([], []).
permutation(List, [First|Perm]) :-
select(First, List, Rest), % tries each List element in turn
permutation(Rest, Perm).
% prefix(Part, Whole) iff Part is a leading substring of Whole
prefix([], _).
prefix([Elem | Rest_of_part], [Elem | Rest_of_whole]) :-
prefix(Rest_of_part, Rest_of_whole).
% remove_dups(List, Pruned)
% removes duplicated elements from List. Beware: if the List has
% non-ground elements, the result may surprise you.
remove_duplicates(List, Pruned) :-
sort(List, Pruned).
% reverse(List, Reversed)
% is true when List and Reversed are lists with the same elements
% but in opposite orders. rev/2 is a synonym for reverse/2.
reverse(List, Reversed) :-
reverse(List, [], Reversed).
reverse([], Reversed, Reversed).
reverse([Head|Tail], Sofar, Reversed) :-
reverse(Tail, [Head|Sofar], Reversed).
% same_length(?List1, ?List2)
% is true when List1 and List2 are both lists and have the same number
% of elements. No relation between the values of their elements is
% implied.
% Modes same_length(-,+) and same_length(+,-) generate either list given
% the other; mode same_length(-,-) generates two lists of the same length,
% in which case the arguments will be bound to lists of length 0, 1, 2, ...
same_length([], []).
same_length([_|List1], [_|List2]) :-
same_length(List1, List2).
% select(?Element, ?Set, ?Residue)
% is true when Set is a list, Element occurs in Set, and Residue is
% everything in Set except Element (things stay in the same order).
select(Element, [Element|Rest], Rest).
select(Element, [Head|Tail], [Head|Rest]) :-
select(Element, Tail, Rest).
% sublist(Sublist, List)
% is true when both append(_,Sublist,S) and append(S,_,List) hold.
sublist(Sublist, List) :-
prefix(Sublist, List).
sublist(Sublist, [_|List]) :-
sublist(Sublist, List).
% substitute(X, XList, Y, YList)
% is true when XList and YList only differ in that the elements X in XList
% are replaced by elements Y in the YList.
substitute(X, XList, Y, YList) :-
'$substitute'(XList, X, Y, YList).
'$substitute'([], _, _, []).
'$substitute'([X0|XList], X, Y, [Y|YList]) :-
X == X0, !,
'$substitute'(XList, X, Y, YList).
'$substitute'([X0|XList], X, Y, [X0|YList]) :-
'$substitute'(XList, X, Y, YList).
% suffix(Suffix, List)
% holds when append(_,Suffix,List) holds.
suffix(Suffix, Suffix).
suffix(Suffix, [_|List]) :-
suffix(Suffix,List).
% sumlist(Numbers, Total)
% is true when Numbers is a list of integers, and Total is their sum.
sumlist(Numbers, Total) :-
sumlist(Numbers, 0, Total).
sumlist([], Total, Total).
sumlist([Head|Tail], Sofar, Total) :-
Next is Sofar+Head,
sumlist(Tail, Next, Total).

331
library/ordsets.yap Normal file
View File

@@ -0,0 +1,331 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
% File : ORDSET.PL
% Author : R.A.O'Keefe
% Updated: 22 May 1983
% Purpose: Ordered set manipulation utilities
% In this module, sets are represented by ordered lists with no
% duplicates. Thus {c,r,a,f,t} would be [a,c,f,r,t]. The ordering
% is defined by the @< family of term comparison predicates, which
% is the ordering used by sort/2 and setof/3.
% The benefit of the ordered representation is that the elementary
% set operations can be done in time proportional to the Sum of the
% argument sizes rather than their Product. Some of the unordered
% set routines, such as member/2, length/2,, select/3 can be used
% unchanged. The main difficulty with the ordered representation is
% remembering to use it!
:- module(ordsets, [
list_to_ord_set/2, % List -> Set
merge/3, % OrdList x OrdList -> OrdList
ord_add_element/3, % Set x Elem -> Set
ord_del_element/3, % Set x Elem -> Set
ord_disjoint/2, % Set x Set ->
ord_insert/3, % Set x Elem -> Set
ord_member/2, % Set -> Elem
ord_intersect/2, % Set x Set ->
ord_intersect/3, % Set x Set -> Set
ord_intersection/3, % Set x Set -> Set
ord_seteq/2, % Set x Set ->
ord_setproduct/3, % Set x Set -> Set
ord_subset/2, % Set x Set ->
ord_subtract/3, % Set x Set -> Set
ord_symdiff/3, % Set x Set -> Set
ord_union/2, % Set^2 -> Set
ord_union/3, % Set x Set -> Set
ord_union/4 % Set x Set -> Set x Set
]).
/*
:- mode
list_to_ord_set(+, ?),
merge(+, +, -),
ord_disjoint(+, +),
ord_disjoint(+, +, +, +, +),
ord_insert(+, +, ?),
ord_insert(+, +, +, +, ?),
ord_intersect(+, +),
ord_intersect(+, +, +, +, +),
ord_intersect(+, +, ?),
ord_intersect(+, +, +, +, +, ?),
ord_seteq(+, +),
ord_subset(+, +),
ord_subset(+, +, +, +, +),
ord_subtract(+, +, ?),
ord_subtract(+, +, +, +, +, ?),
ord_symdiff(+, +, ?),
ord_symdiff(+, +, +, +, +, ?),
ord_union(+, +, ?),
ord_union(+, +, +, +, +, ?).
*/
% list_to_ord_set(+List, ?Set)
% is true when Set is the ordered representation of the set represented
% by the unordered representation List. The only reason for giving it
% a name at all is that you may not have realised that sort/2 could be
% used this way.
list_to_ord_set(List, Set) :-
sort(List, Set).
% merge(+List1, +List2, -Merged)
% is true when Merged is the stable merge of the two given lists.
% If the two lists are not ordered, the merge doesn't mean a great
% deal. Merging is perfectly well defined when the inputs contain
% duplicates, and all copies of an element are preserved in the
% output, e.g. merge("122357", "34568", "12233455678"). Study this
% routine carefully, as it is the basis for all the rest.
merge([Head1|Tail1], [Head2|Tail2], [Head2|Merged]) :-
Head1 @> Head2, !,
merge([Head1|Tail1], Tail2, Merged).
merge([Head1|Tail1], List2, [Head1|Merged]) :-
List2 \== [], !,
merge(Tail1, List2, Merged).
merge([], List2, List2) :- !.
merge(List1, [], List1).
% ord_disjoint(+Set1, +Set2)
% is true when the two ordered sets have no element in common. If the
% arguments are not ordered, I have no idea what happens.
ord_disjoint([], _) :- !.
ord_disjoint(_, []) :- !.
ord_disjoint([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_disjoint(Order, Head1, Tail1, Head2, Tail2).
ord_disjoint(<, _, Tail1, Head2, Tail2) :-
ord_disjoint(Tail1, [Head2|Tail2]).
ord_disjoint(>, Head1, Tail1, _, Tail2) :-
ord_disjoint([Head1|Tail1], Tail2).
% ord_insert(+Set1, +Element, ?Set2)
% ord_add_element(+Set1, +Element, ?Set2)
% is the equivalent of add_element for ordered sets. It should give
% exactly the same result as merge(Set1, [Element], Set2), but a bit
% faster, and certainly more clearly.
ord_add_element([], Element, [Element]).
ord_add_element([Head|Tail], Element, Set) :-
compare(Order, Head, Element),
ord_insert(Order, Head, Tail, Element, Set).
ord_insert([], Element, [Element]).
ord_insert([Head|Tail], Element, Set) :-
compare(Order, Head, Element),
ord_insert(Order, Head, Tail, Element, Set).
ord_insert(<, Head, Tail, Element, [Head|Set]) :-
ord_insert(Tail, Element, Set).
ord_insert(=, Head, Tail, _, [Head|Tail]).
ord_insert(>, Head, Tail, Element, [Element,Head|Tail]).
% ord_intersect(+Set1, +Set2)
% is true when the two ordered sets have at least one element in common.
% Note that the test is == rather than = .
ord_intersect([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_intersect(Order, Head1, Tail1, Head2, Tail2).
ord_intersect(=, _, _, _, _).
ord_intersect(<, _, Tail1, Head2, Tail2) :-
ord_intersect(Tail1, [Head2|Tail2]).
ord_intersect(>, Head1, Tail1, _, Tail2) :-
ord_intersect([Head1|Tail1], Tail2).
ord_intersect(L1, L2, L) :-
ord_intersection(L1, L2, L).
% ord_intersection(+Set1, +Set2, ?Intersection)
% is true when Intersection is the ordered representation of Set1
% and Set2, provided that Set1 and Set2 are ordered sets.
ord_intersection(_, [], []) :- !.
ord_intersection([], _, []) :- !.
ord_intersection([Head1|Tail1], [Head2|Tail2], Intersection) :-
compare(Order, Head1, Head2),
ord_intersection(Order, Head1, Tail1, Head2, Tail2, Intersection).
ord_intersection(=, Head, Tail1, _, Tail2, [Head|Intersection]) :-
ord_intersection(Tail1, Tail2, Intersection).
ord_intersection(<, _, Tail1, Head2, Tail2, Intersection) :-
ord_intersection(Tail1, [Head2|Tail2], Intersection).
ord_intersection(>, Head1, Tail1, _, Tail2, Intersection) :-
ord_intersection([Head1|Tail1], Tail2, Intersection).
% ord_seteq(+Set1, +Set2)
% is true when the two arguments represent the same set. Since they
% are assumed to be ordered representations, they must be identical.
ord_seteq(Set1, Set2) :-
Set1 == Set2.
% ord_subset(+Set1, +Set2)
% is true when every element of the ordered set Set1 appears in the
% ordered set Set2.
ord_subset([], _) :- !.
ord_subset([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_subset(Order, Head1, Tail1, Head2, Tail2).
ord_subset(=, _, Tail1, _, Tail2) :-
ord_subset(Tail1, Tail2).
ord_subset(>, Head1, Tail1, _, Tail2) :-
ord_subset([Head1|Tail1], Tail2).
% ord_subtract(+Set1, +Set2, ?Difference)
% is true when Difference contains all and only the elements of Set1
% which are not also in Set2.
ord_subtract(Set1, [], Set1) :- !.
ord_subtract([], _, []) :- !.
ord_subtract([Head1|Tail1], [Head2|Tail2], Difference) :-
compare(Order, Head1, Head2),
ord_subtract(Order, Head1, Tail1, Head2, Tail2, Difference).
ord_subtract(=, _, Tail1, _, Tail2, Difference) :-
ord_subtract(Tail1, Tail2, Difference).
ord_subtract(<, Head1, Tail1, Head2, Tail2, [Head1|Difference]) :-
ord_subtract(Tail1, [Head2|Tail2], Difference).
ord_subtract(>, Head1, Tail1, _, Tail2, Difference) :-
ord_subtract([Head1|Tail1], Tail2, Difference).
% ord_del_element(+Set1, Element, ?Rest)
% is true when Rest contains the elements of Set1
% except for Set1
ord_del_element([], _, []).
ord_del_element([Head1|Tail1], Head2, Rest) :-
compare(Order, Head1, Head2),
ord_del_element(Order, Head1, Tail1, Head2, Rest).
ord_del_element(=, _, Tail1, _, Tail1).
ord_del_element(<, Head1, Tail1, Head2, [Head1|Difference]) :-
ord_del_element(Tail1, Head2, Difference).
ord_del_element(>, _, Tail1, _, Tail1).
% ord_symdiff(+Set1, +Set2, ?Difference)
% is true when Difference is the symmetric difference of Set1 and Set2.
ord_symdiff(Set1, [], Set1) :- !.
ord_symdiff([], Set2, Set2) :- !.
ord_symdiff([Head1|Tail1], [Head2|Tail2], Difference) :-
compare(Order, Head1, Head2),
ord_symdiff(Order, Head1, Tail1, Head2, Tail2, Difference).
ord_symdiff(=, _, Tail1, _, Tail2, Difference) :-
ord_symdiff(Tail1, Tail2, Difference).
ord_symdiff(<, Head1, Tail1, Head2, Tail2, [Head1|Difference]) :-
ord_symdiff(Tail1, [Head2|Tail2], Difference).
ord_symdiff(>, Head1, Tail1, Head2, Tail2, [Head2|Difference]) :-
ord_symdiff([Head1|Tail1], Tail2, Difference).
% ord_union(+Set1, +Set2, ?Union)
% is true when Union is the union of Set1 and Set2. Note that when
% something occurs in both sets, we want to retain only one copy.
ord_union(Set1, [], Set1) :- !.
ord_union([], Set2, Set2) :- !.
ord_union([Head1|Tail1], [Head2|Tail2], Union) :-
compare(Order, Head1, Head2),
ord_union(Order, Head1, Tail1, Head2, Tail2, Union).
ord_union(=, Head, Tail1, _, Tail2, [Head|Union]) :-
ord_union(Tail1, Tail2, Union).
ord_union(<, Head1, Tail1, Head2, Tail2, [Head1|Union]) :-
ord_union(Tail1, [Head2|Tail2], Union).
ord_union(>, Head1, Tail1, Head2, Tail2, [Head2|Union]) :-
ord_union([Head1|Tail1], Tail2, Union).
% ord_union(+Set1, +Set2, ?Union, ?Difference)
% is true when Union is the union of Set1 and Set2 and Difference is the
% difference between Set2 and Set1.
ord_union(Set1, [], Set1, []) :- !.
ord_union([], Set2, Set2, Set2) :- !.
ord_union([Head1|Tail1], [Head2|Tail2], Union, Diff) :-
compare(Order, Head1, Head2),
ord_union(Order, Head1, Tail1, Head2, Tail2, Union, Diff).
ord_union(=, Head, Tail1, _, Tail2, [Head|Union], Diff) :-
ord_union(Tail1, Tail2, Union, Diff).
ord_union(<, Head1, Tail1, Head2, Tail2, [Head1|Union], Diff) :-
ord_union(Tail1, [Head2|Tail2], Union, Diff).
ord_union(>, Head1, Tail1, Head2, Tail2, [Head2|Union], [Head2|Diff]) :-
ord_union([Head1|Tail1], Tail2, Union, Diff).
% ord_setproduct(+Set1, +Set2, ?Product)
% is in fact identical to setproduct(Set1, Set2, Product).
% If Set1 and Set2 are ordered sets, Product will be an ordered
% set of x1-x2 pairs. Note that we cannot solve for Set1 and
% Set2, because there are infinitely many solutions when
% Product is empty, and may be a large number in other cases.
ord_setproduct([], _, []).
ord_setproduct([H|T], L, Product) :-
ord_setproduct(L, H, Product, Rest),
ord_setproduct(T, L, Rest).
ord_setproduct([], _, L, L).
ord_setproduct([H|T], X, [X-H|TX], TL) :-
ord_setproduct(T, X, TX, TL).
ord_member(El,[H|T]):-
compare(Op,El,H),
ord_member(Op,El,T).
ord_member(=,_,_).
ord_member(>,El,[H|T]) :-
compare(Op,El,H),
ord_member(Op,El,T).
ord_union([], []).
ord_union([Set|Sets], Union) :-
length([Set|Sets], NumberOfSets),
merge_all(NumberOfSets, [Set|Sets], Union, []).
merge_all(N,Sets0,Union,Sets) :-
( N=:=1 -> Sets0=[Union|Sets]
; N=:=2 -> Sets0=[Set1,Set2|Sets],
merge(Set1,Set2,Union)
; A is N>>1,
Z is N-A,
merge_all(A, Sets0, X, Sets1),
merge_all(Z, Sets1, Y, Sets),
merge(X, Y, Union)
).

98
library/prandom.yap Normal file
View File

@@ -0,0 +1,98 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.yap *
* Last rev: 5/15/2000 *
* mods: *
* comments: pseudo random numbers in YAP (from code by Van Gelder) *
* *
*************************************************************************/
% The following code produces the same random numbers as my previous
% ranpkg.pl, but is more accurately documented and slightly more
% efficient.
% ranpkg.pl random number package Allen Van Gelder, Stanford
% rannum produces a random non-negative integer whose low bits are not
% all that random, so it should be scaled to a smaller range in general.
% The integer is in the range 0 .. 2^(w-1) - 1,
% where w is the word size available for integers, e.g., 18 for DEC-10,
% and 16 or 32 for VAX and most IBM.
%
% ranunif produces a uniformly distributed non-negative random integer over
% a caller-specified range. If range is R, the result is in 0 .. R-1.
%
% ranstart must be called before the first use of rannum or ranunif,
% and may be called later to redefine the seed.
% ranstart/0 causes a built-in seed to be used.
% ranstart(N), N an integer, varies this, but the same N always
% produces the same sequence of numbers.
%
% According to my reading of Knuth, Vol. 2, this generator has period
% 2^(w-1) and potency w/2, i.e., 8, 9, or 16 in practice. Knuth says
% potency should be at least 5, so this looks more than adequate.
% Its drawback is the lack of randomness of low-order bits.
:- module(prandom, [
ranstart/0,
ranstart/1,
rannum/1,
rannunif/2]).
:- initialization(ranstart).
%
% vsc: dangerous code, to change.
%
%
wsize(32) :-
yap_flag(max_integer,2147483647), !.
wsize(64).
ranstart :- ranstart(8'365).
ranstart(N) :-
wsize(32), % bits available for int.
MaxInt is \(1 << (Wsize - 1)), % all bits but sign bit are 1.
Incr is (8'154 << (Wsize - 9)) + 1, % per Knuth, v.2 p.78
Mult is 8'3655, % OK for 16-18 Wsize
Prev is Mult * (8 * N + 5) + Incr,
recorda(ranState, ranState(Mult, Prev, Wsize, MaxInt, Incr), Ref).
rannum(Raw) :-
recorded(ranState, ranState(Mult, Prev, Wsize, MaxInt, Incr), Oldref),
erase(Oldref),
Curr is Mult * Prev + Incr,
recorda(ranState, ranState(Mult, Curr, Wsize, MaxInt, Incr), Ref),
( Curr > 0,
Raw is Curr
;
Curr < 0,
Raw is Curr /\ MaxInt % force positive sign bit
).
ranunif(Range, Unif) :-
Range > 0,
recorded(ranState, ranState(Mult, Prev, Wsize, MaxInt, Incr), Oldref),
erase(Oldref),
Curr is Mult * Prev + Incr,
recorda(ranState, ranState(Mult, Curr, Wsize, MaxInt, Incr), Ref),
( Curr > 0,
Raw is Curr
;
Curr < 0,
Raw is Curr /\ MaxInt % force positive sign bit
),
Unif is (Raw * Range) >> (Wsize-1).

187
library/queues.yap Normal file
View File

@@ -0,0 +1,187 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
% File : QUEUES.PL
% Author : R.A.O'Keefe
% Updated: Friday November 18th, 1983, 8:09:31 pm
% Purpose: define queue operations
% Needs : lib(lists) for append/3.
:- module(queues, [
make_queue/1, % create empty queue
join_queue/3, % add element to end of queue
list_join_queue/3, % add many elements to end of queue
jump_queue/3, % add element to front of queue
list_jump_queue/3, % add many elements to front of queue
head_queue/2, % look at first element of queue
serve_queue/3, % remove first element of queue
length_queue/2, % count elements of queue
empty_queue/1, % test whether queue is empty
list_to_queue/2, % convert list to queue
queue_to_list/2 % convert queue to list
]).
:- use_module(library(lists), [append/3]).
/*
:- mode
make_queue(-),
join_queue(+, +, -),
list_join_queue(+, +, -),
jump_queue(+, +, -),
list_jump_queue(+, +, -),
head_queue(+, ?),
serve_queue(+, ?, -),
length_queue(+, ?),
length_queue(+, +, +, -),
empty_queue(+),
list_to_queue(+, -),
queue_to_list(+, -),
queue_to_list(+, +, -).
*/
/* In this package, a queue is represented as a term Front-Back, where
Front is a list and Back is a tail of that list, and is normally a
variable. join_queue will only work when the Back is a variable,
the other routines will accept any tail. The elements of the queue
are the list difference, that is, all the elements starting at Front
and stopping at Back. Examples:
[a,b,c,d,e|Z]-Z has elements a,b,c,d,e
[a,b,c,d,e]-[d,e] has elements a,b,c
Z-Z has no elements
[1,2,3]-[1,2,3] has no elements
*/
% make_queue(Queue)
% creates a new empty queue. It will also match empty queues, but
% because Prolog doesn't do the occurs check, it will also match
% other queues, creating circular lists. So this should ONLY be
% used to make new queues.
make_queue(X-X).
% join_queue(Element, OldQueue, NewQueue)
% adds the new element at the end of the queue. The old queue is
% side-effected, so you *can't* do
% join_queue(1, OldQ, NewQ1),
% join_queue(2, OldQ, NewQ2).
% There isn't any easy way of doing that, sensible though it might
% be. You *can* do
% join_queue(1, OldQ, MidQ),
% join_queue(2, MidQ, NewQ).
% See list_join_queue.
join_queue(Element, Front-[Element|Back], Front-Back).
% list_join_queue(List, OldQueue, NewQueue)
% adds the new elements at the end of the queue. The elements are
% added in the same order that they appear in the list, e.g.
% list_join_queue([y,z], [a,b,c|M]-M, [a,b,c,y,z|N]-N).
list_join_queue(List, Front-OldBack, Front-NewBack) :-
append(List, OldBack, NewBack).
% jump_queue(Element, OldQueue, NewQueue)
% adds the new element at the front of the list. Unlike join_queue,
% jump_queue(1, OldQ, NewQ1),
% jump_queue(2, OldQ, NewQ2)
% *does* work, though if you add things at the end of NewQ1 they
% will also show up in NewQ2. Note that
% jump_queue(1, OldQ, MidQ),
% jump_queue(2, MidQ, NewQ)
% makes NewQ start 2, 1, ...
jump_queue(Element, Front-Back, [Element|Front]-Back).
% list_jump_queue(List, OldQueue, NewQueue)
% adds all the elements of List at the front of the queue. There are
% two ways we might do this. We could add all the elements one at a
% time, so that they would appear at the beginning of the queue in the
% opposite order to the order they had in the list, or we could add
% them in one lump, so that they have the same order in the queue as
% in the list. As you can easily add the elements one at a time if
% that is what you want, I have chosen the latter.
list_jump_queue(List, OldFront-Back, NewFront-Back) :-
append(List, OldFront, NewFront).
% reverse(List, OldFront, NewFront). % for the other definition
% head_queue(Queue, Head)
% unifies Head with the first element of the queue. The tricky part
% is that we might be at the end of a queue: Back-Back, with Back a
% variable, and in that case this predicate should not succeed, as we
% don't know what that element is or whether it exists yet.
head_queue(Front-Back, Head) :-
Front \== Back, % the queue is not empty
Front = [Head|_].
% serve_queue(OldQueue, Head, NewQueue)
% removes the first element of the queue for service.
serve_queue(OldFront-Back, Head, NewFront-Back) :-
OldFront \== Back,
OldFront = [Head|NewFront].
% empty_queue(Queue)
% tests whether the queue is empty. If the back of a queue were
% guaranteed to be a variable, we could have
% empty_queue(Front-Back) :- var(Front).
% but I don't see why you shouldn't be able to treat difference
% lists as queues if you want to.
empty_queue(Front-Back) :-
Front == Back.
% length_queue(Queue, Length)
% counts the number of elements currently in the queue. Note that
% we have to be careful in checking for the end of the list, we
% can't test for [] the way length(List) does.
length_queue(Front-Back, Length) :-
length_queue(Front, Back, 0, N),
Length = N.
length_queue(Front, Back, N, N) :-
Front == Back, !.
length_queue([_|Front], Back, K, N) :-
L is K+1,
length_queue(Front, Back, L, N).
% list_to_queue(List, Queue)
% creates a new queue with the same elements as List.
list_to_queue(List, Front-Back) :-
append(List, Back, Front).
% queue_to_list(Queue, List)
% creates a new list with the same elements as Queue.
queue_to_list(Front-Back, List) :-
queue_to_list(Front, Back, List).
queue_to_list(Front, Back, Ans) :-
Front == Back, !, Ans = [].
queue_to_list([Head|Front], Back, [Head|Tail]) :-
queue_to_list(Front, Back, Tail).

102
library/random.yap Normal file
View File

@@ -0,0 +1,102 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: random.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: Random operations *
* *
*************************************************************************/
:- module(random, [
random/1,
random/3,
randseq/3,
randset/3,
getrand/1,
setrand/1
]).
random(X) :- X is random.
random(X, LOW, UPPER) :- integer(LOW), integer(UPPER), !,
X is integer(random*(UPPER-LOW))+LOW.
random(X, LOW, UPPER) :-
X is random*(UPPER-LOW)+LOW.
randseq(L, M, Rs) :-
integer(L),
L > 0,
integer(M),
M > 0,
M > L,
randseq(L, M, [], Rs).
randseq(0, _, Rs, Rs) :- !.
randseq(K, N, Set, Rs) :-
X is integer(random*N),
not_in(Set, X), !,
K1 is K-1,
randseq(K1, N, [X|Set], Rs).
randseq(K, N, Set, Rs) :-
randseq(K, N, Set, Rs).
not_in([], _).
not_in([X|L], Y) :- X \= Y,
not_in(L, Y).
randset(L, M, Rs) :-
integer(L),
L > 0,
integer(M),
M > 0,
M > L,
randset(L, M, [], Rs).
randset(0, _, Rs, Rs) :- !.
randset(K, N, Set, Rs) :-
X is integer(random*N),
addnew(Set, X, NSet), !,
K1 is K-1,
randset(K1, N, NSet, Rs).
randset(K, N, Set, Rs) :-
randset(K, N, Set, Rs).
addnew([], Y, [Y]).
addnew([X|L], Y, [Y,X|L]) :- X > Y, !.
addnew([X|L], Y, [X|NSet]) :-
X < Y,
addnew(L, Y, NSet).
getrand(rand(X,Y,Z)) :-
srandom(Seed0),
Seed is abs(Seed0),
X is Seed mod 30269,
Seed1 is Seed // 30269,
Y is Seed1 mod 30307,
Seed2 is Seed1 // 30307,
Z is Seed2 mod 30323.
setrand(rand(X,Y,Z)) :-
integer(X),
X > 1,
X < 30269,
integer(Y),
Y > 1,
Y < 30307,
integer(Z),
Z > 1,
Z < 30323,
Seed is X + 30269*(Y + 30307*Z),
srandom(Seed).

56
library/regex/COPYRIGHT Normal file
View File

@@ -0,0 +1,56 @@
Copyright 1992, 1993, 1994 Henry Spencer. All rights reserved.
This software is not subject to any license of the American Telephone
and Telegraph Company or of the Regents of the University of California.
Permission is granted to anyone to use this software for any purpose on
any computer system, and to alter it and redistribute it, subject
to the following restrictions:
1. The author is not responsible for the consequences of use of this
software, no matter how awful, even if they arise from flaws in it.
2. The origin of this software must not be misrepresented, either by
explicit claim or by omission. Since few users ever read sources,
credits must appear in the documentation.
3. Altered versions must be plainly marked as such, and must not be
misrepresented as being the original software. Since few users
ever read sources, credits must appear in the documentation.
4. This notice may not be removed or altered.
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
/*-
* Copyright (c) 1994
* The Regents of the University of California. All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)COPYRIGHT 8.1 (Berkeley) 3/16/94
*/

112
library/regex/Makefile.in Normal file
View File

@@ -0,0 +1,112 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
#
CC=@CC@
CFLAGS= @CFLAGS@ $(YAP_EXTRAS) $(DEFS) -I$(srcdir) -I../.. -I$(srcdir)/../../include
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
SHELL=/bin/sh
RANLIB=@RANLIB@
srcdir=@srcdir@
SHLIB_CFLAGS=@SHLIB_CFLAGS@
SHLIB_SUFFIX=@SHLIB_SUFFIX@
#4.1VPATH=@srcdir@:@srcdir@/OPTYap
CWD=$(PWD)
#
OBJS=regexp.o regcomp.o regexec.o regerror.o regfree.o
SOBJS=regexp@SHLIB_SUFFIX@ regcomp@SHLIB_SUFFIX@ regexec@SHLIB_SUFFIX@ regerror@SHLIB_SUFFIX@ regfree@SHLIB_SUFFIX@
#in some systems we just create a single object, in others we need to
# create a libray
all: @NEWSHOBJ@
sobjs: $(SOBJS)
dll: regexp@SHLIB_SUFFIX@
regexp.o: $(srcdir)/regexp.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/regexp.c -o regexp.o
regcomp.o: $(srcdir)/regcomp.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/regcomp.c -o regcomp.o
regerror.o: $(srcdir)/regerror.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/regerror.c -o regerror.o
regfree.o: $(srcdir)/regfree.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/regfree.c -o regfree.o
regexec.o: $(srcdir)/regexec.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/regexec.c -o regexec.o
%.so: %.o
@SHLIB_LD@ -o $@ $<
regexp.so: regexp.o
@SHLIB_LD@ -o regexp.so regexp.o
regcomp.so: regcomp.o
@SHLIB_LD@ -o regcomp.so regcomp.o
regerror.so: regerror.o
@SHLIB_LD@ -o regerror.so regerror.o
regfree.so: regfree.o
@SHLIB_LD@ -o regfree.so regfree.o
regexec.so: regexec.o
@SHLIB_LD@ -o regexec.so regexec.o
#
# create a new DLL library on cygwin environments
#
# DLLNAME: name of the new dll
# OBJS: list of object files I want to put in
# LIBS: list of libraries to link with
# DEFFILE is the name of the definitions file.
# BASEFILE temporary
# EXPFILE temporary
# ENTRY is the entry point int WINAPI startup (HINSTANCE, DWORD, LPVOID)
#
DLLTOOL=dlltool
DLLNAME=regexp.dll
DLL_LIBS=-lcrtdll -L../.. -lWYap
BASE_FILE=regexp.base
EXP_FILE=regexp.exp
DEF_FILE=$(srcdir)/regexp.def
ENTRY_FUNCTION=_win_regexp@12
#
regexp.dll: $(OBJS)
$(LD) -s --base-file $(BASE_FILE) --dll -o $(DLLNAME) $(OBJS) $(DLL_LIBS) -e $(ENTRY_FUNCTION)
$(DLLTOOL) --as=$(AS) --dllname $(DLLNAME) --def $(DEF_FILE) --base-file $(BASE_FILE) --output-exp $(EXP_FILE)
$(LD) -s --base-file $(BASE_FILE) $(EXP_FILE) -dll -o $(DLLNAME) $(OBJS) $(DLL_LIBS) -e $(ENTRY_FUNCTION)
$(DLLTOOL) --as=$(AS) --dllname $(DLLNAME) --def $(DEF_FILE) --base-file $(BASE_FILE) --output-exp $(EXP_FILE)
$(LD) $(EXP_FILE) --dll -o $(DLLNAME) $(OBJS) $(DLL_LIBS) -e $(ENTRY_FUNCTION)
install: all
$(INSTALL_PROGRAM) $(SOBJS) $(LIBDIR)
install_mingw32: dll
$(INSTALL_PROGRAM) -m 755 regexp.dll $(LIBDIR)/regexp.dll
clean:
rm -f *.o *.so *~ $(OBJS) *.BAK

94
library/regex/WHATSNEW Normal file
View File

@@ -0,0 +1,94 @@
# @(#)WHATSNEW 8.3 (Berkeley) 3/18/94
New in alpha3.4: The complex bug alluded to below has been fixed (in a
slightly kludgey temporary way that may hurt efficiency a bit; this is
another "get it out the door for 4.4" release). The tests at the end of
the tests file have accordingly been uncommented. The primary sign of
the bug was that something like a?b matching ab matched b rather than ab.
(The bug was essentially specific to this exact situation, else it would
have shown up earlier.)
New in alpha3.3: The definition of word boundaries has been altered
slightly, to more closely match the usual programming notion that "_"
is an alphabetic. Stuff used for pre-ANSI systems is now in a subdir,
and the makefile no longer alludes to it in mysterious ways. The
makefile has generally been cleaned up some. Fixes have been made
(again!) so that the regression test will run without -DREDEBUG, at
the cost of weaker checking. A workaround for a bug in some folks'
<assert.h> has been added. And some more things have been added to
tests, including a couple right at the end which are commented out
because the code currently flunks them (complex bug; fix coming).
Plus the usual minor cleanup.
New in alpha3.2: Assorted bits of cleanup and portability improvement
(the development base is now a BSDI system using GCC instead of an ancient
Sun system, and the newer compiler exposed some glitches). Fix for a
serious bug that affected REs using many [] (including REG_ICASE REs
because of the way they are implemented), *sometimes*, depending on
memory-allocation patterns. The header-file prototypes no longer name
the parameters, avoiding possible name conflicts. The possibility that
some clot has defined CHAR_MIN as (say) `-128' instead of `(-128)' is
now handled gracefully. "uchar" is no longer used as an internal type
name (too many people have the same idea). Still the same old lousy
performance, alas.
New in alpha3.1: Basically nothing, this release is just a bookkeeping
convenience. Stay tuned.
New in alpha3.0: Performance is no better, alas, but some fixes have been
made and some functionality has been added. (This is basically the "get
it out the door in time for 4.4" release.) One bug fix: regfree() didn't
free the main internal structure (how embarrassing). It is now possible
to put NULs in either the RE or the target string, using (resp.) a new
REG_PEND flag and the old REG_STARTEND flag. The REG_NOSPEC flag to
regcomp() makes all characters ordinary, so you can match a literal
string easily (this will become more useful when performance improves!).
There are now primitives to match beginnings and ends of words, although
the syntax is disgusting and so is the implementation. The REG_ATOI
debugging interface has changed a bit. And there has been considerable
internal cleanup of various kinds.
New in alpha2.3: Split change list out of README, and moved flags notes
into Makefile. Macro-ized the name of regex(7) in regex(3), since it has
to change for 4.4BSD. Cleanup work in engine.c, and some new regression
tests to catch tricky cases thereof.
New in alpha2.2: Out-of-date manpages updated. Regerror() acquires two
small extensions -- REG_ITOA and REG_ATOI -- which avoid debugging kludges
in my own test program and might be useful to others for similar purposes.
The regression test will now compile (and run) without REDEBUG. The
BRE \$ bug is fixed. Most uses of "uchar" are gone; it's all chars now.
Char/uchar parameters are now written int/unsigned, to avoid possible
portability problems with unpromoted parameters. Some unsigned casts have
been introduced to minimize portability problems with shifting into sign
bits.
New in alpha2.1: Lots of little stuff, cleanup and fixes. The one big
thing is that regex.h is now generated, using mkh, rather than being
supplied in the distribution; due to circularities in dependencies,
you have to build regex.h explicitly by "make h". The two known bugs
have been fixed (and the regression test now checks for them), as has a
problem with assertions not being suppressed in the absence of REDEBUG.
No performance work yet.
New in alpha2: Backslash-anything is an ordinary character, not an
error (except, of course, for the handful of backslashed metacharacters
in BREs), which should reduce script breakage. The regression test
checks *where* null strings are supposed to match, and has generally
been tightened up somewhat. Small bug fixes in parameter passing (not
harmful, but technically errors) and some other areas. Debugging
invoked by defining REDEBUG rather than not defining NDEBUG.
New in alpha+3: full prototyping for internal routines, using a little
helper program, mkh, which extracts prototypes given in stylized comments.
More minor cleanup. Buglet fix: it's CHAR_BIT, not CHAR_BITS. Simple
pre-screening of input when a literal string is known to be part of the
RE; this does wonders for performance.
New in alpha+2: minor bits of cleanup. Notably, the number "32" for the
word width isn't hardwired into regexec.c any more, the public header
file prototypes the functions if __STDC__ is defined, and some small typos
in the manpages have been fixed.
New in alpha+1: improvements to the manual pages, and an important
extension, the REG_STARTEND option to regexec().

62
library/regex/cclass.h Normal file
View File

@@ -0,0 +1,62 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)cclass.h 8.3 (Berkeley) 3/20/94
*/
typedef enum {CALNUM, CALPHA, CBLANK, CCNTRL, CDIGIT, CGRAPH,
CLOWER, CPRINT, CPUNCT, CSPACE, CUPPER, CXDIGIT} citype;
/* character-class table */
static struct cclass {
char *name;
citype fidx;
} cclasses[] = {
{"alnum", CALNUM},
{"alpha", CALPHA},
{"blank", CBLANK},
{"cntrl", CCNTRL},
{"digit", CDIGIT},
{"graph", CGRAPH},
{"lower", CLOWER},
{"print", CPRINT},
{"punct", CPUNCT},
{"space", CSPACE},
{"upper", CUPPER},
{"xdigit", CXDIGIT},
{NULL, }
};

141
library/regex/cname.h Normal file
View File

@@ -0,0 +1,141 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)cname.h 8.3 (Berkeley) 3/20/94
*/
/* character-name table */
static struct cname {
char *name;
char code;
} cnames[] = {
{"NUL", '\0'},
{"SOH", '\001'},
{"STX", '\002'},
{"ETX", '\003'},
{"EOT", '\004'},
{"ENQ", '\005'},
{"ACK", '\006'},
{"BEL", '\007'},
{"alert", '\007'},
{"BS", '\010'},
{"backspace", '\b'},
{"HT", '\011'},
{"tab", '\t'},
{"LF", '\012'},
{"newline", '\n'},
{"VT", '\013'},
{"vertical-tab", '\v'},
{"FF", '\014'},
{"form-feed", '\f'},
{"CR", '\015'},
{"carriage-return", '\r'},
{"SO", '\016'},
{"SI", '\017'},
{"DLE", '\020'},
{"DC1", '\021'},
{"DC2", '\022'},
{"DC3", '\023'},
{"DC4", '\024'},
{"NAK", '\025'},
{"SYN", '\026'},
{"ETB", '\027'},
{"CAN", '\030'},
{"EM", '\031'},
{"SUB", '\032'},
{"ESC", '\033'},
{"IS4", '\034'},
{"FS", '\034'},
{"IS3", '\035'},
{"GS", '\035'},
{"IS2", '\036'},
{"RS", '\036'},
{"IS1", '\037'},
{"US", '\037'},
{"space", ' '},
{"exclamation-mark", '!'},
{"quotation-mark", '"'},
{"number-sign", '#'},
{"dollar-sign", '$'},
{"percent-sign", '%'},
{"ampersand", '&'},
{"apostrophe", '\''},
{"left-parenthesis", '('},
{"right-parenthesis", ')'},
{"asterisk", '*'},
{"plus-sign", '+'},
{"comma", ','},
{"hyphen", '-'},
{"hyphen-minus", '-'},
{"period", '.'},
{"full-stop", '.'},
{"slash", '/'},
{"solidus", '/'},
{"zero", '0'},
{"one", '1'},
{"two", '2'},
{"three", '3'},
{"four", '4'},
{"five", '5'},
{"six", '6'},
{"seven", '7'},
{"eight", '8'},
{"nine", '9'},
{"colon", ':'},
{"semicolon", ';'},
{"less-than-sign", '<'},
{"equals-sign", '='},
{"greater-than-sign", '>'},
{"question-mark", '?'},
{"commercial-at", '@'},
{"left-square-bracket", '['},
{"backslash", '\\'},
{"reverse-solidus", '\\'},
{"right-square-bracket",']'},
{"circumflex", '^'},
{"circumflex-accent", '^'},
{"underscore", '_'},
{"low-line", '_'},
{"grave-accent", '`'},
{"left-brace", '{'},
{"left-curly-bracket", '{'},
{"vertical-line", '|'},
{"right-brace", '}'},
{"right-curly-bracket", '}'},
{"tilde", '~'},
{"DEL", '\177'},
{NULL, 0}
};

48
library/regex/collate.h Normal file
View File

@@ -0,0 +1,48 @@
/*-
* Copyright (c) 1995 Alex Tatmanjants <alex@elvisti.kiev.ua>
* at Electronni Visti IA, Kiev, Ukraine.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* $FreeBSD: src/lib/libc/locale/collate.h,v 1.9 1999/09/12 21:15:14 dt Exp $
*/
#ifndef COLLATE_H_INCLUDED
#define COLLATE_H_INCLUDED
#include <sys/types.h>
#include <limits.h>
#define STR_LEN 10
#define TABLE_SIZE 100
#define COLLATE_VERSION "1.0\n"
struct collate_st_char_pri {
int prim, sec;
};
struct collate_st_chain_pri {
unsigned char str[STR_LEN];
int prim, sec;
};
#endif /* not COLLATE_H_INCLUDED */

1092
library/regex/engine.c Normal file
View File

File diff suppressed because it is too large Load Diff

1837
library/regex/regcomp.c Normal file
View File

File diff suppressed because it is too large Load Diff

174
library/regex/regerror.c Normal file
View File

@@ -0,0 +1,174 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)regerror.c 8.4 (Berkeley) 3/20/94
*/
#if defined(LIBC_SCCS) && !defined(lint)
static char sccsid[] = "@(#)regerror.c 8.4 (Berkeley) 3/20/94";
#endif /* LIBC_SCCS and not lint */
#include <sys/types.h>
#include <stdio.h>
#include <string.h>
#include <limits.h>
#include <stdlib.h>
#include "c_interface.h"
#include "yapregex.h"
#include "utils.h"
/* ========= begin header generated by ./mkh ========= */
#ifdef __cplusplus
extern "C" {
#endif
/* === regerror.c === */
static char * PROTO(regatoi, (const regex_t *preg, char *localbuf));
#ifdef __cplusplus
}
#endif
/* ========= end header generated by ./mkh ========= */
/*
= #define REG_NOMATCH 1
= #define REG_BADPAT 2
= #define REG_ECOLLATE 3
= #define REG_ECTYPE 4
= #define REG_EESCAPE 5
= #define REG_ESUBREG 6
= #define REG_EBRACK 7
= #define REG_EPAREN 8
= #define REG_EBRACE 9
= #define REG_BADBR 10
= #define REG_ERANGE 11
= #define REG_ESPACE 12
= #define REG_BADRPT 13
= #define REG_EMPTY 14
= #define REG_ASSERT 15
= #define REG_INVARG 16
= #define REG_ATOI 255 // convert name to number (!)
= #define REG_ITOA 0400 // convert number to name (!)
*/
static struct rerr {
int code;
char *name;
char *explain;
} rerrs[] = {
{REG_NOMATCH, "REG_NOMATCH", "regexec() failed to match"},
{REG_BADPAT, "REG_BADPAT", "invalid regular expression"},
{REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element"},
{REG_ECTYPE, "REG_ECTYPE", "invalid character class"},
{REG_EESCAPE, "REG_EESCAPE", "trailing backslash (\\)"},
{REG_ESUBREG, "REG_ESUBREG", "invalid backreference number"},
{REG_EBRACK, "REG_EBRACK", "brackets ([ ]) not balanced"},
{REG_EPAREN, "REG_EPAREN", "parentheses not balanced"},
{REG_EBRACE, "REG_EBRACE", "braces not balanced"},
{REG_BADBR, "REG_BADBR", "invalid repetition count(s)"},
{REG_ERANGE, "REG_ERANGE", "invalid character range"},
{REG_ESPACE, "REG_ESPACE", "out of memory"},
{REG_BADRPT, "REG_BADRPT", "repetition-operator operand invalid"},
{REG_EMPTY, "REG_EMPTY", "empty (sub)expression"},
{REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug"},
{REG_INVARG, "REG_INVARG", "invalid argument to regex routine"},
{0, "", "*** unknown regexp error code ***"}
};
/*
- regerror - the interface to error numbers
= extern size_t regerror(int, const regex_t *, char *, size_t);
*/
/* ARGSUSED */
size_t
yap_regerror(int errcode,const regex_t *preg,char *errbuf,size_t errbuf_size)
{
register struct rerr *r;
register size_t len;
register int target = errcode &~ REG_ITOA;
register char *s;
char convbuf[50];
if (errcode == REG_ATOI)
s = regatoi(preg, convbuf);
else {
for (r = rerrs; r->code != 0; r++)
if (r->code == target)
break;
if (errcode&REG_ITOA) {
if (r->code != 0)
(void) strcpy(convbuf, r->name);
else
sprintf(convbuf, "REG_0x%x", target);
assert(strlen(convbuf) < sizeof(convbuf));
s = convbuf;
} else
s = r->explain;
}
len = strlen(s) + 1;
if (errbuf_size > 0) {
if (errbuf_size > len)
(void) strcpy(errbuf, s);
else {
(void) strncpy(errbuf, s, errbuf_size-1);
errbuf[errbuf_size-1] = '\0';
}
}
return(len);
}
/*
- regatoi - internal routine to implement REG_ATOI
== static char *regatoi(const regex_t *preg, char *localbuf);
*/
static char *
regatoi(preg, localbuf)
const regex_t *preg;
char *localbuf;
{
register struct rerr *r;
for (r = rerrs; r->code != 0; r++)
if (strcmp(r->name, preg->re_endp) == 0)
break;
if (r->code == 0)
return("0");
sprintf(localbuf, "%d", r->code);
return(localbuf);
}

173
library/regex/regex2.h Normal file
View File

@@ -0,0 +1,173 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)regex2.h 8.4 (Berkeley) 3/20/94
*/
/*
* First, the stuff that ends up in the outside-world include file
= typedef off_t regoff_t;
= typedef struct {
= int re_magic;
= size_t re_nsub; // number of parenthesized subexpressions
= const char *re_endp; // end pointer for REG_PEND
= struct re_guts *re_g; // none of your business :-)
= } regex_t;
= typedef struct {
= regoff_t rm_so; // start of match
= regoff_t rm_eo; // end of match
= } regmatch_t;
*/
/*
* internals of regex_t
*/
#define MAGIC1 ((('r'^0200)<<8) | 'e')
/*
* The internal representation is a *strip*, a sequence of
* operators ending with an endmarker. (Some terminology etc. is a
* historical relic of earlier versions which used multiple strips.)
* Certain oddities in the representation are there to permit running
* the machinery backwards; in particular, any deviation from sequential
* flow must be marked at both its source and its destination. Some
* fine points:
*
* - OPLUS_ and O_PLUS are *inside* the loop they create.
* - OQUEST_ and O_QUEST are *outside* the bypass they create.
* - OCH_ and O_CH are *outside* the multi-way branch they create, while
* OOR1 and OOR2 are respectively the end and the beginning of one of
* the branches. Note that there is an implicit OOR2 following OCH_
* and an implicit OOR1 preceding O_CH.
*
* In state representations, an operator's bit is on to signify a state
* immediately *preceding* "execution" of that operator.
*/
typedef unsigned long sop; /* strip operator */
typedef long sopno;
#define OPRMASK 0xf8000000L
#define OPDMASK 0x07ffffffL
#define OPSHIFT ((unsigned)27)
#define OP(n) ((n)&OPRMASK)
#define OPND(n) ((n)&OPDMASK)
#define SOP(op, opnd) ((op)|(opnd))
/* operators meaning operand */
/* (back, fwd are offsets) */
#define OEND (1L<<OPSHIFT) /* endmarker - */
#define OCHAR (2L<<OPSHIFT) /* character unsigned char */
#define OBOL (3L<<OPSHIFT) /* left anchor - */
#define OEOL (4L<<OPSHIFT) /* right anchor - */
#define OANY (5L<<OPSHIFT) /* . - */
#define OANYOF (6L<<OPSHIFT) /* [...] set number */
#define OBACK_ (7L<<OPSHIFT) /* begin \d paren number */
#define O_BACK (8L<<OPSHIFT) /* end \d paren number */
#define OPLUS_ (9L<<OPSHIFT) /* + prefix fwd to suffix */
#define O_PLUS (10L<<OPSHIFT) /* + suffix back to prefix */
#define OQUEST_ (11L<<OPSHIFT) /* ? prefix fwd to suffix */
#define O_QUEST (12L<<OPSHIFT) /* ? suffix back to prefix */
#define OLPAREN (13L<<OPSHIFT) /* ( fwd to ) */
#define ORPAREN (14L<<OPSHIFT) /* ) back to ( */
#define OCH_ (15L<<OPSHIFT) /* begin choice fwd to OOR2 */
#define OOR1 (16L<<OPSHIFT) /* | pt. 1 back to OOR1 or OCH_ */
#define OOR2 (17L<<OPSHIFT) /* | pt. 2 fwd to OOR2 or O_CH */
#define O_CH (18L<<OPSHIFT) /* end choice back to OOR1 */
#define OBOW (19L<<OPSHIFT) /* begin word - */
#define OEOW (20L<<OPSHIFT) /* end word - */
/*
* Structure for [] character-set representation. Character sets are
* done as bit vectors, grouped 8 to a byte vector for compactness.
* The individual set therefore has both a pointer to the byte vector
* and a mask to pick out the relevant bit of each byte. A hash code
* simplifies testing whether two sets could be identical.
*
* This will get trickier for multicharacter collating elements. As
* preliminary hooks for dealing with such things, we also carry along
* a string of multi-character elements, and decide the size of the
* vectors at run time.
*/
typedef struct {
uch *ptr; /* -> uch [csetsize] */
uch mask; /* bit within array */
short hash; /* hash code */
size_t smultis;
char *multis; /* -> char[smulti] ab\0cd\0ef\0\0 */
} cset;
/* note that CHadd and CHsub are unsafe, and CHIN doesn't yield 0/1 */
#define CHadd(cs, c) ((cs)->ptr[(uch)(c)] |= (cs)->mask, (cs)->hash += (uch)(c))
#define CHsub(cs, c) ((cs)->ptr[(uch)(c)] &= ~(cs)->mask, (cs)->hash -= (uch)(c))
#define CHIN(cs, c) ((cs)->ptr[(uch)(c)] & (cs)->mask)
#define MCadd(p, cs, cp) mcadd(p, cs, cp) /* regcomp() internal fns */
#define MCsub(p, cs, cp) mcsub(p, cs, cp)
#define MCin(p, cs, cp) mcin(p, cs, cp)
/* stuff for character categories */
typedef unsigned char cat_t;
/*
* main compiled-expression structure
*/
struct re_guts {
int magic;
# define MAGIC2 ((('R'^0200)<<8)|'E')
sop *strip; /* malloced area for strip */
int csetsize; /* number of bits in a cset vector */
int ncsets; /* number of csets in use */
cset *sets; /* -> cset [ncsets] */
uch *setbits; /* -> uch[csetsize][ncsets/CHAR_BIT] */
int cflags; /* copy of regcomp() cflags argument */
sopno nstates; /* = number of sops */
sopno firststate; /* the initial OEND (normally 0) */
sopno laststate; /* the final OEND */
int iflags; /* internal flags */
# define USEBOL 01 /* used ^ */
# define USEEOL 02 /* used $ */
# define BAD 04 /* something wrong */
int nbol; /* number of ^ used */
int neol; /* number of $ used */
int ncategories; /* how many character categories */
cat_t *categories; /* ->catspace[-CHAR_MIN] */
char *must; /* match must contain this string */
int mlen; /* length of must */
size_t nsub; /* copy of re_nsub */
int backrefs; /* does it use back references? */
sopno nplus; /* how deep does it nest +s? */
/* catspace must be last */
cat_t catspace[1]; /* actually [NC] */
};
/* misc utilities */
#define OUT (CHAR_MAX+1) /* a non-character value */
#define ISWORD(c) (isalnum((uch)(c)) || (c) == '_')

182
library/regex/regexec.c Normal file
View File

@@ -0,0 +1,182 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)regexec.c 8.3 (Berkeley) 3/20/94
*/
#if defined(LIBC_SCCS) && !defined(lint)
static char sccsid[] = "@(#)regexec.c 8.3 (Berkeley) 3/20/94";
#endif /* LIBC_SCCS and not lint */
/*
* the outer shell of regexec()
*
* This file includes engine.c *twice*, after muchos fiddling with the
* macros that code uses. This lets the same code operate on two different
* representations for state sets.
*/
#include <sys/types.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <limits.h>
#include <ctype.h>
#include "c_interface.h"
#include "yapregex.h"
#include "utils.h"
#include "regex2.h"
static int nope = 0; /* for use in asserts; shuts lint up */
/* macros for manipulating states, small version */
#define states long
#define states1 states /* for later use in regexec() decision */
#define CLEAR(v) ((v) = 0)
#define SET0(v, n) ((v) &= ~((unsigned long)1 << (n)))
#define SET1(v, n) ((v) |= (unsigned long)1 << (n))
#define ISSET(v, n) (((v) & ((unsigned long)1 << (n))) != 0)
#define ASSIGN(d, s) ((d) = (s))
#define EQ(a, b) ((a) == (b))
#define STATEVARS long dummy /* dummy version */
#define STATESETUP(m, n) /* nothing */
#define STATETEARDOWN(m) /* nothing */
#define SETUP(v) ((v) = 0)
#define onestate long
#define INIT(o, n) ((o) = (unsigned long)1 << (n))
#define INC(o) ((o) <<= 1)
#define ISSTATEIN(v, o) (((v) & (o)) != 0)
/* some abbreviations; note that some of these know variable names! */
/* do "if I'm here, I can also be there" etc without branches */
#define FWD(dst, src, n) ((dst) |= ((unsigned long)(src)&(here)) << (n))
#define BACK(dst, src, n) ((dst) |= ((unsigned long)(src)&(here)) >> (n))
#define ISSETBACK(v, n) (((v) & ((unsigned long)here >> (n))) != 0)
/* function names */
#define SNAMES /* engine.c looks after details */
#include "engine.c"
/* now undo things */
#undef states
#undef CLEAR
#undef SET0
#undef SET1
#undef ISSET
#undef ASSIGN
#undef EQ
#undef STATEVARS
#undef STATESETUP
#undef STATETEARDOWN
#undef SETUP
#undef onestate
#undef INIT
#undef INC
#undef ISSTATEIN
#undef FWD
#undef BACK
#undef ISSETBACK
#undef SNAMES
/* macros for manipulating states, large version */
#define states char *
#define CLEAR(v) memset(v, 0, m->g->nstates)
#define SET0(v, n) ((v)[n] = 0)
#define SET1(v, n) ((v)[n] = 1)
#define ISSET(v, n) ((v)[n])
#define ASSIGN(d, s) memcpy(d, s, m->g->nstates)
#define EQ(a, b) (memcmp(a, b, m->g->nstates) == 0)
#define STATEVARS long vn; char *space
#define STATESETUP(m, nv) { (m)->space = malloc((nv)*(m)->g->nstates); \
if ((m)->space == NULL) return(REG_ESPACE); \
(m)->vn = 0; }
#define STATETEARDOWN(m) { free((m)->space); }
#define SETUP(v) ((v) = &m->space[m->vn++ * m->g->nstates])
#define onestate long
#define INIT(o, n) ((o) = (n))
#define INC(o) ((o)++)
#define ISSTATEIN(v, o) ((v)[o])
/* some abbreviations; note that some of these know variable names! */
/* do "if I'm here, I can also be there" etc without branches */
#define FWD(dst, src, n) ((dst)[here+(n)] |= (src)[here])
#define BACK(dst, src, n) ((dst)[here-(n)] |= (src)[here])
#define ISSETBACK(v, n) ((v)[here - (n)])
/* function names */
#define LNAMES /* flag */
#include "engine.c"
/*
- regexec - interface for matching
= extern int regexec(const regex_t *, const char *, size_t, \
= regmatch_t [], int);
= #define REG_NOTBOL 00001
= #define REG_NOTEOL 00002
= #define REG_STARTEND 00004
= #define REG_TRACE 00400 // tracing of execution
= #define REG_LARGE 01000 // force large representation
= #define REG_BACKR 02000 // force use of backref code
*
* We put this here so we can exploit knowledge of the state representation
* when choosing which matcher to call. Also, by this point the matchers
* have been prototyped.
*/
int /* 0 success, REG_NOMATCH failure */
yap_regexec(preg, string, nmatch, pmatch, eflags)
const regex_t *preg;
const char *string;
size_t nmatch;
regmatch_t pmatch[];
int eflags;
{
register struct re_guts *g = preg->re_g;
#ifdef REDEBUG
# define GOODFLAGS(f) (f)
#else
# define GOODFLAGS(f) ((f)&(REG_NOTBOL|REG_NOTEOL|REG_STARTEND))
#endif
if (preg->re_magic != MAGIC1 || g->magic != MAGIC2)
return(REG_BADPAT);
assert(!(g->iflags&BAD));
if (g->iflags&BAD) /* backstop for no-debug case */
return(REG_BADPAT);
eflags = GOODFLAGS(eflags);
if (g->nstates <= CHAR_BIT*sizeof(states1) && !(eflags&REG_LARGE))
return(smatcher(g, (char *)string, nmatch, pmatch, eflags));
else
return(lmatcher(g, (char *)string, nmatch, pmatch, eflags));
}

180
library/regex/regexp.c Normal file
View File

@@ -0,0 +1,180 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.c *
* Last rev: *
* mods: *
* comments: regular expression interpreter *
* *
*************************************************************************/
#include "config.h"
#if HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#include "c_interface.h"
#include "yapregex.h"
/* for the sake of NULL */
#include <stdio.h>
void PROTO(init_regexp, (void));
static int check_regexp(void)
{
unsigned int buflen = (unsigned int)IntOfTerm(ARG2)+1;
unsigned int sbuflen = (unsigned int)IntOfTerm(ARG4)+1;
char *buf, *sbuf;
regex_t reg;
int out;
int yap_flags = IntOfTerm(ARG5), regcomp_flags = REG_NOSUB|REG_EXTENDED;
if ((buf = (char *)AllocSpaceFromYap(buflen)) == NULL) {
/* early exit */
return(FALSE);
}
if (StringToBuffer(ARG1,buf,buflen) == FALSE) {
/* something went wrong, possibly a type checking error */
FreeSpaceFromYap(buf);
return(FALSE);
}
if (yap_flags & 1)
regcomp_flags |= REG_ICASE;
/* cool, now I have my string in the buffer, let's have some fun */
if (yap_regcomp(&reg,buf, regcomp_flags) != 0)
return(FALSE);
if ((sbuf = (char *)AllocSpaceFromYap(sbuflen)) == NULL) {
/* early exit */
yap_regfree(&reg);
FreeSpaceFromYap(buf);
return(FALSE);
}
if (StringToBuffer(ARG3,sbuf,sbuflen) == FALSE) {
/* something went wrong, possibly a type checking error */
yap_regfree(&reg);
FreeSpaceFromYap(buf);
FreeSpaceFromYap(sbuf);
return(FALSE);
}
out = yap_regexec(&reg,sbuf,0,NULL,0);
yap_regfree(&reg);
FreeSpaceFromYap(buf);
FreeSpaceFromYap(sbuf);
if (out != 0 && out != REG_NOMATCH) {
return(FALSE);
}
return(out == 0);
}
static int regexp(void)
{
unsigned int buflen = (unsigned int)IntOfTerm(ARG2)+1;
unsigned int sbuflen = (unsigned int)IntOfTerm(ARG4)+1;
char *buf, *sbuf;
regex_t reg;
int out;
Int nmatch = IntOfTerm(ARG7);
regmatch_t *pmatch;
Term tout;
int yap_flags = IntOfTerm(ARG5), regcomp_flags = REG_EXTENDED;
if ((buf = (char *)AllocSpaceFromYap(buflen)) == NULL) {
/* early exit */
return(FALSE);
}
if (StringToBuffer(ARG1,buf,buflen) == FALSE) {
/* something went wrong, possibly a type checking error */
FreeSpaceFromYap(buf);
return(FALSE);
}
if (yap_flags & 1)
regcomp_flags |= REG_ICASE;
/* cool, now I have my string in the buffer, let's have some fun */
if (yap_regcomp(&reg,buf, regcomp_flags) != 0)
return(FALSE);
if ((sbuf = (char *)AllocSpaceFromYap(sbuflen)) == NULL) {
/* early exit */
yap_regfree(&reg);
FreeSpaceFromYap(buf);
return(FALSE);
}
if (StringToBuffer(ARG3,sbuf,sbuflen) == FALSE) {
/* something went wrong, possibly a type checking error */
yap_regfree(&reg);
FreeSpaceFromYap(buf);
FreeSpaceFromYap(sbuf);
return(FALSE);
}
pmatch = AllocSpaceFromYap(sizeof(regmatch_t)*nmatch);
out = yap_regexec(&reg,sbuf,(int)nmatch,pmatch,0);
if (out == 0) {
/* match succeed, let's fill the match in */
Int i;
Term TNil = MkAtomTerm(LookupAtom("[]"));
Functor FDiff = MkFunctor(LookupAtom("-"),2);
tout = ARG6;
for (i = 0; i < nmatch; i++) {
int j;
Term t = TNil;
if (pmatch[i].rm_so == -1) break;
if (yap_flags & 2) {
Term to[2];
to[0] = MkIntTerm(pmatch[i].rm_so);
to[1] = MkIntTerm(pmatch[i].rm_eo);
t = MkApplTerm(FDiff,2,to);
} else {
for (j = pmatch[i].rm_eo-1; j >= pmatch[i].rm_so; j--) {
t = MkPairTerm(MkIntTerm(sbuf[j]),t);
}
}
unify(t,HeadOfTerm(tout));
tout = TailOfTerm(tout);
}
}
else if (out != REG_NOMATCH) {
return(FALSE);
}
yap_regfree(&reg);
FreeSpaceFromYap(buf);
FreeSpaceFromYap(sbuf);
FreeSpaceFromYap(pmatch);
return(out == 0);
}
void
init_regexp(void)
{
UserCPredicate("check_regexp", check_regexp, 5);
UserCPredicate("check_regexp", regexp, 7);
}
#ifdef _WIN32
#include <windows.h>
int WINAPI PROTO(win_regexp, (HANDLE, DWORD, LPVOID));
int WINAPI win_regexp(HANDLE hinst, DWORD reason, LPVOID reserved)
{
switch (reason)
{
case DLL_PROCESS_ATTACH:
break;
case DLL_PROCESS_DETACH:
break;
case DLL_THREAD_ATTACH:
break;
case DLL_THREAD_DETACH:
break;
}
return 1;
}
#endif

2
library/regex/regexp.def Normal file
View File

@@ -0,0 +1,2 @@
EXPORTS
init_regexp

81
library/regex/regfree.c Normal file
View File

@@ -0,0 +1,81 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)regfree.c 8.3 (Berkeley) 3/20/94
*/
#if defined(LIBC_SCCS) && !defined(lint)
static char sccsid[] = "@(#)regfree.c 8.3 (Berkeley) 3/20/94";
#endif /* LIBC_SCCS and not lint */
#include <sys/types.h>
#include <stdio.h>
#include <stdlib.h>
#include "c_interface.h"
#include "yapregex.h"
#include "utils.h"
#include "regex2.h"
/*
- regfree - free everything
= extern void regfree(regex_t *);
*/
void
yap_regfree(preg)
regex_t *preg;
{
register struct re_guts *g;
if (preg->re_magic != MAGIC1) /* oops */
return; /* nice to complain, but hard */
g = preg->re_g;
if (g == NULL || g->magic != MAGIC2) /* oops again */
return;
preg->re_magic = 0; /* mark it invalid */
g->magic = 0; /* mark it invalid */
if (g->strip != NULL)
free((char *)g->strip);
if (g->sets != NULL)
free((char *)g->sets);
if (g->setbits != NULL)
free((char *)g->setbits);
if (g->must != NULL)
free(g->must);
free((char *)g);
}

61
library/regex/utils.h Normal file
View File

@@ -0,0 +1,61 @@
/*-
* Copyright (c) 1992, 1993, 1994 Henry Spencer.
* Copyright (c) 1992, 1993, 1994
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)utils.h 8.3 (Berkeley) 3/20/94
*/
/* utility definitions */
#ifdef _WIN32
#define DUPMAX ((unsigned int)-2) /* xxx is this right? */
#else
#define DUPMAX _POSIX2_RE_DUP_MAX /* xxx is this right? */
#endif
#define INFINITY (DUPMAX + 1)
#define NC (CHAR_MAX - CHAR_MIN + 1)
typedef unsigned char uch;
/* switch off assertions (if not already off) if no REDEBUG */
#ifndef REDEBUG
#ifndef NDEBUG
#define NDEBUG /* no assertions please */
#endif
#endif
#include <assert.h>
/* for old systems with bcopy() but no memmove() */
#ifdef USEBCOPY
#define memmove(d, s, c) bcopy(s, d, c)
#endif

101
library/regex/yapregex.h Normal file
View File

@@ -0,0 +1,101 @@
/*-
* Copyright (c) 1992 Henry Spencer.
* Copyright (c) 1992, 1993
* The Regents of the University of California. All rights reserved.
*
* This code is derived from software contributed to Berkeley by
* Henry Spencer of the University of Toronto.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*
* @(#)regex.h 8.2 (Berkeley) 1/3/94
*/
#ifndef _REGEX_H_
#define _REGEX_H_
/* types */
typedef int regoff_t;
typedef struct {
int re_magic;
int re_nsub; /* number of parenthesized subexpressions */
const char *re_endp; /* end pointer for REG_PEND */
struct re_guts *re_g; /* none of your business :-) */
} regex_t;
typedef struct {
regoff_t rm_so; /* start of match */
regoff_t rm_eo; /* end of match */
} regmatch_t;
/* regcomp() flags */
#define REG_BASIC 0000
#define REG_EXTENDED 0001
#define REG_ICASE 0002
#define REG_NOSUB 0004
#define REG_NEWLINE 0010
#define REG_NOSPEC 0020
#define REG_PEND 0040
#define REG_DUMP 0200
/* regerror() flags */
#define REG_NOMATCH 1
#define REG_BADPAT 2
#define REG_ECOLLATE 3
#define REG_ECTYPE 4
#define REG_EESCAPE 5
#define REG_ESUBREG 6
#define REG_EBRACK 7
#define REG_EPAREN 8
#define REG_EBRACE 9
#define REG_BADBR 10
#define REG_ERANGE 11
#define REG_ESPACE 12
#define REG_BADRPT 13
#define REG_EMPTY 14
#define REG_ASSERT 15
#define REG_INVARG 16
#define REG_ATOI 255 /* convert name to number (!) */
#define REG_ITOA 0400 /* convert number to name (!) */
/* regexec() flags */
#define REG_NOTBOL 00001
#define REG_NOTEOL 00002
#define REG_STARTEND 00004
#define REG_TRACE 00400 /* tracing of execution */
#define REG_LARGE 01000 /* force large representation */
#define REG_BACKR 02000 /* force use of backref code */
int PROTO(yap_regcomp, (regex_t *, const char *, int));
size_t PROTO(yap_regerror, (int, const regex_t *, char *, size_t));
int PROTO(yap_regexec, (const regex_t *, const char *, size_t, regmatch_t [], int));
void PROTO(yap_regfree, (regex_t *));
#endif /* !_REGEX_H_ */

72
library/regexp.yap Normal file
View File

@@ -0,0 +1,72 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.yap *
* Last rev: 3/22/2000 *
* mods: *
* comments: Support for Regular Expressions in YAP *
* *
*************************************************************************/
:- module(regexp, [
regexp/3,
regexp/4
]).
:- load_foreign_files([regexp,regcomp,regfree,regerror,regexec], [], init_regexp).
regexp(RegExp, String, Opts) :-
length(RegExp, LRE),
length(String, LS),
check_opts(Opts,0,IOpts,regexp(RegExp, String, Opts)),
check_regexp(RegExp,LRE,String,LS,IOpts).
regexp(RegExp, String, Opts, OUT) :-
length(RegExp, LRE),
length(String, LS),
check_out(OUT,0,Count,regexp(RegExp, String, Opts, OUT)),
check_opts(Opts,0,IOpts,regexp(RegExp, String, Opts, OUT)),
check_regexp(RegExp,LRE,String,LS,IOpts,OUT,Count).
%
% OUT must be bound to a list of unbound variables.
% Check this and count how many.
%
check_out(V,_,_,G) :- var(V), !,
throw(error(instantiation_error,G)).
check_out([],I,I,_) :- !.
check_out([V|L],I0,IF,G) :- !,
(nonvar(V) -> throw(error(type_error(variable,V),G)) ; true),
I is I0+1,
check_out(L,I,IF,G).
check_out(OUT,_,_,G) :-
throw(error(type_error(variable,OUT),G)).
%
% Option processing
%
check_opts(V,_,_,G) :- var(V), !,
throw(error(instantiation_error,G)).
check_opts([],I,I,_) :- !.
check_opts([A|L],I0,IF,G) :- !,
process_opt(A,I1,G),
I is I0+I1,
check_opts(L,I,IF,G).
check_opts(Opts,_,_,G) :-
throw(error(type_error(variable,Opts),G)).
process_opt(V,I,G) :- var(V), !,
throw(error(instantiation_error,G)).
process_opt(nocase,1,_) :- !.
process_opt(indices,2,_) :- !.
process_opt(I,_,G) :-
throw(error(domain_error(flag_value,regexp_options+I),G)).

186
library/splay.yap Normal file
View File

@@ -0,0 +1,186 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: splay.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: Vijay Saraswat's implementation of Splay trees *
* *
*************************************************************************/
:- module(splay,[
splay_access/5,
splay_insert/4,
splay_del/3,
splay_join/3,
splay_split/5]).
% Date: Sun 22 Mar 87 03:40:22-EST
% >From: vijay <Vijay.Saraswat@C.CS.CMU.EDU>
% Subject: Splay trees in LP languages.
% There have hardly been any interesting programs in this Digest for a
% long while now. Here is something which may stir the slothful among
% you! I present Prolog programs for implementing self-adjusting binary
% search trees, using splaying. These programs should be among the most
% efficient Prolog programs for maintaining binary search trees, with
% dynamic insertion and deletion.
% The algorithm is taken from: "Self-adjusting Binary Search Trees",
% D.D. Sleator and R.E. Tarjan, JACM, vol. 32, No.3, July 1985, p. 668.
% (See Tarjan's Turing Award lecture in this month's CACM for a more
% informal introduction).
% -----------------------------------------
% The operations provided by the program are:
% 1. access(i,t): (implemented by the call access(V, I, T, New))
% "If item i is in tree t, return a pointer to its location;
% otherwise return a pointer to the null node."
% In our implementation, in the call access(V, I, T, New),
% V is unifies with `null' if the item is not there, else
% with `true' if it is there, in which case I is also
% unified with that item.
% 2. insert(i,t): (implemented by the call insert(I, T, New))
% "Insert item i in tree t, assuming that it is not there already."
% (In our implementation, i is not inserted if it is already
% there: rather it is unified with the item already in the tree.)
% 3. delete(i,t): (implemented by the call del(I, T, New))
% "Delete item i from tree t, assuming that it is present."
% (In our implementation, the call fails if the item is not in
% the tree.)
% 4. join(t1,t2): (Implemented by the call join(T1, T2, New))
% "Combine trees t1 and t2 into a single tree containing
% all items from both trees, and return the resulting
% tree. This operation assumes that all items in t1 are
% less than all those in t2 and destroys both t1 and t2."
% 5. split(i,t): (implemented by the call split(I, T, Left, Right))
% "Construct and return two trees t1 and t2, where t1
% contains all items in t less than i, and t2 contains all
% items in t greater than i. This operations destroys t."
% The basic workhorse is the routine bst(Op, Item, Tree, NewTree), which
% returns in NewTree a binary search tree obtained by searching for Item
% in Tree and splaying. OP controls what must happen if Item is not
% found in the Tree. If Op = access(V), then V is unified with null if
% the item is not found in the tree, and with true if it is; in the
% latter case Item is also unified with the item found in the tree. In
% the first case, splaying is done at the node at which the discovery
% was made that Item was not in the tree, and in the second case
% splaying is done at the node at which Item is found. If Op=insert,
% then Item is inserted in the tree if it is not found, and splaying is
% done at the new node; if the item is found, then splaying is done at
% the node at which it is found.
% A node is simply an n/3 structure: n(NodeValue, LeftSon, RightSon).
% NodeValue could be as simple as an integer, or it could be a (Key,
% Value) pair.
% A node is simply an n/3 structure: n(NodeValue, LeftSon, RightSon).
% NodeValue could be as simple as an integer, or it could be a (Key,
% Value) pair.
% Here are the top-level axioms. The algorithm for del/3 is the first
% algorithm mentioned in the JACM paper: namely, first access the
% element to be deleted, thus bringing it to the root, and then join its
% sons. (join/4 is discussed later.)
splay_access(V, Item, Val, Tree, NewTree):-
bst(access(V), Item, Val, Tree, NewTree).
splay_insert(Item, Val,Tree, NewTree):-
bst(insert, Item, Val, Tree, NewTree).
splay_del(Item, Tree, NewTree):-
bst(access(true), Item, Val, Tree, n(Item, Val, Left, Right)),
join(Left, Right, NewTree).
splay_join(Left, Right, New):-
join(L-L, Left, Right, New).
splay_split(Item, Val, Tree, Left, Right):-
bst(access(true), Item, Val, Tree, n(Item, Val, Left, Right)).
% We now consider the definition of bst. We use the notion of
% `difference-bsts'. There are two types of difference-bsts, a left one
% and a right one. The left one is of the form T-L where T is a bst and
% L is the *right* son of the node with the largest value in T. The
% right one is of the form T-R where T is a binary search tree and R is
% the *left* son of the node with the smallest value in T. An empty bst
% is denoted by a variable. Hence L-L denotes the empty left (as well as
% right) difference bst.
% As discussed in the JACM paper, we start with a notion of a left
% fragment and a right fragment of the new bst to be constructed.
% Intially, the two fragments are empty.
bst(Op, Item, Val, Tree, NewTree):-
bst(Op, Item, Val, L-L, Tree, R-R, NewTree).
% We now consider the base cases. The empty tree is a variable: hence it
% will unify with the atom null. (A non-empty tree is a n/3 structure,
% which will not unify with null). If Item was being *access*ed, then it
% was not found in the tree, and hence Null=null. On the other hand, if
% the Item is found at the root, then the call terminates, with the New
% Tree being set up appropriately.
% The base clauses are:
bst(access(Null), Item, _, L, null, R, Tree):- !, Null = null.
bst(access(true), Item, Val, Left-A, n(Item0, Val0, A, B), Right-B, n(Item, Val, Left, Right)) :- Item == Item0, !, Val = Val0.
bst(insert, Item, Val, Left-A, T, Right-B, n(Item0, Val, Left, Right)) :-
(var(T) ; T = n(Item0, Val0, A, B), Item == Item0), !, Item = Item0.
% We now consider the zig case, namely that we have reached a node such
% that the required Item is either to the left of the current node and
% the current node is a leaf, or the required item is the left son of
% the current node. Depending upon the Op, the appropriate action is
% taken:
bst(access(Null), Item, _, Left-L, n(X, VX, null, B), Right-B, n(X, VX, Left, Right)) :-
Item @< X, !, Null = null.
bst(Op, Item, Val, Left, n(X, VX, n(Item, Val, A1, A2), B), R-n(X, VX, NR,B), New):-
Item @< X, !,
bst(Op, Item, Val, Left, n(Item, Val, A1, A2), R-NR, New).
% The recursive cases are straightforward:
% Zig-Zig:
bst(Op, Item, Val, Left, n(X, VX, n(Y, VY, Z, B), C), R-n(Y, VY, NR, n(X, VX, B, C)), New):-
Item @< X, Item @< Y, !,
bst(Op, Item, Val, Left, Z, R-NR, New).
% Zig-Zag:
bst(Op, Item, Val, L-n(Y, VY, A, NL), n(X, VX, n(Y, VY, A, Z), C), R-n(X, NX, NR, C), New):-
Item @< X, Y @< Item,!,
bst(Op, Item, Val, L-NL, Z, R-NR, New).
% The symmetric cases for the right sons of the current node
% are straightforward too:
% Zag
bst(access(Null), Item, _, Left-B, n(X, VX, B, null), Right-R, n(X, VX, Left, Right)):-
X @< Item, !, Null = null. % end of the road.
bst(Op, Item, Val, L-n(X, VX, B, NL), n(X, VX, B, n(Item, Val, A1, A2)), Right, New):-
X @< Item, !,
bst(Op, Item, Val, L-NL, n(Item, Val, A1, A2), Right, New).
% Zag-Zag
bst(Op, Item, Val, L-n(Y, VY, n(X, VX, C, B), NL), n(X, VX, C, n(Y, VY, B, Z)), Right, New):-
X @< Item, Y @<Item,!,
bst(Op, Item, Val, L-NL, Z, Right, New).
% Zag-Zig
bst(Op, Item, Val, L-n(X, VX, A, NL), n(X, VX, A, n(Y, VY, Z, C)), R-n(Y, VY, NR, C), New):-
X @< Item, Item @< Y,!,
bst(Op, Item, Val, L-NL, Z, R-NR, New).
% We now consider the definition of join. To join Left to Right, it is
% sufficient to splay at the rightmost vertex in Left, and make Right
% its Right son. To build NewTree, we initially start with an empty left
join(Left-A, n(X, VX, A, var), Right, n(X, VX, Left, Right)):-!.
join(Left-n(X, VX, A, B), n(X, VX, A, n(Y, VY, B, var)), Right, n(Y, VY, Left, Right)):- !.
join(Left-n(Y, VY, n(X, VX, C, B), NL), n(X, VX, C, n(Y, VY, B, n(Z, VZ, A1, A2))), Right, New):-
join(Left-NL, n(Z, VZ,A1, A2), Right, New).

38
library/terms.yap Normal file
View File

@@ -0,0 +1,38 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: terms.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: Term manipulation operations *
* *
*************************************************************************/
:- module(terms, [
term_hash/2,
term_hash/4,
term_variables/2,
variant/2,
subsumes/2,
subsumes_chk/2,
cyclic_term/1,
acyclic_term/1
]).
term_hash(T,H) :-
term_hash(T, -1, 33554432, H).
subsumes_chk(X,Y) :-
\+ \+ subsumes(X,Y).

42
library/timeout.yap Normal file
View File

@@ -0,0 +1,42 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: timeout.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: Goal within timeout *
* *
*************************************************************************/
:- module(timeout, [
time_out/3
]).
:- meta_predicate time_out(:,+,-).
%
% not the nicest program I've ever seen.
%
time_out(Goal, Time, Result) :-
T is Time//1000,
% enable alarm
alarm(T,throw(time_out),_),
% launch goal and wait for signal
( catch(Goal, time_out, Result = time_out)
% make sure to disable alarm
->
alarm(0,_,_)
;
alarm(0,_,_),
fail
),
% just couldn't resist...
(Result = success -> true ; true).

181
library/trees.yap Normal file
View File

@@ -0,0 +1,181 @@
% This file has been included as an YAP library by Vitor Santos Costa, 1999
% File : TREES.PL
% Author : R.A.O'Keefe
% Updated: 8 November 1983
% Purpose: Updatable binary trees.
/* These are the routines I meant to describe in DAI-WP-150, but the
wrong version went in. We have
list_to_tree : O(N)
tree_to_list : O(N)
tree_size : O(N)
map_tree : O(N)
get_label : O(lg N)
put_label : O(lg N)
where N is the number of elements in the tree. The way get_label
and put_label work is worth noting: they build up a pattern which
is matched against the whole tree when the position number finally
reaches 1. In effect they start out from the desired node and
build up a path to the root. They still cost O(lg N) time rather
than O(N) because the patterns contain O(lg N) distinct variables,
with no duplications. put_label simultaneously builds up a pattern
to match the old tree and a pattern to match the new tree.
*/
:- module(trees, [
get_label/3,
list_to_tree/2,
map_tree/3,
put_label/4,
tree_size/2,
tree_to_list/2
]).
:- meta_predicate
map_tree(:, ?, ?).
/*
:- mode
get_label(+, +, ?),
find_node(+, +, +),
list_to_tree(+, -),
list_to_tree(+, +, -),
list_to_tree(+),
map_tree(+, +, -),
put_label(+, +, +, -),
find_node(+, +, +, -, +),
tree_size(+, ?),
tree_size(+, +, -),
tree_to_list(+, -),
tree_to_list(+, -, -).
*/
% get_label(Index, Tree, Label)
% treats the tree as an array of N elements and returns the Index-th.
% If Index < 1 or > N it simply fails, there is no such element.
get_label(N, Tree, Label) :-
find_node(N, Tree, t(Label,_,_)).
find_node(1, Tree, Tree) :- !.
find_node(N, Tree, Node) :-
N > 1,
0 is N mod 2,
M is N / 2, !,
find_node(M, Tree, t(_,Node,_)).
find_node(N, Tree, Node) :-
N > 2,
1 is N mod 2,
M is N / 2, !,
find_node(M, Tree, t(_,_,Node)).
% list_to_tree(List, Tree)
% takes a given List of N elements and constructs a binary Tree
% where get_label(K, Tree, Lab) <=> Lab is the Kth element of List.
list_to_tree(List, Tree) :-
list_to_tree(List, [Tree|Tail], Tail).
list_to_tree([Head|Tail], [t(Head,Left,Right)|Qhead], [Left,Right|Qtail]) :-
list_to_tree(Tail, Qhead, Qtail).
list_to_tree([], Qhead, []) :-
list_to_tree(Qhead).
list_to_tree([t|Qhead]) :-
list_to_tree(Qhead).
list_to_tree([]).
% map_tree(Pred, OldTree, NewTree)
% is true when OldTree and NewTree are binary trees of the same shape
% and Pred(Old,New) is true for corresponding elements of the two trees.
% In fact this routine is perfectly happy constructing either tree given
% the other, I have given it the mode I have for that bogus reason
% "efficiency" and because it is normally used this way round. This is
% really meant more as an illustration of how to map over trees than as
% a tool for everyday use.
map_tree(Pred, t(Old,OLeft,ORight), t(New,NLeft,NRight)) :-
tree_apply(Pred, [Old,New]),
map_tree(Pred, OLeft, NLeft),
map_tree(Pred, ORight, NRight).
map_tree(_, t, t).
tree_apply(Pred,Args) :-
G =.. [Pred,Args],
call(G), !.
% put_label(Index, OldTree, Label, NewTree)
% constructs a new tree the same shape as the old which moreover has the
% same elements except that the Index-th one is Label. Unlike the
% "arrays" of Arrays.Pl, OldTree is not modified and you can hang on to
% it as long as you please. Note that O(lg N) new space is needed.
put_label(N, Old, Label, New) :-
find_node(N, Old, t(_,Left,Right), New, t(Label,Left,Right)).
find_node(1, Old, Old, New, New) :- !.
find_node(N, Old, OldSub, New, NewSub) :-
N > 1,
0 is N mod 2,
M is N / 2, !,
find_node(M, Old, t(Label,OldSub,Right), New, t(Label,NewSub,Right)).
find_node(N, Old, OldSub, New, NewSub) :-
N > 2,
1 is N mod 2,
M is N / 2, !,
find_node(M, Old, t(Label,Left,OldSub), New, t(Label,Left,NewSub)).
% tree_size(Tree, Size)
% calculates the number of elements in the Tree. All trees made by
% list_to_tree that are the same size have the same shape.
tree_size(Tree, Size) :-
tree_size(Tree, 0, Total), !,
Size = Total.
tree_size(t(_,Left,Right), SoFar, Total) :-
tree_size(Right, SoFar, M),
N is M+1, !,
tree_size(Left, N, Total).
tree_size(t, Accum, Accum).
% tree_to_list(Tree, List)
% is the converse operation to list_to_tree. Any mapping or checking
% operation can be done by converting the tree to a list, mapping or
% checking the list, and converting the result, if any, back to a tree.
% It is also easier for a human to read a list than a tree, as the
% order in the tree goes all over the place.
tree_to_list(Tree, List) :-
tree_to_list([Tree|Tail], Tail, List).
tree_to_list([], [], []) :- !.
tree_to_list([t|_], _, []) :- !.
tree_to_list([t(Head,Left,Right)|Qhead], [Left,Right|Qtail], [Head|Tail]) :-
tree_to_list(Qhead, Qtail, Tail).
list(0, []).
list(N, [N|L]) :- M is N-1, list(M, L).

527
library/ugraphs.yap Normal file
View File

@@ -0,0 +1,527 @@
% File : GRAPHS.PL
% Author : R.A.O'Keefe
% Updated: 20 March 1984
% Purpose: Graph-processing utilities.
%
% adapted to support some of the functionality of the SICStus ugraphs library
% by Vitor Santos Costa.
%
/* The P-representation of a graph is a list of (from-to) vertex
pairs, where the pairs can be in any old order. This form is
convenient for input/output.
The S-representation of a graph is a list of (vertex-neighbours)
pairs, where the pairs are in standard order (as produced by
keysort) and the neighbours of each vertex are also in standard
order (as produced by sort). This form is convenient for many
calculations.
p_to_s_graph(Pform, Sform) converts a P- to an S- representation.
s_to_p_graph(Sform, Pform) converts an S- to a P- representation.
warshall(Graph, Closure) takes the transitive closure of a graph
in S-form. (NB: this is not the reflexive transitive closure).
s_to_p_trans(Sform, Pform) converts Sform to Pform, transposed.
p_transpose transposes a graph in P-form, cost O(|E|).
s_transpose transposes a graph in S-form, cost O(|V|^2).
*/
:- module(ugraphs, [
vertices_edges_to_ugraph/3,
vertices/2,
edges/2,
add_vertices/3,
del_vertices/3,
add_edges/3,
del_edges/3,
transpose/2,
neighbours/3,
neighbors/3,
complement/2,
compose/3,
top_sort/2,
transitive_closure/2
]).
:- use_module(library(lists), [
append/3,
member/2,
memberchk/2
]).
:- use_module(library(ordsets), [
ord_union/3,
ord_subtract/3,
ord_add_element/3
]).
/*
:- public
p_to_s_graph/2,
s_to_p_graph/2, % edges
s_to_p_trans/2,
p_member/3,
s_member/3,
p_transpose/2,
s_transpose/2,
compose/3,
top_sort/2,
vertices/2,
warshall/2.
:- mode
vertices(+, -),
p_to_s_graph(+, -),
p_to_s_vertices(+, -),
p_to_s_group(+, +, -),
p_to_s_group(+, +, -, -),
s_to_p_graph(+, -),
s_to_p_graph(+, +, -, -),
s_to_p_trans(+, -),
s_to_p_trans(+, +, -, -),
p_member(?, ?, +),
s_member(?, ?, +),
p_transpose(+, -),
s_transpose(+, -),
s_transpose(+, -, ?, -),
transpose_s(+, +, +, -),
compose(+, +, -),
compose(+, +, +, -),
compose1(+, +, +, -),
compose1(+, +, +, +, +, +, +, -),
top_sort(+, -),
vertices_and_zeros(+, -, ?),
count_edges(+, +, +, -),
incr_list(+, +, +, -),
select_zeros(+, +, -),
top_sort(+, -, +, +, +),
decr_list(+, +, +, -, +, -),
warshall(+, -),
warshall(+, +, -),
warshall(+, +, +, -).
*/
% vertices(S_Graph, Vertices)
% strips off the neighbours lists of an S-representation to produce
% a list of the vertices of the graph. (It is a characteristic of
% S-representations that *every* vertex appears, even if it has no
% neighbours.)
vertices([], []) :- !.
vertices([Vertex-_|Graph], [Vertex|Vertices]) :-
vertices(Graph, Vertices).
vertices_edges_to_ugraph(Vertices, Edges, Graph) :-
sort(Edges, EdgeSet),
p_to_s_vertices(EdgeSet, IVertexBag),
append(Vertices, IVertexBag, VertexBag),
sort(VertexBag, VertexSet),
p_to_s_group(VertexSet, EdgeSet, Graph).
add_vertices(Vertices, Graph, NewGraph) :-
msort(Vertices, V1),
add_vertices_to_s_graph(V1, Graph, NewGraph).
add_vertices_to_s_graph(L, [], NL) :- !, add_empty_vertices(L, NL).
add_vertices_to_s_graph([], L, L) :- !.
add_vertices_to_s_graph([V1|VL], [V-Edges|G], NGL) :-
compare(Res, V1, V),
add_vertices_to_s_graph(Res, V1, VL, V, Edges, G, NGL).
add_vertices_to_s_graph(=, _, VL, V, Edges, G, [V-Edges|NGL]) :-
add_vertices_to_s_graph(VL, G, NGL).
add_vertices_to_s_graph(<, V1, VL, V, Edges, G, [V1-[]|NGL]) :-
add_vertices_to_s_graph(VL, [V-Edges|G], NGL).
add_vertices_to_s_graph(>, V1, VL, V, Edges, G, [V-Edges|NGL]) :-
add_vertices_to_s_graph([V1|VL], G, NGL).
add_empty_vertices([], []).
add_empty_vertices([V|G], [V-[]|NG]) :-
add_empty_vertices(G, NG).
%
% unmark a set of vertices plus all edges leading to them.
%
del_vertices(Vertices, Graph, NewGraph) :-
msort(Vertices, V1),
(V1 = [] -> Graph = NewGraph ;
del_vertices(Graph, V1, V1, NewGraph) ).
del_vertices(G, [], V1, NG) :- !,
del_remaining_edges_for_vertices(G, V1, NG).
del_vertices([], _, _, []).
del_vertices([V-Edges|G], [V0|Vs], V1, NG) :-
compare(Res, V, V0),
split_on_del_vertices(Res, V,Edges, [V0|Vs], NVs, V1, NG, NGr),
del_vertices(G, NVs, V1, NGr).
del_remaining_edges_for_vertices([], _, []).
del_remaining_edges_for_vertices([V0-Edges|G], V1, [V0-NEdges|NG]) :-
ord_subtract(Edges, V1, NEdges),
del_remaining_edges_for_vertices(G, V1, NG).
split_on_del_vertices(<, V, Edges, Vs, Vs, V1, [V-NEdges|NG], NG) :-
ord_subtract(Edges, V1, NEdges).
split_on_del_vertices(>, V, Edges, [_|Vs], Vs, V1, [V-NEdges|NG], NG) :-
ord_subtract(Edges, V1, NEdges).
split_on_del_vertices(=, _, _, [_|Vs], Vs, _, NG, NG).
add_edges(Graph, Edges, NewGraph) :-
p_to_s_graph(Edges, G1),
graph_union(Graph, G1, NewGraph).
% graph_union(+Set1, +Set2, ?Union)
% is true when Union is the union of Set1 and Set2. This code is a copy
% of set union
graph_union(Set1, [], Set1) :- !.
graph_union([], Set2, Set2) :- !.
graph_union([Head1-E1|Tail1], [Head2-E2|Tail2], Union) :-
compare(Order, Head1, Head2),
graph_union(Order, Head1-E1, Tail1, Head2-E2, Tail2, Union).
graph_union(=, Head-E1, Tail1, _-E2, Tail2, [Head-Es|Union]) :-
ord_union(E1, E2, Es),
graph_union(Tail1, Tail2, Union).
graph_union(<, Head1, Tail1, Head2, Tail2, [Head1|Union]) :-
graph_union(Tail1, [Head2|Tail2], Union).
graph_union(>, Head1, Tail1, Head2, Tail2, [Head2|Union]) :-
graph_union([Head1|Tail1], Tail2, Union).
del_edges(Graph, Edges, NewGraph) :-
p_to_s_graph(Edges, G1),
graph_subtract(Graph, G1, NewGraph).
% graph_subtract(+Set1, +Set2, ?Difference)
% is based on ord_subtract
%
graph_subtract(Set1, [], Set1) :- !.
graph_subtract([], _, []).
graph_subtract([Head1-E1|Tail1], [Head2-E2|Tail2], Difference) :-
compare(Order, Head1, Head2),
graph_subtract(Order, Head1-E1, Tail1, Head2-E2, Tail2, Difference).
graph_subtract(=, H-E1, Tail1, _-E2, Tail2, [H-E|Difference]) :-
ord_subtract(E1,E2,E),
graph_subtract(Tail1, Tail2, Difference).
graph_subtract(<, Head1, Tail1, Head2, Tail2, [Head1|Difference]) :-
graph_subtract(Tail1, [Head2|Tail2], Difference).
graph_subtract(>, Head1, Tail1, _, Tail2, Difference) :-
graph_subtract([Head1|Tail1], Tail2, Difference).
edges(Graph, Edges) :-
s_to_p_graph(Graph, Edges).
p_to_s_graph(P_Graph, S_Graph) :-
sort(P_Graph, EdgeSet),
p_to_s_vertices(EdgeSet, VertexBag),
sort(VertexBag, VertexSet),
p_to_s_group(VertexSet, EdgeSet, S_Graph).
p_to_s_vertices([], []) :- !.
p_to_s_vertices([A-Z|Edges], [A,Z|Vertices]) :-
p_to_s_vertices(Edges, Vertices).
p_to_s_group([], _, []) :- !.
p_to_s_group([Vertex|Vertices], EdgeSet, [Vertex-Neibs|G]) :-
p_to_s_group(EdgeSet, Vertex, Neibs, RestEdges),
p_to_s_group(Vertices, RestEdges, G).
p_to_s_group([V-X|Edges], V, [X|Neibs], RestEdges) :- !,
p_to_s_group(Edges, V, Neibs, RestEdges).
p_to_s_group(Edges, _, [], Edges).
s_to_p_graph([], []) :- !.
s_to_p_graph([Vertex-Neibs|G], P_Graph) :-
s_to_p_graph(Neibs, Vertex, P_Graph, Rest_P_Graph),
s_to_p_graph(G, Rest_P_Graph).
s_to_p_graph([], _, P_Graph, P_Graph) :- !.
s_to_p_graph([Neib|Neibs], Vertex, [Vertex-Neib|P], Rest_P) :-
s_to_p_graph(Neibs, Vertex, P, Rest_P).
s_to_p_trans([], []) :- !.
s_to_p_trans([Vertex-Neibs|G], P_Graph) :-
s_to_p_trans(Neibs, Vertex, P_Graph, Rest_P_Graph),
s_to_p_trans(G, Rest_P_Graph).
s_to_p_trans([], _, P_Graph, P_Graph) :- !.
s_to_p_trans([Neib|Neibs], Vertex, [Neib-Vertex|P], Rest_P) :-
s_to_p_trans(Neibs, Vertex, P, Rest_P).
transitive_closure(Graph, Closure) :-
warshall(Graph, Graph, Closure).
warshall(Graph, Closure) :-
warshall(Graph, Graph, Closure).
warshall([], Closure, Closure) :- !.
warshall([V-_|G], E, Closure) :-
memberchk(V-Y, E), % Y := E(v)
warshall(E, V, Y, NewE),
warshall(G, NewE, Closure).
warshall([X-Neibs|G], V, Y, [X-NewNeibs|NewG]) :-
memberchk(V, Neibs),
!,
ord_union(Neibs, Y, NewNeibs),
warshall(G, V, Y, NewG).
warshall([X-Neibs|G], V, Y, [X-Neibs|NewG]) :- !,
warshall(G, V, Y, NewG).
warshall([], _, _, []).
p_transpose([], []) :- !.
p_transpose([From-To|Edges], [To-From|Transpose]) :-
p_transpose(Edges, Transpose).
transpose(S_Graph, Transpose) :-
s_transpose(S_Graph, Base, Base, Transpose).
s_transpose(S_Graph, Transpose) :-
s_transpose(S_Graph, Base, Base, Transpose).
s_transpose([], [], Base, Base) :- !.
s_transpose([Vertex-Neibs|Graph], [Vertex-[]|RestBase], Base, Transpose) :-
s_transpose(Graph, RestBase, Base, SoFar),
transpose_s(SoFar, Neibs, Vertex, Transpose).
transpose_s([Neib-Trans|SoFar], [Neib|Neibs], Vertex,
[Neib-[Vertex|Trans]|Transpose]) :- !,
transpose_s(SoFar, Neibs, Vertex, Transpose).
transpose_s([Head|SoFar], Neibs, Vertex, [Head|Transpose]) :- !,
transpose_s(SoFar, Neibs, Vertex, Transpose).
transpose_s([], [], _, []).
% p_member(X, Y, P_Graph)
% tests whether the edge (X,Y) occurs in the graph. This always
% costs O(|E|) time. Here, as in all the operations in this file,
% vertex labels are assumed to be ground terms, or at least to be
% sufficiently instantiated that no two of them have a common instance.
p_member(X, Y, P_Graph) :-
nonvar(X), nonvar(Y), !,
memberchk(X-Y, P_Graph).
p_member(X, Y, P_Graph) :-
member(X-Y, P_Graph).
% s_member(X, Y, S_Graph)
% tests whether the edge (X,Y) occurs in the graph. If either
% X or Y is instantiated, the check is order |V| rather than
% order |E|.
s_member(X, Y, S_Graph) :-
var(X), var(Y), !,
member(X-Neibs, S_Graph),
member(Y, Neibs).
s_member(X, Y, S_Graph) :-
var(X), !,
member(X-Neibs, S_Graph),
memberchk(Y, Neibs).
s_member(X, Y, S_Graph) :-
var(Y), !,
memberchk(X-Neibs, S_Graph),
member(Y, Neibs).
s_member(X, Y, S_Graph) :-
memberchk(X-Neibs, S_Graph),
memberchk(Y, Neibs).
% compose(G1, G2, Composition)
% calculates the composition of two S-form graphs, which need not
% have the same set of vertices.
compose(G1, G2, Composition) :-
vertices(G1, V1),
vertices(G2, V2),
ord_union(V1, V2, V),
compose(V, G1, G2, Composition).
compose([], _, _, []) :- !.
compose([Vertex|Vertices], [Vertex-Neibs|G1], G2, [Vertex-Comp|Composition]) :- !,
compose1(Neibs, G2, [], Comp),
compose(Vertices, G1, G2, Composition).
compose([Vertex|Vertices], G1, G2, [Vertex-[]|Composition]) :-
compose(Vertices, G1, G2, Composition).
compose1([V1|Vs1], [V2-N2|G2], SoFar, Comp) :-
compare(Rel, V1, V2), !,
compose1(Rel, V1, Vs1, V2, N2, G2, SoFar, Comp).
compose1(_, _, Comp, Comp).
compose1(<, _, Vs1, V2, N2, G2, SoFar, Comp) :- !,
compose1(Vs1, [V2-N2|G2], SoFar, Comp).
compose1(>, V1, Vs1, _, _, G2, SoFar, Comp) :- !,
compose1([V1|Vs1], G2, SoFar, Comp).
compose1(=, V1, Vs1, V1, N2, G2, SoFar, Comp) :-
ord_union(N2, SoFar, Next),
compose1(Vs1, G2, Next, Comp).
/* NOT USED AFTER ALL
% raakau(Vertices, InitialValue, Tree)
% takes an *ordered* list of verticies and an initial value, and
% makes a very special sort of tree out of them, which represents
% a function sending each vertex to the initial value. Note that
% in the third clause for raakau/6 Z can never be 0, this means
% that it doesn't matter *what* "greatest member" is reported for
% empty trees.
raakau(Vertices, InitialValue, Tree) :-
length(Vertices, N),
raakau(N, Vertices, _, _, InitialValue, Tree).
raakau(0, Vs, Vs, 0, I, t) :- !.
raakau(1, [V|Vs], Vs, V, I, t(V,I)) :- !.
raakau(N, Vi, Vo, W, I, t(V,W,I,L,R)) :-
A is (N-1)/2,
Z is (N-1)-A, % Z >= 1
raakau(A, Vi, [V|Vm], _, I, L),
raakau(Z, Vm, Vo, W, I, R).
% incdec(OldTree, Labels, Incr, NewTree)
% adds Incr to the value associated with each element of Labels
% in OldTree, producing a new tree. OldTree must have been produced
% either by raakau or by incdec, Labels must be in ascedning order,
% and must be a subset of the labels of the tree.
incdec(OldTree, Labels, Incr, NewTree) :-
incdec(OldTree, NewTree, Labels, _, Incr).
incdec(t(V,M), t(V,N), [V|L], L, I) :- !,
N is M+I.
incdec(t(V,W,M,L1,R1), t(V,W,N,L2,R2), Li, Lo, I) :-
( Li = [Hi|_], Hi @< V, !,
incdec(L1, L2, Li, Lm, I)
; L2 = L1, Lm = Li
),
( Lm = [V|Lr], !,
N is M+I
; Lr = Lm, N = M
),
( Lr = [Hr|_], Hr @=< W, !,
incdec(R1, R2, Lr, Lo, I)
; R2 = R1, Lo = Lr
).
/* END UNUSED CODE */
top_sort(Graph, Sorted) :-
vertices_and_zeros(Graph, Vertices, Counts0),
count_edges(Graph, Vertices, Counts0, Counts1),
select_zeros(Counts1, Vertices, Zeros),
top_sort(Zeros, Sorted, Graph, Vertices, Counts1).
vertices_and_zeros([], [], []) :- !.
vertices_and_zeros([Vertex-_|Graph], [Vertex|Vertices], [0|Zeros]) :-
vertices_and_zeros(Graph, Vertices, Zeros).
count_edges([], _, Counts, Counts) :- !.
count_edges([_-Neibs|Graph], Vertices, Counts0, Counts2) :-
incr_list(Neibs, Vertices, Counts0, Counts1),
count_edges(Graph, Vertices, Counts1, Counts2).
incr_list([], _, Counts, Counts) :- !.
incr_list([V1|Neibs], [V2|Vertices], [M|Counts0], [N|Counts1]) :- V1 == V2, !,
N is M+1,
incr_list(Neibs, Vertices, Counts0, Counts1).
incr_list(Neibs, [_|Vertices], [N|Counts0], [N|Counts1]) :-
incr_list(Neibs, Vertices, Counts0, Counts1).
select_zeros([], [], []) :- !.
select_zeros([0|Counts], [Vertex|Vertices], [Vertex|Zeros]) :- !,
select_zeros(Counts, Vertices, Zeros).
select_zeros([_|Counts], [_|Vertices], Zeros) :-
select_zeros(Counts, Vertices, Zeros).
top_sort([], [], Graph, _, Counts) :- !,
vertices_and_zeros(Graph, _, Counts).
top_sort([Zero|Zeros], [Zero|Sorted], Graph, Vertices, Counts1) :-
graph_memberchk(Zero-Neibs, Graph),
decr_list(Neibs, Vertices, Counts1, Counts2, Zeros, NewZeros),
top_sort(NewZeros, Sorted, Graph, Vertices, Counts2).
graph_memberchk(Element1-Edges, [Element2-Edges2|_]) :- Element1 == Element2, !,
Edges = Edges2.
graph_memberchk(Element, [_|Rest]) :-
graph_memberchk(Element, Rest).
decr_list([], _, Counts, Counts, Zeros, Zeros) :- !.
decr_list([V1|Neibs], [V2|Vertices], [1|Counts1], [0|Counts2], Zi, Zo) :- V1 == V2, !,
decr_list(Neibs, Vertices, Counts1, Counts2, [V2|Zi], Zo).
decr_list([V1|Neibs], [V2|Vertices], [N|Counts1], [M|Counts2], Zi, Zo) :- V1 == V2, !,
M is N-1,
decr_list(Neibs, Vertices, Counts1, Counts2, Zi, Zo).
decr_list(Neibs, [_|Vertices], [N|Counts1], [N|Counts2], Zi, Zo) :-
decr_list(Neibs, Vertices, Counts1, Counts2, Zi, Zo).
neighbors(V,[V0-Neig|_],Neig) :- V == V0, !.
neighbors(V,[_|G],Neig) :-
neighbors(V,G,Neig).
neighbours(V,[V0-Neig|_],Neig) :- V == V0, !.
neighbours(V,[_|G],Neig) :-
neighbours(V,G,Neig).
%
% Simple two-step algorithm. You could be smarter, I suppose.
%
complement(G, NG) :-
vertices(G,Vs),
complement(G,Vs,NG).
complement([], _, []).
complement([V-Ns|G], Vs, [V-INs|NG]) :-
ord_add_element(Ns,V,Ns1),
ord_subtract(Vs,Ns1,INs),
complement(G, Vs, NG).