% TOY Sequel (Relational database for TOY Prolog)
% (c) 1983 Kluzniak/Szpakowicz, IIUW Warszawa

toysequel :- write('--- TOY-Sequel, IIUW Warszawa 1983 ---'), nl,
      repeat, tag(getcommand(Cmd, Errflag)),
      tag(docommand(Cmd, Errflag)),
      Cmd = sequelstop, !.

getcommand(Cmd, Errflag) :-
      readcmd(CmdString),
      scan(CmdString, TList), compile(TList, Cmd).

docommand(Cmd, Errflag) :- var(Errflag), !, Cmd.
docommand(_, _).

scan(CmdString, TList) :-
      phrase(tokens(TList), CmdString), tracescan(TList).

compile(TList, Cmd) :-
      phrase(command(Cmd), TList), !, tracecompile(Cmd).
compile(_, error) :- synerr(badcommand).

tracescan(Cmd) :- tracescan, !, write('--- scanned '(Cmd)), nl.
tracescan(_).

tracecompile(Cmd) :- tracecompile, !, write('--- compiled '(Cmd)), nl.
tracecompile(_).

tracescan. tracecompile.


readcmd(String) :- rdchsk(Ch), readcmd(Ch, String).

readcmd('.', []) :- !, rch.
readcmd('"', ['"' | Rest]) :-
      !, rdch(Ch), readstr(Ch, Rest, RestAfter),
      rdch(Nextch), readcmd(Nextch, RestAfter).
readcmd(Ch, [Ch | Rest]) :- rdch(Nextch), readcmd(Nextch, Rest).

readstr('"', ['"' | Rest], Rest) :- !.
readstr(Ch, [Ch | Rest], RestAfter) :-
      rdch(Nextch), readstr(Nextch, Rest, RestAfter).


tokens([T | Ts]) --> token(T), !, sp, tokens(Ts).
tokens([]) --> [].

token(n(Name)) -->
      letter(L), namechars(NN), {pname(Name, [L | NN])}.
token(s(String)) --> ['"'], stringchars(String).
token(i(Integer)) -->
      sign(S), digit(D), digits(DD),
      {pnamei(I, [D | DD]), signed(S, I, Integer)}.
token(Ch) --> [Ch].

letter(Ch) --> [Ch], {letter(Ch)}.

namechars([Ch | Chs]) --> letter(Ch), !, namechars(Chs).
namechars([Ch | Chs]) --> digit(Ch), !, namechars(Chs).
namechars([]) --> [].

stringchars(['"' | Chs]) --> ['"', '"'], !, stringchars(Chs).
stringchars([]) --> ['"'], !.
stringchars([Ch | Chs]) --> [Ch], stringchars(Chs).

digit(Ch) --> [Ch], {digit(Ch)}.

digits([D | DD]) --> digit(D), !, digits(DD).
digits([]) --> [].

sign('-') --> ['-'].
sign('+') --> ['+'].
sign('+') --> [].

signed('+', I, I).
signed('-', I, Integer) :- Integer is - I.

sp --> [' '], !, sp.
sp --> [].



qname(Qual-Name) --> [n(Qual), '_', n(Name)], !.
qname(Variable-Name) --> [n(Name)].

constant(Int, integer) --> [i(Int)].
constant(Str, string ) --> [s(Str)].

:- op(100, xfx, ':').

newrelname(RelNm, Alias, Generator, OldST, [Alias : RelST | OldST]) :-
      'r e l'(RelNm, Generator, RelST), !.
newrelname(RelNm, _, fail, OldST, OldST) :- synerr(norelname(RelNm)).

findattr(Q-Nm, Var, Type, [Q : RelST | ST]) :-
      member(attr(Nm, Type, Var), RelST), !.
findattr(QNm, Var, Type, [_ | ST]) :- !, findattr(QNm, Var, Type, ST).
findattr(QNm, _, _, []) :- synerr(noattribute(QNm)).


command(Cmd) --> create(Cmd).
command(Cmd) --> cancel(Cmd).
command(Cmd) --> select(Cmd).
command(Cmd) --> relations(Cmd).
command(Cmd) --> relation(Cmd).
command(Cmd) --> insert(Cmd).
command(Cmd) --> delete(Cmd).
command(Cmd) --> update(Cmd).
command(Cmd) --> stop(Cmd).
command(Cmd) --> dump(Cmd).
command(Cmd) --> load(Cmd).


