gistfile1.txt

/* %% ['/home/alan/projects/snippets/lispfl.pl']. */

:- use_module(library(clpfd)).

%% functional forms

ff(def).
ff(const).
ff(comp).
ff(juxt).
ff(map).

def([Name, Expr], _, _) :-
    assert(define(Name, Expr)).

const([X], _, Res) :- Res = X.

comp_([], Res, Res).
comp_([Fe|Fexprs], Arg, Res) :-
    eval([Fe, Arg], EArg),
    comp_(Fexprs, EArg, Res).
comp(Fexprs, Arg, Res) :-
    reverse(Fexprs, RevFexprs),
    comp_(RevFexprs, Arg, Res).

juxt_([], _, Res, Res).
juxt_([Fe|Fexprs], EArg, Rets, Res) :-
    eval([Fe, EArg], Ret),
    append(Rets, [Ret], NewRets),
    juxt_(Fexprs, EArg, NewRets, Res).
juxt(Fexprs, Arg, Res) :-
    juxt_(Fexprs, Arg, [], Res).

map(_, [], Res, Res).
map(Fn, [X|Xs], Rets, Res) :-
    eval([Fn,X], Ret),
    append(Rets, [Ret], NewRets),
    map(Fn, Xs, NewRets, Res).
map([Fn], Xs, Res) :-
    map(Fn, Xs, [], Res).

%% functions

fn(*).
fn(+).
fn(-).
fn(id).
fn(range).
fn(trans).
fn(list).

*([], Res)       :- Res is 1.
*([X|More], Res) :- *(More, Res2), Res is X * Res2.

+([], Res)       :- Res is 0.
+([X|More], Res) :- +(More, Res2), Res is X + Res2.

-([], Res)       :- Res is 0.
-([X], Res)      :- Res is X * -1.
-([X,Y], Res)    :- Res is X - Y.
-([X|More], Res) :- -(More, Res2), Res is X - Res2.

id(Expr, Res) :- Res = Expr.

range([Min, Ceil], Res) :- Max is Ceil - 1, numlist(Min, Max, Res).
range([Ceil], Res)      :- range([0, Ceil], Res).

trans(Lists, Res) :- transpose(Lists, Res).

%% evaluation

eval([N, List], Res)         :- integer(N), N >= 0,
    nth0(N, List, Res), !.
eval([N, List], Res)         :- integer(N), N < 0,
    reverse(List, RList),
    abs(N, Idx),
    Idx2 is Idx - 1,
    nth0(Idx2, RList, Res), !.
eval([Fn, Arg], Res)         :- fn(Fn),
    call(Fn, Arg, Res), !.
eval([[Ff|Exprs], Arg], Res) :- ff(Ff),
    call(Ff, Exprs, Arg, Res), !.
eval([Ff|Exprs], Res)        :- ff(Ff),
    call(Ff, Exprs, [], Res), !.
eval([Name, Arg], Res)       :- define(Name, Expr),
    eval([Expr, Arg], Res), !.
eval(Name, Res)              :- atom(Name),
    define(Name, Res), !.
eval(Res, Res).

%% expand definitions

expand(Name, Exp)                :-
    define(Name, Source),
    expand(Source, Exp).
expand(Name, Exp)                :- ff(Name), Exp = Name.
expand(Name, Exp)                :- fn(Name), Exp = Name.
expand(N, Exp)                   :- number(N), Exp = N.
expand([Op|Args], Exp)           :-
    expand(Op, Args, [], Exp).
expand(Op, [A|Args], EArgs, Exp) :-
    expand(A, EA),
    append(EArgs, [EA], NewEArgs),
    expand(Op, Args, NewEArgs, Exp).
expand(Op, [], EArgs, Exp)       :-
    append([Op], EArgs, Exp).

%% program equality

eq([comp, [juxt|Fs], G], X) :-
    eval([[map, [juxt, [const, comp], id, [const, G]]], Fs], Comps),
    append([juxt], Comps, X).
