grass interpreter implemented in prolog

grass.prolog

%% http://www.blue.sky.or.jp/grass/

% 記号処理能力はなかなか強力
% grass の Operational Semantics をほとんどそのまま書下せたのはすごい
% DCG (Definite Clause Grammars) を使って構文解析が素直に書けるのもいい

% Syntax
token('w', ['w', 'ｗ']).
token('W', ['W', 'Ｗ']).
token('v', ['v', 'ｖ']).
token_value(X, V) :- token(V, Ts), member(X, Ts), !.

tokens(S, L) :-
    atom_chars(S, Xs),
    findall(V, (member(X, Xs),  token_value(X, V)), L).

parse(S, C) :- tokens(S, L), prog(C, L, []), !.

prog([X]) --> abs(X).
prog(L) --> apps(L).
prog([X|L]) --> abs(X), [v], prog(L).
prog(L) --> apps(L1), [v], prog(L2), {append(L1, L2, L)}.

app(app(M,N)) --> uww(M), ww(N).
abs(abs(N,X)) --> ww(N), apps(X).

apps([]) --> [].
apps([X|L]) --> app(X), apps(L).

uww(1) --> ['W'].
uww(N) --> ['W'], uww(N1), {N is N1 + 1}.

ww(1) --> ['w'].
ww(N) --> ['w'], ww(N1), {N is N1 + 1}.


% CED Transformation Rules
trans(([app(M,N)|C], E, D) -> (Cm, [(Cn,En)|Em], [(C,E)|D])) :-
    nth1(M, E, (Cm,Em)),
    nth1(N, E, (Cn,En)).

trans(([abs(N,Ca)|C], E, D) -> (C, [(Ca,E)|E], D)) :-
    N == 1.
trans(([abs(N,Ca)|C], E, D) -> (C, [F|E], D)) :-
    N > 1,
    N1 is N - 1,
    F = ([abs(N1,Ca)], E).

trans(([], [F|_], [(C1,E1)|D]) -> (C1, [F|E1], D)).

% Primitives
trans((out, [F|E], D) -> ([], [F|E], D)) :-
    F = (char(N), _), number(N),
    put_code(N).

trans((in, [_|E], D) -> ([], [F|E], D)) :-
    get_code(N), N >= 0, !,
    F = (char(N), []).
trans((in, [F|E], D) -> ([], [F|E], D)).

trans((succ, [F|E], D) -> ([], [F1|E], D)) :-
    F = (char(N), _),
    F1 = (char(N1), []),
    N1 is (N + 1) mod 256.

trans((char(N), [F|E], D) -> ([], [F1|E], D)) :-
    F = (char(N), _), !,
    F1 = ([abs(1, true)], []).
trans((char(_), [_|E], D) -> ([], [F1|E], D)) :-
    F1 = ([abs(1, false)], []).

trans((true,  [_,X|E], D) -> ([], [X|E], D)).
trans((false, [Y,_|E], D) -> ([], [Y|E], D)).

% Main
env([(out, []), (succ, []), (char(W), []), (in, [])]) :-
    atom_char(w, W).

dump([([app(1,1)], []), ([], [])]).

transform_all(([], _, [])) :- !.
transform_all(CED) :-
    %% CED = (C, E, D),
    %% format('~n  C=~w~n  E=~w~n  D=~w~n', [C, E, D]),
    trans(CED -> CED1), !,
    transform_all(CED1).

grass(S) :-
    parse(S, C),
    env(E), dump(D),
    transform_all((C, E, D)).

:- grass('wWwwwWwwwwwWWWWwvwvwwWWWWwWWWWwwwvwwWWwwWwwvwwWWWwWWWwvwWWwWwvwWWwwwwwWwwvwwWWwWWWwvWwvwwwWWWwwWwwWWWWwvWwwwWWWWwWWWWwwwWwwWWWWWwWWWWWWwvwwWWwWWWwvWwwWWwwwwWWWwwwwwwWWWWWWWWWWwwwwwwwwWwwWWwwwwWWWwwwwwwvwwwWWWwwWwwWWWWwvWwwwwwwWWwwwwWWWwwwwWWWWwWWWWWWWWWWWWWWWWWWWwwwwwWwwWWwWWWwWWWWwvwWWWWWWWWWWWWWWWWWWWWWWWWWWWWWwwwwwwwwwWwwwwwwwwwWwwwwwwWwwwwwwwWwwwwwwwWwwwwwwwwwwwwwwwwwwwWwwwwwwwwwwwwwwwwwwwwwwvwwvWWwWwwWwwwwwwWwwwwwwWwwwwwwwwwWwwwwwwwwwwwwwwwwwwWwwwwwwwwwwwwwwwwwvw').