• R/O
  • SSH

Joypy: Commit

Main interpreter and library.


Commit MetaInfo

Revisiona5b8b7826c480f5e468df4ef7322d37312e1606d (tree)
Time2019-08-11 14:07:17
AuthorSimon Forman <sforman@hush...>
CommiterSimon Forman

Log Message

cleanup old files

Change Summary

Incremental Difference

diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/gthun.pl
--- a/thun/gnu-prolog/gthun.pl Sat Aug 10 22:03:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
1-
2-:- op(990, xfy, =-).
3-:- dynamic((=-)/2).
4-
5-:- initialization(loop).
6-
7-
8-/*
9-Parser
10-*/
11-
12-joy_parse([T|S]) --> blanks, joy_term(T), blanks, joy_parse(S).
13-joy_parse([]) --> [].
14-
15-joy_term(N) --> num(N), !.
16-joy_term(S) --> [0'[], !, joy_parse(S), [0']].
17-joy_term(A) --> chars(Chars), !, {atom_codes(A, Chars)}.
18-
19-
20-/*
21-Interpreter.
22-*/
23-
24-thun([], S, S).
25-
26-thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
27-thun( [Func|E], Si, So) :- func(Func, Si, S), !, thun(E, S, So).
28-thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), !, thun(Eo, S, So).
29-
30-thun(Err, S, [Err|S]) :- write('Unknown term!'), nl.
31-
32-
33-/*
34-Literals
35-*/
36-
37-literal(V) :- var(V).
38-literal(I) :- number(I).
39-literal([]).
40-literal([_|_]).
41-literal(true).
42-literal(false).
43-
44-
45-/*
46-Functions
47-*/
48-
49-func(cons, [A, B|S], [[B|A]|S]).
50-func(swap, [A, B|S], [B, A|S]).
51-func(dup, [A|S], [A, A|S]).
52-func(pop, [_|S], S ).
53-
54-func(uncons, Si, So) :- func(cons, So, Si).
55-
56-func(+, [A, B|S], [B+A|S]).
57-func(=, [A|S], [B|S]) :- B is A.
58-
59-func(clear, _, []).
60-func(stack, S, [S|S]).
61-
62-
63-/*
64-Definitions
65-*/
66-
67-% This is NOT the Continuation-Passing Style
68-%
69-% func(Name, Si, So) :- Name =- Body, thun(Body, Si, So).
70-
71-func(inscribe, [Definition|S], S) :-
72- Definition = [Name|Body],
73- atom(Name),
74- assertz(Name =- Body).
75-
76-swons =- [swap, cons].
77-x =- [dup, i].
78-unit =- [[], cons].
79-enstacken =- [stack, [clear], dip].
80-
81-% This IS the Continuation-Passing Style
82-%
83-combo(Name, S, S, Ei, Eo) :- Name =- Body, append(Body, Ei, Eo).
84-
85-/*
86-Combinators
87-*/
88-
89-combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
90-combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
91-combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
92-
93-combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
94-combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
95-
96-combo(loop, [_, false|S], S, E, E ).
97-combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
98-
99-combo(step, [_, []|S], S, E, E ).
100-combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
101-combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
102-
103-
104-/*
105-Main Loop
106-*/
107-
108-loop :- line(Line), loop(Line, [], _Out).
109-
110-loop([eof], S, S) :- !.
111-loop( Line, In, Out) :-
112- do_line(Line, In, S),
113- write(S), nl,
114- line(NextLine), !,
115- loop(NextLine, S, Out).
116-
117-
118-do_line(Line, In, Out) :- phrase(joy_parse(E), Line), thun(E, In, Out).
119-do_line(_Line, S, S) :- write('Err'), nl.
120-
diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/junk/gthun.pl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/thun/gnu-prolog/junk/gthun.pl Sat Aug 10 22:07:17 2019 -0700
@@ -0,0 +1,120 @@
1+
2+:- op(990, xfy, =-).
3+:- dynamic((=-)/2).
4+
5+:- initialization(loop).
6+
7+
8+/*
9+Parser
10+*/
11+
12+joy_parse([T|S]) --> blanks, joy_term(T), blanks, joy_parse(S).
13+joy_parse([]) --> [].
14+
15+joy_term(N) --> num(N), !.
16+joy_term(S) --> [0'[], !, joy_parse(S), [0']].
17+joy_term(A) --> chars(Chars), !, {atom_codes(A, Chars)}.
18+
19+
20+/*
21+Interpreter.
22+*/
23+
24+thun([], S, S).
25+
26+thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
27+thun( [Func|E], Si, So) :- func(Func, Si, S), !, thun(E, S, So).
28+thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), !, thun(Eo, S, So).
29+
30+thun(Err, S, [Err|S]) :- write('Unknown term!'), nl.
31+
32+
33+/*
34+Literals
35+*/
36+
37+literal(V) :- var(V).
38+literal(I) :- number(I).
39+literal([]).
40+literal([_|_]).
41+literal(true).
42+literal(false).
43+
44+
45+/*
46+Functions
47+*/
48+
49+func(cons, [A, B|S], [[B|A]|S]).
50+func(swap, [A, B|S], [B, A|S]).
51+func(dup, [A|S], [A, A|S]).
52+func(pop, [_|S], S ).
53+
54+func(uncons, Si, So) :- func(cons, So, Si).
55+
56+func(+, [A, B|S], [B+A|S]).
57+func(=, [A|S], [B|S]) :- B is A.
58+
59+func(clear, _, []).
60+func(stack, S, [S|S]).
61+
62+
63+/*
64+Definitions
65+*/
66+
67+% This is NOT the Continuation-Passing Style
68+%
69+% func(Name, Si, So) :- Name =- Body, thun(Body, Si, So).
70+
71+func(inscribe, [Definition|S], S) :-
72+ Definition = [Name|Body],
73+ atom(Name),
74+ assertz(Name =- Body).
75+
76+swons =- [swap, cons].
77+x =- [dup, i].
78+unit =- [[], cons].
79+enstacken =- [stack, [clear], dip].
80+
81+% This IS the Continuation-Passing Style
82+%
83+combo(Name, S, S, Ei, Eo) :- Name =- Body, append(Body, Ei, Eo).
84+
85+/*
86+Combinators
87+*/
88+
89+combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
90+combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
91+combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
92+
93+combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
94+combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
95+
96+combo(loop, [_, false|S], S, E, E ).
97+combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
98+
99+combo(step, [_, []|S], S, E, E ).
100+combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
101+combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
102+
103+
104+/*
105+Main Loop
106+*/
107+
108+loop :- line(Line), loop(Line, [], _Out).
109+
110+loop([eof], S, S) :- !.
111+loop( Line, In, Out) :-
112+ do_line(Line, In, S),
113+ write(S), nl,
114+ line(NextLine), !,
115+ loop(NextLine, S, Out).
116+
117+
118+do_line(Line, In, Out) :- phrase(joy_parse(E), Line), thun(E, In, Out).
119+do_line(_Line, S, S) :- write('Err'), nl.
120+
diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/junk/meta.pl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/thun/gnu-prolog/junk/meta.pl Sat Aug 10 22:07:17 2019 -0700
@@ -0,0 +1,10 @@
1+
2+
3+do(DCG) :-
4+ fd_domain(X, 0, 9),
5+ fd_labeling(X),
6+ number_codes(X, [C]),
7+ DCG = `-->`(digit(C), [C]).
8+
9+
10+
diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/junk/swi-thun.pl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/thun/gnu-prolog/junk/swi-thun.pl Sat Aug 10 22:07:17 2019 -0700
@@ -0,0 +1,350 @@
1+:- dynamic(func/3).
2+:- discontiguous(func/3).
3+
4+/*
5+ Copyright © 2018, 2019 Simon Forman
6+
7+ This file is part of Thun
8+
9+ Thun is free software: you can redistribute it and/or modify
10+ it under the terms of the GNU General Public License as published by
11+ the Free Software Foundation, either version 3 of the License, or
12+ (at your option) any later version.
13+
14+ Thun is distributed in the hope that it will be useful,
15+ but WITHOUT ANY WARRANTY; without even the implied warranty of
16+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17+ GNU General Public License for more details.
18+
19+ You should have received a copy of the GNU General Public License
20+ along with Thun. If not see <http://www.gnu.org/licenses/>.
21+
22+*/
23+:- dynamic(def/2).
24+
25+
26+/*
27+
28+To handle comparision operators the possibility of exceptions due to
29+insufficiently instantiated arguments must be handled. First try to make
30+the comparison and set the result to a Boolean atom. If an exception
31+happens just leave the comparison expression as the result and some other
32+function or combinator will deal with it. Example:
33+
34+ func(>, [A, B|S], [C|S]) :- catch(
35+ (B > A -> C=true ; C=false),
36+ _,
37+ C=(B>A) % in case of error.
38+ ).
39+
40+To save on conceptual overhead I've defined a term_expansion/2 that sets
41+up the func/3 for each op.
42+*/
43+
44+term_expansion(comparison_operator(X), (func(X, [A, B|S], [C|S]) :-
45+ F =.. [X, B, A], catch((F -> C=true ; C=false), _, C=F))).
46+
47+% I don't use Prolog-compatible op symbols in all cases.
48+term_expansion(comparison_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
49+ F =.. [Y, B, A], catch((F -> C=true ; C=false), _, C=F))).
50+
51+% Likewise for math operators, try to evaluate, otherwise use the
52+% symbolic form.
53+
54+term_expansion(math_operator(X), (func(X, [A, B|S], [C|S]) :-
55+ F =.. [X, B, A], catch(C is F, _, C=F))).
56+
57+term_expansion(math_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
58+ F =.. [Y, B, A], catch(C is F, _, C=F))).
59+
60+
61+/*
62+An entry point.
63+*/
64+
65+joy(InputString, StackIn, StackOut) :-
66+ phrase(joy_parse(Expression), InputString), !,
67+ thun(Expression, StackIn, StackOut).
68+
69+/*
70+Parser
71+
72+ joy :== number | '[' joy* ']' | atom
73+
74+*/
75+
76+joy_parse([T|J]) --> blanks, joy_term(T), blanks, joy_parse(J).
77+joy_parse([]) --> [].
78+
79+joy_term(N) --> number(N), !.
80+joy_term(J) --> "[", !, joy_parse(J), "]".
81+joy_term(C) --> symbol(C).
82+
83+symbol(C) --> chars(Chars), !, {Chars \= [61, 61], atom_string(C, Chars)}.
84+
85+chars([Ch|Rest]) --> char(Ch), chars(Rest).
86+chars([Ch]) --> char(Ch).
87+
88+char(Ch) --> [Ch], {Ch \== 91, Ch \== 93, code_type(Ch, graph)}.
89+
90+
91+/*
92+Interpreter
93+thun(Expression, InputStack, OutputStack)
94+*/
95+
96+thun([], S, S).
97+thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
98+thun( [Def|E], Si, So) :- def(Def, Body), !, append(Body, E, Eo), thun(Eo, Si, So).
99+thun( [Func|E], Si, So) :- func(Func, Si, S), thun(E, S, So).
100+thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
101+
102+% Some error handling.
103+
104+thun([Unknown|E], Si, So) :-
105+ damned_thing(Unknown),
106+ write("wtf? "),
107+ writeln(Unknown),
108+ So = [[Unknown|E]|Si].
109+
110+damned_thing(It) :-
111+ \+ literal(It),
112+ \+ def(It, _),
113+ \+ func(It, _, _),
114+ \+ combo(It, _, _, _, _).
115+
116+
117+/*
118+Literals
119+*/
120+
121+literal(V) :- var(V).
122+literal(I) :- number(I).
123+literal([]).
124+literal([_|_]).
125+literal(true).
126+literal(false).
127+
128+% Symbolic math expressions are literals.
129+literal(_+_).
130+literal(_-_).
131+literal(_*_).
132+literal(_/_).
133+literal(_ mod _).
134+
135+% Symbolic comparisons are literals.
136+literal(_>_).
137+literal(_<_).
138+literal(_>=_).
139+literal(_=<_).
140+literal(_=:=_).
141+literal(_=\=_).
142+
143+
144+/*
145+Functions
146+*/
147+
148+func(cons, [A, B|S], [[B|A]|S]).
149+func(swap, [A, B|S], [B, A|S]).
150+func(dup, [A|S], [A, A|S]).
151+func(pop, [_|S], S ).
152+
153+% Symbolic math. Compute the answer, or derivative, or whatever, later.
154+math_operator(+).
155+math_operator(-).
156+math_operator(*).
157+math_operator(/).
158+math_operator(mod).
159+
160+% Attempt to calculate the value of a symbolic math expression.
161+func(calc, [A|S], [B|S]) :- B is A.
162+
163+func(sqrt, [A|S], [sqrt(A)|S]).
164+
165+func(concat, [A, B|S], [C|S]) :- append(B, A, C).
166+func(flatten, [A|S], [B|S]) :- flatten(A, B).
167+func(swaack, [R|S], [S|R]).
168+func(stack, S , [S|S]).
169+func(clear, _ , []).
170+func(first, [[X|_]|S], [X|S]).
171+func(rest, [[_|X]|S], [X|S]).
172+func(unit, [X|S], [[X]|S]).
173+
174+func(rolldown, [A, B, C|S], [B, C, A|S]).
175+func(dupd, [A, B|S], [A, B, B|S]).
176+func(over, [A, B|S], [B, A, B|S]).
177+func(tuck, [A, B|S], [A, B, A|S]).
178+
179+func(shift, [[B|A], C|D], [A, [B|C]|D]).
180+
181+func(rollup, Si, So) :- func(rolldown, So, Si).
182+func(uncons, Si, So) :- func(cons, So, Si).
183+
184+func(bool, [ 0|S], [false|S]) :- !.
185+func(bool, [ 0.0|S], [false|S]) :- !.
186+func(bool, [ []|S], [false|S]) :- !.
187+func(bool, [ ""|S], [false|S]) :- !.
188+func(bool, [false|S], [false|S]) :- !.
189+
190+func(bool, [_|S], [true|S]).
191+
192+comparison_operator(>).
193+comparison_operator(<).
194+comparison_operator(>=).
195+comparison_operator(<=, =<).
196+comparison_operator(=, =:=).
197+comparison_operator(<>, =\=).
198+
199+
200+/*
201+Definitions
202+*/
203+
204+joy_def(def(Def, Body)) --> symbol(Def), blanks, "==", joy_parse(Body).
205+
206+joy_defs --> blanks, joy_def(Def), {assert_def(Def)}, blanks, joy_defs.
207+joy_defs --> [].
208+
209+assert_defs(DefsFile) :-
210+ read_file_to_codes(DefsFile, Codes, []),
211+ phrase(joy_defs, Codes).
212+
213+assert_def(def(Def, Body)) :-
214+ retractall(def(Def, _)),
215+ assertz(def(Def, Body)).
216+
217+:- assert_defs("defs.txt").
218+
219+
220+/*
221+Combinators
222+*/
223+
224+combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
225+combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
226+combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
227+
228+combo(dupdip, [P, X|S], [X|S], Ei, Eo) :- append(P, [X|Ei], Eo).
229+
230+combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
231+combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
232+combo(branch, [T, F, Expr|S], S, Ei, Eo) :-
233+ \+ Expr = true, \+ Expr = false,
234+ catch( % Try Expr and do one or the other,
235+ (Expr -> append(T, Ei, Eo) ; append(F, Ei, Eo)),
236+ _, % If Expr don't grok, try both branches.
237+ (append(T, Ei, Eo) ; append(F, Ei, Eo))
238+ ).
239+
240+combo(loop, [_, false|S], S, E, E ).
241+combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
242+combo(loop, [B, Expr|S], S, Ei, Eo) :-
243+ \+ Expr = true, \+ Expr = false,
244+ catch( % Try Expr and do one or the other,
245+ (Expr -> append(B, [B, loop|Ei], Eo) ; Ei=Eo),
246+ _, % If Expr don't grok, try both branches.
247+ (Ei=Eo ; append(B, [B, loop|Ei], Eo))
248+ ).
249+
250+combo(step, [_, []|S], S, E, E ).
251+combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
252+combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
253+
254+combo(times, [_, 0|S], S, E, E ).
255+combo(times, [P, 1|S], S, Ei, Eo) :- append(P, Ei, Eo).
256+combo(times, [P, N|S], S, Ei, Eo) :- N #>= 2, M #= N - 1, append(P, [M, P, times|Ei], Eo).
257+combo(times, [_, N|S], S, _, _ ) :- N #< 0, fail.
258+
259+combo(genrec, [R1, R0, Then, If|S],
260+ [ Else, Then, If|S], E, [ifte|E]) :-
261+ Quoted = [If, Then, R0, R1, genrec],
262+ append(R0, [Quoted|R1], Else).
263+
264+/*
265+This is a crude but servicable implementation of the map combinator.
266+
267+Obviously it would be nice to take advantage of the implied parallelism.
268+Instead the quoted program, stack, and terms in the input list are
269+transformed to simple Joy expressions that run the quoted program on
270+prepared copies of the stack that each have one of the input terms on
271+top. These expressions are collected in a list and the whole thing is
272+evaluated (with infra) on an empty list, which becomes the output list.
273+
274+The chief advantage of doing it this way (as opposed to using Prolog's
275+map) is that the whole state remains in the pending expression, so
276+there's nothing stashed in Prolog's call stack. This preserves the nice
277+property that you can interrupt the Joy evaluation and save or transmit
278+the stack+expression knowing that you have all the state.
279+*/
280+
281+combo(map, [_, []|S], [[]|S], E, E ) :- !.
282+combo(map, [P, List|S], [Mapped, []|S], E, [infra|E]) :-
283+ prepare_mapping(P, S, List, Mapped).
284+
285+% Set up a program for each term in ListIn
286+%
287+% [term S] [P] infrst
288+%
289+% prepare_mapping(P, S, ListIn, ListOut).
290+
291+prepare_mapping(P, S, In, Out) :- prepare_mapping(P, S, In, [], Out).
292+
293+prepare_mapping( _, _, [], Out, Out) :- !.
294+prepare_mapping( P, S, [T|In], Acc, Out) :-
295+ prepare_mapping(P, S, In, [[T|S], P, infrst|Acc], Out).
296+
297+
298+/*
299+Compiler
300+*/
301+
302+joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), asserta(Rule).
303+
304+show_joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), portray_clause(Rule).
305+
306+jcmpl(Name, Expression, Rule) :-
307+ call_residue_vars(thun(Expression, Si, So), Term),
308+ copy_term(Term, Term, Gs),
309+ Head =.. [func, Name, Si, So],
310+ rule(Head, Gs, Rule).
311+
312+rule(Head, [], Head ).
313+rule(Head, [A|B], Head :- maplist(call, [A|B])).
314+
315+sjc(Name, InputString) :- phrase(joy_parse(E), InputString), show_joy_compile(Name, E).
316+
317+
318+% Simple DCGs to expand/contract definitions.
319+
320+expando, Body --> [Def], {def(Def, Body)}.
321+contracto, [Def] --> {def(Def, Body)}, Body.
322+
323+% Apply expando/contracto more than once, and descend into sub-lists.
324+% The K term is one of expando or contracto, and the J term is used
325+% on sub-lists, i.e. expando/grow and contracto/shrink.
326+% BTW, "rebo" is a meaningless name, don't break your brain
327+% trying to figure it out.
328+
329+rebo(K, J) --> K , rebo(K, J).
330+rebo(K, J), [E] --> [[H|T]], !, {call(J, [H|T], E)}, rebo(K, J).
331+rebo(K, J), [A] --> [ A ], !, rebo(K, J).
332+rebo(_, _) --> [].
333+
334+to_fixed_point(DCG, Ei, Eo) :-
335+ phrase(DCG, Ei, E), % Apply DCG...
336+ (Ei=E -> Eo=E ; to_fixed_point(DCG, E, Eo)). % ...until a fixed-point is reached.
337+
338+grow --> to_fixed_point(rebo(expando, grow )).
339+shrink --> to_fixed_point(rebo(contracto, shrink)).
340+
341+
342+% format_n(N) --> {number(N), !, number_codes(N, Codes)}, Codes.
343+% format_n(N) --> signed_digits(Codes), !, {number_codes(N, Codes)}.
344+
345+% signed_digits([45|Codes]) --> [45], !, digits(Codes).
346+% signed_digits( Codes ) --> digits(Codes).
347+
348+% digits([Ch|Chars]) --> [Ch], {code_type(Ch, digit)}, digits(Chars).
349+% digits([]), [Ch] --> [Ch], {code_type(Ch, space) ; Ch=0'] }.
350+% digits([], [], _). % Match if followed by space, ], or nothing.
diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/meta.pl
--- a/thun/gnu-prolog/meta.pl Sat Aug 10 22:03:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,10 +0,0 @@
1-
2-
3-do(DCG) :-
4- fd_domain(X, 0, 9),
5- fd_labeling(X),
6- number_codes(X, [C]),
7- DCG = `-->`(digit(C), [C]).
8-
9-
10-
diff -r 541a67d69c9a -r a5b8b7826c48 thun/gnu-prolog/swi-thun.pl
--- a/thun/gnu-prolog/swi-thun.pl Sat Aug 10 22:03:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,350 +0,0 @@
1-:- dynamic(func/3).
2-:- discontiguous(func/3).
3-
4-/*
5- Copyright © 2018, 2019 Simon Forman
6-
7- This file is part of Thun
8-
9- Thun is free software: you can redistribute it and/or modify
10- it under the terms of the GNU General Public License as published by
11- the Free Software Foundation, either version 3 of the License, or
12- (at your option) any later version.
13-
14- Thun is distributed in the hope that it will be useful,
15- but WITHOUT ANY WARRANTY; without even the implied warranty of
16- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17- GNU General Public License for more details.
18-
19- You should have received a copy of the GNU General Public License
20- along with Thun. If not see <http://www.gnu.org/licenses/>.
21-
22-*/
23-:- dynamic(def/2).
24-
25-
26-/*
27-
28-To handle comparision operators the possibility of exceptions due to
29-insufficiently instantiated arguments must be handled. First try to make
30-the comparison and set the result to a Boolean atom. If an exception
31-happens just leave the comparison expression as the result and some other
32-function or combinator will deal with it. Example:
33-
34- func(>, [A, B|S], [C|S]) :- catch(
35- (B > A -> C=true ; C=false),
36- _,
37- C=(B>A) % in case of error.
38- ).
39-
40-To save on conceptual overhead I've defined a term_expansion/2 that sets
41-up the func/3 for each op.
42-*/
43-
44-term_expansion(comparison_operator(X), (func(X, [A, B|S], [C|S]) :-
45- F =.. [X, B, A], catch((F -> C=true ; C=false), _, C=F))).
46-
47-% I don't use Prolog-compatible op symbols in all cases.
48-term_expansion(comparison_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
49- F =.. [Y, B, A], catch((F -> C=true ; C=false), _, C=F))).
50-
51-% Likewise for math operators, try to evaluate, otherwise use the
52-% symbolic form.
53-
54-term_expansion(math_operator(X), (func(X, [A, B|S], [C|S]) :-
55- F =.. [X, B, A], catch(C is F, _, C=F))).
56-
57-term_expansion(math_operator(X, Y), (func(X, [A, B|S], [C|S]) :-
58- F =.. [Y, B, A], catch(C is F, _, C=F))).
59-
60-
61-/*
62-An entry point.
63-*/
64-
65-joy(InputString, StackIn, StackOut) :-
66- phrase(joy_parse(Expression), InputString), !,
67- thun(Expression, StackIn, StackOut).
68-
69-/*
70-Parser
71-
72- joy :== number | '[' joy* ']' | atom
73-
74-*/
75-
76-joy_parse([T|J]) --> blanks, joy_term(T), blanks, joy_parse(J).
77-joy_parse([]) --> [].
78-
79-joy_term(N) --> number(N), !.
80-joy_term(J) --> "[", !, joy_parse(J), "]".
81-joy_term(C) --> symbol(C).
82-
83-symbol(C) --> chars(Chars), !, {Chars \= [61, 61], atom_string(C, Chars)}.
84-
85-chars([Ch|Rest]) --> char(Ch), chars(Rest).
86-chars([Ch]) --> char(Ch).
87-
88-char(Ch) --> [Ch], {Ch \== 91, Ch \== 93, code_type(Ch, graph)}.
89-
90-
91-/*
92-Interpreter
93-thun(Expression, InputStack, OutputStack)
94-*/
95-
96-thun([], S, S).
97-thun( [Lit|E], Si, So) :- literal(Lit), !, thun(E, [Lit|Si], So).
98-thun( [Def|E], Si, So) :- def(Def, Body), !, append(Body, E, Eo), thun(Eo, Si, So).
99-thun( [Func|E], Si, So) :- func(Func, Si, S), thun(E, S, So).
100-thun([Combo|E], Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
101-
102-% Some error handling.
103-
104-thun([Unknown|E], Si, So) :-
105- damned_thing(Unknown),
106- write("wtf? "),
107- writeln(Unknown),
108- So = [[Unknown|E]|Si].
109-
110-damned_thing(It) :-
111- \+ literal(It),
112- \+ def(It, _),
113- \+ func(It, _, _),
114- \+ combo(It, _, _, _, _).
115-
116-
117-/*
118-Literals
119-*/
120-
121-literal(V) :- var(V).
122-literal(I) :- number(I).
123-literal([]).
124-literal([_|_]).
125-literal(true).
126-literal(false).
127-
128-% Symbolic math expressions are literals.
129-literal(_+_).
130-literal(_-_).
131-literal(_*_).
132-literal(_/_).
133-literal(_ mod _).
134-
135-% Symbolic comparisons are literals.
136-literal(_>_).
137-literal(_<_).
138-literal(_>=_).
139-literal(_=<_).
140-literal(_=:=_).
141-literal(_=\=_).
142-
143-
144-/*
145-Functions
146-*/
147-
148-func(cons, [A, B|S], [[B|A]|S]).
149-func(swap, [A, B|S], [B, A|S]).
150-func(dup, [A|S], [A, A|S]).
151-func(pop, [_|S], S ).
152-
153-% Symbolic math. Compute the answer, or derivative, or whatever, later.
154-math_operator(+).
155-math_operator(-).
156-math_operator(*).
157-math_operator(/).
158-math_operator(mod).
159-
160-% Attempt to calculate the value of a symbolic math expression.
161-func(calc, [A|S], [B|S]) :- B is A.
162-
163-func(sqrt, [A|S], [sqrt(A)|S]).
164-
165-func(concat, [A, B|S], [C|S]) :- append(B, A, C).
166-func(flatten, [A|S], [B|S]) :- flatten(A, B).
167-func(swaack, [R|S], [S|R]).
168-func(stack, S , [S|S]).
169-func(clear, _ , []).
170-func(first, [[X|_]|S], [X|S]).
171-func(rest, [[_|X]|S], [X|S]).
172-func(unit, [X|S], [[X]|S]).
173-
174-func(rolldown, [A, B, C|S], [B, C, A|S]).
175-func(dupd, [A, B|S], [A, B, B|S]).
176-func(over, [A, B|S], [B, A, B|S]).
177-func(tuck, [A, B|S], [A, B, A|S]).
178-
179-func(shift, [[B|A], C|D], [A, [B|C]|D]).
180-
181-func(rollup, Si, So) :- func(rolldown, So, Si).
182-func(uncons, Si, So) :- func(cons, So, Si).
183-
184-func(bool, [ 0|S], [false|S]) :- !.
185-func(bool, [ 0.0|S], [false|S]) :- !.
186-func(bool, [ []|S], [false|S]) :- !.
187-func(bool, [ ""|S], [false|S]) :- !.
188-func(bool, [false|S], [false|S]) :- !.
189-
190-func(bool, [_|S], [true|S]).
191-
192-comparison_operator(>).
193-comparison_operator(<).
194-comparison_operator(>=).
195-comparison_operator(<=, =<).
196-comparison_operator(=, =:=).
197-comparison_operator(<>, =\=).
198-
199-
200-/*
201-Definitions
202-*/
203-
204-joy_def(def(Def, Body)) --> symbol(Def), blanks, "==", joy_parse(Body).
205-
206-joy_defs --> blanks, joy_def(Def), {assert_def(Def)}, blanks, joy_defs.
207-joy_defs --> [].
208-
209-assert_defs(DefsFile) :-
210- read_file_to_codes(DefsFile, Codes, []),
211- phrase(joy_defs, Codes).
212-
213-assert_def(def(Def, Body)) :-
214- retractall(def(Def, _)),
215- assertz(def(Def, Body)).
216-
217-:- assert_defs("defs.txt").
218-
219-
220-/*
221-Combinators
222-*/
223-
224-combo(i, [P|S], S, Ei, Eo) :- append(P, Ei, Eo).
225-combo(dip, [P, X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
226-combo(dipd, [P, X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
227-
228-combo(dupdip, [P, X|S], [X|S], Ei, Eo) :- append(P, [X|Ei], Eo).
229-
230-combo(branch, [T, _, true|S], S, Ei, Eo) :- append(T, Ei, Eo).
231-combo(branch, [_, F, false|S], S, Ei, Eo) :- append(F, Ei, Eo).
232-combo(branch, [T, F, Expr|S], S, Ei, Eo) :-
233- \+ Expr = true, \+ Expr = false,
234- catch( % Try Expr and do one or the other,
235- (Expr -> append(T, Ei, Eo) ; append(F, Ei, Eo)),
236- _, % If Expr don't grok, try both branches.
237- (append(T, Ei, Eo) ; append(F, Ei, Eo))
238- ).
239-
240-combo(loop, [_, false|S], S, E, E ).
241-combo(loop, [B, true|S], S, Ei, Eo) :- append(B, [B, loop|Ei], Eo).
242-combo(loop, [B, Expr|S], S, Ei, Eo) :-
243- \+ Expr = true, \+ Expr = false,
244- catch( % Try Expr and do one or the other,
245- (Expr -> append(B, [B, loop|Ei], Eo) ; Ei=Eo),
246- _, % If Expr don't grok, try both branches.
247- (Ei=Eo ; append(B, [B, loop|Ei], Eo))
248- ).
249-
250-combo(step, [_, []|S], S, E, E ).
251-combo(step, [P, [X]|S], [X|S], Ei, Eo) :- !, append(P, Ei, Eo).
252-combo(step, [P, [X|Z]|S], [X|S], Ei, Eo) :- append(P, [Z, P, step|Ei], Eo).
253-
254-combo(times, [_, 0|S], S, E, E ).
255-combo(times, [P, 1|S], S, Ei, Eo) :- append(P, Ei, Eo).
256-combo(times, [P, N|S], S, Ei, Eo) :- N #>= 2, M #= N - 1, append(P, [M, P, times|Ei], Eo).
257-combo(times, [_, N|S], S, _, _ ) :- N #< 0, fail.
258-
259-combo(genrec, [R1, R0, Then, If|S],
260- [ Else, Then, If|S], E, [ifte|E]) :-
261- Quoted = [If, Then, R0, R1, genrec],
262- append(R0, [Quoted|R1], Else).
263-
264-/*
265-This is a crude but servicable implementation of the map combinator.
266-
267-Obviously it would be nice to take advantage of the implied parallelism.
268-Instead the quoted program, stack, and terms in the input list are
269-transformed to simple Joy expressions that run the quoted program on
270-prepared copies of the stack that each have one of the input terms on
271-top. These expressions are collected in a list and the whole thing is
272-evaluated (with infra) on an empty list, which becomes the output list.
273-
274-The chief advantage of doing it this way (as opposed to using Prolog's
275-map) is that the whole state remains in the pending expression, so
276-there's nothing stashed in Prolog's call stack. This preserves the nice
277-property that you can interrupt the Joy evaluation and save or transmit
278-the stack+expression knowing that you have all the state.
279-*/
280-
281-combo(map, [_, []|S], [[]|S], E, E ) :- !.
282-combo(map, [P, List|S], [Mapped, []|S], E, [infra|E]) :-
283- prepare_mapping(P, S, List, Mapped).
284-
285-% Set up a program for each term in ListIn
286-%
287-% [term S] [P] infrst
288-%
289-% prepare_mapping(P, S, ListIn, ListOut).
290-
291-prepare_mapping(P, S, In, Out) :- prepare_mapping(P, S, In, [], Out).
292-
293-prepare_mapping( _, _, [], Out, Out) :- !.
294-prepare_mapping( P, S, [T|In], Acc, Out) :-
295- prepare_mapping(P, S, In, [[T|S], P, infrst|Acc], Out).
296-
297-
298-/*
299-Compiler
300-*/
301-
302-joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), asserta(Rule).
303-
304-show_joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), portray_clause(Rule).
305-
306-jcmpl(Name, Expression, Rule) :-
307- call_residue_vars(thun(Expression, Si, So), Term),
308- copy_term(Term, Term, Gs),
309- Head =.. [func, Name, Si, So],
310- rule(Head, Gs, Rule).
311-
312-rule(Head, [], Head ).
313-rule(Head, [A|B], Head :- maplist(call, [A|B])).
314-
315-sjc(Name, InputString) :- phrase(joy_parse(E), InputString), show_joy_compile(Name, E).
316-
317-
318-% Simple DCGs to expand/contract definitions.
319-
320-expando, Body --> [Def], {def(Def, Body)}.
321-contracto, [Def] --> {def(Def, Body)}, Body.
322-
323-% Apply expando/contracto more than once, and descend into sub-lists.
324-% The K term is one of expando or contracto, and the J term is used
325-% on sub-lists, i.e. expando/grow and contracto/shrink.
326-% BTW, "rebo" is a meaningless name, don't break your brain
327-% trying to figure it out.
328-
329-rebo(K, J) --> K , rebo(K, J).
330-rebo(K, J), [E] --> [[H|T]], !, {call(J, [H|T], E)}, rebo(K, J).
331-rebo(K, J), [A] --> [ A ], !, rebo(K, J).
332-rebo(_, _) --> [].
333-
334-to_fixed_point(DCG, Ei, Eo) :-
335- phrase(DCG, Ei, E), % Apply DCG...
336- (Ei=E -> Eo=E ; to_fixed_point(DCG, E, Eo)). % ...until a fixed-point is reached.
337-
338-grow --> to_fixed_point(rebo(expando, grow )).
339-shrink --> to_fixed_point(rebo(contracto, shrink)).
340-
341-
342-% format_n(N) --> {number(N), !, number_codes(N, Codes)}, Codes.
343-% format_n(N) --> signed_digits(Codes), !, {number_codes(N, Codes)}.
344-
345-% signed_digits([45|Codes]) --> [45], !, digits(Codes).
346-% signed_digits( Codes ) --> digits(Codes).
347-
348-% digits([Ch|Chars]) --> [Ch], {code_type(Ch, digit)}, digits(Chars).
349-% digits([]), [Ch] --> [Ch], {code_type(Ch, space) ; Ch=0'] }.
350-% digits([], [], _). % Match if followed by space, ], or nothing.
Show on old repository browser