Entry 6366

:- dynamic ptr/1.
:- dynamic cell/2.
:- dynamic memo/2.

% le predicat qui lit stdin.
bfread :-
        writeln('Tapez votre code entre quote ('') suivi d''un point'),
        read(A),
        atom_codes(A, L),
        bf(L).

% le prédicat bf qui prend une chaine en argument
bf(L) :-
        maplist(char_code, L1, L),
        writef('%s\n', [L]),
        retractall(ptr(_)),
        retractall(cell(_,_)),
        % pour la memorisation des codes de boucle
        retractall(memo(_,_)),
        % on cree le pointeur index dans le tableau, initialise a 0.
        assert(ptr(0)),
        % on cree le tableau de 30 000 valeurs initialisees à 0
        forall(between(0, 30000, I), assert(cell(I, 0))),
        bf(L1, _, _).

% le parsing des commandes hors boucle
bf(['>'|B]) -->
        {incrptr},
        bf(B).

bf(['<'|B]) -->
        {decrptr},
        bf(B).

bf(['+'|B]) -->
        {incrcell},
        bf(B).

bf(['-'|B]) -->
        {decrcell},
        bf(B).

bf(['.'|B]) -->
        {putchar},
        bf(B).

bf([','|B]) -->
        {getchar},
        bf(B).

% on rencontre un début de boucle,
bf(['['|B]) -->
        {% on doit sauter au ']' suivant
         carnull,
        % on n'a pas besoin de mémoriser le saut
         skip(B, 0, U-U, _T, B1)},
        bf(B1).

% on rencontre un début de boucle,
bf(['['|B]) -->
        {% ici on commence la boucle, il faut memoriser les caracteres lus
         \+ carnull,
        % on est au premier niveau d'imbrication de boucle
        % on n'a pas de code de boucle a memoriser
        asserta(memo(0, X-X))},
        % utilisation des differences-listes
        % pas de code mémorise, donc liste vide symbolisee par U-U en "ecriture dl".
        bfmemo(B, U-U).

% tout caractere inconnu est considere comme commentaire donc oublie
bf([_|B]) -->
        bf(B).

% quand c'est fini, c'est fini
bf([]) --> [].

% le parsing des commandes de boucle
% Il faut les mémoriser
bfmemo(['>'|B], T) -->
        {incrptr,
         append_dl(T, ['>' | U]-U, T1)},
        bfmemo(B, T1).

bfmemo(['<'|B], T) -->
        {decrptr,
         append_dl(T, ['<' | U]-U, T1)},
        bfmemo(B, T1).

bfmemo(['+'|B], T) -->
        {incrcell,
         append_dl(T, ['+' | U]-U, T1)},
        bfmemo(B, T1).

bfmemo(['-'|B], T) -->
        {decrcell,
         append_dl(T, ['-' | U]-U, T1)},
        bfmemo(B, T1).

bfmemo(['.'|B], T) -->
        {putchar,
         append_dl(T, ['.' | U]-U, T1)},
        bfmemo(B, T1).

bfmemo([','|B], T) -->
        {getchar,
         append_dl(T, [',' | U]-U, T1)},
        bfmemo(B, T1).


bfmemo(['['|B], T) -->
        {% le caractere pointe est null, on saute
         % et on memorise la partie sautee
         carnull,
         skip(B, 0, ['['|W]-W, SF, B1),
         append_dl(T, SF, T1)
        },
        bfmemo(B1, T1).

bfmemo(['['|B], T) -->
        {
         % le caractere pointé est non null
         \+carnull,
         append_dl(T, ['['|U]-U, T1),
         memo(N, _),
         N1 is N+1,
         % on debute une nouvelle boucle
         % on memorise le debut de la precedente boucle
         asserta(memo(N1, T1))
        },
        bfmemo(B, V-V).


bfmemo([']'|B], T) -->
        {
        % Si l'octet pointe est null, on continue
        carnull,
        % on recupere les donnees memorisees
        memo(N, L),
        % ici on n'est pas au niveau 0
        N \= 0, !,
        % on efface le niveau
        retract(memo(N,L)),
        append_dl(T, [']'|U]-U, T1),
        append_dl(L, T1, T2)
        },
        % on continue en bfmemo
        bfmemo(B, T2).