eq([juxt|Comps], X) :-
    eval([[map, 1], Comps], Fs),
    eval([[comp, 2, 0], Comps], H),
    append([juxt], Fs, Juxt),
    append([[comp], [Juxt], [H]], X).

eq([comp,X], X).
eq(X, [comp,X]).

eq(Name1, Name2) :-
    define(Name1, Source1),
    define(Name2, Source2),
    expand(Source1, Exp1),
    expand(Source2, Exp2),
    eq(Exp1, Exp2).

eq(X, Y) :- X == Y.

%% prelude

:- dynamic define/2.

define(len,       [comp, +, [map, [const, 1]]]).
define(inc,       [comp, +, [juxt, id, [const, 1]]]).
define(dec,       [comp, -, [juxt, id, [const, 1]]]).
define(factorial, [comp, *, range, [juxt, [const, 1], inc]]).
define(ip,        [comp, +, [map, *], trans]).

%% demo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
Welcome to SWI-Prolog (Multi-threaded, 64 bits, Version 5.10.4)
Copyright (c) 1990-2011 University of Amsterdam, VU Amsterdam
SWI-Prolog comes with ABSOLUTELY NO WARRANTY. This is free software,
and you are welcome to redistribute it under certain conditions.
Please visit http://www.swi-prolog.org for details.

For help, use ?- help(Topic). or ?- apropos(Word).

?- ['/home/alan/projects/snippets/lispfl.pl'].
                                %    library(error) compiled into error 0.00 sec, 17,944 bytes
                                %   library(apply) compiled into apply 0.01 sec, 29,096 bytes
                                %   library(assoc) compiled into assoc 0.00 sec, 36,240 bytes
                                %   library(lists) compiled into lists 0.00 sec, 25,304 bytes
                                %   library(pairs) compiled into pairs 0.00 sec, 8,216 bytes
                                %  library(clpfd) compiled into clpfd 0.04 sec, 735,496 bytes
                                % /home/alan/projects/snippets/lispfl.pl compiled 0.04 sec, 756,248 bytes
true.

?- eval([len,[1,2,3]], Out).
Out = 3.

?- eval([inc,1], Out).
Out = 2.

?- define(inc, Source).
Source = [comp, +, [juxt, id, [const, 1]]].

?- eval([factorial,5], Out).
Out = 120.

?- eval(factorial, Out).
Out = [comp, *, range, [juxt, [const, 1], inc]].

?- eval(factorial, Out), expand(Out, Exp).
Out = [comp, *, range, [juxt, [const, 1], inc]],
Exp = [comp, *, range, [juxt, [const, 1], [comp, +|...]]] ;
false.

?- set_prolog_flag(toplevel_print_options, [quoted(true), portray(true), max_depth(100), priority(699)]).
true.

?- eval(factorial, Out), expand(Out, Exp).
Out = [comp,*,range,[juxt,[const,1],inc]],
Exp = [comp,*,range,[juxt,[const,1],[comp,+,[juxt,id,[const,1]]]]] ;
false.

?- eq([comp,f], f).
true ;
false.

?- eq([comp,[juxt,a,b],c], Alternate).
Alternate = [juxt,[comp,a,c],[comp,b,c]] ;
Alternate = [comp,[comp,[juxt,a,b],c]] ;
false.

?- eq([comp,[juxt,inc,dec],inc], Alternate), expand(Alternate, Expansion).
Alternate = [juxt,[comp,inc,inc],[comp,dec,inc]],
Expansion = [juxt,[comp,[comp,+,[juxt,id,[const,1]]],[comp,+,[juxt,id,[const,1]]]],[comp,[comp,-,[juxt,id,[const,1]]],[comp,+,[juxt,id,[const,1]]]]] ;
Alternate = [comp,[comp,[juxt,inc,dec],inc]],
Expansion = [comp,[comp,[juxt,[comp,+,[juxt,id,[const,1]]],[comp,-,[juxt,id,[const,1]]]],[comp,+,[juxt,id,[const,1]]]]] ;
false.

*/