create(newrel(RelName, [V | Vs], [attr(Nm, Type, V) | As])) -->
      [n(create), n(RelName)],
      ['<'], typnam(Type, Nm), typnams(Vs, As), ['>'].

typnams([V | Vs], [attr(Nm, Type, V) | As]) -->
      [','], !, typnam(Type, Nm), typnams(Vs, As).
typnams([], []) --> [].

typnam(string, Nm) --> [n(string), n(Nm)], !.
typnam(integer, Nm) --> [n(integer), n(Nm)], !.
typnam(notype, Nm) --> synerrc(typeexpected).

newrel(RelName, Vars, RelST) :-
      not 'r e l'(RelName, _, _), !,
      mkgen(RelName, Vars, Generator),
      assert('r e l'(RelName, Generator, RelST)).
newrel(RelName, _, _) :- namerr(duprelname(RelName)).

mkgen(RelName, Vars, Generator) :-
      pname(RelName, Chars), pname(RelNm, [' ' | Chars]),
      Generator =.. [RelNm | Vars].


cancel(cancel(RelName)) --> [n(cancel), n(RelName)].

cancel(RelName) :- retract('r e l'(RelName, Generator, _)), !,
      retract(Generator), fail.
cancel(RelName) :- namerr(unknown(RelName)).


select((Generators, Filter, writetuple(Tup), fail)) -->
      selectexp(set(Generators, Filter, Tup, _), []).

writetuple([]) :- !, nl.
writetuple([Val| Vals]) :-
      writeval(Val), display('  '), writetuple(Vals).

writeval([FirstLetter | RestOfString]) :- display(FirstLetter),
      writestring(RestOfString).
writeval(Val) :- display(Val).

writestring([]) :- !.
writestring([Ch | Chs]) :- display(Ch), writestring(Chs).

relations(('r e l'(RelNm, _, _), write(RelNm), nl, fail)) -->
      [n(relations)].


relation(relation(Name)) --> [n(relation), n(Name)].

relation(RelNm) :- 'r e l'(RelNm, _, Attrs), !, listattrs(Attrs).
relation(RelNm) :- write(RelNm), write(' is not a relation !'), nl.

listattrs([]) :- !.
listattrs([attr(Name, Type, _) | Attrs]) :-
      write(Type), write('  '), write(Name), nl,
      listattrs(Attrs).


selectexp(set(Generators, Filter, Tuple, Types), InitST) -->
      [n(select), n(from)], relnames(Generators, InitST, ST),
      [n(tuples)], tuplepattern(Tuple, Types, ST),
      whereclause(Filter, ST).

relnames((Gen, Gens), OldST, NewST) -->
      relname(Name, Alias), [','], !, relnames(Gens, OldST, TempST),
      { newrelname(Name, Alias, Gen, TempST, NewST) }.
relnames(Gen, OldST, NewST) -->
      relname(Name, Alias), { newrelname(Name, Alias, Gen, OldST, NewST) }.

relname(Name, Alias) --> [n(Alias), '=', n(Name)], !.
relname(Name, Name) --> [n(Name)].

tuplepattern([A | As], [T | Ts], ST) -->
      ['<'], attrpatt(A, T, ST), attrpatts(As, Ts, ST), ['>'].

attrpatts([A | As], [T | Ts], ST) -->
      [','], !, attrpatt(A, T, ST), attrpatts(As, Ts, ST).
attrpatts([], [], _) --> [].

attrpatt(Attribute, Type, _) --> constant(Attribute, Type), !.
attrpatt(A, T, ST) --> qname(QN), {findattr(QN, A, T, ST) }.

whereclause(Filter, ST) --> [n(where)], !, boolexp(Filter, ST).
whereclause(true, _) --> [].


boolexp(E, ST) --> bterm(T, ST), rboolexp(T, E, ST).

rboolexp(L, (L ; R), ST) --> [n(or)], !, boolexp(R, ST).
rboolexp(E, E, _) --> [].

bterm(T, ST) --> bfactor(F, ST), rbterm(F, T, ST).

rbterm(L, (L, R), ST) --> [n(and)], !, bterm(R, ST).
rbterm(L, L, _) --> [].

bfactor(not F, ST) --> [n('not')], !, bfactor(F, ST).
bfactor(E, ST) --> ['('], !, boolexp(E, ST), [')'].
bfactor(E, ST) --> inexp(E, ST).
bfactor(E, ST) --> relexp(E, ST).

