%*****************************************************************************
%
%       Metis Buildin
%               PSI - KL1 version
%
%               created by      : ???
%               version         : 1.0
%               revision        : 0.0
%               date created    : 8-30-91
%               date changed    : ???
%               comments
%*****************************************************************************


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%       metis_buildin_macro                                     %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
macro_bank metis_buildin_macro has 

    nature
        metis_utility_methods,
        metis_db_methods,
        metis_device_methods,
        metis_main_methods,
        metis_command_methods;
end.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%       metis_buildin                                           %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
class metis_buildin with_macro metis_buildin_macro has

    attribute
            see,
            tell;

    component
            see_name,
            see_list,
            tell_name,
            tell_list,
            prompt := ':| ',
            prompt_mode := on;

    :prolog_op(Class,P,T,F) :- !,
            op(Class,P,T,F);
    :prolog_terminal_open(Class) :- !,
            terminal_open(Class);
    :prolog_terminal_close(_) :- !,
            :deactivate(#metis_window!superior);
    :prolog_see(Class,Fname) :- !,
            see(Fname,Class);
    :prolog_seeing(Class,Fname) :- !,
            seeing(Fname,Class);
    :prolog_seen(Class) :- !,
            seen(Class);
    :prolog_tell(Class,Fname) :- !,
            tell(Fname,Class);
    :prolog_telling(Class,Fname) :- !,
            telling(Fname,Class);
    :prolog_told(Class) :- !,
            told(Class);
    :prolog_name(_,Atom,List) :- !,
            name(Atom,List);
    :prolog_get0(Class,C) :- !,
            get0(Class,C);
    :prolog_read(Class,Term) :- !,
            read(Class,Term);
    :prolog_write(Class,Term) :- !,
            write(Class,Term);
    :prolog_write(Class,Term,Vin,Vout) :- !,
            write(Class,Term,Vin,Vout);
    :prolog_writeq(Class,Term) :- !,
            writeq(Class,Term);
    :prolog_writeq(Class,Term,Vin,Vout) :- !,
            writeq(Class,Term,Vin,Vout);
    :prolog_put(Class,C) :- !,
            put(Class,C);
    :prolog_prompt(Class,P,NewP) :- !,
            prompt(Class,P,NewP);
    :prolog_call(_,P) :- !,
            call(P);
    :prolog_notcall(_,P) :- !,
            notcall(P);
    :prolog_bagof(_,D,P,L) :- !,
            bagof(D,P,L);
    :prolog_length(_,List,L) :- !,
            length(List,L);
    :prolog_nl(Class) :- !,
            nl(Class);
    :prolog_tab(Class,N) :- !,
            tab(N,Class);
    :prolog_print(Class,Term) :- !,
            print(Class,Term);
    :prolog_halt(_) :- !,
            halt;
    :'prolog_=..'(_,Term,List) :- !,
            '=..'(Term,List);
    :prolog_var(_,Var) :- !,
            unbound(Var);
    :prolog_nonvar(_,Var) :- !,
            bound(Var);
    :prolog_sort(_,L,R) :- !,
            sort(L,[],R);
    :prolog_plsys(_,A) :- !,
            plsys(A);
    :prolog_nofileerrors(_) :- !;
    :prolog_rename(_,File,NewFile) :- !,
            rename(File,NewFile);
    :prolog_functor(_,T,F,N) :- !,
            functor(T,F,N);
    :prolog_compare(_,OP,L,R) :- !,
            compare(OP,L,R);
    :prolog_log(_) :- !;
    :prolog_nolog(_) :- !;
    :prolog_numbervars(_,Term,Cin,Cout) :- !,
            numbervars(Term,Cin,Cout);
    :prolog_ttyflush(_) :- !;
    :prolog_statistics(_,A,B) :- !;


local

%-----< operator decralation >--------------------------------------------------

    op(Class,P,T,F) :- !,
            set_op(input,Class!see,P,T,F),
            set_op(output,Class!tell,P,T,F),
            set_op(inout,#metis_window!process,P,T,F),
            set_op(inout,#metis_window!equations,P,T,F),
            set_op(inout,#metis_window!rules,P,T,F),
            :assert(#metis_assert,'{DB-op}sys'(P,T,F));     %%for mpsi (read_all)

%%for default operator declaration
    set_op(Mode,Obj) :-
            ( :metis_op(#metis_operator,P,T,F)
            ; :clause(#metis_assert,'{DB-op}sys'(P,T,F),true) ),    %%for mpsi (read_all)
            set_op(Mode,Obj,P,T,F),
            fail;
    set_op(_,_) :- !;

%%for normal operator declaration
    set_op(inout,Obj,P,T,F) :- !,
            set_op(input,Obj,P,T,F),
            set_op(output,Obj,P,T,F);
    set_op(input,Obj,P,T,F) :- !,
            :get_parsing_operator(Obj,OP),
            operator_declaration(P,OP,T,F);
    set_op(output,Obj,P,T,F) :- !,
            :get_unparsing_operator(Obj,OP),
            operator_declaration(P,OP,T,F);

    operator_declaration(0,OP,_,F) :- !,
            ( :remove_operator(OP,F) ; true );
    operator_declaration(P,OP,T,F) :- !,
            add_operator_declaration(OP,P,T,F);

    add_operator_declaration(OP,P,T,F) :-
            :add_operator(OP,F,T,P),!;
    add_operator_declaration(OP,P,T,F) :- !,
            :remove_operator(OP,F),
            :add_operator(OP,F,T,P);

%-----< terminal_open >--------------------------------------------------

    terminal_open(Class) :- !,
            Class!prompt := ':|',
            Class!prompt_mode := on,
            :window_control(#metis_window,open),
            set_windows_operator,
            set_current_io(Class);

    set_windows_operator :- !,
            set_op(inout,#metis_window!process),
            set_op(inout,#metis_window!equations),
            set_op(inout,#metis_window!rules);

    set_current_io(Class) :- !,
            :create(#list_index,See_list),
            :create(#list_index,Tell_list),
            Class!see_list := See_list,
            Class!tell_list := Tell_list,
            Class!see := #metis_window!process,
            Class!tell := #metis_window!process;


%-----< see >--------------------------------------------------

    see(user,Class) :-
            Class!see := #metis_window!process ,!;
    see(Fname,Class) :- !,
            :get_atom_string(#symbolizer,Fname,Fname_),
            see_file_get(Fname_,Class),
            Class!see_name := Fname_ ;

    see_file_get(Fname,Class) :-
            :get_at(Class!see_list,See,Fname),!,
            Class!see := See ;
    see_file_get(Fname,Class) :- !,
            :create(#standard_input_file,See,Fname),
            set_op(input,See),
            :add_at(Class!see_list,See,Fname),
            Class!see := See ;

%-----< seeing >--------------------------------------------------

    seeing(user,Class) :-
            Class!see =:= #metis_window!process,!;
    seeing(Fname,Class) :- !,
            :enter_atom(#symbolizer,Fname,Class!see_name);

%-----< seen >--------------------------------------------------

    seen(Class) :-
            :close_input(Class!see),
            :remove_at(Class!see_list,_,Class!see_name),
            Class!see := #metis_window!process;


%-----< tell >--------------------------------------------------
    tell(user,Class) :- !,
            Class!tell := #metis_window!process;
    tell(Fname,Class) :- !,
            :get_atom_string(#symbolizer,Fname,Fname_),
            tell_file_get(Fname_,Class),
            Class!tell_name := Fname_ ;

    tell_file_get(Fname,Class) :- 
            :get_at(Class!tell_list,Tell,Fname),!,
            Class!tell := Tell ;
    tell_file_get(Fname,Class) :- !,
            :create(#standard_output_file,Tell,Fname),
            :unquote_atom(Tell),
            set_op(output,Tell),
            :add_at(Class!tell_list,Tell,Fname),
            Class!tell := Tell ;

%-----< telling >--------------------------------------------------
    telling(user,Class) :-
            Class!tell =:= #metis_window!process ,!;
    telling(Fname,Class) :-
            :enter_atom(#symbolizer,Fname,Class!tell_name);

%-----< told >--------------------------------------------------
    told(Class) :- !,
            :close_output(Class!tell),
            :remove_at(Class!tell_list,_,Class!tell_name),
            Class!tell := #metis_window!process ;

            
%-----< name >--------------------------------------------------

    name(A,B):-
            integer(A),!,
            name_num(A,A1),
            rev_list(A1,[],B);
    name(A,B):-
            list(B),
            name_list_integer(B),!,
            name_list(A,B);
    name(A,B):- !,
            name_(A,B);   

%%%%% for integer 
    name_num(0,[C]) :- !,
            jis_from_integer(0,C),!;
    name_num(Int,C) :- !,
            name_num_(Int,C),!;

    name_num_(0,[]) :- !;
    name_num_(Int,[C|Crem]):-
            integer(Int),!,
            mod(Int,S,Mod),
            jis_from_integer(Mod,C),!,
            name_num_(S,Crem);

    mod(Int,S,Mod) :- !,
            Mod = Int mod 10,
            S = Int div 10;

    name_list_integer([]) :- !;
    name_list_integer([H|T]):-
            integer(H),     
            jis_from_integer(_,H),!,
            name_list_integer(T);

    name_list(L1,L2) :- !,
            name_list_all(L2,Jis),
            :append(#string,Jis,Jis1),
            :get_number(#symbolizer,L1,Jis1);

    name_list_all([],[]) :- !;
    name_list_all([H|T],[H1|T1]) :- !,
            integer_from_jis(H1,H),!,
            name_list_all(T,T1);
 
    jis_from_integer(0,48):-!;
    jis_from_integer(1,49):-!;
    jis_from_integer(2,50):-!;
    jis_from_integer(3,51):-!;
    jis_from_integer(4,52):-!;
    jis_from_integer(5,53):-!;
    jis_from_integer(6,54):-!;
    jis_from_integer(7,55):-!;
    jis_from_integer(8,56):-!;
    jis_from_integer(9,57):-!;

    integer_from_jis("0",48):-!;
    integer_from_jis("1",49):-!;
    integer_from_jis("2",50):-!;
    integer_from_jis("3",51):-!;
    integer_from_jis("4",52):-!;
    integer_from_jis("5",53):-!;
    integer_from_jis("6",54):-!;
    integer_from_jis("7",55):-!;
    integer_from_jis("8",56):-!;
    integer_from_jis("9",57):-!;

%%%%% for other type
    name_(X,Y):-
            atomic(X),!,
            :get_atom_token(#symbolizer,X,Name),
            jis_to_ascii_list(Name,Y);
    name_(X,Y):-!,
            ascii_to_jis_list(Y,XX),
            :enter_atom(#symbolizer,X,XX);
 
    jis_to_ascii_list([],[]) :- !;
    jis_to_ascii_list([Name|Oname],[Lis|Olis]) :- !,
            :from_kanji(#ascii_coder,Name,Lis),!,
            jis_to_ascii_list(Oname,Olis); 

    ascii_to_jis_list([],[]) :- !;
    ascii_to_jis_list([Name|Oname],[Lis|Olis]) :- !,
            :to_kanji(#ascii_coder,Name,Lis),!,
            ascii_to_jis_list(Oname,Olis); 


%-----< get0 >--------------------------------------------------

%    get0(Class,C) :-
%            (
%                Class!prompt_mode == on,
%                Class!see == #metis_window!process ,!,
%                write_prompt(Class!see,Class!prompt),
%                Class!prompt_mode := off
%            ;
%                true
%            ),
%            :getc(Class!see,JisC),!, 
%            :from_kanji(#ascii_coder,JisC,AsciiC),
%            get0_cr(AsciiC,C),
%            (
%                AsciiC == 10 ,
%                Class!see == #metis_window!process,!,
%                Class!prompt_mode := on
%            ;
%                true
%            );

    get0(Class,C) :-
            get0_with_prompt(Class!prompt_mode,Class), 
            get0_get(C,Class),
            get0_next_prompt(C,Class);
    get0(Class,C) :-
            get0_get(C,Class);
    get0(Class,26):-
            :end_of_input(Class!see),!;
    get0(Class,C) :- !,
            get0(Class,C);

    get0_with_prompt(off,_) :- !;
    get0_with_prompt(on,Class) :-
            Class!see == #metis_window!process,!,
            write_prompt(Class!tell,Class!prompt),
            Class!prompt_mode := off;

    get0_get(C,Class) :- !,
            :getc(Class!see,JisC),!, 
            :from_kanji(#ascii_coder,JisC,AsciiC),
            get0_get_cr(AsciiC,C);

    get0_get_cr(10,31) :- !;
    get0_get_cr(C,C) :- !;  

    get0_next_prompt(31,Class) :-
                Class!see == #metis_window!process,!,
                Class!prompt_mode := on;
    get0_next_prompt(_,_) :- !;

%-----< read >--------------------------------------------------

    read(Class,X):-
            (
                Class!see == #metis_window!process,!,
                write_prompt(Class!see,Class!prompt)
            ;
                true
            ),
            :gett(Class!see,X),!;
    read(Class,end_of_file):-
            :end_of_input(Class!see),!;
    read(Class,X):-!,
            read(Class,X);

%-----< write_prompt >--------------------------------------------------

    write_prompt(W,P) :- !,
            melt(P,PP),
            writel_prompt_list(PP,W);

    writel_prompt_list([],_) :- !;
    writel_prompt_list([P|Prem],W) :- !,
            :putt(W,P),!,
            writel_prompt_list(Prem,W);
    writel_prompt_list(P,W) :- !,
            :putt(W,P);

%-----< write >--------------------------------------------------

    write(Class,Term) :- !,
            :putt(Class!tell,Term);

    write(Class,Term,Vin,Vout) :- !,
            :putt(Class!tell,Term,Vin,Vout);

%-----< writeq >--------------------------------------------------

    writeq(Class,Term) :- !,
            :quote_atom(Class!tell),
            write(Class,Term),
            :unquote_atom(Class!tell);

    writeq(Class,Term,Vin,Vout) :- !,
            :quote_atom(Class!tell),
            write(Class,Term,Vin,Vout),
            :unquote_atom(Class!tell);

%-----< put >--------------------------------------------------

    put(Class,C):-!,
            :to_kanji(#ascii_coder,C,C_),
            :putc(Class!tell,C_);


%-----< prompt >--------------------------------------------------

    prompt(Class,P,NewP):-!,
            melt(Class!prompt,P),
            freeze(NewP,PP),
            Class!prompt := PP;


%-----< call >--------------------------------------------------

    call(command_select(C,Mode,Crem,Usg,Next)) :-!,
            interface(command_select(C,Mode,Crem,Usg,Next));
%%    call(read_file(Inp,Ext,Trm)) :- !,
%%            :read_file(#metis_device,Inp,Ext,Trm);
    call(refer_match(Equation,Existing,Id,Obj)) :-!,
            interface(refer_match(Equation,Existing,Id,Obj));
    call(refer(Operator,Existing,Op,Ref)) :-!,
            interface(refer(Operator,Existing,Op,Ref));
    call(can_less(L,R,Oin,Otmp,A,Ptmp)) :-!,
            interface(can_less(L,R,Oin,Otmp,A,Ptmp));
    call(get_one_list(Pin,L)):-!,
            interface(get_one_list(Pin,L));
    call(reduce_one(Term,TT,No)):-!,
            interface(reduce_one(Term,TT,No));
    call(Call):-!,
            :call(#metis_assert,Call);

%-----< notcall >--------------------------------------------------

    notcall(Call) :-
            call(Call),!,
            fail;
    notcall(_) :- !;



%-----< bagof >--------------------------------------------------

    bagof(Data,Pred,List) :- !,
            gennum(ID),
            bagof_universal(Pred,Call,_),!,
            bagof(ID,Data,Call,List);
            
    bagof_universal(^(V,Pred),Call,[V|Var]) :- !,        
            bagof_universal(Pred,Call,Var);
    bagof_universal(Call,Call,[]) :- !;

    bagof(ID,Data,Call,_) :-
            call(Call),
            :assertz(#metis_assert,'$BAGOF'(ID,Data)),
            fail;
    bagof(ID,_,_,List) :- !,
            call('$BAGOF'(ID,_)),!,
            bagof_list(ID,List);

    bagof_list(ID,[Data|List]) :-
            :retract(#metis_assert,'$BAGOF'(ID,Data)),!,
            bagof_list(ID,List);
    bagof_list(_,[]) :- !;

    gennum(N) :-
            :retract(#metis_assert,'$GENNUM'(N)),!,
            N1 is N+1,
            :asserta(#metis_assert,'$GENNUM'(N1));
    gennum(0) :- !,
            :asserta(#metis_assert,'$GENNUM'(1));

%-------< length >------------------------------------------------

    length(List,L) :- !,
           list_to_vector(List,S,_),
           stack_vector(S,L);

%-----< nl >--------------------------------------------------

    nl(Class) :- !,
            :putf(Class!tell,"\n");

%-----< tab >--------------------------------------------------

    tab(0,Class):-!;
    tab(N,Class):-
        :putc(Class!tell,#" "),
        tab(N-1,Class);

%-----< print >--------------------------------------------------

    print(Class,X) :- !,
            write(Class,X);

%-----< halt >--------------------------------------------------

    halt :- !,
            :self(#process,MyProcess),
            :exterminate(MyProcess);

%-----< '=..' >--------------------------------------------------

    '=..'([H|T],[.,H,T]):- !;
    '=..'(F,[F]) :- atomic(F),!;
    '=..'({F,A1},[F,A1]) :- !;
    '=..'({F,A1,A2},[F,A1,A2]) :- !;
    '=..'({F,A1,A2,A3},[F,A1,A2,A3]) :- !;
    '=..'({F,A1,A2,A3,A4},[F,A1,A2,A3,A4]) :- !;
    '=..'({F,A1,A2,A3,A4,A5},[F,A1,A2,A3,A4,A5]) :- !;
    '=..'({F,A1,A2,A3,A4,A5,A6},[F,A1,A2,A3,A4,A5,A6]) :- !;
    '=..'({F,A1,A2,A3,A4,A5,A6,A7},[F,A1,A2,A3,A4,A5,A6,A7]) :- !;
    '=..'({F,A1,A2,A3,A4,A5,A6,A7,A8},[F,A1,A2,A3,A4,A5,A6,A7,A8]) :- !;
    '=..'({F,A1,A2,A3,A4,A5,A6,A7,A8,A9},[F,A1,A2,A3,A4,A5,A6,A7,A8,A9]) :- !;
    '=..'(X,Y):-
            stack_vector(X,_),!,
            vector_to_list(X,[],Y);
    '=..'(X,Y):-
            list(Y),!,
            list_to_vector(Y,X,_);

%-----< sort >--------------------------------------------------

    sort([X|L],R0,R):-!,
            sort_partition(L,X,L1,L2),
            sort(L2,R0,R1),
            sort(L1,[X|R1],R);
    sort([],R,R):-!;

    sort_partition([X|L],Y,L1,L2) :- X == Y,!,
            sort_partition(L,Y,L1,L2);
    sort_partition([X|L],Y,[X|L1],L2) :- X =< Y,!,
            sort_partition(L,Y,L1,L2);
    sort_partition([X|L],Y,L1,[X|L2]) :- X > Y,!,
            sort_partition(L,Y,L1,L2);
    sort_partition([],_,[],[]):-!;

%-----< plsys >--------------------------------------------------

    plsys(jobno(000)) :- !;
    plsys(_) :- !;

%-----< rename >--------------------------------------------------

    rename(File,[]) :- !,
            :get_atom_string(#symbolizer,File,FileS),
            :append(#string,[FileS,".*"],FileExt),
            :delete(#file_utility,[FileExt],_);
    rename(File,NewFile) :- !,
            :get_atom_string(#symbolizer,File,FileS),
            :get_atom_string(#symbolizer,NewFile,NewFileS),
            :rename(#file_utility,[FileS],[NewFileS],_),
            :append(#string,[FileS,".*"],FileExt),
            :delete(#file_utility,[FileExt],_);

%-----< functor >--------------------------------------------------

    functor(T,F,N):-
            structure(T),!,
            first(T,F),
            stack_vector(T,N1),
            N = N1-1;
    functor(T,F,N):-
            atom(T),!,
            F = T,
            N = 0;
    functor(T,F,N):-
            unbound(T),
            N1 = N + 1,
            (N == 0,!,T = F
            ;
            new_stack_vector(T,N1),
            first(T,F) );
 
%-----< rev_list(for name) >---------------------------------------

    rev_list([],L,L) :- !;
    rev_list([X|L],L2,L3) :- !,
            rev_list(L,[X|L2],L3);

%-----< compare >--------------------------------------------------

    compare(=,T,T) :- !;
    compare(Sym,L,R) :- !,  
            '=..'(L,[Lop|Larg]),
            '=..'(R,[Rop|Rarg]),
            compare_term(Lop,Rop,Larg,Rarg,Sym);

    compare_term(Op,Op,Larg,Rarg,Sym) :- !,
            compare_arg(Larg,Rarg,Sym);
    compare_term(Lop,Rop,_,_,Sym) :- !,
            compare_op(Lop,Rop,Sym);

    compare_arg([],_,<) :- !;
    compare_arg(_,[],>) :- !;
    compare_arg([T|Lrem],[T|Rrem],Sym) :- !,
            compare_arg(Lrem,Rrem,Sym);
    compare_arg([L|_],[R|_],Sym) :- !,
            compare(Sym,L,R);

    compare_op(Lop,Rop,Sym) :- !,
            name(Lop,Lname),
            name(Rop,Rname),
            compare_name(Lname,Rname,Sym);

    compare_name([],_,<) :- !;
    compare_name(_,[],>) :- !;
    compare_name([C|Lrem],[C|Rrem],Sym) :- !,
            compare_name(Lrem,Rrem,Sym);
    compare_name([Lc|_],[Rc|_],Sym) :- !,
            ( Lc<Rc,Sym=(<) ; Sym=(>));

%-----< numbervars >-----------------------------------------------

     numbervars('$VAR'(C),C,C1) :- !,
              C1 is C+1;
     numbervars('$VAR'(_),C,C) :- !;
     numbervars(Term,Cin,Cout) :- !,
              '=..'(Term,[_|Arg]),!,
              numbervars_arg(Arg,Cin,Cout);

     numbervars_arg([],C,C) :- !;
     numbervars_arg([T|Term],Cin,Cout) :- !,
              numbervars(T,Cin,Cmed),!,
              numbervars_arg(Term,Cmed,Cout);

end.