spcompat.pl

来自「SRI international 发布的OAA框架软件」· PL 代码 · 共 1,075 行 · 第 1/3 页

% are structures of the form timeval(Seconds,Microseconds). Which is a bit
% of a pain, but there we are.

tcp_now(timeval(Secs,Micros)) :-
  statistics(walltime,[Millis|_]),
  Secs is Millis // 1000,
  Micros is 1000*(Millis-1000*Secs).

tcp_time_plus(TV1,Delta,TV2) :-
  ground(TV1),
  ground(Delta),
  !,
  TV1=timeval(Secs1,Micros1),
  Micros1a is Micros1+integer(0.5+Delta*1000000),
  Secs2 is Secs1 + Micros1a // 1000000,
  Micros2 is Micros1a - 1000000*(Secs2-Secs1),
  TV2=timeval(Secs2,Micros2).
tcp_time_plus(TV1,Delta,TV2) :-
  ground(TV2),
  ground(Delta),
  !,
  TV2=timeval(Secs2,Micros2),
  Micros2a is Micros2-integer(0.5+Delta*1000000),
  (Micros2a >= 0 -> 
     TV1=timeval(Secs2,Micros2a);
   Secs1 is Secs2 + (Micros2a+1) // 1000000 -1,
     Micros1 is Micros2a + 1000000*(Secs2-Secs1),
     TV1=timeval(Secs1,Micros1)).
tcp_time_plus(TV1,Delta,TV2) :-
  ground(TV1),
  ground(TV2),
  !,
  TV1=timeval(Secs1,Micros1),
  TV2=timeval(Secs2,Micros2),
  Delta is Secs2-Secs1 + (Micros2-Micros1)/1000000.
% This should probably raise another exception...
tcp_time_plus(TV1,Delta,TV2) :-
  raise_exception(bad_arguments(tcp_time_plus(TV1,Delta,TV2))).

% We maintain the wakeups in a sorted list so tcp_scheduled_wakeup
% (and tcp_select) are relatively efficient. The price is that
% scheduling and cancelling wakeups is a bit less efficient, but
% we assume checking will be more frequent than setting.

tcp_schedule_wakeup(Timeval,Term) :-
  (retract(tcp_scheduled_wakeups(Existing)) ->
     sort([wakeup(Timeval,Term)|Existing],New);
   New=[wakeup(Timeval,Term)]),
  assert(tcp_scheduled_wakeups(New)).

tcp_scheduled_wakeup(Timeval,Term) :-
  tcp_scheduled_wakeups(List),
  member(wakeup(Timeval,Term),List).

tcp_cancel_wakeup(Timeval,Term) :-
  tcp_scheduled_wakeups(Existing),
  append(Pre,[wakeup(Timeval,Term)|Post],Existing),
  !,
  retract(tcp_scheduled_wakeups(_)),
  append(Pre,Post,New),
  assert(tcp_scheduled_wakeups(New)).

tcp_cancel_wakeups :-
  retractall(tcp_scheduled_wakeups(_)).

% This can be used to test wakeups are working. A call such as
%   tcp_test_wakeup_mechanism(2.8,11.2).
% sets a wakeup for 2.8 seconds time, then calls tcp_select with a
% timeout of 11.2 seconds. X should get returned as wakeup(foo), not
% timeout, after 2.8 seconds. If the numbers are reversed, we should
% get a timeout instead.

tcp_test_wakeup_mechanism(WakeupSecs,TimeoutSecs) :-
  (bad_timeout_value(WakeupSecs);
   bad_timeout_value(TimeoutSecs)),
  !.
tcp_test_wakeup_mechanism(WakeupSecs,TimeoutSecs) :-
  format('~N~nTesting Sicstus TCP wakeup mechanism emulator.~n',[]),
  format('~NWakeup time is ~w, and timeout time is ~w.~n',
         [WakeupSecs,TimeoutSecs]),
  (TimeoutSecs = 0 ->
     format('~NA timeout time of 0 seconds means no timeout.~n',[]);
   true),
  (WakeupSecs > TimeoutSecs, TimeoutSecs > 0 -> 
     format('~NHmm...we expect a timeout, as it precedes the wakeup.~n',[]),
     MinSecs=TimeoutSecs,
     Expect=timeout;
   MinSecs=WakeupSecs,
     format('~NHmm...we expect a wakeup, as it precedes the timeout.~n',[]),
     Expect=wakeup(foo)),
  format('Setting the wakeup...~n',[]),
  tcp_cancel_wakeups,
  tcp_now(Now),
  tcp_time_plus(Now,WakeupSecs,Then),
  tcp_schedule_wakeup(Then,foo),
  format('~NCalling tcp_select/2, which should return "~w".~n',[Expect]),
  format('Please wait ~w seconds...~n',[MinSecs]),
  tcp_select(TimeoutSecs,X),
  format('~Ntcp_select/2 returned "~w".~n',[X]),
  (X == Expect -> format('~NGood, that''s what I expected.~n',[]);
   format('That''s bad. It should have returned "~w"~n',[Expect])),
  !.