bfmemo([']'|B], _T) -->
        {
        % Si l'octet pointe est null, on continue
        carnull,
        % on recupere les donnees memorisees
        memo(N, L),
        % ici on est au niveau 0
        N = 0, !,
        % on efface tout
        retract(memo(N,L))
        },
        % on continue en bf
        bf(B).


bfmemo([']'|B], T) -->
        {
        % ici on repart au debut de la boucle
        \+ carnull,
        % on recree la liste des donnees à partir du debut de la boucle
        append_dl(T, [']'|V]-V, T1-[]),
        append(T1, B, T2)
        },
        bfmemo(T2, U-U).


% tout caractère inconnu est ignore
bfmemo([_C|B], T) -->
        bfmemo(B, T).

% la concatenation des differences-listes, en temps constant !
append_dl(X1-X2, X2-X3, X1-X3).


% skip(Liste, Niveau SC, SR, LR)
% Permet le saut au ']' suivant

% Liste  : la liste a travailler
% Niveau : niveau d'imbrication des []
% SC     : dl-partie a sauter en construction
% SR     : dl-partie a sauter resultat
% LR     : Liste resultat restant a etudier

% on termine la recherche
skip([']'|B], 0, SC, ST, B) :-
        append_dl(SC, [']'|U]- U, ST).

% on baisse d'un niveau d'imbrication
skip([']'|B], N, SC, ST, BF) :-
        N1 is N-1,
        append_dl(SC, [']'|U]- U, SC1),
        skip(B, N1, SC1, ST, BF).

% on augmente le niveau d'imbrication
skip(['['|B], N, SC, ST, BF) :-
        N1 is N+1,
        append_dl(SC, ['['|U]- U, SC1),
        skip(B, N1, SC1, ST, BF).


skip([A|B], N, SC, ST, BF) :-
        append_dl(SC, [A|U]- U, SC1),
        skip(B, N, SC1, ST, BF).





%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%        Les primitives du langage
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
incrptr :-
        retract(ptr(N)),
        N1 is N+1,
        assert(ptr(N1)).

decrptr :-
        retract(ptr(N)),
        N1 is N-1,
        assert(ptr(N1)).

incrcell :-
        ptr(N),
        retract(cell(N, V)),
        V1 is (V+1) mod 256,

        assert(cell(N, V1)).

decrcell :-
        ptr(N),
        retract(cell(N, V)),
        V1 is V-1,
        assert(cell(N, V1)).

putchar :-
        ptr(N),
        cell(N, V),
        char_code(A, V),
        write(A).

getchar :-
        ptr(N),
        retract(cell(N, _)),
        read(A),
        (   number(A) -> number_codes(A, [V]); char_code(A,V)),
        assert(cell(N, V)).


% la valeur courante est-elle nulle
carnull :-
        ptr(N),
        cell(N, 0).

% quelques prog d'exemples
bf_test :-
/*
        writeln('Hello World !'),
L = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++
.<<+++++++++++++++.>.+++.------.--------.>+.>.",
*/

/*
        writeln('Addition'),
         L = ",>++++++[<-------->-],[<+>-]<.",
*/

/*
        writeln('Multiplication'),
L = ",>,>++++++++[<------<------>>-]<<[>[>+>+<<-]>>[<<+>>-]<<<-]
>>>++++++[<++++++++>-]<.>.",
*/

/*
        writeln('Affiche le caractère entre'),
        L = ",[.,]",
*/

/*
        writeln('Mise en majuscule de la saisie'),
        L = ",----------[----------------------.,----------]",
*/

/*
        writeln('recherche du minimum de deux nombres'),
        L = ",>,[->>+<<]+<[->>>[>>>>>+<<<<<->+<<]<[>]>>>>>[-<<->>>>>>>]<[>]<<<<<<]>[>>>>->]<<<<<<[-]>[-]>>[-]>.",
*/


        writeln('Calcul des nombres de Fibonacci'),
L =">++++++++++>+>+[[+++++[>++++++++<-]>.<++++++[>--------<-]+<<<]>.>>[
[-]<[>+<-]>>[<<+>+>-]<[>+<-[>+<-[>+<-[>+<-[>+<-[>+<-
[>+<-[>+<-[>+<-[>[-]>+>+<<<-[>+<-]]]]]]]]]]]+>>>]<<<]",


/*
        writeln('Test BlueStorm sur les carres '),
L = "+++++++++++++++++++++++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]",
*/
        bf(L).