1/*******************************************************************
    2 *
    3 * A Common Lisp compiler/interpretor, written in Prolog
    4 *
    5 * (xxxxx.pl)
    6 *
    7 *
    8 * Douglas'' Notes:
    9 *
   10 * @TODO - add writable strings
   11 *
   12 * (c) Douglas Miles, 2017
   13 *
   14 * The program is a *HUGE* common-lisp compiler/interpreter. It is written for YAP/SWI-Prolog .
   15 *
   16 *******************************************************************/
   17:- module(string, []).   18
   19:- meta_predicate index_of_first_failure(*,2,*,*,*).   20:- meta_predicate index_of_first_success(*,2,*,*,*).   21
   22
   23
   24% base-string == (vector base-character) 
   25% simple-base-string == (simple-array base-character (*))
   26
   27as_string_upper(C,SN):- compound(C),\+ is_list(C),functor(C,_P,A),arg(A,C,S),!, as_string_upper(S,SN).
   28as_string_upper(S,U):- to_prolog_string_anyways(S,D),string_upper(D,U).
   29
   30is_characterp(X):-var(X),!,fail.
   31is_characterp('#\\'(V)):- nonvar(V).
   32
   33is_stringp(X):- string(X),nop(dbginfo(is_stringp(X))).
   34is_stringp(X):- is_lisp_string(X).
   35
   36is_lisp_string(X):-var(X),!,fail.
   37is_lisp_string('$ARRAY'([_N],claz_base_character,List)):- nonvar(List).
   38
   39% deduced now
   40% GROVELED f_stringp(A, R):- t_or_nil(is_stringp(A),R).
   41
   42f_string(O,S):- to_prolog_string(O,PLS),to_lisp_string(PLS,S).
   43
   44% only handles the same things as #'STRING
   45to_prolog_string(SS,SS):- notrace(string(SS)),!.
   46to_prolog_string(SS,SS):- notrace(var(SS)),!,break.
   47to_prolog_string([],"").
   48to_prolog_string('$ARRAY'(_N,claz_base_character,List),SS):- !,always(lisp_chars_to_pl_string(List,SS)),!.
   49%to_prolog_string('$ARRAY'(_,_,List),SS):-  !,lisp_chars_to_pl_string(List,SS).
   50to_prolog_string('#\\'(Char),Str):- !, f_char_code('#\\'(Char),Code),text_to_string([Code],Str).
   51to_prolog_string(S,SN):- is_symbolp(S),!,pl_symbol_name(S,S2),to_prolog_string(S2,SN).
   52
   53% Only Make a STRING if not already a Prolog String
   54to_prolog_string_if_needed(L,Loc):- \+ string(L),!,always(to_prolog_string_anyways(L,Loc)).
   55% Always make a STRING
   56to_prolog_string_anyways(I,O):- atom(I),upcase_atom(I,I),!,atom_string(I,O).
   57to_prolog_string_anyways(I,O):- is_pathnamep(I),pl_namestring(I,O),!.
   58to_prolog_string_anyways(I,O):- to_prolog_string(I,O),!.
   59to_prolog_string_anyways(I,O):- is_classp(I),claz_to_symbol(I,Symbol),!,to_prolog_string_anyways(Symbol,O).
   60to_prolog_string_anyways(I,O):- always(atom_string(I,O)),!.
   61
   62
   63
   64% grabs ugly objects
   65%to_prolog_string(S,SN):- atom_concat_or_rtrace(':',S0,S),!,to_prolog_string(S0,SN).% TODO add a warjing that hte keyword was somehow misrepresented
   66%to_prolog_string(S,SN):- atom_concat_or_rtrace('kw_',S0,S),!,to_prolog_string(S0,SN). % TODO add a warjing that hte keyword was somehow missing
   67%to_prolog_string(S,SN):- notrace(catch(text_to_string(S,SN),_,fail)),!.
   68
   69to_lisp_string('$ARRAY'([N],claz_base_character,List),'$ARRAY'([N],claz_base_character,List)):-!.
   70to_lisp_string(Text,'$ARRAY'([*],claz_base_character,List)):- always((catch(text_to_string(Text,Str),E,
   71  (dumpST,userout(E),fail)),string_chars(Str,Chars),maplist(make_lisp_character,Chars,List))).
   72
   73% SHARED SECTION
   74wl:coercion(In, claz_prolog_string, Out):- to_prolog_string(In,Out).
   75wl:coercion(In, claz_string, Out):- f_string(In,Out).
   76wl:coercion(In, claz_character, Out):- make_lisp_character(In,Out).
   77wl:coercion(In, claz_string, Out):- f_string(In,Out).
   78wl:coercion(In, claz_cons, Out):- functor(In,_F,A),arg(A,In,Out),is_list(Out).
   79
   80wl:coercion(List, object(_,'$ARRAY'(A1,A2)), '$ARRAY'(A1,A2,List)).
   81wl:coercion(In, claz_sequence, Out):- is_stringp(In),to_lisp_string(In,Out).
   82wl:coercion(In, sequence(string,'$ARRAY'(A1,A2)), List):- string(In),to_lisp_string(In,'$ARRAY'(A1,A2,List)).
   83wl:coercion(In, sequence(string,'$ARRAY'(A1,A2)), List):- is_stringp(In),to_lisp_string(In,'$ARRAY'(A1,A2,List)).
   84
   85wl:coercion([H|T], object(Cons,_), [H|T]):- Cons==claz_cons.
   86wl:coercion([H|T], sequence(claz_cons,claz_cons), [H|T]):-!. 
   87
   88% index_of_first(N,Pred,X,Y,R)
   89index_of_first_success(N,Pred,[X|XX],[Y|YY],R):- !,
   90 ( call(Pred,X,Y) -> R = N;
   91    (N2 is N+1, index_of_first_success(N2,Pred,XX,YY,R))).
   92index_of_first_success(_,_,_,_,[]).
   93% index_of_first(N,Pred,X,Y,R)
   94index_of_first_failure(N,Pred,[X|XX],[Y|YY],R):- !,
   95 ( call(Pred,X,Y) -> R = N;
   96    (N2 is N+1, index_of_first_failure(N2,Pred,XX,YY,R))).
   97index_of_first_failure(_,_,_,_,[]).
   98
   99% http://clhs.lisp.se/Body/f_stgeq_.htm
  100
  101% string>
  102(wl:init_args(2,string_c62)).
  103wl:type_checked(f_string_c62(claz_cons,claz_cons,keys,index)).
  104f_string_c62(X,Y,Keys,R):-
  105   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  106   index_of_first_success(Start1,@>,XR,YR,R).
  107
  108
  109% string>=
  110(wl:init_args(2,string_c62_c61)).
  111wl:type_checked(f_string_c62_c61(claz_cons,claz_cons,keys,index)).
  112f_string_c62_c61(X,Y,Keys,R):-
  113   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  114   index_of_first_success(Start1,@>=,XR,YR,R).
  115
  116
  117% string<
  118(wl:init_args(2,string_c60)).
  119wl:type_checked(f_string_c60(claz_cons,claz_cons,keys,index)).
  120f_string_c60(X,Y,Keys,R):-
  121   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  122   index_of_first_success(Start1,@<,XR,YR,R).
  123
  124
  125% string<=
  126(wl:init_args(2,string_c60_c61)).
  127wl:type_checked(f_string_c60_c61(claz_cons,claz_cons,keys,index)).
  128f_string_c60_c61(X,Y,Keys,R):-
  129   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  130   index_of_first_success(Start1,@=<,XR,YR,R).
  131
  132% string/=
  133(wl:init_args(2,string_c47_c61)).
  134wl:type_checked(f_string_c47_c61(claz_cons,claz_cons,keys,index)).
  135f_string_c47_c61(X,Y,Keys,R):-
  136   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  137   index_of_first_success(Start1,\==,XR,YR,R).
  138
  139% string-lessp
  140(wl:init_args(2,string_lessp)).
  141wl:type_checked(f_string_lessp(claz_cons,claz_cons,keys,index)).
  142f_string_lessp(X,Y,Keys,R):-
  143   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  144   index_of_first_success(Start1,char_lessp,XR,YR,R).
  145
  146% string-not-lessp
  147(wl:init_args(2,string_not_lessp)).
  148wl:type_checked(f_string_not_lessp(claz_cons,claz_cons,keys,index)).
  149f_string_not_lessp(X,Y,Keys,R):-
  150   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  151   index_of_first_failure(Start1,char_lessp,XR,YR,R).
  152
  153% string-greaterp
  154(wl:init_args(2,string_greaterp)).
  155wl:type_checked(f_string_greaterp(claz_cons,claz_cons,keys,index)).
  156f_string_greaterp(X,Y,Keys,R):-
  157   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  158   index_of_first_success(Start1,char_greaterp,XR,YR,R).
  159
  160% string-not-greaterp
  161(wl:init_args(2,string_not_greaterp)).
  162wl:type_checked(f_string_not_greaterp(claz_cons,claz_cons,keys,index)).
  163f_string_not_greaterp(X,Y,Keys,R):-
  164   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  165   index_of_first_failure(Start1,char_greaterp,XR,YR,R).
  166
  167char_lessp(X,Y):- to_prolog_char(X,XX),to_prolog_char(Y,YY), char_type(XX,upper(XXX)),char_type(YY,upper(YYY)), XXX@<YYY.
  168char_greaterp(X,Y):- to_prolog_char(X,XX),to_prolog_char(Y,YY), char_type(XX,upper(XXX)),char_type(YY,upper(YYY)), XXX@>YYY.
  169char_same(X,Y):- to_prolog_char(X,XX),to_prolog_char(Y,YY), char_type(XX,upper(XXX)),char_type(YY,upper(YYY)), XXX==YYY.
  170char_same(X,Y):- to_prolog_char(X,XX),to_prolog_char(Y,YY), XX==YY.
  171
  172char_exact(X,Y):- to_prolog_char(X,XX),to_prolog_char(Y,YY), XX==YY.
  173
  174
  175% string-equals
  176wl:type_checked(f_string_equals(claz_cons,claz_cons,keys,boolean)).
  177(wl:init_args(2,string_equals)).
  178f_string_equals(X,Y,Keys,R):-
  179   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  180   index_of_first_failure(Start1,char_same,XR,YR,Index),
  181   t_or_nil(Index==[],R).
  182
  183
  184% string-not-equal
  185(wl:init_args(2,string_not_equal)).
  186wl:type_checked(f_string_not_equal(claz_cons,claz_cons,keys,index)).
  187f_string_not_equal(X,Y,Keys,R):-
  188   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  189   index_of_first_failure(Start1,char_same,XR,YR,R).
  190
  191
  192% string=
  193wl:type_checked(f_string_c61(claz_cons,claz_cons,keys,boolean)).
  194(wl:init_args(2,string_c61)).
  195f_string_c61(X,Y,Keys,R):-
  196   range_1_and_2(X,Y,Keys,XR,YR,Start1),
  197   index_of_first_failure(Start1,char_exact,XR,YR,Index),
  198   t_or_nil(Index==[],R).
  199
  200
  201%is_string_equal_case_sensitive(X,Y):- to_prolog_string(X,XX),to_prolog_string(Y,YY),XX==YY.
  202%is_string_equal_case_insensitive(X,Y):- to_prolog_string(X,XX),to_prolog_string(Y,YY),
  203%  (XX==YY-> true ; (string_upper(XX,XXX),string_upper(YY,YYY),XXX==YYY)).
  204f_char(String,Index,Char):-f_aref(String,[Index],Char).
  205  
  206
  207
  208
  209
  210:- fixup_exports.