inexp((Generator, Filter), ST) -->
      tuplepattern(Patt, Type, ST), [n(in)],
      setexp(set(Generator, Filter, Tuple, Types), ST),
      matchpatterns(Patt, Type, Tuple, Types).

matchpatterns(Patt, Types, Patt, Types) --> !.
matchpatterns(P1, T1, P2, T2) -->
      synerrc(badinexppattern(T1, P1, T2, P2)).


setexp(Set, ST) --> ['('], !, setexp(Set, ST), [')'].
setexp(Set, ST) --> selectexp(Set, ST), !.
setexp(set(member(Patt, [Tup | Tups]), true, Patt, Types), ST) -->
      tuple(Tup, Types), tuples(Tups, Types),
      { mkpattern(Types, Patt) }, !.
setexp(set(fail, fail, [], []), _) --> synerrc(badsetexpression).

tuples([Tup | Tups], Types) --> [','], !, tuple(Tup, TupTypes),
      { checktype(Types, TupTypes) }, tuples(Tups, Types).
tuples([], _) --> [].

tuple([A | As], [T | Ts]) -->
      ['<'], constant(A, T), constants(As, Ts), ['>'], !.
tuple([], []) --> ['<'], synerrc(badtuple), { fail }.

constants([A | As], [T | Ts]) -->
      [','], !, constant(A, T), constants(As, Ts).
constants([], []) --> [].

checktype(Type, Type).
checktype(T1, T2) :- synerr(inconsistent(T1, T2)).

mkpattern([], []) :- !.
mkpattern([_ | Types], [V | Vs]) :- mkpattern(Types, Vs).


relexp(E, ST) -->
      simplexp(LeftE, LeftType, ST), relop(Op), !,
      simplexp(RightE, RightType, ST),
      { consrel(LeftE, LeftType, Op, RightE, RightType, E) }.

relop('=<') --> ['=', '<'].
relop('=:=') --> ['='].
relop('=\=') --> ['<', '>'].
relop('<') --> ['<'].
relop('>=') --> ['>', '='].
relop('>') --> ['>'].

consrel(L, Type, Op, R, Type, E) :- consrel(L, Op, R, Type, E), !.
consrel(L, LType, Op, R, RType, fail) :-
      E =.. [Op, L, R], synerrc(typeconflict(LType, RType, E)).

consrel(Arg, '=:=', Arg, _, true).
consrel(L, '=:=', R, string, fail).
consrel(L, '=\=', R, string, not L = R).
consrel(L, Op, R, integer, E) :- E =.. [Op, L, R].
consrel(L, '<', R, string, lstr(L, R)).
consrel(L, '=<', R, string, (lstr(L, R) ; L = R)).
consrel(L, '>', R, string, lstr(R, L)).
consrel(L, '>=', R, string, (lstr(R, L) ; R = L)).

lstr([], [_ | _]) :- !.
lstr([Ch1 | _], [Ch2 | _]) :- Ch1 @< Ch2, !.
lstr([Ch | Chs1], [Ch | Chs2]) :- lstr(Chs1, Chs2).


simplexp(E, string, ST) --> stringexp(E, ST), !.
simplexp(E, integer, ST) --> arithexp(E, ST).

stringexp(Str, _) --> [s(Str)], !.
stringexp(Var, ST) -->
      qname(QN), { findattr(QN, Var, Type, ST), Type = string }.

arithexp(E, ST) --> aterm(T, ST), rarithexp(T, E, ST).

rarithexp(L, E, ST) -->
      ['+'], !, aterm(T, ST), rarithexp(L+T, E, ST).
rarithexp(L, E, ST) -->
      ['-'], !, aterm(T, ST), rarithexp(L-T, E, ST).
rarithexp(E, E, _) --> [].

aterm(T, ST) --> afactor(F, ST), raterm(F, T, ST).

raterm(L, T, ST) -->
      ['*'], !, afactor(F, ST), raterm(L*F, T, ST).
raterm(L, T, ST) -->
      ['/'], !, afactor(F, ST), raterm(L/F, T, ST).
raterm(T, T, _) --> [].

afactor(E, ST) --> ['('], !, arithexp(E, ST), [')'].
afactor(Int, _) --> [i(Int)], !.
afactor(Var, ST) -->
      qname(QN), { findattr(QN, Var, Type, ST), Type = integer }, !.
afactor(0, _) --> qname(QN), !, synerrc(notinteger(QN)).
afactor(0, _) --> synerrc(nointegerfactor).

