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