/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Lisprolog -- Interpreter for a simple Lisp. Written in Prolog. Written Nov. 26th, 2006 by Markus Triska (triska@gmx.at). Public domain code. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ :-module(moo_ext_lisp_triska,[codelist_to_forms/2]). :- style_check(-singleton). :- style_check(-discontiguous). % :- style_check(-atom). :- set_prolog_flag(double_quotes, codes). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Parsing - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ :-dynamic(user:mpred_prop/2). :-multifile(user:mpred_prop/2). :- use_module('../../../src_lib/logicmoo_util/logicmoo_util_all.pl'). parsing(String, Expr) :- string(String),!,string_codes(String,Codes),phrase(expressions(Expr), Codes). parsing(String, Expr) :- phrase(expressions(Expr), String). expressions([E|Es]) --> ws, expression(E), ws, !, % single solution: longest input match expressions(Es). expressions([]) --> []. ws --> [W], { code_type(W, space) }, ws. ws --> []. % A number N is represented as n(N), a symbol S as s(S). expression(s(A)) --> symbol(Cs), { atom_codes(A, Cs) }. expression(n(N)) --> number(Cs), { number_codes(N, Cs) }. expression(List) --> "(", expressions(List), ")". expression([s(quote),Q]) --> "'", expression(Q). number([D|Ds]) --> digit(D), number(Ds). number([D]) --> digit(D). digit(D) --> [D], { code_type(D, digit) }. symbol([A|As]) --> [A], { memberchk(A, "+/-*><=") ; code_type(A, alpha) }, symbolr(As). symbolr([A|As]) --> [A], { memberchk(A, "+/-*><=") ; code_type(A, alnum) }, symbolr(As). symbolr([]) --> []. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Interpretation -------------- Declaratively, execution of a Lisp form is a relation between the (function and variable) binding environment before its execution and the environment after its execution. A Lisp program is a sequence of Lisp forms, and its result is the sequence of their results. The environment is represented as a pair of association lists Fs-Vs, associating function names with argument names and bodies, and variables with values. DCGs are used to implicitly thread the environment state through. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ codelist_to_forms(AsciiCodesList,FormsOut):- parsing(AsciiCodesList, Forms0), compile_all(Forms0, FormsOut),!. run(Program, Values) :- parsing(Program, Forms0), empty_assoc(E), compile_all(Forms0, Forms), writeq(seeingFormas(Forms)),nl, phrase(eval_all(Forms, Values0), [E-E], _), maplist(unfunc, Values0, Values). unfunc(s(S), S). unfunc(t, t). unfunc(n(N), N). unfunc([], []). unfunc([Q0|Qs0], [Q|Qs]) :- unfunc(Q0, Q), unfunc(Qs0, Qs). fold([], _, V, n(V)). fold([n(F)|Fs], Op, V0, V) :- E =.. [Op,V0,F], V1 is E, fold(Fs, Op, V1, V). compile_all(Fs0, Fs) :- maplist(compile, Fs0, Fs). /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - compile/2 marks (with 'user/1') calls of user-defined functions. This eliminates an otherwise defaulty representation of function calls and thus allows for first argument indexing in eval//3. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ compile(F0, F) :- ( F0 = n(_) -> F = F0 ; F0 = s(t) -> F = t ; F0 = s(nil) -> F = [] ; F0 = s(_) -> F = F0 ; F0 = [] -> F = [] ; F0 = [s(quote),Arg] -> F = [quote,Arg] ; F0 = [s(setq),s(Var),Val0] -> compile(Val0, Val), F = [setq,Var,Val] ; F0 = [s(Op)|Args0], memberchk(Op, [+,-,*,equal,if,>,<,=,progn,eval,list,car,cons, cdr,while,not]) -> compile_all(Args0, Args), F = [Op|Args] ; F0 = [s(defun),s(Name),Args0|Body0] -> compile_all(Body0, Body), maplist(arg(1), Args0, Args), F = [defun,Name,Args|Body] ; F0 = [s(Op)|Args0] -> compile_all(Args0, Args), F = [user(Op)|Args] ). eval_all([], []) --> []. eval_all([A|As], [B|Bs]) --> eval(A, B), eval_all(As, Bs). eval(n(N), n(N)) --> []. eval(t, t) --> []. eval([], []) --> []. eval(s(A), V), [Fs-Vs] --> [Fs-Vs], { get_assoc(A, Vs, V) }. eval([L|Ls], Value) --> eval(L, Ls, Value). eval(quote, [Q], Q) --> []. eval(+, As0, V) --> eval_all(As0, As), { fold(As, +, 0, V) }. eval(-, As0, V) --> eval_all(As0, [n(V0)|Vs0]), { fold(Vs0, -, V0, V) }. eval(*, As0, V) --> eval_all(As0, Vs), { fold(Vs, *, 1, V) }. eval(car, [A], C) --> eval(A, V), { V == [] -> C = [] ; V = [C|_] }. eval(cdr, [A], C) --> eval(A, V), { V == [] -> C = [] ; V = [_|C] }. eval(list, Ls0, Ls) --> eval_all(Ls0, Ls). eval(not, [A], V) --> eval(A, V0), goal_truth(V0=[], V). eval(>, [A,B], V) --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1>V2, V). eval(<, [A,B], V) --> eval(>, [B,A], V). eval(=, [A,B], V) --> eval(A, n(V1)), eval(B, n(V2)), goal_truth(V1=:=V2, V). eval(progn, Ps, V) --> eval_all(Ps, Vs), { last(Vs, V) }. eval(eval, [A], V) --> eval(A, F0), { compile(F0, F1) }, eval(F1, V). eval(equal, [A,B], V) --> eval(A, V1), eval(B, V2), goal_truth(V1=V2, V). eval(cons, [A,B], [V0|V1]) --> eval(A, V0), eval(B, V1). eval(while, [Cond|Bs], []) --> ( eval(Cond, []) -> [] ; eval_all(Bs, _), eval(while, [Cond|Bs], _) ). eval(defun, [F,As|Body], s(F)), [Fs-Vs0] --> [Fs0-Vs0], { put_assoc(F, Fs0, As-Body, Fs) }. eval(user(F), As0, V), [Fs-Vs] --> eval_all(As0, As1), [Fs-Vs], { empty_assoc(E), get_assoc(F, Fs, As-Body), bind_arguments(As, As1, E, Bindings), phrase(eval_all(Body, Results), [Fs-Bindings], _), last(Results, V) }. eval(setq, [Var,V0], V), [Fs0-Vs] --> eval(V0, V), [Fs0-Vs0], { put_assoc(Var, Vs0, V, Vs) }. eval(if, [Cond,Then|Else], Value) --> ( eval(Cond, []) -> eval_all(Else, Values), { last(Values, Value) } ; eval(Then, Value) ). :- meta_predicate user:goal_truth(0,*,*,*). goal_truth(Goal, T) --> { Goal -> T = t ; T = [] }. bind_arguments([], [], Bs, Bs). bind_arguments([A|As], [V|Vs], Bs0, Bs) :- put_assoc(A, Bs0, V, Bs1), bind_arguments(As, Vs, Bs1, Bs). run(S):-'format'('~n~s~n',[S]),run(S,V),writeq(V). if_script_file_time(X):-if_startup_script(time(X)). % Append: :- if_script_file_time(run(" (defun append (x y) (if x (cons (car x) (append (cdr x) y)) y)) (append '(a b) '(3 4 5))")). %@ V = [append, [a, b, 3, 4, 5]]. % Fibonacci, naive version: :- if_script_file_time(run(" (defun fib (n) (if (= 0 n) 0 (if (= 1 n) 1 (+ (fib (- n 1)) (fib (- n 2)))))) (fib 24)")). %@ % 14,255,802 inferences, 3.71 CPU in 3.87 seconds (96% CPU, 3842534 Lips) %@ V = [fib, 46368]. % Fibonacci, accumulating version: :- if_script_file_time(run(" (defun fib (n) (if (= 0 n) 0 (fib1 0 1 1 n))) (defun fib1 (f1 f2 i to) (if (= i to) f2 (fib1 f2 (+ f1 f2) (+ i 1) to))) (fib 250)")). %@ % 39,882 inferences, 0.010 CPU in 0.013 seconds (80% CPU, 3988200 Lips) %@ V = [fib, fib1, 7896325826131730509282738943634332893686268675876375]. % Fibonacci, iterative version: :- if_script_file_time(run(" (defun fib (n) (setq f (cons 0 1)) (setq i 0) (while (< i n) (setq f (cons (cdr f) (+ (car f) (cdr f)))) (setq i (+ i 1))) (car f)) (fib 350)")). %@ % 34,233 inferences, 0.010 CPU in 0.010 seconds (98% CPU, 3423300 Lips) %@ V = [fib, 6254449428820551641549772190170184190608177514674331726439961915653414425]. % Higher-order programming and eval: :- if_startup_script(run(" (defun map (f xs) (if xs (cons (eval (list f (car xs))) (map f (cdr xs))) ())) (defun plus1 (x) (+ 1 x)) (map 'plus1 '(1 2 3)) " )). %@ V = [map, plus1, [2, 3, 4]].