insert((Generators, Filter, assertz(NewTuple), fail)) -->
      [n(into), n(RelName)],
      { 'r e l'(RelName, _, RelST) }, !, [n(insert)],
      setexp(set(Generators, Filter, Tuple, Types), []),
      { checktypes(Types, RelST),
      mkgen(RelName, Tuple, NewTuple) }.
insert(fail) --> [n(into), n(RelNm)],
      synerrc(norelname(RelNm)).

checktypes([], []) :- !.
checktypes([T | Ts], [attr(_, T, _) | As]) :- !, checktypes(Ts, As).
checktypes(Types, Attributes) :- synerr(badsettype(Types, Attributes)).

delete((RelGen, RelFilter, retract(RelGen), fail)) -->
      [n(from), n(RelNm)],
      { newrelname(RelNm, RelNm, RelGen, [], ST) },
      [n(delete)], delfilter(RelFilter, ST).

defilter(true, _) --> [n(all), n(tuples)], !.
delfilter(RelFilter, ST) -->
      [n(tuples), n(where)], boolexp(RelFilter, ST).


update((OldTup, UseGens, Filter, Modifications,
                         retract(OldTup), assert(NewTup), fail)) -->
      [n(update), n(RelNm)],
      { 'r e l'(RelNm, OldTup, OldST),
      'r e l'(RelNm, NewTup, NewST), !,
      makemodlist(OldST, NewST, MList) },
      usingclause(UseGens, UseST), { ST = [RelNm : OldST | UseST] },
      [n(so), n(that)],
      modifier(Modification, MList, ST),
      modifiers(Modification, Modifications, MList, ST),
      { closemodlist(MList) }, whereclause(Filter, ST).
update(fail) --> [n(update)], synerrc(noupdatedrelation).

usingclause(Gens, ST) --> [n(using)], relnames(Gens, [], ST).
usingclause(true, ST) --> [].

modifiers(M, (M, Ms), MList, ST) -->
      [','], !, modifier(MM, MList, ST),
      modifiers(MM, Ms, MList, ST).
modifiers(M, M, _, _) --> [].

modifier(AttrVar is Expr, MList, ST) -->
      [n(Nm)], { findmname(Nm, AttrVar, Type, MList) },
      ['='], simplexp(Expr, EType, ST),
      { mtype(Type, EType, Nm) }.

makemodlist([Old | Olds], [attr(_, _, NewV) | NewVs],
                          [modif(Old, NewV, Mod) | Mods]) :-
      !, makemodlist(Olds, NewVs, Mods).
makemodlist([], [], []).

closemodlist([Mod | Mods]) :- closemod(Mod), !, closemodlist(Mods).
closemodlist([]).

closemod(modif(attr(_, _, OldV), OldV, Mod)) :- var(Mod).
closemod(_).

findmname(Nm, NewV, T, MList) :-
      member(modif(attr(Nm, T, _), NewV, Mod), MList), !,
      mmod(Mod, Nm).
findmname(Nm, _, _, _) :- synerr(notinupdatedrel(Nm)).

mmod(Mod, Nm) :- not var(Mod), !, synerr(updatedtwice(Nm)).
mmod(true, _).

mtype(Type, Type, _) :- !.
mtype(T1, T2, Nm) :- synerr(typeconflict(T1, Nm, T2)).


stop(sequelstop) --> [n(stop)].

sequelstop.

load(consult(FileName)) --> [n(load), n(from), n(FileName)].

dump(dump(FileName)) --> [n(dump), n(to), n(FileName)].

dump(FileName) :- tell(FileName),
      'r e l'(Nm, Gen, ST), wclause('r e l'(Nm, Gen, ST)),
      Gen, wclause(Gen), fail.
dump(_) :- write('end.'), nl, told.

wclause(Cl) :- writeq(Cl), wch('.'), nl.



synerr(Info) :- synmes(Info), ancestor(getcommand(_, error)).

synerrc(Info) --> { synmes(Info), write('Context : ') },
                  context.
synerrc(_) --> { nl, ancestor(getcommand(_, error)) }.

synmes(Info) :- nl, write('--- Syntactic error : '), write(Info), nl.

context --> [Token], { wtoken(Token) }, context.

wtoken(T) :- wt(T, RealT), write(RealT), write(' '), !.
wt(n(Name), Name).
wt(i(Integer), Integer).
wt(s(String), String).
wt(Char, Char).

namerr(Info) :- nl, write('*** Error : '), nl,
      write(Info), nl, tagfail(docommand(_, _)).

end.