1/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    2    Lisprolog -- Interpreter for a simple Lisp. Written in Prolog.
    3    Written Nov. 26th, 2006 by Markus Triska (triska@gmx.at).
    4    Public domain code.
    5- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
    6
    7:-module(moo_ext_lisp_triska,[codelist_to_forms/2]).    8:- style_check(-singleton).    9:- style_check(-discontiguous).   10% :- style_check(-atom).
   11:- set_prolog_flag(double_quotes, codes). 
   12/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   13   Parsing
   14- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   15:-dynamic(user:mpred_prop/2).   16:-multifile(user:mpred_prop/2).   17:- use_module('../../../src_lib/logicmoo_util/logicmoo_util_all.pl').   18
   19parsing(String, Expr) :- string(String),!,string_codes(String,Codes),phrase(expressions(Expr), Codes).
   20parsing(String, Expr) :- phrase(expressions(Expr), String).
   21
   22expressions([E|Es]) -->
   23    ws, expression(E), ws,
   24    !, % single solution: longest input match
   25    expressions(Es).
   26expressions([]) --> [].
   27
   28ws --> [W], { code_type(W, space) }, ws.
   29ws --> [].
   30
   31% A number N is represented as n(N), a symbol S as s(S).
   32
   33expression(s(A))         --> symbol(Cs), { atom_codes(A, Cs) }.
   34expression(n(N))         --> number(Cs), { number_codes(N, Cs) }.
   35expression(List)         --> "(", expressions(List), ")".
   36expression([s(quote),Q]) --> "'", expression(Q).
   37
   38number([D|Ds]) --> digit(D), number(Ds).
   39number([D])    --> digit(D).
   40
   41digit(D) --> [D], { code_type(D, digit) }.
   42
   43symbol([A|As]) -->
   44    [A],
   45    { memberchk(A, "+/-*><=") ; code_type(A, alpha) },
   46    symbolr(As).
   47
   48symbolr([A|As]) -->
   49    [A],
   50    { memberchk(A, "+/-*><=") ; code_type(A, alnum) },
   51    symbolr(As).
   52symbolr([]) --> [].
   53
   54/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   55   Interpretation
   56   --------------
   57
   58   Declaratively, execution of a Lisp form is a relation between the
   59   (function and variable) binding environment before its execution
   60   and the environment after its execution. A Lisp program is a
   61   sequence of Lisp forms, and its result is the sequence of their
   62   results. The environment is represented as a pair of association
   63   lists Fs-Vs, associating function names with argument names and
   64   bodies, and variables with values. DCGs are used to implicitly
   65   thread the environment state through.
   66- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   67
   68codelist_to_forms(AsciiCodesList,FormsOut):-
   69    parsing(AsciiCodesList, Forms0),    
   70    compile_all(Forms0, FormsOut),!.
   71
   72run(Program, Values) :-
   73    parsing(Program, Forms0),    
   74    empty_assoc(E),
   75    compile_all(Forms0, Forms),
   76    writeq(seeingFormas(Forms)),nl,
   77    phrase(eval_all(Forms, Values0), [E-E], _),
   78    maplist(unfunc, Values0, Values).
   79
   80unfunc(s(S), S).
   81unfunc(t, t).
   82unfunc(n(N), N).
   83unfunc([], []).
   84unfunc([Q0|Qs0], [Q|Qs]) :- unfunc(Q0, Q), unfunc(Qs0, Qs).
   85
   86fold([], _, V, n(V)).
   87fold([n(F)|Fs], Op, V0, V) :- E =.. [Op,V0,F], V1 is E, fold(Fs, Op, V1, V).
   88
   89compile_all(Fs0, Fs) :- maplist(compile, Fs0, Fs).
   90
   91/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   92    compile/2 marks (with 'user/1') calls of user-defined functions.
   93    This eliminates an otherwise defaulty representation of function
   94    calls and thus allows for first argument indexing in eval//3.
   95- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   96
   97compile(F0, F) :-
   98    (   F0 = n(_)   -> F = F0
   99    ;   F0 = s(t)   -> F = t
  100    ;   F0 = s(nil) -> F = []
  101    ;   F0 = s(_)   -> F = F0
  102    ;   F0 = [] -> F = []
  103    ;   F0 = [s(quote),Arg] -> F = [quote,Arg]
  104    ;   F0 = [s(setq),s(Var),Val0] -> compile(Val0, Val), F = [setq,Var,Val]
  105    ;   F0 = [s(Op)|Args0],
  106        memberchk(Op, [+,-,*,equal,if,>,<,=,progn,eval,list,car,cons,
  107                       cdr,while,not]) ->
  108        compile_all(Args0, Args),
  109        F = [Op|Args]
  110    ;   F0 = [s(defun),s(Name),Args0|Body0] ->
  111        compile_all(Body0, Body),
  112        maplist(arg(1), Args0, Args),
  113        F = [defun,Name,Args|Body]
  114    ;   F0 = [s(Op)|Args0] -> compile_all(Args0, Args), F = [user(Op)|Args]
  115    ).
  116
  117eval_all([], [])         --> [].
  118eval_all([A|As], [B|Bs]) --> eval(A, B), eval_all(As, Bs).
  119
  120eval(n(N), n(N))       --> [].
  121eval(t, t)             --> [].
  122eval([], [])           --> [].
  123eval(s(A), V), [Fs-Vs] --> [Fs-Vs], { get_assoc(A, Vs, V) }.
  124eval([L|Ls], Value)    --> eval(L, Ls, Value).
  125
  126eval(quote, [Q], Q) --> [].
  127eval(+, As0, V)     --> eval_all(As0, As), { fold(As, +, 0, V) }.
  128eval(-, As0, V)     --> eval_all(As0, [n(V0)|Vs0]), { fold(Vs0, -, V0, V) }.
  129eval(*, As0, V)     --> eval_all(As0, Vs), { fold(Vs, *, 1, V) }.
  130eval(car, [A], C)   --> eval(A, V), { V == [] -> C = [] ; V = [C|_] }.
  131eval(cdr, [A], C)   --> eval(A, V), { V == [] -> C = [] ; V = [_|C] }.
  132eval(list, Ls0, Ls) --> eval_all(Ls0, Ls).
  133eval(not, [A], V)   --> eval(A, V0), goal_truth(V0=[], V).
  134eval(>, [A,B], V)   --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1>V2, V).
  135eval(<, [A,B], V)   --> eval(>, [B,A], V).
  136eval(=, [A,B], V)   --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1=:=V2, V).
  137eval(progn, Ps, V)  --> eval_all(Ps, Vs), { last(Vs, V) }.
  138eval(eval, [A], V)  --> eval(A, F0), { compile(F0, F1) }, eval(F1, V).
  139eval(equal, [A,B], V) --> eval(A, V1), eval(B, V2), goal_truth(V1=V2, V).
  140eval(cons, [A,B], [V0|V1])  --> eval(A, V0), eval(B, V1).
  141eval(while, [Cond|Bs], [])  -->
  142    (   eval(Cond, []) -> []
  143    ;   eval_all(Bs, _),
  144        eval(while, [Cond|Bs], _)
  145    ).
  146eval(defun, [F,As|Body], s(F)), [Fs-Vs0] -->
  147    [Fs0-Vs0],
  148    { put_assoc(F, Fs0, As-Body, Fs) }.
  149eval(user(F), As0, V), [Fs-Vs] -->
  150    eval_all(As0, As1),
  151    [Fs-Vs],
  152    { empty_assoc(E),
  153      get_assoc(F, Fs, As-Body),
  154      bind_arguments(As, As1, E, Bindings),
  155      phrase(eval_all(Body, Results), [Fs-Bindings], _),
  156      last(Results, V) }.
  157eval(setq, [Var,V0], V), [Fs0-Vs] -->
  158    eval(V0, V),
  159    [Fs0-Vs0],
  160    { put_assoc(Var, Vs0, V, Vs) }.
  161eval(if, [Cond,Then|Else], Value) -->
  162    (   eval(Cond, []) -> eval_all(Else, Values), { last(Values, Value) }
  163    ;   eval(Then, Value)
  164    ).
  165
  166:- meta_predicate user:goal_truth(0,*,*,*).  167goal_truth(Goal, T) --> { Goal -> T = t ; T = [] }.
  168
  169bind_arguments([], [], Bs, Bs).
  170bind_arguments([A|As], [V|Vs], Bs0, Bs) :-
  171    put_assoc(A, Bs0, V, Bs1),
  172    bind_arguments(As, Vs, Bs1, Bs).
  173
  174run(S):-'format'('~n~s~n',[S]),run(S,V),writeq(V).
  175
  176if_script_file_time(X):-if_startup_script(time(X)).
  177
  178% Append:
  179    :- if_script_file_time(run("
  180        (defun append (x y)
  181          (if x
  182              (cons (car x) (append (cdr x) y))
  183            y))
  184
  185        (append '(a b) '(3 4 5))")).  186
  187    %@ V = [append, [a, b, 3, 4, 5]].
  188    
  189
  190% Fibonacci, naive version:
  191    :- if_script_file_time(run("
  192        (defun fib (n)
  193          (if (= 0 n)
  194              0
  195            (if (= 1 n)
  196                1
  197              (+ (fib (- n 1)) (fib (- n 2))))))
  198        (fib 24)")).  199
  200    %@ % 14,255,802 inferences, 3.71 CPU in 3.87 seconds (96% CPU, 3842534 Lips)
  201    %@ V = [fib, 46368].
  202    
  203
  204% Fibonacci, accumulating version:
  205    :- if_script_file_time(run("
  206        (defun fib (n)
  207          (if (= 0 n) 0 (fib1 0 1 1 n)))
  208
  209        (defun fib1 (f1 f2 i to)
  210          (if (= i to)
  211              f2
  212            (fib1 f2 (+ f1 f2) (+ i 1) to)))
  213
  214        (fib 250)")).  215
  216    %@ % 39,882 inferences, 0.010 CPU in 0.013 seconds (80% CPU, 3988200 Lips)
  217    %@ V = [fib, fib1, 7896325826131730509282738943634332893686268675876375].
  218    
  219
  220% Fibonacci, iterative version:
  221    :- if_script_file_time(run("
  222        (defun fib (n)
  223          (setq f (cons 0 1))
  224          (setq i 0)
  225          (while (< i n)
  226            (setq f (cons (cdr f) (+ (car f) (cdr f))))
  227            (setq i (+ i 1)))
  228          (car f))
  229
  230        (fib 350)")).  231
  232    %@ % 34,233 inferences, 0.010 CPU in 0.010 seconds (98% CPU, 3423300 Lips)
  233    %@ V = [fib, 6254449428820551641549772190170184190608177514674331726439961915653414425].
  234    
  235
  236% Higher-order programming and eval:
  237    :- if_startup_script(run("
  238        (defun map (f xs)
  239          (if xs
  240              (cons (eval (list f (car xs))) (map f (cdr xs)))
  241            ()))
  242
  243        (defun plus1 (x) (+ 1 x))
  244
  245        (map 'plus1 '(1 2 3))
  246        "
  247        )).  248
  249    %@ V = [map, plus1, [2, 3, 4]].