home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / SOURCE / BUILT_IN.LF < prev    next >
Text File  |  1996-06-04  |  25KB  |  945 lines
  1. % Copyright 1991 Digital Equipment Corporation.
  2. % All Rights Reserved.
  3. %
  4. % The BUILT_IN module
  5. %
  6. % This file should not be modified by the user.
  7. %
  8. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  9. %    $Id: built_ins.lf.in,v 1.2 1996/01/17 00:47:28 vorbeck Exp $    
  10.  
  11. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  12. %
  13. % Declarations
  14. %
  15. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  16.  
  17. %%% public built_ins
  18.  
  19. public(trace_input, query, declaration, error, abort, aborthook,abs, append,
  20.        apply, asc, assert, asserta, bagof, beep, begin_raw, bool,
  21.        bool_pred,bi_load_path, call_once,
  22.        call_handler, ceiling, children, chr, clause,
  23.        close, cond, cons, copy_pointer, copy_rules, copy_term, cos, cpu_time,
  24.        current_module, delay_check, disj, display_module_status,
  25.        display_modules, dynamic, end_raw, eval, evalin, exists_file,
  26.        exists_choice, exp, fail, false, features, floor, fx, fy, gc, genint,
  27.        get, get_choice, get_raw, glb, halt, has_feature, implies, in_raw,
  28.        inherited_modules, init, initrandom, input_file, int, int2str,
  29.        is_function, is_number, is_predicate, is_sort, is_value, least_sorts,
  30.        length,life_ext, list, listing, load, load_module,
  31.        load_path,load_suffixes, loaded_file, local_time, log, lub, map, maprel,
  32.        max, maxint, member, min, module, mresiduate, nil, nl, nl_err,
  33.        non_strict, nonvar, op, open, open_in, open_modules, open_out, ops,
  34.        % not, PVR 10.2.94
  35.        page_width, parents, parse, pause, pretty_write, pretty_writeq,
  36.        print_codes, print_depth, print_variables, private, project,
  37.        psi2str, public, put, put_err, put_raw, random, read, read_token, real,
  38.        real_time, reduce, repeat, reset_window_flag, residuate, retract, rlist,
  39.        root_sort, run, set_choice, set_input, set_output, setq, simple_load,
  40.        sin, sqrt, static, statistics, step, str, str2psi, strcon, string,
  41.        strip, strlen, strval, subsort, substr, succeed,system, tan,
  42.        time, tprove, trace, true, undo, var, verbose, window_flag,
  43.        write, write_canonical, write_err, writeq, writeq_err, import,
  44.        % xor, PVR 10.2.94
  45.        substitute,is_persistent, global, persistent, display_persistent, alias,
  46.        bestof, % RM: Apr 15 1993
  47.        private_feature, % RM: Mar 11 1993
  48.        split_double,     % RM: Jun 29 1993
  49.        string_address,    % RM: Jul 6 1993
  50.        deref_length,     % RM: Jul 15 1993
  51.        argv,             % RM: Sep 20 1993  PVR 11.2.94
  52.        public_symbols,    % RM: Jan 28 1994
  53.        chdir,         % RM: Feb 10 1994
  54.        getenv,         % RM: Feb 10 1994
  55.        module_name,    % RM: Feb 16 1994
  56.        combined_name,    % RM: Feb 16 1994
  57.        quiet,           % BD: Feb 17 1994
  58.        feature_values)?
  59.  
  60. %%% These are considered private:
  61. %%% '*** ERROR ***', '<NULL PSI TERM>',
  62. %%% bottom,comment,constant,variable,init
  63.  
  64. private(c_op)? % RM: Feb 24 1993
  65.  
  66.  
  67. %%% Operators
  68.  
  69. % c_op(300,yfx,mod)? PVR 24.2.94
  70.  
  71.  
  72. %%% Built-in sorts.
  73.  
  74. cons <| list.
  75. nil <| list.
  76. list <| built_in.
  77.  
  78. string <| built_in.
  79.  
  80. real <| built_in.
  81. int <| real.
  82.  
  83. bool <| built_in.
  84. true <| bool.
  85. false <| bool.
  86.  
  87. %%% non strict declarations
  88.  
  89. non_strict(non_strict)?
  90. non_strict(dynamic)?
  91. non_strict(static)?
  92. non_strict(delay_check)?
  93. non_strict(listing)?
  94. non_strict(evalin)?
  95. non_strict(eval)?
  96. non_strict(global) ?           %% BD 3.3.94
  97. non_strict(persistent) ?       %% BD 3.3.94
  98.  
  99. %%% SYSTEM MODULE
  100.  
  101. built_ins#set_module("sys")?
  102. built_ins#open_module("syntax")?
  103.  
  104. built_ins#public
  105.     (bitvector,regexp,stream,file_stream,socket_stream,
  106.      make_bitvector,bitvector_and,bitvector_or,bitvector_xor,
  107.      bitvector_not,bitvector_count,bitvector_get,bitvector_set,
  108.      bitvector_clear,
  109.      regexp_compile,regexp_execute,
  110.      fopen,fclose,get_buffer,get_record,get_code,ftell,fseek,
  111.      socket,bind,connect,fwrite,fflush,listen,accept,
  112.      errno,errmsg,
  113.      import_symbol,
  114.      process_no_children,process_exited,process_signaled,
  115.      process_stopped,process_continued,
  116.      fork,wait,waitpid,kill,int2stream,stdin,stdout,stderr,
  117.      cuserid,gethostname,lazy_project,wait_on_feature,my_wait_on_feature,
  118.      apply1,getpid,ftruncate,stream2sys_stream,sys_stream2stream
  119.      @DBM_LF@
  120. )?
  121.  
  122. % built_ins#non_strict(wait_on_feature)?
  123.  
  124. bytedata  <| built_ins#built_in. % DENYS: BYTEDATA
  125. bitvector <| bytedata.
  126. regexp    <| bytedata.
  127. stream    <| bytedata.
  128. file_stream   <| stream.
  129. socket_stream <| stream.
  130.  
  131. built_ins#global(stdin  <- int2stream(0,"r")&file_stream)?
  132. built_ins#global(stdout <- int2stream(1,"w")&file_stream)?
  133. built_ins#global(stderr <- int2stream(2,"w")&file_stream)?
  134.  
  135. built_ins#persistent(string_out)?
  136. string_out <<-
  137.     S:fopen(Path:built_ins#strcon("/tmp/.life",
  138.                       built_ins#psi2str(getpid)),"w+")
  139.     |
  140.     0=built_ins#system(built_ins#strcon("rm ",Path)),%unlink was non portable
  141.     S.stream = sys_stream2stream(S),
  142.     S.stdout = (O|built_ins#open_out("stdout",O))?
  143.  
  144. psi2string(X) -> S | psi2stringX(X,S).
  145.  
  146. psi2stringX(X,S) :-
  147.     fseek(O:string_out,0),
  148.     built_ins#set_output(O.stream),
  149.     built_ins#writeq(X),
  150.     fflush(O),
  151.     built_ins#set_output(O.stdout),
  152.     N=ftell(O),
  153.     fseek(O,0),
  154.     S=get_buffer(O,N).
  155.  
  156. built_ins#public(psi2string)?
  157.  
  158. built_ins#set_module("built_ins")?
  159.  
  160. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  161.  
  162. %%%  For correct operation of the interpreter, nothing before this line should
  163. %%%  be modified.  What comes after is used for definition of built-ins and can
  164. %%%  be edited (albeit very carefully).
  165.  
  166. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  167.  
  168.  
  169. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  170. %
  171. % System built-ins
  172. %
  173. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  174.  
  175. %%% call once must be a boolean function for use in cond
  176. %non_strict(call_once)?                              %% DENYS Jan 25 1995
  177. %call_once(G) -> T | (evalin(G),T=true;T=false),!. %% DENYS Jan 25 1995
  178.  
  179. %%% A more useful listing predicate from the c_listing built-in.
  180.  
  181. non_strict(listing)?
  182. X:listing :-
  183.     %%    trace(T,U),   % RM: Dec  9 1992 
  184.     listing_2(features(X), X).
  185.     %%    trace(T,U).
  186.  
  187. listing_2([],    _) :- !.
  188. listing_2([F],   X) :- !, nl, listing_3(F, X).
  189. listing_2([F|L], X) :- nl, listing_3(F, X), listing_2(L, X).
  190.  
  191. listing_3(F, X) :- P=X.F, c_listing(P), listing_4(P).
  192.  
  193. listing_4(P) :- var(P), !,
  194.         write("% '@' is the top sort."), nl.
  195. %% listing_4(P:int)    :- !, listing_4a(int).
  196. %% listing_4(P:real)   :- !, listing_4a(real).
  197. %% listing_4(P:string) :- !, listing_4a(string).
  198. listing_4(P) :- listing_4a(P).
  199.  
  200. listing_4a(P) :- is_sort(P), is_value(P)=false, !, 
  201.     listing_5(parents(P), P),
  202.         listing_6(children(P), P).
  203.     % write("% Parents: "),writeq(parents(P)), nl,
  204.     % write("% Children: "),writeq(children(P)), nl.
  205.  
  206.  
  207. listing_4a(_).
  208.  
  209. listing_5([], _) :- !.
  210. listing_5([X|Xs], Y) :-
  211.     writeq(Y), write(" <| "), writeq(X), write("."), nl,
  212.     listing_5(Xs, Y).
  213.  
  214. listing_6([], _) :- !.
  215. listing_6([X|Xs], Y) :-
  216.     writeq(X), write(" <| "), writeq(Y), write("."), nl,
  217.     listing_6(Xs, Y).
  218.  
  219.  
  220. %%% An op predicate that handles any pattern of arguments. 
  221.  
  222. non_strict(op)?
  223. op(P,K,F,precedence=>P,kind=>K,functor=>F) :-
  224.     trace(T,U),
  225.     ( op_2(P,K,F), trace(T,U)
  226.     ; trace(T,U), fail
  227.     ).
  228.  
  229. op_2(P,K,F) :- nonvar(P), nonvar(K), nonvar(F), F=list, !, op_3(F,P,K).
  230. op_2(P,K,F) :- nonvar(F), F=list, !,
  231.     write_err("*** Error: invalid operator declaration."),
  232.     nl_err.
  233. op_2(P,K,F) :- nonvar(P), nonvar(K), nonvar(F), !, c_op(P,K,F).
  234. op_2(P,K,F) :- member(op(P,K,F),ops).
  235.  
  236. % List of operators.
  237. op_3([]) :- !.
  238. op_3([H|T],P,K) :- op_2(P,K,H),op_3(T,P,K).
  239.  
  240.  
  241. %%% Default call handler.
  242. %%% This is called for predicates that have no definition.
  243. %%% More sophisticated call handlers can be written to do auto-loading
  244. %%% of undefined predicates.
  245.  
  246. call_handler(P) :- is_sort(P), !,
  247.     write_err("*** Error: the sort '"),writeq_err(P),
  248.         write_err("' occurs where a predicate or function is expected."),
  249.     nl_err, abort.
  250. call_handler(P) :- !,
  251.     write_err("*** Error: '"),writeq_err(P),
  252.         write_err("' is not a predicate or a function."), nl_err,
  253.     abort.
  254.  
  255.  
  256. %%% Pause for N seconds.
  257. pause(N) :-
  258.     S=real_time,
  259.     repeat,
  260.     real_time-S>N,
  261.     !.
  262.  
  263. %%% Time a goal (whether it succeeds or fails).
  264. run(G) :-
  265.     S=cpu_time,
  266.     (G;succeed),
  267.     !,
  268.     write("Time = ",cpu_time-S," sec"),
  269.     nl.
  270.  
  271.  
  272. %%% Personal customizing.
  273.  
  274. init :-
  275.     exists_file("./.wild_life"),
  276.     simple_load("./.wild_life"),
  277.     quiet_write("Loaded customizing file from current directory."),
  278.     !.
  279.  
  280. init :-
  281.     exists_file("~/.wild_life"),
  282.     simple_load("~/.wild_life"),
  283.     quiet_write("Loaded customizing file from home directory."),
  284.     !.
  285.  
  286. init :-
  287.     quiet_write("No customizing file loaded."),
  288.     !.
  289.  
  290. %% init :-                                        %% was in .set_up
  291. %%     exists_file("+SETUPDIR+/.wild_life"),
  292. %%     simple_load("+SETUPDIR+/.wild_life"),
  293. %%     write("Loaded default customizing file."), nl
  294. %%     !.
  295.  
  296. init :-
  297.     write_err("*** Warning: couldn't access any customizing file."),
  298.     nl_err.
  299.  
  300.  
  301. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  302. %
  303. % Input-Output
  304. %
  305. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  306.  
  307. %%% Newline
  308.  
  309. nl :- write("
  310. ").
  311.  
  312. nl_err :- write_err("
  313. ").
  314.  
  315.  
  316. %%% Beep
  317.  
  318. beep :- put(7).
  319.  
  320.  
  321. %%% Quiet writing for support of '-q' option
  322. %%% This built-in doesn't write anything if the '-q' option is enabled.
  323. %%% 21.1 & RM: Feb 17 1993 
  324.  
  325. quiet_write :- quiet, !.
  326. S:quiet_write :- quiet_write_loop(features(S),S), nl.
  327.  
  328. quiet_write_loop([]) :- !.
  329. quiet_write_loop([X|L], S) :-
  330.     write(S.X),
  331.     quiet_write_loop(L, S).
  332.  
  333.  
  334.  
  335. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  336. %
  337. % Loading Files
  338. %
  339. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  340.  
  341. %%% A very useful load that searches a path, does suffix completion,
  342. %%% and remembers if a file has already been loaded.
  343. %%% The default path may be extended by an optional user-defined function
  344. %%% load_path that gives a disjunction of directories to search in.
  345. %%% The set of default suffixes may be extended by an optional user-defined
  346. %%% function load_suffixes that gives a disjunction of suffixes.
  347. %%% This predicate accepts an arbitrary number of arguments.
  348.  
  349. persistent(load_option,top_load,loading) ?
  350. load_option <<- false ?
  351. loading <<- false ?
  352.  
  353. non_strict(load)?
  354. X:load :-
  355.     CM = current_module,
  356.     F = features(X),
  357.     (
  358.         loading,!,
  359.         load_2(F,X)
  360.     ;
  361.         loading <<- true,
  362.         top_load <<- get_choice,
  363.         load_2(F,X),!,loading <<- false
  364.     ;
  365.         open_out("stdout",_),
  366.         open_in("stdin",_),
  367.         set_module(CM),
  368.         loading <<- false,
  369.         fail
  370.     ).
  371.  
  372. load_2([F|L],X) :-
  373.     (
  374.         find_file(X.F,CF),!,
  375.         (
  376.         has_feature(CF,consulted,Bool),!,
  377.         quiet_write("*** File """,CF,""" is already loaded.")
  378.         ;
  379.         quiet_write("*** Loading File """,CF,""""),
  380.         first_load(CF)
  381.         ),
  382.         load_2(L,X)
  383.     ;
  384.         set_choice(top_load),fail
  385.     ).
  386. load_2([]).
  387.  
  388. first_load(CF) :-
  389.     (
  390.         load_option,!,
  391.         consulted.CF <<- true,
  392.         simple_exp_load(CF)
  393.     ;
  394.         consulted.CF <<- false,
  395.         simple_load(CF)
  396.     ).
  397.  
  398. find_file(F:string,CF) :-
  399.     !,
  400.         (
  401.         CF=strcon(bi_load_path,
  402.               strcon(F,
  403.                  life_ext)),
  404.         exists_file(CF), !
  405.     ;
  406.         write_err("*** File """,F,""" not found."),nl_err,
  407.         fail 
  408.     ).
  409. find_file(F) :-
  410.     write_err("*** Error: File name "),
  411.     writeq_err(F),
  412.     write_err(" should be a string."),
  413.     nl_err,
  414.     fail.
  415.  
  416. bi_load_path ->  {
  417.              ""
  418.                  ;
  419.              strcon((load_path | is_function(`load_path)),
  420.                 %% {"";"/"}
  421.                 "/"
  422.                )
  423.          ;
  424.              lib_dir
  425.          ;
  426.              tools_dir
  427.                  ; %% "+SETUPDIR+/Examples/"   % BD June 10 1993
  428.              examples_dir
  429.          ;
  430.              superlint_dir
  431.          ; %% For the Demo Directory   % MJV January 16 1996
  432.              demo_dir
  433.          }.
  434.  
  435. %%% The user may define a function load_suffixes that returns a
  436. %%% disjunction of other suffixes to be used.
  437. life_ext -> { ".lf"
  438.             ; ""
  439.         ; (load_suffixes | is_function(`load_suffixes))
  440.         ; ".life"
  441.         }.
  442.  
  443.  
  444. %%% reconsult facility
  445.  
  446. public(reconsult) ?
  447.  
  448. non_strict(reconsult)?
  449.  
  450. X:reconsult :-
  451.     CM = current_module,
  452.     F = features(X),
  453.     (
  454.         loading,!,
  455.         reconsult_2(F,X)
  456.     ;
  457.         loading <<- true,
  458.         top_load <<- get_choice,
  459.         reconsult_2(F,X),!,loading <<- false
  460.     ;
  461.         open_out("stdout",_),
  462.         open_in("stdin",_),
  463.         set_module(CM),
  464.         loading <<- false,
  465.         fail
  466.     ).
  467.  
  468. reconsult_2([F|L],X) :-
  469.     find_file(X.F,CF),!,
  470.     (
  471.         has_feature(CF,consulted,Bool),!,
  472.         (
  473.         Bool,!,
  474.         reload(CF,Bool)
  475.         ;
  476.         write_err("*** File """,CF,""" cannot be reconsulted."),
  477.         nl_err
  478.         )
  479.     ;
  480.         quiet_write("*** Loading File """,CF,""""),
  481.         first_load(CF)
  482.     ),
  483.     reconsult_2(L,X).
  484. reconsult_2([]).
  485.  
  486.  
  487. reload(CF,Bool) :-
  488.     retract_file(Bool),
  489.     quiet_write("*** Reconsulting File """,CF,""""),
  490.     quiet_write(" "),
  491.     quiet_write("*** Warning: sort,public,non_strict and operators ",
  492.             "declarations are not undone."),
  493.     quiet_write("***          Rules added using queries in the ",
  494.             "file are not retracted."),
  495.     quiet_write(" "),
  496.     first_load(CF).
  497.  
  498.  
  499. retract_file(B) :-
  500.     X = current_module,
  501.     retract_modules(features(B),B),
  502.     set_module(X).
  503.  
  504. retract_modules([M1|Ms],B) :- !,
  505.     M = psi2str(M1),
  506.     %% set_module(M),
  507.     retract_functions(features(B.M1.functions,M),B.M1.functions), 
  508.     retract_predicates(features(B.M1.preds,M),B.M1.preds).
  509. retract_modules([]).
  510.  
  511. retract_functions([F|Fs]) :- !,
  512.     (
  513.         retract_all_f(F)
  514.     ;
  515.         retract_functions(Fs)
  516.     ).
  517. retract_functions([]).
  518. retract_predicates([F|Fs]) :- !,
  519.     (
  520.         retract_all_p(F)
  521.     ;
  522.         retract_predicates(Fs)
  523.     ).
  524. retract_predicates([]).
  525.  
  526.  
  527. retract_all_f(F) :-
  528.     retract((F -> @)),
  529.     retract_all_f(F).
  530. retract_all_p(F) :-
  531.     retract((F :- @)),
  532.     retract_all_p(F).
  533.  
  534.  
  535.  
  536. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  537. %
  538. % Meta features
  539. %
  540. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  541.  
  542. %%% Negation
  543.  
  544. \+ X :- X,!,fail.
  545. (\+) .
  546.  
  547. %%% Quote
  548.  
  549. non_strict(`)?
  550. `X -> X.
  551.  
  552.  
  553. %%% Definition of bagof using non-backtrackable destructive assignment.
  554. %%% bagof(X,G) -> R:[]:cond(call_once((G,R<<-[X|R],fail)),R,R). % (19.8)
  555. %%% This version does not allow non-residuating functions in G &
  556. %%% "leaks" the evaluation of G into X on the outside:
  557. %%% bagof(X,G) -> R:[] | (G,R<<-[X|R],fail ; true).
  558.  
  559. %%% This version seems to be completely clean:
  560. %%% non_strict(bagof)?
  561. %%% bagof(X,G) -> R:[] | (evalin(G),R<<-[evalin(X)|R],fail ; R<-copy_term(R)).
  562.  
  563. %%% New version using persistent terms:     RM: Feb 16 1993 
  564. %%% The old version had a complexity of O(n2), now down to O(n).
  565.  
  566. non_strict(bagof)?
  567. bagof(X,G) -> N |
  568.         L<<-[],
  569.         ((evalin(G),                         % Prove G
  570.           L<<-[evalin(X)|copy_pointer(L)],   % Record the binding of X
  571.           fail)                              % Force back-tracking on G
  572.         ;
  573.          (N<-copy_term(L))).                 % Copy the resulting global term
  574.                                              % back onto the stack.
  575.  
  576.  
  577. %%% Best solution to a goal by some relation:
  578.  
  579. non_strict(bestof)?
  580. bestof(X,R,G) -> N |
  581.        L<<-first_value,
  582.        (evalin(G),                         % Prove G
  583.     cond(L:==first_value,              % Record the binding of X
  584.          L<<-evalin(X),
  585.          cond(R(X,L),                  % Compare to last value
  586.           L<<-evalin(X),
  587.           succeed)),
  588.     fail                               % Force back-tracking on G
  589.     ;
  590.         N<-copy_term(L)).                  % Copy the resulting global term
  591.                                            % back onto the stack.
  592.  
  593.  
  594. % Reducing a monoidal binary operator over a list:
  595. reduce(F,E,[H|T]) -> F(H,reduce(F,E,T)).
  596. reduce(F,E,[]) -> E.
  597.  
  598. % Mapping a function over a list:
  599. map(F,[H|T])->[F(H)|map(F,T)].
  600. map(F,[])->[].
  601.  
  602. % Mapping a unary relation over a list:
  603. maprel(P,[H|T]) :- !,root_sort(P) & @(H),maprel(P,T).
  604. maprel(P,[]).
  605.  
  606.  
  607.  
  608. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  609. %
  610. % Basic Lists Manipulation
  611. %
  612. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  613.  
  614. append([H|T],L:list)->[H|append(T,L)].
  615. append([],L:list)->L.
  616.  
  617. length([H|T])->1+length(T).
  618. length([])->0.
  619.  
  620. member(X,[X|_]).
  621. member(X,[_|L]) :- member(X,L).
  622.  
  623. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  624. %
  625. % Arithmetic
  626. %
  627. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  628.  
  629. A^N:int -> cond(N<0,1/pwr(A,-N),pwr(A,N)).
  630.  
  631. pwr(A,0) -> 1.
  632. pwr(A,1) -> A.
  633. % PVR 24.2.94
  634. pwr(A,N) -> cond((N /\ 1)=:=0, X*X, X*X*A) | X=pwr(A,N>>1).
  635. % pwr(A,N) -> A*pwr(A,(N-1)).
  636.  
  637. abs(R) -> cond(R<0,-R,R).
  638. max(A,B) -> cond(A>B,A,B).
  639. min(A,B) -> cond(A>B,B,A).
  640.  
  641.  
  642. % Generate a unique integer for each call to genint
  643. persistent(genint_counter)?
  644. genint_counter<<-0?
  645. genint -> copy_term(genint_counter) | genint_counter<<-genint_counter+1.
  646.  
  647.  
  648. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  649. %
  650. % String Manipulation
  651. %
  652. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  653.  
  654. "" $== "" -> true.
  655. S1:string $== S2:string ->
  656.     (asc(S1)=:=asc(S2)) and
  657.     lenstreq(substr(S1,2,L1:strlen(S1)),substr(S2,2,L2:strlen(S2)),L1,L2).
  658.  
  659. lenstreq("","",_,_) -> true.
  660. lenstreq(S1,S2,L1,L2) ->
  661.     L1=:=L2 and L1>0 and (asc(S1)=:=asc(S2)) and
  662.     lenstreq(substr(S1,2,LL1:(L1-1)),substr(S2,2,LL2:(L2-1)),LL1,LL2).
  663.  
  664. "" $=< string -> true.
  665. string $=< "" -> false.
  666. S1:string $=< S2:string ->
  667.     (C1:asc(S1)<C2:asc(S2))
  668.     or
  669.     (C1=:=C2 and lenstrle(substr(S1,2,L1:strlen(S1)),
  670.                               substr(S2,2,L2:strlen(S2)),
  671.                               L1,L2)).
  672.  
  673. lenstrle("",string,_,_) -> true.
  674. lenstrle(string,"",_,_) -> false.
  675. lenstrle(S1,S2,L1,L2) ->
  676.     (C1:asc(S1) < C2:asc(S2))
  677.     or
  678.     (C1=:=C2 and lenstrle(substr(S1,2,LL1:(L1-1)),
  679.                               substr(S2,2,LL2:(L2-1)),
  680.                               LL1,LL2)).
  681.  
  682. S1:string $< S2:string -> S1$=<S2 and not(S1$==S2).
  683. S1:string $> S2:string -> not(S1$=<S2).
  684. S1:string $>= S2:string -> not(S1$=<S2) or S1$==S2.
  685. S1:string $\== S2:string -> not(S1$==S2).
  686.  
  687. %%% Convert "any" psi-term to a string.
  688. %%% This converts strings to themselves, integers to a string giving their
  689. %%% value, and other psi-terms to a string giving their print name.
  690.  
  691. str(X) -> cond(is_value(X),strval(X),psi2str(X)).
  692.  
  693. strval(S:string) -> S.
  694. strval(N:int) -> int2str(N).
  695.  
  696.  
  697. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  698. %
  699. %  Declarations of support of modules      RM: Jan  6 1993
  700. %
  701. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  702.  
  703. module(N) :-
  704.     N:<string,
  705.         !,
  706.     set_module(N),
  707.     setq(open_modules,[]),
  708.     setq(inherited_modules,[]),
  709.     open("syntax"),
  710.     open("built_ins"),
  711.     open("x").
  712.                         
  713. module(N) :-                                     % PVR 13.9.93
  714.     write_err("*** Error: module name '"),writeq_err(N),
  715.     write_err("' should be a string"),
  716.     nl_err.
  717.  
  718. X:open :- open_list(features(X), X).
  719.  
  720. open_list([]) :- !.
  721. open_list([F|FL], X) :- open_one(X.F), open_list(FL, X).
  722.  
  723. open_one(N:string) :- !,
  724.     open_module(N),
  725.     setq(open_modules,[N|open_modules]).
  726.  
  727. open_one(N) :-                                   % PVR 13.9.93
  728.     write_err("*** Error: module argument '"),writeq_err(N),
  729.     write_err("' of open should be a string"),
  730.     nl_err.
  731.  
  732.  
  733. display_module_status :-
  734.     write("%%%%%%%%%%%%%%%%%%%%"),nl,
  735.     write("%%% current module: ",current_module),nl,
  736.     write("%%% open modules: ",open_modules),nl,
  737.     write("%%% inherited modules: ",inherited_modules),nl,
  738.     write("%%%%%%%%%%%%%%%%%%%%"),nl.
  739.  
  740.  
  741. public(import_clauses)?
  742. non_strict(import_clauses)?
  743.  
  744. import_clauses(for => Sort,
  745.                replacing => RepList) :-
  746.  
  747.     (
  748.         is_function(Sort),
  749.         (Connect = ->) ;
  750.         
  751.         is_predicate(Sort),
  752.         (Connect = :-) ;
  753.         
  754.         write_err("*** Import: ",Sort," is not a predicate or function"),
  755.         nl_err,
  756.         fail
  757.         ),
  758.     ! ,
  759.     get_and_replace(Sort,Connect,RepList);
  760.     succeed.
  761.  
  762.  
  763. get_and_replace(Sort,Connect,RepList) :-
  764.     Connect=@(Sort,Body),
  765.     clause(Connect),
  766.     %%    write("Importing clause:"),
  767.     %%    nl,
  768.     %%    writeq(Connect),
  769.     %%    nl,
  770.     replace(Connect,RepList),
  771.     %%    write("as clause:"),
  772.     %%    nl,
  773.     %%    writeq(Connect),
  774.     %%    nl,
  775.     %%    nl,
  776.     R=root_sort(Connect.1),
  777.     dynamic(R),
  778.     assert(Connect),
  779.     fail.
  780.  
  781.  
  782. replace(Connect,[]) :- ! .
  783. replace(Connect,[(A,B)|T]) :-
  784.     substitute(A,B,Connect),
  785.     replace(Connect,T).
  786.  
  787.  
  788. %%% PVR 13.9.93
  789. non_strict(import)?
  790. X:import :-
  791.     load&strip(X),
  792.     import_list(features(X), X).
  793.  
  794. import_list([]) :- !.
  795. import_list([F|FL], X) :- import_one(X.F), import_list(FL,X).
  796.  
  797. import_one(X) :-
  798.     Module =remove_path(X),
  799.     (open(Module),!;succeed).
  800.  
  801. remove_path(File) -> remove_path_loop(File,strlen(File)).
  802.  
  803. remove_path_loop(File,0) -> File.
  804. remove_path_loop(File,L) -> cond(L<1,
  805.                  File,
  806.                  cond(substr(File,L,1) $== "/",
  807.                       substr(File,L+1,strlen(File)-L),
  808.                       remove_path_loop(File,L-1))).
  809.  
  810. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  811. %
  812. %  Compatibility with older versions 
  813. %
  814. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  815.  
  816. project(A,B) -> B.A.
  817.  
  818.  
  819. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  820. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  821. %%
  822. %% Obsolete
  823. %%
  824. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  825. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  826.  
  827. %%%public('\+','$==','$=<', c_op,append_file, built_in, day, encode,
  828. %%%       freeze,functor,genint_counter, hour, inf_loop, kind, lenstreq,
  829. %%%       lenstrle,c_listing,  minute, month, precedence, second, stream,
  830. %%%       warning, 
  831. %%%       weekday, where, set_module, open_module,xf, xfx, xfy, yf, yfx,
  832. %%%       new_block, block_struct, block_valueintset,block_valuerealset,
  833. %%%       block_valueintget,block_valuerealget,block_subblockset,
  834. %%%       block_subblockget,is_block,same_block, block_privateintget,
  835. %%%       block_privateintset,block_privaterealget,block_privaterealset,
  836. %%%       block_wake,
  837. %%%       c_xareallzero, c_xareallpos, c_xareallneg,
  838. %%%       c_xelm, c_xadd_basic, c_xclean_linear, c_xobjective,
  839. %%%       syntax
  840. %%%      ) ?
  841.  
  842. %%%c_op(1200,fx,block_struct)?    % RM 20 Jan 93
  843.  
  844.  
  845. %%%% To force a type encoding.
  846. %%%encode?
  847.  
  848. %%% non_strict(global)?  %% RM: Apr  8 1993 
  849.  
  850. %%%non_strict(assert)?  %% 17.9
  851. %%%non_strict(asserta)?  %% 17.9
  852. %%%non_strict(clause)?  %% 17.9
  853. %%%non_strict(retract)?  %% 17.9
  854. %%%non_strict(cond)? %% 24.8
  855.  
  856. %%%A ## B -> A.B.
  857.  
  858.  
  859. %%%A poor man's global variable update:
  860. %%%set(X,V) :- retract((X->@)), !, assert((X->V)).
  861. %%%set(X,V) :- dynamic(X), assert((X->V)).
  862.  
  863. %%%This has become a C built-in:
  864. %%%non_strict(setq)?
  865. %%%setq(X,V) :- Value = eval(V), retract((X->@)), !, assert((X->Value)).
  866. %%%setq(X,V) :- dynamic(X), Value = eval(V), assert((X->Value)).
  867.  
  868.  
  869. %%%These are removed since their functionality is subsumed by that of
  870. %%%unification.
  871. %%%Lisp pseudo-compatibility.
  872. %%%nil -> [].
  873. %%%cons(H,T) -> [H|T].
  874. %%%car([H|T]) -> H.
  875. %%%cdr([H|T]) -> T.
  876.  
  877. %%%Repeat.
  878. %%%repeat.
  879. %%%repeat :- repeat.
  880.  
  881. %%%Handy for functional programming.
  882. %%%where -> @.
  883.  
  884. %%%Logic functions (some are C built-ins).
  885.  
  886. %%%and(false,bool) -> false.
  887. %%%and(bool,false) -> false.
  888. %%%and(true,true) -> true.
  889.  
  890. %%%or(true,bool) -> true.
  891. %%%or(bool,true) -> true.
  892. %%%or(false,false) -> false.
  893.  
  894. % PVR 10.2.94
  895. %%%not(true) -> false.
  896. %%%not(false) -> true.
  897. %%%xor(true,false) -> true.
  898. %%%xor(false,true) -> true.
  899. %%%xor(bool,bool) -> false.
  900.  
  901. %%%dynamic(genint_counter)?
  902. %%%genint_counter -> 0.
  903. %%%genint -> N:genint_counter | setq(genint_counter,N+1).
  904.  
  905. %%%This works but results in several genints in the same expression
  906. %%%all getting the same resulting value:
  907. %%%persistent(genint_counter)?
  908. %%%genint_counter<<-0?
  909. %%%genint -> N:genint_counter | genint_counter<<-N+1.
  910.  
  911. %%%This is now a C built-in:
  912. %%%int2str(N:int) -> cond(N<0,
  913. %%%                       strcon("-",num(-N)),
  914. %%%                       num(N)).
  915.  
  916. %%%num(N) -> cond(N<10,
  917. %%%                   psi2str(chr(N+48)),
  918. %%%                   strcon(num(Q:floor(N/10)),num(N-Q*10))).
  919.  
  920. %%%This is the same speed:
  921. %%%num2str(0) -> "0".
  922. %%%num2str(1) -> "1".
  923. %%%num2str(2) -> "2".
  924. %%%num2str(3) -> "3".
  925. %%%num2str(4) -> "4".
  926. %%%num2str(5) -> "5".
  927. %%%num2str(6) -> "6".
  928. %%%num2str(7) -> "7".
  929. %%%num2str(8) -> "8".
  930. %%%num2str(9) -> "9".
  931. %%%num2str(N:int) ->
  932. %%%        cond(N<0,
  933. %%%             strcon("-",num2str(-N)),
  934. %%%             strcon(num2str(Q:floor(N/10)),num2str(N-Q*10))).
  935.  
  936. %%% nl :- put(10).
  937. %%% nl_err :- put_err(10).
  938. %%% Infinite loop.
  939. %%% inf_loop -> inf_loop.
  940.  
  941. %%%copy_rules(Symbol,SourceModule,NewName) :-
  942. %%%    load_module(SourceModule),
  943. %%%    var(NewName),
  944. %%%    copy_rules(Symbol,SourceModule,NewName).
  945.