6
7:-module(moo_ext_lisp_triska,[codelist_to_forms/2]). 8:- style_check(-singleton). 9:- style_check(-discontiguous). 11:- set_prolog_flag(double_quotes, codes).
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 !, 25 expressions(Es).
26expressions([]) --> [].
27
28ws --> [W], { code_type(W, space) }, ws.
29ws --> [].
30
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
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
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
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 188
189
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 201 202
203
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 217 218
219
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 233 234
235
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