--- /dev/null
+/*
+
+████████╗██╗ ██╗██╗ ██╗███╗ ██╗
+╚══██╔══╝██║ ██║██║ ██║████╗ ██║
+ ██║ ███████║██║ ██║██╔██╗ ██║
+ ██║ ██╔══██║██║ ██║██║╚██╗██║
+ ██║ ██║ ██║╚██████╔╝██║ ╚████║
+ ╚═╝ ╚═╝ ╚═╝ ╚═════╝ ╚═╝ ╚═══╝
+
+ Copyright © 2018, 2019, 2020 Simon Forman
+
+ This file is part of Thun
+
+ Thun is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ Thun is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with Thun. If not see <http://www.gnu.org/licenses/>.
+
+(Big fonts are from Figlet "ANSI Shadow" http://www.patorjk.com/software/taag/#p=display&f=ANSI%20Shadow&t=formatter
+ and "Small".)
+
+Table of Contents
+ Parser & Grammar
+ Semantics
+ Functions
+ Combinators
+ Definitions
+ Compiler
+ to Prolog
+ to Machine Code
+ Meta-Programming
+ Expand/Contract Definitions
+ Formatter
+ Partial Reducer
+
+ */
+
+:- use_module(library(clpfd)).
+:- use_module(library(dcg/basics)).
+:- dynamic func/3.
+:- dynamic def/2.
+
+
+/*
+An entry point.
+*/
+
+joy(InputString, StackIn, StackOut) :-
+ phrase(joy_parse(Expression), InputString), !,
+ thun(Expression, StackIn, StackOut).
+
+/*
+
+██████╗ █████╗ ██████╗ ███████╗███████╗██████╗ ██╗
+██╔══██╗██╔══██╗██╔══██╗██╔════╝██╔════╝██╔══██╗ ██║
+██████╔╝███████║██████╔╝███████╗█████╗ ██████╔╝ ████████╗
+██╔═══╝ ██╔══██║██╔══██╗╚════██║██╔══╝ ██╔══██╗ ██╔═██╔═╝
+██║ ██║ ██║██║ ██║███████║███████╗██║ ██║ ██████║
+╚═╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚══════╝╚═╝ ╚═╝ ╚═════╝
+
+ ██████╗ ██████╗ █████╗ ███╗ ███╗███╗ ███╗ █████╗ ██████╗
+██╔════╝ ██╔══██╗██╔══██╗████╗ ████║████╗ ████║██╔══██╗██╔══██╗
+██║ ███╗██████╔╝███████║██╔████╔██║██╔████╔██║███████║██████╔╝
+██║ ██║██╔══██╗██╔══██║██║╚██╔╝██║██║╚██╔╝██║██╔══██║██╔══██╗
+╚██████╔╝██║ ██║██║ ██║██║ ╚═╝ ██║██║ ╚═╝ ██║██║ ██║██║ ██║
+ ╚═════╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝
+
+The grammar of Joy is very simple. A Joy expression is zero or more Joy
+terms separated by blanks, and terms can be either integers, Booleans,
+quoted Joy expressions, or symbols (names of functions.)
+
+ joy ::= ( blanks term blanks )*
+
+ term ::= integer | bool | '[' joy ']' | symbol
+
+ integer ::= [ '-' | '+' ] ('0'...'9')+
+ bool ::= 'true' | 'false'
+ symbol ::= char+
+
+ char ::= <Any non-space other than '[' and ']'.>
+ blanks ::= <Zero or more whitespace characters.>
+
+For integer//1 and blanks//0 I delegate to SWI's dcg/basics library. The
+blank//0 matches and discards space and newline characters and integer//1
+"processes an optional sign followed by a non-empty sequence of digits
+into an integer." (https://www.swi-prolog.org/pldoc/man?section=basics)
+
+Symbols can be made of any non-blank characters except '['and ']' which
+are fully reserved for list literals (aka "quotes"). 'true' and 'false'
+would be valid symbols but they are reserved for Boolean literals.
+
+For now strings are neglected in favor of lists of numbers. (But there's
+no support for parsing string notation and converting to lists of ints.)
+
+One wrinkle of the grammar is that numbers do not need to be followed by
+blanks before the next match, which is nice when the next match is a
+square bracket but a little weird when it's a symbol term. E.g. "2[3]"
+parses as [2, [3]] but "23x" parses as [23, x]. It's a minor thing not
+worth disfiguring the grammar to change IMO.
+
+Integers are converted to Prolog integers, symbols and bools to Prolog
+atoms, and list literals to Prolog lists.
+
+*/
+
+joy_parse([J|Js]) --> blanks, joy_term(J), blanks, joy_parse(Js).
+joy_parse([]) --> [].
+
+joy_term(int(I)) --> integer(I), !.
+joy_term(list(J)) --> "[", !, joy_parse(J), "]".
+joy_term(bool(true)) --> "true", !.
+joy_term(bool(false)) --> "false", !.
+joy_term(symbol(S)) --> symbol(S).
+
+symbol(C) --> chars(Chars), !, {atom_string(C, Chars)}.
+
+chars([Ch|Rest]) --> char(Ch), chars(Rest).
+chars([Ch]) --> char(Ch).
+
+char(Ch) --> [Ch], {Ch \== 91, Ch \== 93, code_type(Ch, graph)}.
+
+
+/* Here is an example of Joy code:
+
+ [ [[abs] ii <=]
+ [
+ [<>] [pop !-] ||
+ ] &&
+ ]
+ [[ !-] [[++]] [[--]] ifte dip]
+ [[pop !-] [--] [++] ifte ]
+ ifte
+
+It probably seems unreadable but with a little familiarity it becomes
+just as legible as any other notation. This function accepts two
+integers on the stack and increments or decrements one of them such that
+the new pair of numbers is the next coordinate pair in a square spiral
+(like that used to construct an Ulam Spiral). It is adapted from the
+code in the answer here:
+
+https://stackoverflow.com/questions/398299/looping-in-a-spiral/31864777#31864777
+
+It can be used with the x combinator to make a kind of generator for
+spiral square coordinates.
+
+
+
+███████╗███████╗███╗ ███╗ █████╗ ███╗ ██╗████████╗██╗ ██████╗███████╗
+██╔════╝██╔════╝████╗ ████║██╔══██╗████╗ ██║╚══██╔══╝██║██╔════╝██╔════╝
+███████╗█████╗ ██╔████╔██║███████║██╔██╗ ██║ ██║ ██║██║ ███████╗
+╚════██║██╔══╝ ██║╚██╔╝██║██╔══██║██║╚██╗██║ ██║ ██║██║ ╚════██║
+███████║███████╗██║ ╚═╝ ██║██║ ██║██║ ╚████║ ██║ ██║╚██████╗███████║
+╚══════╝╚══════╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═══╝ ╚═╝ ╚═╝ ╚═════╝╚══════╝
+
+The fundamental Joy relation involves an expression and two stacks. One
+stack serves as input and the other as output.
+
+ thun(Expression, InputStack, OutputStack)
+
+The null expression (denoted by an empty Prolog list) is effectively an
+identity function and serves as the end-of-processing marker. As a
+matter of efficiency (of Prolog) the thun/3 predicate picks off the first
+term of the expression (if any) and passes it to thun/4 which can then
+take advantage of Prolog indexing on the first term of a predicate. */
+
+thun([], S, S).
+thun([Term|E], Si, So) :- thun(Term, E, Si, So).
+
+/* The thun/4 predicate was originally written in terms of the thun/3
+predicate, which was very elegant, but prevented (I assume but have not
+checked) tail-call recursion. In order to alleviate this, partial
+reduction is used to generate the actual thun/4 rules, see below.
+
+Original thun/4 code:
+
+thun(int(I), E, Si, So) :- thun(E, [ int(I)|Si], So).
+thun(bool(B), E, Si, So) :- thun(E, [bool(B)|Si], So).
+thun(list(L), E, Si, So) :- thun(E, [list(L)|Si], So).
+thun(symbol(Def), E, Si, So) :- def(Def, Body), append(Body, E, Eo), thun(Eo, Si, So).
+thun(symbol(Func), E, Si, So) :- func(Func, Si, S), thun(E, S, So).
+thun(symbol(Combo), E, Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
+
+Integers, Boolean values, and lists are put onto the stack, symbols are
+dispatched to one of three kinds of processing: functions, combinators
+and definitions (see "defs.txt".) */
+
+% Literals turn out okay.
+
+thun(int(A), [], B, [int(A)|B]).
+thun(int(C), [A|B], D, E) :- thun(A, B, [int(C)|D], E).
+
+thun(bool(A), [], B, [bool(A)|B]).
+thun(bool(C), [A|B], D, E) :- thun(A, B, [bool(C)|D], E).
+
+thun(list(A), [], B, [list(A)|B]).
+thun(list(C), [A|B], D, E) :- thun(A, B, [list(C)|D], E).
+
+% Partial reduction works for func/3 cases.
+
+thun(symbol(A), [], B, C) :- func(A, B, C).
+thun(symbol(A), [C|D], B, F) :- func(A, B, E), thun(C, D, E, F).
+
+% Combinators look ok too.
+
+% thun(symbol(A), D, B, C) :- combo(A, B, C, D, []).
+% thun(symbol(A), C, B, G) :- combo(A, B, F, C, [D|E]), thun(D, E, F, G).
+
+% However, in this case, I think the original version will be more
+% efficient.
+
+thun(symbol(Combo), E, Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So).
+
+% In the reduced rules Prolog will redo all the work of the combo/5
+% predicate on backtracking through the second rule. It will try combo/5,
+% which usually won't end in Eo=[] so the first rule fails, then it will
+% try combo/5 again in the second rule. In this form, after combo/5 has
+% completed Prolog has computed Eo and can index on it for thun/3.
+%
+% Neither functions nor definitions can affect the expression so this
+% consideration doesn't apply to those rules. The unification of the head
+% clauses will distinguish the cases for them.
+
+% Definitions don't work though (See "Partial Reducer" section below.)
+% I hand-wrote the def/3 cases here.
+
+thun(symbol(D), [], Si, So) :- def(D, [DH| E]), thun(DH, E, Si, So).
+thun(symbol(D), [H|E0], Si, So) :- def(D, [DH|DE]),
+ append(DE, [H|E0], E), /* ................. */ thun(DH, E, Si, So).
+
+% Partial reduction has been the subject of a great deal of research and
+% I'm sure there's a way to make definitions work, but it's beyond the
+% scope of the project at the moment. It works well enough as-is that I'm
+% happy to manually write out two rules by hand.
+
+% Some error handling.
+
+thun(symbol(Unknown), _, _, _) :-
+ \+ def(Unknown, _),
+ \+ func(Unknown, _, _),
+ \+ combo(Unknown, _, _, _, _),
+ write("Unknown: "),
+ writeln(Unknown),
+ fail.
+
+/*
+
+███████╗██╗ ██╗███╗ ██╗ ██████╗████████╗██╗ ██████╗ ███╗ ██╗███████╗
+██╔════╝██║ ██║████╗ ██║██╔════╝╚══██╔══╝██║██╔═══██╗████╗ ██║██╔════╝
+█████╗ ██║ ██║██╔██╗ ██║██║ ██║ ██║██║ ██║██╔██╗ ██║███████╗
+██╔══╝ ██║ ██║██║╚██╗██║██║ ██║ ██║██║ ██║██║╚██╗██║╚════██║
+██║ ╚██████╔╝██║ ╚████║╚██████╗ ██║ ██║╚██████╔╝██║ ╚████║███████║
+╚═╝ ╚═════╝ ╚═╝ ╚═══╝ ╚═════╝ ╚═╝ ╚═╝ ╚═════╝ ╚═╝ ╚═══╝╚══════╝
+
+*/
+
+func(words, S, [Words|S]) :- words(Words).
+
+func(swap, [A, B|S], [B, A|S]).
+func(dup, [A|S], [A, A|S]).
+func(pop, [_|S], S ).
+
+func(cons, [list(A), B |S], [list([B|A])|S]).
+func(concat, [list(A), list(B)|S], [list(C)|S]) :- append(B, A, C).
+func(flatten, [list(A)|S], [list(B)|S]) :- flatten(A, B).
+func(swaack, [list(R)|S], [list(S)|R]).
+func(stack, S , [list(S)|S]).
+func(clear, _ , []).
+func(first, [list([X|_])|S], [ X |S]).
+func(rest, [list([_|X])|S], [list(X)|S]).
+func(unit, [X|S], [list([X])|S]).
+
+func(rolldown, [A, B, C|S], [B, C, A|S]).
+func(dupd, [A, B|S], [A, B, B|S]).
+func(over, [A, B|S], [B, A, B|S]).
+func(tuck, [A, B|S], [A, B, A|S]).
+
+func(shift, [list([B|A]), list(C)|D], [list(A), list([B|C])|D]).
+
+func(rollup, Si, So) :- func(rolldown, So, Si).
+func(uncons, Si, So) :- func(cons, So, Si).
+
+func(bool, [ int(0)|S], [bool(false)|S]).
+func(bool, [ list([])|S], [bool(false)|S]).
+func(bool, [bool(false)|S], [bool(false)|S]).
+
+func(bool, [ int(N)|S], [bool(true)|S]) :- N #\= 0.
+func(bool, [list([_|_])|S], [bool(true)|S]).
+func(bool, [ bool(true)|S], [bool(true)|S]).
+% func(bool, [A|S], [bool(true)|S]) :- \+ func(bool, [A], [bool(false)]).
+
+func('empty?', [ list([])|S], [ bool(true)|S]).
+func('empty?', [ list([_|_])|S], [bool(false)|S]).
+
+func('list?', [ list(_)|S], [ bool(true)|S]).
+func('list?', [ bool(_)|S], [bool(false)|S]).
+func('list?', [ int(_)|S], [bool(false)|S]).
+func('list?', [symbol(_)|S], [bool(false)|S]).
+
+func('one-or-more?', [list([_|_])|S], [ bool(true)|S]).
+func('one-or-more?', [ list([])|S], [bool(false)|S]).
+
+func(and, [bool(true), bool(true)|S], [ bool(true)|S]).
+func(and, [bool(true), bool(false)|S], [bool(false)|S]).
+func(and, [bool(false), bool(true)|S], [bool(false)|S]).
+func(and, [bool(false), bool(false)|S], [bool(false)|S]).
+
+func(or, [bool(true), bool(true)|S], [ bool(true)|S]).
+func(or, [bool(true), bool(false)|S], [ bool(true)|S]).
+func(or, [bool(false), bool(true)|S], [ bool(true)|S]).
+func(or, [bool(false), bool(false)|S], [bool(false)|S]).
+
+func( + , [int(A), int(B)|S], [int(C)|S]) :- C #= A + B.
+func( - , [int(A), int(B)|S], [int(C)|S]) :- C #= B - A.
+func( * , [int(A), int(B)|S], [int(C)|S]) :- C #= A * B.
+func( / , [int(A), int(B)|S], [int(C)|S]) :- C #= B div A.
+func('%', [int(A), int(B)|S], [int(C)|S]) :- C #= B mod A.
+
+func('/%', [int(A), int(B)|S], [int(C), int(D)|S]) :- C #= B div A, D #= B mod A.
+func( pm , [int(A), int(B)|S], [int(C), int(D)|S]) :- C #= A + B, D #= B - A.
+
+func(>, [int(A), int(B)|S], [T|S]) :- B #> A #<==> R, r_truth(R, T).
+func(<, [int(A), int(B)|S], [T|S]) :- B #< A #<==> R, r_truth(R, T).
+func(=, [int(A), int(B)|S], [T|S]) :- B #= A #<==> R, r_truth(R, T).
+func(>=, [int(A), int(B)|S], [T|S]) :- B #>= A #<==> R, r_truth(R, T).
+func(<=, [int(A), int(B)|S], [T|S]) :- B #=< A #<==> R, r_truth(R, T).
+func(<>, [int(A), int(B)|S], [T|S]) :- B #\= A #<==> R, r_truth(R, T).
+
+r_truth(0, bool(false)).
+r_truth(1, bool(true)).
+
+
+/*
+
+ ██████╗ ██████╗ ███╗ ███╗██████╗ ██╗███╗ ██╗ █████╗ ████████╗ ██████╗ ██████╗ ███████╗
+██╔════╝██╔═══██╗████╗ ████║██╔══██╗██║████╗ ██║██╔══██╗╚══██╔══╝██╔═══██╗██╔══██╗██╔════╝
+██║ ██║ ██║██╔████╔██║██████╔╝██║██╔██╗ ██║███████║ ██║ ██║ ██║██████╔╝███████╗
+██║ ██║ ██║██║╚██╔╝██║██╔══██╗██║██║╚██╗██║██╔══██║ ██║ ██║ ██║██╔══██╗╚════██║
+╚██████╗╚██████╔╝██║ ╚═╝ ██║██████╔╝██║██║ ╚████║██║ ██║ ██║ ╚██████╔╝██║ ██║███████║
+ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝╚═════╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═╝ ╚═╝ ╚═════╝ ╚═╝ ╚═╝╚══════╝
+
+*/
+
+combo(i, [list(P)|S], S, Ei, Eo) :- append(P, Ei, Eo).
+combo(dip, [list(P), X|S], S, Ei, Eo) :- append(P, [X|Ei], Eo).
+combo(dipd, [list(P), X, Y|S], S, Ei, Eo) :- append(P, [Y, X|Ei], Eo).
+
+combo(dupdip, [list(P), X|S], [X|S], Ei, Eo) :- append(P, [X|Ei], Eo).
+
+combo(branch, [list(T), list(_), bool(true)|S], S, Ei, Eo) :- append(T, Ei, Eo).
+combo(branch, [list(_), list(F), bool(false)|S], S, Ei, Eo) :- append(F, Ei, Eo).
+
+combo(loop, [list(_), bool(false)|S], S, E, E ).
+combo(loop, [list(B), bool(true)|S], S, Ei, Eo) :- append(B, [list(B), symbol(loop)|Ei], Eo).
+
+combo(step, [list(_), list([])|S], S, E, E ).
+combo(step, [list(P), list([X|Z])|S], [X|S], Ei, Eo) :- append(P, [list(Z), list(P), symbol(step)|Ei], Eo).
+
+combo(times, [list(_), int(0)|S], S, E, E ).
+combo(times, [list(P), int(1)|S], S, Ei, Eo) :- append(P, Ei, Eo).
+combo(times, [list(P), int(N)|S], S, Ei, Eo) :- N #>= 2, M #= N - 1, append(P, [int(M), list(P), symbol(times)|Ei], Eo).
+combo(times, [list(_), int(N)|S], S, _, _ ) :- N #< 0, fail.
+
+combo(genrec, [R1, R0, Then, If|S],
+ [ Else, Then, If|S], E, [ifte|E]) :-
+ append(R0, [[If, Then, R0, R1, symbol(genrec)]|R1], Else).
+
+/*
+This is a crude but servicable implementation of the map combinator.
+
+Obviously it would be nice to take advantage of the implied parallelism.
+Instead the quoted program, stack, and terms in the input list are
+transformed to simple Joy expressions that run the quoted program on
+prepared copies of the stack that each have one of the input terms on
+top. These expressions are collected in a list and the whole thing is
+evaluated (with infra) on an empty list, which becomes the output list.
+
+The chief advantage of doing it this way (as opposed to using Prolog's
+map) is that the whole state remains in the pending expression, so
+there's nothing stashed in Prolog's call stack. This preserves the nice
+property that you can interrupt the Joy evaluation and save or transmit
+the stack+expression knowing that you have all the state.
+*/
+
+combo(map, [list(_), list([])|S], [list([])|S], E, E ) :- !.
+combo(map, [list(P), list(List)|S], [list(Mapped), list([])|S], E, [symbol(infra)|E]) :-
+ prepare_mapping(list(P), S, List, Mapped).
+
+% Set up a program for each term in ListIn
+%
+% [term S] [P] infrst
+%
+% prepare_mapping(P, S, ListIn, ListOut).
+
+prepare_mapping(Pl, S, In, Out) :- prepare_mapping(Pl, S, In, [], Out).
+
+prepare_mapping( _, _, [], Out, Out) :- !.
+prepare_mapping( Pl, S, [T|In], Acc, Out) :-
+ prepare_mapping(Pl, S, In, [list([T|S]), Pl, symbol(infrst)|Acc], Out).
+
+
+/*
+
+██████╗ ███████╗███████╗██╗███╗ ██╗██╗████████╗██╗ ██████╗ ███╗ ██╗███████╗
+██╔══██╗██╔════╝██╔════╝██║████╗ ██║██║╚══██╔══╝██║██╔═══██╗████╗ ██║██╔════╝
+██║ ██║█████╗ █████╗ ██║██╔██╗ ██║██║ ██║ ██║██║ ██║██╔██╗ ██║███████╗
+██║ ██║██╔══╝ ██╔══╝ ██║██║╚██╗██║██║ ██║ ██║██║ ██║██║╚██╗██║╚════██║
+██████╔╝███████╗██║ ██║██║ ╚████║██║ ██║ ██║╚██████╔╝██║ ╚████║███████║
+╚═════╝ ╚══════╝╚═╝ ╚═╝╚═╝ ╚═══╝╚═╝ ╚═╝ ╚═╝ ╚═════╝ ╚═╝ ╚═══╝╚══════╝
+
+*/
+
+joy_def --> joy_parse([symbol(Name)|Body]), { assert_def(Name, Body) }.
+
+assert_defs(DefsFile) :-
+ read_file_to_codes(DefsFile, Codes, []),
+ lines(Codes, Lines),
+ maplist(phrase(joy_def), Lines).
+
+assert_def(Symbol, Body) :-
+ ( % Don't let this "shadow" functions or combinators.
+ \+ func(Symbol, _, _),
+ \+ combo(Symbol, _, _, _, _)
+ ) -> ( % Replace any existing defs of this name.
+ retractall(def(Symbol, _)),
+ assertz(def(Symbol, Body))
+ ) ; true.
+
+% Split on newline chars a list of codes into a list of lists of codes
+% one per line. Helper function.
+lines([], []) :- !.
+lines(Codes, [Line|Lines]) :- append(Line, [0'\n|Rest], Codes), !, lines(Rest, Lines).
+lines(Codes, [Codes]).
+
+:- assert_defs("defs.txt").
+
+
+% A meta function that finds the names of all available functions.
+
+words(Words) :-
+ findall(Name, clause(func(Name, _, _), _), Funcs),
+ findall(Name, clause(combo(Name, _, _, _, _), _), Combos, Funcs),
+ findall(Name, clause(def(Name, _), _), Words0, Combos),
+ list_to_set(Words0, Words1),
+ sort(Words1, Words).
+
+
+/*
+
+ ██████╗ ██████╗ ███╗ ███╗██████╗ ██╗██╗ ███████╗██████╗
+██╔════╝██╔═══██╗████╗ ████║██╔══██╗██║██║ ██╔════╝██╔══██╗
+██║ ██║ ██║██╔████╔██║██████╔╝██║██║ █████╗ ██████╔╝
+██║ ██║ ██║██║╚██╔╝██║██╔═══╝ ██║██║ ██╔══╝ ██╔══██╗
+╚██████╗╚██████╔╝██║ ╚═╝ ██║██║ ██║███████╗███████╗██║ ██║
+ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚══════╝╚═╝ ╚═╝
+ _ ___ _
+ | |_ ___ | _ \_ _ ___| |___ __ _
+ | _/ _ \ | _/ '_/ _ \ | _ \/ _` |
+ \__\___/ |_| |_| \___/_|___/\__, |
+ |___/
+
+This is an experimental compiler from Joy expressions to Prolog code.
+As you will see it's also doing type inference and type checking.
+
+For many Joy expressions the existing code is enough to "compile" them to
+Prolog code. E.g. the definition of 'third' is 'rest rest first' and
+that's enough for the code to generate the "type" of the expression:
+
+ ?- joy(`third`, Si, So).
+ Si = [list([_32906, _32942, _32958|_32960])|_32898],
+ So = [_32958|_32898] .
+
+Because 'third' is just manipulating lists (the stack is a list too) the
+type signature is the whole of the (Prolog) implementation of the
+function:
+
+ ?- sjc(third, `third`).
+ func(third, [list([_, _, A|_])|B], [A|B]).
+
+So that's nice.
+
+Functions that involve just math require capturing the constraints
+recorded by the CLP(FD) subsystem. SWI Prolog provide a predicate
+call_residue_vars/2 to do just that. Together with copy_term/3 it's
+possible to collect all the information needed to capture functions
+made out of math and stack/list manipulation. (I do not understand the
+details of how they work. Markus Triska said they would do the trick and
+they did.)
+
+https://www.swi-prolog.org/pldoc/doc_for?object=call_residue_vars/2
+
+https://www.swi-prolog.org/pldoc/doc_for?object=copy_term/3
+
+I think this is sort of like "gradual" or "dependent" types. But the
+formal theory there is beyond me. In any event, it captures the integer
+constraints established by the expressions as well as the "types" of
+inputs and outputs.
+
+ ?- sjc(fn, `* + * -`).
+ func(fn, [int(H), int(I), int(F), int(D), int(C)|A], [int(B)|A]) :-
+ maplist(call,
+
+ [ clpfd:(B+E#=C),
+ clpfd:(G*D#=E),
+ clpfd:(J+F#=G),
+ clpfd:(H*I#=J)
+ ]).
+
+For functions involving 'branch', compilation results in one rule for each
+(reachable) path of the branch:
+
+ ?- sjc(fn, `[+] [-] branch`).
+
+ func(fn, [bool(true), int(C), int(D)|A], [int(B)|A]) :-
+ maplist(call, [clpfd:(B+C#=D)]).
+
+ func(fn, [bool(false), int(B), int(C)|A], [int(D)|A]) :-
+ maplist(call, [clpfd:(B+C#=D)]).
+
+(Note that in the subtraction case (bool(true)) the CLP(FD) constraints
+are coded as addition but the meaning is the same (subtaction) because of
+how the logic variables are named: B + C #= D <==> B #= D - C.)
+
+?- sjc(fn, `[[+] [-] branch] [pop *] branch`).
+
+ func(fn, [bool(true), _, int(B), int(C)|A], [int(D)|A]) :-
+ maplist(call, [clpfd:(B*C#=D)]).
+
+ func(fn, [bool(false), bool(true), int(C), int(D)|A], [int(B)|A]) :-
+ maplist(call, [clpfd:(B+C#=D)]).
+
+ func(fn, [bool(false), bool(false), int(B), int(C)|A], [int(D)|A]) :-
+ maplist(call, [clpfd:(B+C#=D)]).
+
+Three paths, three rules. Neat, eh?
+
+That leaves loop, genrec, and x combinators...
+
+
+*/
+
+joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), asserta(Rule).
+
+show_joy_compile(Name, Expression) :- jcmpl(Name, Expression, Rule), portray_clause(Rule).
+
+jcmpl(Name, Expression, Rule) :-
+ call_residue_vars(thun(Expression, Si, So), Term),
+ copy_term(Term, Term, Gs),
+ Head =.. [func, Name, Si, So],
+ rule(Head, Gs, Rule).
+
+rule(Head, [], Head).
+rule(Head, [A|B], Head :- maplist(call, [A|B])).
+
+sjc(Name, InputString) :- phrase(joy_parse(E), InputString), show_joy_compile(Name, E).
+
+
+/*
+
+Experiments with compilation.
+
+?- sjc(fn, `[+ dup bool] loop`).
+
+func(fn, [bool(false)|A], A).
+
+func(fn, [bool(true), int(B), int(C)|A], [int(0)|A]) :-
+ maplist(call, [clpfd:(B+C#=0)]).
+
+func(fn, [bool(true), int(D), int(E), int(B)|A], [int(0)|A]) :-
+ maplist(call,
+ [ clpfd:(B in inf.. -1\/1..sup),
+ clpfd:(C+B#=0),
+ clpfd:(C in inf.. -1\/1..sup),
+ clpfd:(D+E#=C)
+ ]).
+
+func(fn, [bool(true), int(F), int(G), int(D), int(B)|A], [int(0)|A]) :-
+ maplist(call,
+ [ clpfd:(B in inf.. -1\/1..sup),
+ clpfd:(C+B#=0),
+ clpfd:(C in inf.. -1\/1..sup),
+ clpfd:(E+D#=C),
+ clpfd:(E in inf.. -1\/1..sup),
+ clpfd:(F+G#=E)
+ ]).
+
+
+
+?- sjc(fn, `[] loop`).
+
+func(fn, [bool(false)|A], A).
+
+func(fn, [bool(true), bool(false)|A], A).
+
+func(fn, [bool(true), bool(true), bool(false)|A], A).
+
+func(fn, [bool(true), bool(true), bool(true), bool(false)|A], A).
+
+So...
+
+ `[] loop` ::= true* false
+
+sorta...
+
+
+The quine '[[dup cons] dup cons]' works fine:
+
+?- sjc(fn, `dup cons`).
+func(fn, [list(A)|B], [list([list(A)|A])|B]).
+
+?- sjc(fn, `[dup cons] dup cons`).
+func(fn, A, [list([list([symbol(dup), symbol(cons)]), symbol(dup), symbol(cons)])|A]).
+
+?- sjc(fn, `[dup cons] dup cons i`).
+func(fn, A, [list([list([symbol(dup), symbol(cons)]), symbol(dup), symbol(cons)])|A]).
+
+?- sjc(fn, `[dup cons] dup cons i i i i`).
+func(fn, A, [list([list([symbol(dup), symbol(cons)]), symbol(dup), symbol(cons)])|A]).
+
+
+In the right context the system will "hallucinate" programs:
+
+?- sjc(fn, `x`).
+func(fn, [list([])|A], [list([])|A]).
+
+func(fn, [list([int(A)])|B], [int(A), list([int(A)])|B]).
+
+func(fn, [list([bool(A)])|B], [bool(A), list([bool(A)])|B]).
+
+func(fn, [list([list(A)])|B], [list(A), list([list(A)])|B]).
+
+func(fn, [list([symbol(?)])|A], [bool(true), list([symbol(?)])|A]).
+
+func(fn, [list([symbol(app1)]), list([]), A|B], [A, A|B]).
+
+func(fn, [list([symbol(app1)]), list([int(A)]), B|C], [int(A), B|C]).
+
+func(fn, [list([symbol(app1)]), list([bool(A)]), B|C], [bool(A), B|C]).
+
+With iterative deepening this might be very interesting...
+
+
+Infinite loops are infinite:
+
+?- sjc(fn, `[x] x`).
+ERROR: Out of global-stack.
+
+
+?- sjc(fn, `sum`).
+func(fn, [list([])|A], [int(0)|A]).
+
+func(fn, [list([int(A)])|B], [int(A)|B]) :-
+ maplist(call, [clpfd:(A in inf..sup)]).
+
+func(fn, [list([int(C), int(B)])|A], [int(D)|A]) :-
+ maplist(call, [clpfd:(B+C#=D)]).
+
+func(fn, [list([int(E), int(D), int(B)])|A], [int(C)|A]) :-
+ maplist(call,
+
+ [ clpfd:(B+F#=C),
+ clpfd:(D+E#=F)
+ ]).
+
+func(fn, [list([int(G), int(F), int(D), int(B)])|A], [int(C)|A]) :-
+ maplist(call,
+
+ [ clpfd:(B+E#=C),
+ clpfd:(D+H#=E),
+ clpfd:(F+G#=H)
+ ]).
+
+
+TODO: genrec, fix points.
+
+
+
+
+ ██████╗ ██████╗ ███╗ ███╗██████╗ ██╗██╗ ███████╗██████╗
+██╔════╝██╔═══██╗████╗ ████║██╔══██╗██║██║ ██╔════╝██╔══██╗
+██║ ██║ ██║██╔████╔██║██████╔╝██║██║ █████╗ ██████╔╝
+██║ ██║ ██║██║╚██╔╝██║██╔═══╝ ██║██║ ██╔══╝ ██╔══██╗
+╚██████╗╚██████╔╝██║ ╚═╝ ██║██║ ██║███████╗███████╗██║ ██║
+ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝╚══════╝╚═╝ ╚═╝
+ _ __ __ _ _ ___ _
+ | |_ ___ | \/ |__ _ __| |_ (_)_ _ ___ / __|___ __| |___
+ | _/ _ \ | |\/| / _` / _| ' \| | ' \/ -_) | (__/ _ \/ _` / -_)
+ \__\___/ |_| |_\__,_\__|_||_|_|_||_\___| \___\___/\__,_\___|
+
+Options for getting machine code out of Joy (in Prolog) code?
+
+1) Translate Joy to Factor and delegate to Factor's native code
+generation.
+
+2) Use e.g. GNU Prolog to compile the Prolog code of Joy.
+
+3) Translate to:
+
+ 3a) LLVM IR.
+
+ 3b) Some subset of C.
+
+ 3c) Python for Cython.
+
+ 3d) WASM? Something else...?
+
+But those all rely on a big pile of OPC (Other Ppl's Code). WHich brings
+me to...
+
+4) Oberon RISC CPU machine code. The one I really want to do. I have an
+assembler for it, there are emulators and FPGA incarnations, and it's
+small and clean.
+
+ 4a) Prolog machine description of the RISC chip.
+
+ 4b) How to actually compile Joy to asm? There is a wealth of
+ available information and research to draw on, but most of it is in
+ the context of cenventional languages. Static Joy code presents few
+ problems but the dynamic nature of most Joy programs does, I think.
+ (I.e. a lot of Joy code starts by constructing some other Joy code
+ and running it. It remains to be seen how much of a challenge that
+ will be. In the limit, you need Prolog at runtime to JIT compile.)
+
+ 4c) Self-hosting requires Prolog-in-Joy.
+
+
+ ___ ___ ___ ___ __ __ _ _ ___ _
+| _ |_ _/ __|/ __| | \/ |__ _ __| |_ (_)_ _ ___ / __|___ __| |___
+| /| |\__ | (__ | |\/| / _` / _| ' \| | ' \/ -_) | (__/ _ / _` / -_)
+|_|_|___|___/\___| |_| |_\__,_\__|_||_|_|_||_\___| \___\___\__,_\___|
+
+This is an experimental compiler from Joy expressions to machine code.
+
+One interesting twist is that Joy doesn't mention variables, just the
+operators, so they have to be inferred from the ops.
+
+So let's take e.g. '+'?
+
+It seems we want to maintain a mapping from stack locations to registers,
+and maybe from locations in lists on the stack, and to memory locations as
+well as registers?
+
+But consider 'pop', the register pointed to by stack_0 is put back in an
+available register pool, but then all the stack_N mappings have to point
+to stack_N+1 (i.e. stack_0 must now point to what stack_1 pointed to and
+stack_1 must point to stack_2, and so on...)
+
+What if we keep a stack of register/RAM locations in the same order as
+the Joy stack?
+
+Reference counting for registers? Can it be avoided? When you "free" a
+register you can just check the stack to see if it's still in there and,
+if not, release it back to the free pool. You can amortize that w/o
+keeping a counter by keeping a linear list of registers alongside the
+stack and pushing and popping registers from it as they are used/free'd
+and then checking if a register is ready for reclaimation is just
+member/3. Or you can just keep a reference count for each register...
+Would it be useful to put CLP(FD) constraints on the ref counts?
+
+reggy(FreePool, References, ValueMap)
+
+*/
+
+encode_list(List, FP, FP, Addr) --> [],
+ {addr(list(List))=Addr}.
+
+get_reggy([], _, _) :- writeln('Out of Registers'), fail.
+get_reggy([Reg|FreePool], Reg, FreePool).
+
+get_reg(Reg, reggy(FreePool0, References, V), reggy(FreePool, [Reg|References], V)) --> [],
+ {get_reggy(FreePool0, Reg, FreePool)}.
+
+free_reg(Reg, reggy(FreePool0, References0, V0), reggy(FreePool, References, V)) --> [],
+ { select(Reg, References0, References),
+ ( member(Reg, References) % If reg is still in use
+ -> FreePool= FreePool0, V0=V % we can't free it yet
+ ; FreePool=[Reg|FreePool0], % otherwise we put it back in the pool.
+ del_assoc(Reg, V0, _, V)
+ )}.
+
+add_ref(Reg, reggy(FreePool, References, V), reggy(FreePool, [Reg|References], V)) --> [].
+
+assoc_reg(Reg, Value, reggy(FreePool, References, V0), reggy(FreePool, References, V)) --> [],
+ {put_assoc(Reg, V0, Value, V)}.
+
+thun_compile(E, Si, So, FP) -->
+ {empty_assoc(V),
+ FP0=reggy([r0, r1, r2, r3,
+ r4, r5, r6, r7,
+ r8, r9, rA, rB,
+ rC, rD, rE, rF], [], V)},
+ thun_compile(E, Si, So, FP0, FP).
+
+thun_compile([], S, S, FP, FP) --> [].
+thun_compile([Term|Rest], Si, So, FP0, FP1) --> thun_compile(Term, Rest, Si, So, FP0, FP1).
+
+thun_compile(int(I), E, Si, So, FP0, FP) -->
+ [mov_imm(R, int(I))],
+ get_reg(R, FP0, FP1), assoc_reg(R, int(I), FP1, FP2),
+ thun_compile(E, [R|Si], So, FP2, FP).
+
+thun_compile(bool(B), E, Si, So, FP0, FP) -->
+ get_reg(R, FP0, FP1), assoc_reg(R, bool(B), FP1, FP2),
+ thun_compile(E, [R|Si], So, FP2, FP).
+
+thun_compile(list(L), E, Si, So, FP0, FP) -->
+ encode_list(L, FP0, FP1, Addr),
+ get_reg(R, FP1, FP2),
+ [load_imm(R, Addr)],
+ assoc_reg(R, Addr, FP2, FP3),
+ thun_compile(E, [R|Si], So, FP3, FP).
+
+thun_compile(symbol(Name), E, Si, So, FP0, FP) --> {def(Name, _)}, !, def_compile(Name, E, Si, So, FP0, FP).
+thun_compile(symbol(Name), E, Si, So, FP0, FP) --> {func(Name, _, _)}, !, func_compile(Name, E, Si, So, FP0, FP).
+thun_compile(symbol(Name), E, Si, So, FP0, FP) --> {combo(Name, _, _, _, _)}, combo_compile(Name, E, Si, So, FP0, FP).
+
+% I'm going to assume that any defs that can be compiled to funcs already
+% have been. Defs that can't be pre-compiled shove their body expression
+% onto the pending expression (continuation) to be compiled "inline".
+
+def_compile(Def, E, Si, So, FP0, FP) -->
+ {def(Def, Body),
+ append(Body, E, Eo)},
+ thun_compile(Eo, Si, So, FP0, FP).
+
+
+% swap (et. al.) doesn't change register refs nor introspect values
+% so we can delegate its effect to the semantic relation.
+non_alloc(swap).
+non_alloc(rollup).
+non_alloc(rolldown).
+
+% Functions delegate to a per-function compilation relation.
+
+func_compile(+, E, [A, B|S], So, FP0, FP) --> !,
+ free_reg(A, FP0, FP1),
+ free_reg(B, FP1, FP2),
+ get_reg(R, FP2, FP3),
+ assoc_reg(R, int(_), FP3, FP4),
+ [add(R, A, B)],
+ % Update value in the context?
+ thun_compile(E, [R|S], So, FP4, FP).
+
+func_compile(dup, E, [A|S], So, FP0, FP) --> !,
+ add_ref(A, FP0, FP1),
+ thun_compile(E, [A, A|S], So, FP1, FP).
+
+func_compile(pop, E, [A|S], So, FP0, FP) --> !,
+ free_reg(A, FP0, FP1),
+ thun_compile(E, S, So, FP1, FP).
+
+func_compile(cons, E, [List, Item|S], So, FP0, FP) --> !,
+ % allocate a cons cell
+ % https://mitpress.mit.edu/sites/default/files/sicp/full-text/book/book-Z-H-33.html#%_sec_5.3
+ thun_compile(E, S, So, FP0, FP).
+
+func_compile(Func, E, Si, So, FP0, FP) --> { non_alloc(Func), !,
+ func(Func, Si, S) },
+ thun_compile(E, S, So, FP0, FP).
+
+func_compile(_Func, E, Si, So, FP0, FP) -->
+ % look up function, compile it...
+ {Si = S},
+ thun_compile(E, S, So, FP0, FP).
+
+
+combo_compile(_Combo, E, Si, So, FP0, FP) -->
+ % look up combinator, compile it...
+ {Si = S, E = Eo},
+ thun_compile(Eo, S, So, FP0, FP).
+
+
+compiler(InputString, MachineCode, StackIn, StackOut) :-
+ phrase(joy_parse(Expression), InputString), !,
+ phrase(thun_compile(Expression, StackIn, StackOut, _), MachineCode, []).
+
+
+show_compiler(InputString, StackIn, StackOut) :-
+ phrase(joy_parse(Expression), InputString), !,
+ phrase(thun_compile(Expression, StackIn, StackOut, reggy(_, _, V)), MachineCode, []),
+ maplist(portray_clause, MachineCode),
+ assoc_to_list(V, VP),
+ portray_clause(VP).
+
+
+/*
+
+?- compiler(`1 2 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(_18272, int(1)), mov_imm(_18298, int(2))],
+StackOut = [_18298, _18272|StackIn].
+
+
+- - - -
+
+
+?- compiler(`1 2 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r1, int(1)), mov_imm(r2, int(2)), add(r1, r2, r1)],
+StackOut = [r1|StackIn].
+
+?- compiler(`1 2 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r1, int(1)), mov_imm(r2, int(2)), add(r1, r2, r1)],
+StackOut = [r1|StackIn].
+
+?- compiler(`1 2 + 3 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r1, int(1)), mov_imm(r2, int(2)), add(r1, r2, r1), mov_imm(r3, int(3)), add(r1, r3, r1)],
+StackOut = [r1|StackIn].
+
+?- compiler(`1 2 + +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r1, int(1)), mov_imm(r2, int(2)), add(r1, r2, r1), add(_37848, r1, _37848)],
+StackIn = StackOut, StackOut = [_37848|_37850].
+
+?- compiler(`+ +`, MachineCode, StackIn, StackOut).
+MachineCode = [add(_37270, _37264, _37270), add(_37688, _37270, _37688)],
+StackIn = [_37264, _37270, _37688|_37690],
+StackOut = [_37688|_37690].
+
+?- compiler(`+ +`, MachineCode, [r1, r2, r3], StackOut).
+MachineCode = [add(r2, r1, r2), add(r3, r2, r3)],
+StackOut = [r3].
+
+?- compiler(`+ +`, MachineCode, [r1, r2, r3, r4, r5, r6, r7], StackOut).
+MachineCode = [add(r2, r1, r2), add(r3, r2, r3)],
+StackOut = [r3, r4, r5, r6, r7].
+
+- - - - -
+
+
+?- compiler(`1 2 3 + +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r0, int(1)), mov_imm(r1, int(2)), mov_imm(r2, int(3)), add(r1, r2, r1), add(r0, r1, r0)],
+StackOut = [r0|StackIn].
+
+
+register free seems to work...
+
+?- compiler(`1 2 + 3 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r0, int(1)), mov_imm(r1, int(2)), add(r0, r1, r0), mov_imm(r1, int(3)), add(r0, r1, r0)],
+StackOut = [r0|StackIn] ;
+false.
+
+- - - -
+
+?- compiler(`1 2 dup + 3 +`, MachineCode, StackIn, StackOut).
+MachineCode = [mov_imm(r0, int(1)), mov_imm(r1, int(2)), add(r1, r1, r1), mov_imm(r2, int(3)), add(r1, r2, r1)],
+StackOut = [r1, r0|StackIn] .
+
+?- compiler(`dup +`, MachineCode, StackIn, StackOut).
+MachineCode = [add(_37000, _37000, _37000)],
+StackIn = StackOut, StackOut = [_37000|_37002].
+
+?- compiler(`dup +`, MachineCode, [r0], StackOut).
+MachineCode = [add(r0, r0, r0)],
+StackOut = [r0].
+
+?- compiler(`dup +`, MachineCode, [r0], [r0]).
+MachineCode = [add(r0, r0, r0)].
+
+- - - -
+
+?- compiler(`1 2 3 4 5 + + + 6 7 + 8 + +`, MachineCode, StackIn, StackOut), maplist(portray_clause, MachineCode).
+mov_imm(r0, int(1)).
+mov_imm(r1, int(2)).
+mov_imm(r2, int(3)).
+mov_imm(r3, int(4)).
+mov_imm(r4, int(5)).
+add(r3, r4, r3).
+add(r2, r3, r2).
+add(r1, r2, r1).
+mov_imm(r2, int(6)).
+mov_imm(r3, int(7)).
+add(r2, r3, r2).
+mov_imm(r3, int(8)).
+add(r2, r3, r2).
+add(r1, r2, r1).
+
+
+Fun!
+
+- - - -
+
+Test that returning registers before asking for new ones
+does reuse registers that are unused and preserve registers
+that are still in use.
+
+?- show_compiler(`1 dup 2 + swap 3 +`, StackIn, StackOut).
+mov_imm(r0, int(1)).
+mov_imm(r1, int(2)).
+add(r1, r1, r0).
+mov_imm(r2, int(3)).
+add(r0, r2, r0).
+[r0-int(_), r1-int(_)].
+StackOut = [r0, r1|StackIn] .
+
+
+
+
+███╗ ███╗███████╗████████╗ █████╗ ██████╗ ██████╗ ██████╗ ██████╗ ██████╗ █████╗ ███╗ ███╗███╗ ███╗██╗███╗ ██╗ ██████╗
+████╗ ████║██╔════╝╚══██╔══╝██╔══██╗ ██╔══██╗██╔══██╗██╔═══██╗██╔════╝ ██╔══██╗██╔══██╗████╗ ████║████╗ ████║██║████╗ ██║██╔════╝
+██╔████╔██║█████╗ ██║ ███████║█████╗██████╔╝██████╔╝██║ ██║██║ ███╗██████╔╝███████║██╔████╔██║██╔████╔██║██║██╔██╗ ██║██║ ███╗
+██║╚██╔╝██║██╔══╝ ██║ ██╔══██║╚════╝██╔═══╝ ██╔══██╗██║ ██║██║ ██║██╔══██╗██╔══██║██║╚██╔╝██║██║╚██╔╝██║██║██║╚██╗██║██║ ██║
+██║ ╚═╝ ██║███████╗ ██║ ██║ ██║ ██║ ██║ ██║╚██████╔╝╚██████╔╝██║ ██║██║ ██║██║ ╚═╝ ██║██║ ╚═╝ ██║██║██║ ╚████║╚██████╔╝
+╚═╝ ╚═╝╚══════╝ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝╚═╝╚═╝ ╚═══╝ ╚═════╝
+
+
+
+
+
+
+
+███████╗██╗ ██╗██████╗ █████╗ ███╗ ██╗██████╗ ██╗ ██████╗ ██████╗ ███╗ ██╗████████╗██████╗ █████╗ ██████╗████████╗
+██╔════╝╚██╗██╔╝██╔══██╗██╔══██╗████╗ ██║██╔══██╗ ██╔╝ ██╔════╝██╔═══██╗████╗ ██║╚══██╔══╝██╔══██╗██╔══██╗██╔════╝╚══██╔══╝
+█████╗ ╚███╔╝ ██████╔╝███████║██╔██╗ ██║██║ ██║ ██╔╝ ██║ ██║ ██║██╔██╗ ██║ ██║ ██████╔╝███████║██║ ██║
+██╔══╝ ██╔██╗ ██╔═══╝ ██╔══██║██║╚██╗██║██║ ██║ ██╔╝ ██║ ██║ ██║██║╚██╗██║ ██║ ██╔══██╗██╔══██║██║ ██║
+███████╗██╔╝ ██╗██║ ██║ ██║██║ ╚████║██████╔╝ ██╔╝ ╚██████╗╚██████╔╝██║ ╚████║ ██║ ██║ ██║██║ ██║╚██████╗ ██║
+╚══════╝╚═╝ ╚═╝╚═╝ ╚═╝ ╚═╝╚═╝ ╚═══╝╚═════╝ ╚═╝ ╚═════╝ ╚═════╝ ╚═╝ ╚═══╝ ╚═╝ ╚═╝ ╚═╝╚═╝ ╚═╝ ╚═════╝ ╚═╝
+
+*/
+
+% Simple DCGs to expand/contract definitions.
+
+expando, Body --> [Def], {def(Def, Body)}.
+contracto, [Def] --> {def(Def, Body)}, Body.
+
+% Apply expando/contracto more than once, and descend into sub-lists.
+% The K term is one of expando or contracto, and the J term is used
+% on sub-lists, i.e. expando/grow and contracto/shrink.
+% BTW, "rebo" is a meaningless name, don't break your brain
+% trying to figure it out.
+
+rebo(K, J) --> K , rebo(K, J).
+rebo(K, J), [E] --> [[H|T]], !, {call(J, [H|T], E)}, rebo(K, J).
+rebo(K, J), [A] --> [ A ], !, rebo(K, J).
+rebo(_, _) --> [].
+
+to_fixed_point(DCG, Ei, Eo) :-
+ phrase(DCG, Ei, E), % Apply DCG...
+ (Ei=E -> Eo=E ; to_fixed_point(DCG, E, Eo)). % ...until a fixed-point is reached.
+
+grow --> to_fixed_point(rebo(expando, grow )).
+shrink --> to_fixed_point(rebo(contracto, shrink)).
+
+% ?- phrase(grow, [third], Out).
+% Out = [rest, rest, first] ;
+% Out = [rest, rest, first] ;
+% Out = [rest, second] ;
+% Out = [third].
+
+% ?- phrase(shrink, [rest, rest, first], Out).
+% Out = [rrest, first] ;
+% Out = [third] ;
+% Out = [rest, second] ;
+% Out = [rest, rest, first].
+
+/*
+
+███████╗ ██████╗ ██████╗ ███╗ ███╗ █████╗ ████████╗████████╗███████╗██████╗
+██╔════╝██╔═══██╗██╔══██╗████╗ ████║██╔══██╗╚══██╔══╝╚══██╔══╝██╔════╝██╔══██╗
+█████╗ ██║ ██║██████╔╝██╔████╔██║███████║ ██║ ██║ █████╗ ██████╔╝
+██╔══╝ ██║ ██║██╔══██╗██║╚██╔╝██║██╔══██║ ██║ ██║ ██╔══╝ ██╔══██╗
+██║ ╚██████╔╝██║ ██║██║ ╚═╝ ██║██║ ██║ ██║ ██║ ███████╗██║ ██║
+╚═╝ ╚═════╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚══════╝╚═╝ ╚═╝
+
+
+?- phrase(joy_parse(E), `22 18 true [false] [1[2[3]]]`), !, format_joy_terms(E, A, []), string_codes(S, A).
+E = [int(22), int(18), bool(true), list([bool(false)]), list([int(1), list([...|...])])],
+A = [50, 50, 32, 49, 56, 32, 116, 114, 117|...],
+S = "22 18 true [false] [1 [2 [3]]]".
+
+*/
+
+format_joy_expression( int(I)) --> { number_codes(I, Codes) }, Codes.
+format_joy_expression( bool(B)) --> { atom_codes(B, Codes) }, Codes.
+format_joy_expression(symbol(S)) --> { atom_codes(S, Codes) }, Codes.
+format_joy_expression( list(J)) --> "[", format_joy_terms(J), "]".
+
+format_joy_terms( []) --> [].
+format_joy_terms( [T]) --> format_joy_expression(T), !.
+format_joy_terms([T|Ts]) --> format_joy_expression(T), " ", format_joy_terms(Ts).
+
+joy_terms_to_string(Expr, String) :-
+ format_joy_terms(Expr, Codes, []),
+ string_codes(String, Codes).
+
+
+/*
+
+██████╗ █████╗ ██████╗ ████████╗██╗ █████╗ ██╗
+██╔══██╗██╔══██╗██╔══██╗╚══██╔══╝██║██╔══██╗██║
+██████╔╝███████║██████╔╝ ██║ ██║███████║██║
+██╔═══╝ ██╔══██║██╔══██╗ ██║ ██║██╔══██║██║
+██║ ██║ ██║██║ ██║ ██║ ██║██║ ██║███████╗
+╚═╝ ╚═╝ ╚═╝╚═╝ ╚═╝ ╚═╝ ╚═╝╚═╝ ╚═╝╚══════╝
+
+██████╗ ███████╗██████╗ ██╗ ██╗ ██████╗███████╗██████╗
+██╔══██╗██╔════╝██╔══██╗██║ ██║██╔════╝██╔════╝██╔══██╗
+██████╔╝█████╗ ██║ ██║██║ ██║██║ █████╗ ██████╔╝
+██╔══██╗██╔══╝ ██║ ██║██║ ██║██║ ██╔══╝ ██╔══██╗
+██║ ██║███████╗██████╔╝╚██████╔╝╚██████╗███████╗██║ ██║
+╚═╝ ╚═╝╚══════╝╚═════╝ ╚═════╝ ╚═════╝╚══════╝╚═╝ ╚═╝
+
+Partial Reducer from "The Art of Prolog" by Sterling and Shapiro
+Program 18.3, pg. 362 */
+
+process(Program, ReducedProgram) :-
+ findall(PC1, (member(C1, Program), preduce(C1, PC1)), ReducedProgram).
+
+preduce( (A :- B), (Pa :- Pb) ) :- !, preduce(B, Pb), preduce(A, Pa).
+preduce( true, true ) :- !.
+preduce( (A, B), Residue ) :- !, preduce(A, Pa), preduce(B, Pb), combine(Pa, Pb, Residue).
+% preduce( A, B ) :- should_fold(A, B), !.
+preduce( A, Residue ) :- should_unfold(A), !, clause(A, B), preduce(B, Residue).
+preduce( A, A ).
+
+% As {*,1} and {+,0} so we have {(,),true}. Whatsitsname? Monoid or something...
+% {*,0} {+,Inf} {(,),fail}...
+
+combine(true, B, B) :- !.
+combine(A, true, A) :- !.
+combine(A, B, (A, B)).
+
+/*
+
+Partial reduction of thun/3 in the thun/4 relation gives a new
+version of thun/4 that is tail-recursive. You generate the new
+relation rules like so:
+
+ ?- thunder(C), process(C, R), maplist(portray_clause, R).
+
+I just cut-n-paste from the SWI terminal and rearrange it.
+
+*/
+
+should_unfold(thun(_, _, _)).
+% should_unfold(func(_, _, _)).
+% should_unfold(def(_, _)).
+
+thunder([ % Source code for thun/4.
+ (thun( int(I), E, Si, So) :- thun(E, [ int(I)|Si], So)),
+ (thun(bool(B), E, Si, So) :- thun(E, [bool(B)|Si], So)),
+ (thun(list(L), E, Si, So) :- thun(E, [list(L)|Si], So)),
+ % (thun(symbol(Def), E, Si, So) :- def(Def, [Head|Body]), append(Body, E, Eo), thun(Head, Eo, Si, So)),
+ (thun(symbol(Func), E, Si, So) :- func(Func, Si, S), thun(E, S, So))
+ % (thun(symbol(Combo), E, Si, So) :- combo(Combo, Si, S, E, Eo), thun(Eo, S, So))
+]).
+
+/*
+
+N.B.: in 'thun(symbol(Def)...' the last clause has changed from thun/3 to thun/4.
+The earlier version doesn't transform into correct code:
+
+ thun(symbol(B), D, A, A) :- def(B, C), append(C, D, []).
+ thun(symbol(A), C, F, G) :- def(A, B), append(B, C, [D|E]), thun(D, E, F, G).
+
+With the change to thun/4 it doesn't transform under reduction w/ thun/3.
+
+You can also unfold def/2 and func/3 (but you need to check for bugs!)
+
+Functions become clauses like these:
+
+ thun(symbol(rolldown), [], [C, A, B|D], [A, B, C|D]).
+ thun(symbol(rolldown), [A|B], [E, C, D|F], G) :- thun(A, B, [C, D, E|F], G).
+
+ thun(symbol(dupd), [], [A, B|C], [A, B, B|C]).
+ thun(symbol(dupd), [A|B], [C, D|E], F) :- thun(A, B, [C, D, D|E], F).
+
+ thun(symbol(over), [], [B, A|C], [A, B, A|C]).
+ thun(symbol(over), [A|B], [D, C|E], F) :- thun(A, B, [C, D, C|E], F).
+
+Definitions become
+
+ thun(symbol(of), A, D, E) :-
+ append([symbol(swap), symbol(at)], A, [B|C]),
+ thun(B, C, D, E).
+
+ thun(symbol(pam), A, D, E) :-
+ append([list([symbol(i)]), symbol(map)], A, [B|C]),
+ thun(B, C, D, E).
+
+ thun(symbol(popd), A, D, E) :-
+ append([list([symbol(pop)]), symbol(dip)], A, [B|C]),
+ thun(B, C, D, E).
+
+These are tail-recursive and allow for better indexing so I would expect
+them to be more efficient than the originals. Ii would be even nicer to
+get them looking like this:
+
+ thun(symbol(of), A, D, E) :- thun(symbol(swap), [symbol(at)|A], D, E).
+
+And then if 'swap' was a definition you could push it out even further,
+you could pre-expand definitions and functions (and maybe even some
+combinators!)
+
+*/
\ No newline at end of file
projects / scryer-prolog.git / commitdiff