FLP: Prolog blocks

block.pl

:- module(block,[op(1150,fx,block), (block)/1]).

:- op(1150,fx,block).

block X :-
  assert_block(X).

:- multifile user:blocking/3.
:- dynamic user:blocking/3.

assert_block(X) :-
  ( X = (X1,X2) ->
    assert_block(X1),
    assert_block(X2)
  ;
    functor(X,Functor,Arity),
    X =.. [Functor|Vars],
    assert(user:blocking(Functor,Arity,Vars))
  ).

compiler.pl

:- module(interpreter, [op(1150,fx,block), (block)/1]).
:- use_module(block).

:- multifile user:term_expansion/2.
:- dynamic user:term_expansion/2.

% rewrite term to wrap it if it's blocking
user:term_expansion(Term :- Body, NTerm :- NBody) :-
  functor(Term,Functor,Arity),
  Term =.. [Functor|Vars],
  findall(Descr,user:blocking(Functor,Arity,Descr),L),
  ( L = [_|_] ->
    % create a new body, replacing the head by new variables
    functor(NTerm,Functor,Arity),
    NTerm =.. [Functor|NewVars],
    expand_head(NewVars,Vars,Assignments),
    append(Assignments,[Body],NewBody),
    collect((,),NewBody,NewBody_),

    % create blocking statements for the head
    expand_blocks(L,NewVars,Blocks),
    collect((,),Blocks,Blocks_),

    % write('expanding '), write(Term), write(' with '), writeln(L),
    NBody = when(Blocks_,NewBody_)
  ;
    NTerm = Term, NBody = Body
  ).

% also rewrite simple fact terms
user:term_expansion(Term, NTerm :- NBody) :-
  functor(Term,Functor,_),
  Functor \== (:-), 
  user:term_expansion(Term :- true, NTerm :- NBody).

expand_head([],[],[]).
expand_head([X|Xs],[Y|Ys],Z) :-
  Z = [X = Y|Zs],
  expand_head(Xs,Ys,Zs).

expand_blocks([],_,[]).
expand_blocks([L|Ls],Vars,Result) :-
  expand_block(L,Vars,Block),
  collect((;),Block,Statements),
  Result = [Statements|Result2],
  expand_blocks(Ls,Vars,Result2).

expand_block([],[],[]).
expand_block([B|Bs],[V|Vs],Result) :-
  ( B = (-) ->
    Result = [nonvar(V)|Result2]
  ;
    Result = Result2
  ),
  expand_block(Bs,Vs,Result2).

% join a list of elements with operator
collect(Operator,[L|Ls],Result) :-
  ( Ls = [_|_] ->
    collect(Operator,Ls,Result2),
    Result =.. [Operator,L,Result2]
  ;
    Result = L
  ).

compiler_demo.pl

:- use_module(compiler).
:- use_module(functions).

% de compiler zal de hoofding wijzigen en blokkerende
% condities toevoegen aan de body
show_clauses :-
  listing(add),
  listing(my_merge).

% my_merge blokkeert eerst, en zal pas uitgevoerd worden
% wanneer A of B gebonden wordt
merge_test :-
  my_merge([1,2],A,B),
  write('A = '), write(A), write(', B = '), writeln(B),
  A = [3,4],
  write('A = '), write(A), write(', B = '), writeln(B).

% queens
queens_test :-
  queens(12, L),
  write('L = '), writeln(L).

% psort
psort_test :-
  psort([10,9,8,7,6,5,4,3,2,1], L),
  write('L = '), writeln(L).

functions.pl

:- module(functions, [add/3, my_merge/3, app/3, queens/2, range/3, safe/1,
                      no_attack/2, no_attack/3, no_attack/4, psort/2,
                      permute/2, sorted/1, sorted/2]).

:- block add(-,?,?), add(?,-,?).

add(X,Y,Z) :- Z is X + Y.

:- block my_merge(-,?,-), my_merge(?,-,-).

my_merge([], Y, Y).
my_merge(X, [], X).
my_merge([H|X], [E|Y], [H|Z]) :-
  H @< E,
  my_merge(X, [E|Y], Z).
my_merge([H|X], [E|Y], [E|Z]) :-
  H @>= E,
  my_merge([H|X], Y, Z).

:- block app(-,?,-), app(?,-,-).

app([],L,L).
app([X|Xs],Ys,[X|Zs]) :-
  app(Xs,Ys,Zs).

