tco.prolog

corecursion(Name, App, Deep, [{C, Before, After} | Stack]) :-
  App =.. [app, ctor(C) | Rest],
  append([Before, [It], After], Rest),
  corecursion(Name, It, Deep, Stack).

corecursion(Name, App, Rest, []) :-
  App =.. [app, Name | Rest].

deepest_corecursion(Name, App, Scheme, Stack) :-
  findall(Scheme - Stack, corecursion(Name, App, Scheme, Stack), List),
  longest_stack(List, Scheme - Stack),
  !.

longest_stack(It, Res) :- longest_stack(0 - [], It, Res).

longest_stack(Len - Longest, [It - X | Xs], Res) :-
  length(X, XL),
  (   XL >= Len
  ->  longest_stack(XL - (It - X), Xs, Res)
  ;   longest_stack(Len - Longest, Xs, Res)
  ).

longest_stack(_ - R, [], R).

% fold_branch(A, B, C, D, E, _) --> { writeln(fold_branch(A, B, C, D, E)), fail }.
fold_branch(Name, Args, Case, App, Res) -->
  { deepest_corecursion(Name, App, Scheme, Stack)
  , maplist(join(->), Args, Scheme, Transform)
  , exclude(identity, Transform, ActiveTransform)
  , fold(Fixpoint, Stack, Action)
  , Res = if(Case, ActiveTransform, Fixpoint = Action)
  },
  free(Fixpoint).

identity(X -> X).

free(N, N, M) :- M is N + 1.

fold(Pt, [], Pt).
fold(Pt, [{C, B, A} | Rest], F) :-
  fold(Pt, Rest, X),
  append([B, [X], A], Args),
  F =.. [app, ctor(C) | Args].

join(Op, X, Y, R) :- R =.. [Op, X, Y].

partition1([], _, [], []) --> {}.
partition1([S | Sources], Prod, [R | Successes], Failed) -->
  call(Prod, S, R),
  !,
  partition1(Sources, Prod, Successes, Failed).

partition1([S | Sources], Prod, Successes, [S | Failed]) -->
  partition1(Sources, Prod, Successes, Failed).

test_map(
  map - [f, list]: case(
    (list: cons) -> app(ctor(cons), app(f, list/x), app(map, f, list/xs)),
    (list: nil)  -> nil
  )
).

test_foldl(
  foldl - [op, zero, list]: case(
    (list: cons) -> app(foldl, op, app(op, zero, list/x), list/xs),
    (list: nil)  -> zero
  )
).

test_zip(
  zipWith - [op, xs, ys]: case(
    (xs: cons, ys: cons) -> app(ctor(cons), app(op, xs/head, ys/head), app(zipWith, op, xs/tail, ys/tail)),
    (true) -> nil
  )
).

fold_branch1(Name, Args, Case -> App, Res) -->
  fold_branch(Name, Args, Case, App, Res).

fold_branches(Name, Args, Branches, Fors, Linear) -->
  partition1(Branches, fold_branch1(Name, Args), Fors, Linear).

compile_fun(Name - Args : Cases, Res) -->
  { Cases =.. [case | Branches] },
  fold_branches(Name, Args, Branches, X, Y),
  { Pseudo = (cycle(X) -> Y) },
  { Res = Pseudo }.

test(S)
  :-  call(S, T)
  ,   compile_fun(T, R, 0, _)
  ,   writeln(transforming: T)
  ,   writeln(got: R)
  ,   writeln(-)
  .

:- test(test_map).
:- test(test_foldl).
:- test(test_zip).