tcp_test_wakeup_mechanism(_,_) :-
  format('~NOh, dear. This predicate really shouldn''t fail.~n',[]),
  fail.

% Check the times offered are sensible...

bad_timeout_value(Val) :-
  \+((number(Val),Val>=0)),
  !,
  format('~NBad value "~w": it should be a positive number (of seconds).',[Val]).
bad_timeout_value(Val) :-
  Val > 500,
  !,
  format('~NBad value "~w": do you really want to wait for ~w seconds?~n',
         [Val,Val]).

% ------------------------------------------------------------------------

% Part of Quintus library(strings)...

concat(X, Y, Z) :-
  atom_chars(X, XCs),
  atom_chars(Y, YCs),
  append(XCs, YCs, ZCs),
  atom_chars(Z, ZCs).

:- dynamic gensym_ctr/1.
gensym_ctr(0).

gensym(Prefix, Sym) :-
  gensym_ctr(N),
  M is N + 1,
  retractall(gensym_ctr(_)),
  assert(gensym_ctr(M)),
  number_chars(M, NChars),
  atom_chars(Prefix, PChars),
  append(PChars, NChars, Chars),
  atom_chars(Sym, Chars).

% @@Needs to be completed!
span_trim(X, X).

% ------------------------------------------------------------------------

% Part of Quintus library(system)...

unix(argv(Args)) :-
  prolog_flag(argv,Args).

% ------------------------------------------------------------------------

% Simulate the effect of Quintus load_files(File,[all_dynamic(true)]).

load_all_dynamic(File) :-
  open(File,read,S),
  % Character escapes (e.g., \n) are *not* employed in ICL expressions.
  % (icldataq, among other things, depends on this.)
  % We assume that files loaded here might contain ICL expressions,
  % and so should follow the same convention.
  prolog_flag(character_escapes,CE,off),
  repeat,
  read(S,Term),
  (Term == end_of_file;
   Term = (:- multifile(_)) -> fail;
   Term = (:- dynamic(_)) -> fail;
   Term = (:-(Goal)) -> call(Goal),fail;
   assertz(Term),fail),
   prolog_flag(character_escapes,_,CE),
  !.

% ------------------------------------------------------------------------

% Emulate ask_oneof/3 in Quintus library ask.pl.

ask_oneof(Prompt,Constants,Answer) :-
  current_output(CO),
  format('~N~w: ',[Prompt]),
  flush_output(CO),
  read_line_of_chars(Chars),
  findall(Constant,
          (member(Constant,Constants),
           atom_chars(Constant,CChars),
           append(Chars,_,CChars)),
          Matches),
  (Matches=[Answer] -> true;
   ask_oneof(Prompt,Constants,Answer)).

read_line_of_chars(Chars) :-
  get0(C),
  (C = 10 -> Chars=[];
   C < 0 -> Chars=[];
   Chars=[C|Rest],
     read_line_of_chars(Rest)).

ask_number(Prompt,Default,Answer) :-
    current_output(CO),
  format('~N~w [~w]: ',[Prompt,Default]),
  flush_output(CO),
  read_line_of_chars(Chars),
  (number_chars(Answer,Chars) -> true;
   ask_number(Prompt,Default,Answer)).

% ------------------------------------------------------------------------

% Emulate part of Quintus library(sets)...

union([List],List) :-
  !.
union([List|Lists],Union) :-
  union(Lists,Union1),
  union(List,Union1,Union).

union([],Set,Set).
union([E|Set1],Set2,[E|Set12]) :-
  \+(memberchk(E,Set2)),
  !,
  union(Set1,Set2,Set12).
union([_|Set1],Set2,Set12) :-
  union(Set1,Set2,Set12).

%   intersect(+Set1, +Set2)
%   is true when the two sets have a member in common.
%   You should ensure that the arguments are proper lists.

intersect(Set1, Set2) :-
        member(Element, Set1),          %  generates Elements from Set1
        memberchk(Element, Set2),       %  tests them against Set2
        !.                              %  if it succeeds once, is enough.

%   intersection(+Set1, +Set2, ?Intersection)
%   is true when all three arguments are lists representing sets,
%   and Intersection contains every element of Set1 which is also
%   an element of Set2, the order of elements in Intersection
%   being the same as in Set1.  