queens(N,Qs) :-
  range(1,N,Ns),
  safe(Qs),
  permute(Ns,Qs).

range(L,U,R) :-
  findall(X,between(L,U,X),R).

:- block safe(-).

safe([Q|Qs]) :-
  no_attack(Q,Qs),
  safe(Qs).
safe([]).

:- block no_attack(-,?), no_attack(?,-), no_attack(?,?,-,?).

no_attack(X,Xs) :-
  no_attack(X,1,Xs).

no_attack(_,_,[]).
no_attack(X,N,[Y|Ys]) :-
  no_attack(X,N,Y,Ys).

no_attack(X,N,Y,Ys) :-
  X =\= Y + N,
  X =\= Y - N,
  N1 is N + 1,
  no_attack(X,N1,Ys).

psort(L,NL) :-
  length(L,N),
  % door de lengte van NL te beperken
  % verkrijgen we eindig gedrag van psort
  length(NL,N),
  sorted(NL),
  permute(L,NL).

permute([],[]).
permute([X|Xs],[Y|Zs]) :-
  select(Y,[X|Xs],Ys),
  permute(Ys,Zs).

:- block sorted(-).

sorted([]).
sorted([_]).
sorted([X,Y|Zs]) :-
  sorted(X,Y),
  sorted([Y|Zs]).

:- block sorted(-,?), sorted(?,-).

sorted(X,Y) :-
  X =< Y.

interpreter.pl

:- module(interpreter, [op(1150,fx,block), (block)/1, eval/1]).
:- use_module(block).

eval(G) :- eval(G, true, true).

% G: statement to be evaluated
% S: tuple of statements that are currently blocked
% Snew: tuple of statements that will be blocked after evaluating this statement
eval(G, S, Snew) :-
  ( G = true -> true, S = Snew
  ; G = (X @< Y) -> X @< Y, S = Snew
  ; G = (X @>= Y) -> X @>= Y, S = Snew
  ; G = (X =< Y) -> X =< Y, S = Snew
  ; G = (X = Y) -> X = Y, eval(S, true, Snew)
  ; G = (X =\= Y) -> X =\= Y, eval(S, true, Snew)
  ; G = (X is Exp) -> X is Exp, eval(S, true, Snew)
  ; G = (I -> T ; E) ->
    ( eval(I,S,S2) ->
        eval(T,S2,Snew)
    ; eval(E,S,Snew)
    )
  ; G = (G1,G2) ->
    eval(G1,S,S2),
    eval(G2,S2,Snew)
  ; G = write(X) -> write(X), S = Snew
  ; G = writeln(X) -> writeln(X), S = Snew
  ; G = findall(X,Y,Z) -> findall(X,Y,Z), eval(S, true, Snew)
  ; G = select(X,Y,Z) -> select(X,Y,Z), eval(S, true, Snew)
  ; G = length(A,B) -> length(A,B), eval(S, true, Snew)
  ;
    ( ready(G) ->
      clause(G,NG),
      eval(NG, S, Snew)
    ;
      % write(G), writeln(' is blocking'),
      Snew = (G,S)
    )
  ).

% verify that a functor is ready for evaluation
ready(G) :-
  functor(G,Functor,Arity),
  G =.. [Functor|Vars],
  findall(Descr,user:blocking(Functor,Arity,Descr),L),
  evaluate_blocks(L,Vars).

evaluate_blocks([],_).
evaluate_blocks([L|Ls],Vars) :-
  not(maplist(evaluate_variable, L, Vars)),
  evaluate_blocks(Ls,Vars).

evaluate_variable(-,V) :- !, var(V).
evaluate_variable(_,_).

interpreter_demo.pl

:- use_module(interpreter).
:- use_module(functions).

% my_merge blokkeert eerst, en zal pas uitgevoerd worden
% wanneer A of B gebonden wordt
merge_test :- 
  eval((
    my_merge([1,2],A,B),
    write('A = '), write(A), write(', B = '), writeln(B),
    A = [3,4],
    write('A = '), write(A), write(', B = '), writeln(B)
  )).

% queens
queens_test :-
  eval((
    queens(8, L),
    write('L = '), writeln(L)
  )).

% psort
psort_test :-
  eval((
    psort([10,9,8,7,6,5,4,3,2,1], L),
    write('L = '), writeln(L)
  )).