/*
 * Copyright (c) 1995, 1996 Gunther Schadow.  All rights reserved.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

 % Consistency check clauses for the HL-7 v2.2 database
 %
 %   main entry point is hl7check/0
 %

:- module(db_check,[hl7check/0,removeNoKey/0,undefdSeg/1,retractNotify/1]).
:- style_check(+string).

:- use_module(db-inter,[nil/1, nonnil/1]).

tableClasses(Cls) :- findall(Cl, (table(_,_,Cl), nonnil(Cl)), Cll),
	sort(Cll, Cls).

 % For each table, there must exist at least one value definition and
 % vice versa.
 %
tablesWOvalue(Class, Tl) :- findall(X, (table(X,_,Cl),
	Cl = Class,
	\+ value(_,X,_,_,_,_)),  
	Tl).
valuesWOtable(Vl) :- findall(X, (value(_,X,_,_,_,_), \+ table(X,_,_)),
	Vl).

 % Any field/11 should belong to a segment, and there shouldn't be any
 % segments without a field.
 %
fieldsWOsegment(Fds) :- findall([S, F],
	(field(_,_,S,F,_,_,_,_,_,_,_),
	\+ segment(S,_,_)), Fds).

segmentsWOfield(Sgs) :- findall(S,
	(segment(S,_,_),
	\+ field(_,_,S,_,_,_,_,_,_,_,_)), Sgs).

 % Now we're concerned with message definitions. A message definition
 % is sytactically defined/checked by the following
 %
msgSyntax(message(N,E,_,D,B)) :- atom(N), (nil(E); atom(E)), 
	string(D), msgSyBody(B).

msgSyBody([S]) :- msgSyElem(S).
msgSyBody([S|T]) :- msgSyElem(S), msgSyBody(T).

msgSyElem(S) :- atom(S).
msgSyElem(F) :- F =.. [rep|A], msgSyBody(A).
msgSyElem(F) :- F =.. [opt|A], msgSyBody(A).
msgSyElem(S) :- nil(S).
 
 % Check for any message definitions not complying to the above
 % syntax
msgSyErr(Ms) :- findall(msg(M,E),
	(message(M,E,_,D,B),
	\+ msgSyntax(message(M,E,_,D,B))), Ms1),
	sort(Ms1, Ms).

 % Selectors
 %
msgName(message(N,_,_,_,_), N).
msgBody(message(_,_,_,_,B), B).

 % Is a segment part of a message?
 %
msgSeg(M, S) :- msgBody(M, B), segInMbdy(S, B).

segInMbdy(S, [S|_]) :- atom(S).
segInMbdy(S, [B|_]) :- B =.. [rep|T], segInMbdy(S, T).
segInMbdy(S, [B|_]) :- B =.. [opt|T], segInMbdy(S, T).
segInMbdy(S, [_|T]) :- segInMbdy(S, T).

 % Check if any used segment is in the list of segments.
 %
undefdSeg(MSs) :- findall([M,E,S],
	(rdb:message(M,E,_,_,B),
	segInMbdy(S,B),
	\+ (rdb:segment(S,_,_) ; S=any)), MSs).

 % How we format the output.
 %
portray([]) :- write(none).
portray([A]) :- write(A), put('.').
portray([A|R]) :- write(A), put(','), portray(R).

 % Subclauses for check/0
 %
checkLonelyTabs :-
	tableClasses(Cls),
	findall(Cl,
	(
	    member(Cl,Cls),
	    tablesWOvalue(Cl, TwoV), sort(TwoV, TwoVs),
	    writef("    for class `%t': %t\n", [Cl, TwoVs])
	), _).

 % remove all facts, whose Key is undefined
 %
 %   FIXME! This only works if non key values are a superkey themselves
removeNoKey :-
	forall((rdb:segment(A,B,C), nil(A)),
	  retractNotify(rdb:segment(A,B,C))),
	forall((rdb:table(A,B,C), nil(A)),
	  retractNotify(rdb:table(A,B,C))),
	forall((rdb:value(A,B,C,D,E,F), (nil(B); nil(D))),
	  retractNotify(rdb:value(A,B,C,D,E,F))),
	forall((rdb:field(A,B,C,D,E,F,G,H,I,J,K), (nil(C); nil(D))),
	  retractNotify(rdb:field(A,B,C,D,E,F,G,H,I,J,K))),
	forall((rdb:message(A,B,C,D,E), nil(A)),
	  retractNotify(rdb:message(A,B,C,D,E))).

retractNotify(X) :-
	sformat(S,"retracting ~p~n", [X]),
	write(user_error,S),
	retract(X) ; true.

 % The main clause for checks
 %
hl7check :- writef("Loading database:\n"), 
	use_module(rhl7),
	writef("Removing Facts with undefined key value:\n"),
	removeNoKey,
	writef("Performing checks on:\n"),

	writef("*** Tables\n"),
	writef("  tables without any value definition:\n"),
	checkLonelyTabs,
	valuesWOtable(VTl), sort(VTl,VTls),
	writef("  values without any defining table: %t\n", [VTls]),

	writef("*** Fields\n"),
	fieldsWOsegment(FwoS), sort(FwoS, FwoSs),
	writef("  fields without segment: %t\n", [FwoSs]),
        segmentsWOfield(SwoF), sort(SwoF, SwoFs),
	writef("  segments without field: %t\n", [SwoFs]),

	writef("*** Messages\n"),
	msgSyErr(MSyRs), sort(MSyRs, MSyRss),
	writef("  message definition syntax errors: %t\n", [MSyRss]),
        undefdSeg(UdSs), sort(UdSs, UdSss),
	writef("  undefined segments used: %t\n", [UdSss]).
        
%
% End of check clauses