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