intersection([], _, []).
intersection([Element|Elements], Set, Intersection) :-
        memberchk(Element, Set),
        !,
        Intersection = [Element|Rest],
        intersection(Elements, Set, Rest).
intersection([_|Elements], Set, Intersection) :-
        intersection(Elements, Set, Intersection).


%   intersection(+ListOfSets, ?Intersection)
%   is true when Intersection is the intersection of all the sets in
%   ListOfSets.  The order of elements in Intersection is taken from
%   the first set in ListOfSets.

intersection([Set|Sets], Intersection) :-
        intersection1(Set, Sets, Intersection).

intersection1([], _, []).
intersection1([Element|Elements], Sets, Intersection) :-
        memberchk_all(Sets, Element),
        !,
        Intersection = [Element|Rest],
        intersection1(Elements, Sets, Rest).
intersection1([_|Elements], Sets, Intersection) :-
        intersection1(Elements, Sets, Intersection).

memberchk_all([], _).
memberchk_all([Set|Sets], Element) :-
        memberchk(Element, Set),
        memberchk_all(Sets, Element).

%   subtract(+Set1, +Set2, ?Difference)
%   is like intersection, but this time it is the elements of Set1 which
%   *are* in Set2 that are deleted.

subtract([], _, []).
subtract([Element|Residue], Set, Difference) :-
        memberchk(Element, Set), !,
        subtract(Residue, Set, Difference).
subtract([Element|Residue], Set, [Element|Difference]) :-
        subtract(Residue, Set, Difference).

subset([], _).
subset([Element|Residue], Set) :-
    memberchk(Element, Set),
    subset(Residue, Set).

%# EXTRA STUFF FOR OAA V2

tcp_inet_addr(Host,IPNum) :-
  hostname_address(Host,IPNum).

%# NOTE: there is an incompatibility here. now/1 under Quintus returns
%# the number of seconds since January 1st 1970. But this is only used
%# to provide the third argument of oaa_data_ref/3, and that argument
%# never seems to be used. So I'm providing an increasing function of time
%# as a lazy way out. DMC.

/* Now provided by Sicstus (starting with 3.9.0) */
:- ( current_predicate(now, system:now(_)) ->
        true
   | otherwise ->
        assert((now(When) :-
	        statistics(walltime,[When|_])))
   ).  

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%   samsort(+Compare, +List, ?Sorted)
%     Derived from Richard O'Keefe's samsort routine, which was
%     placed in the public domain as part of the Edinburgh Prolog Tools.
%     Compare is the functor of a 2-argument predicate, which 
%     succeeds IFF Arg1 =< Arg2.

samsort(Compare, List, Sorted) :-
        samsort(List, Compare, [], 0, Sorted).

samsort([], Compare, Stack, _, Sorted) :-
        samfuse(Stack, Compare, Sorted).
samsort([Head|Tail], Compare, Stack, R, Sorted) :-
        sam_run(Tail, [Head|Queue], [Head|Queue], Compare, Run, Rest),
        S is R+1,
        samfuse(Stack, Run, Compare, S, NewStack),
        samsort(Rest, Compare, NewStack, S, Sorted).


samfuse([], _, []).
samfuse([Run|Stack], Compare, Sorted) :-
        samfuse(Stack, Run, Compare, 0, [Sorted]).

samfuse([B|Rest], A, Compare, K, Ans) :-
        0 is K /\ 1,
        !,
        J is K >> 1,
        sammerge(B, A, Compare, C),
        samfuse(Rest, C, Compare, J, Ans).
samfuse(Stack, Run, _, _, [Run|Stack]).

sam_run([], Run, [_], _, Run, []).
sam_run([Head|Tail], QH, QT, Compare, Run, Rest) :-
        sam_run(QH, QT, Head, Tail, Compare, Run, Rest).

sam_run(Qh, [Last|Qt], Head, Tail, Compare, Run, Rest) :-
        call_compare(Compare, Last, Head),
        !,
        Qt = [Head|_],
        sam_run(Tail, Qh, Qt, Compare, Run, Rest).
sam_run(Run, [_], Head, Tail, Compare, Run, [Head|Tail]) :-
        Run = [H|_],
	call_compare(Compare, H, Head),
        !.
sam_run(Qh, Qt, Head, Tail, Compare, Run, Rest) :-
        sam_run(Tail, [Head|Qh], Qt, Compare, Run, Rest).

sammerge(List1, [], _, List1) :- !.
sammerge([], List2, _, List2) :- !.
sammerge([Head1|Tail1], [Head2|Tail2], Compare, [Head1|Merged]) :-
        call_compare(Compare, Head1, Head2),
        !,
        sammerge(Tail1, [Head2|Tail2], Compare, Merged).
sammerge(List1, [Head2|Tail2], Compare, [Head2|Merged]) :-