/*
 * 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 database
 %
 %   main entry point is hl7check/0
 %

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

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

 % The following tables are grep(1)ed from the document. We want to
 % check, if the appendix A leaves any table out, which is defined in
 % the chapters.    
 %
 % grep "TABLE ????" kap*.txt| sed ...
 %
 % check which of these tables are left undefined
 % 
undefdTables(Cts) :- ensure_loaded(chptbl),
	findall(Ct, (chapterTable(Ct), \+ table(Ct,_,_)), Cts).

 % check if table/2 is part of table/3, since we keep table/3, if
 % there's no loss of information. 
 %
table2in3(Tns) :- findall(Tn, (table(Tn,_), \+ table(Tn,_,_)), Tns).

 % compare descriptions of tables
 %
tabComp(Tns) :- findall(Tn, (table(Tn,D1,_), table(Tn,D2), 
	D1\=D2), Tns).

 % Now we'll do essencialy the same with segment/2 and segment/3
 %
 % check if segment/2 is part of segment/3, since we keep segment/3,
 % there's no loss of information. 
 %
segment2in3(Ss) :- findall(S, (segment(S,_), \+ segment(S,_,_)), Ss).

 % compare descriptions of segments
 %
segComp(Ss) :- findall(S, (segment(S,D1,_), segment(S,D2), D1\=D2),
	Ss).

 % Now we'll deal with values. There are value/4 value/5 and value/7
 % to which univalue/4 provides a common interface.
 %
univalue(Tab, Sym, Desc, ValNum) :-
	rdb:value(Tab, Sym, Desc, ValNum).
univalue(Tab, Sym, Desc, ValNum) :-
	rdb:value(Tab, Sym, Desc, _, ValNum).
univalue(Tab, Sym, Desc, ValNum) :-
	rdb:value(Tab, Sym, Desc, _,_,_, ValNum).

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,
	\+ univalue(X,_,_,_)),  
	Tl).
valuesWOtable(Vl) :- findall(X, (univalue(X,_,_,_), \+ table(X,_,_)),
	Vl).

 % Data_element/9, data_type/3 and field/10 all have some length
 % attibute which should belong to either data_type or
 % data_element/field only. Do all three instantations have the same
 % meaning? Anyway, we check for any conflicts and assume they all
 % mean the same thing. 
 %
lenCompD(Des) :- findall(De, (data_type(Dt,_,Ldt),
	nonnil(Ldt),
	data_element(De,_,_,_,Lde,Dt,_,_,_), 
	Ldt \= Lde), Des).

lenCompF(Fds) :- findall([S,F], (data_type(Dt,_,Ldt),
	nonnil(Ldt),
	field(S,F,Lf,Dt,_,_,_,_,_,_),
	Ldt \= Lf), Fds).

 % Field depends extensively on data_element. Actually a field is a
 % data element at a certain place in the sequence of a segment. Check
 % if any data_element/9 is in field/10 for we want to keep field and
 % discard data_element.
 %
datelInField(Des) :- findall(X, (data_element(X,_,_,_,_,_,_,_,_),
	\+ field(_,_,_,_,_,_,_,X,_,_)), Des).

 % Here we prove if field and data_element are equivalent. If for any
 % data element there exists exactly one field, we assume that they
 % are  equivalent.
 %
datelEoField(Des) :- findall(X, (data_element(X,_,_,_,_,_,_,_,_),
	field(S1,F1,_,_,_,_,_,X,_,_),
	field(S2,F2,_,_,_,_,_,X,_,_),
	(S1\=S2; F1\=F2)), Des).

 % Check for any conflicts of data_element/9 and field/10
 %
 %
fieldDatelComp(FDCs) :- findall([Seg,Fld,Datel],
	(field(Seg,Fld,Len,DT,RO,RP,Tbl,Datel,_,_),
	data_element(Datel,_,Seg1,_,Len1,DT1,RO1,RP1,Tbl1),
	(Seg1\=Seg; DT1\=DT; Tbl1\=Tbl; Len1\=Len; RO1\=RO; RP1\=RP)),
	FDCs).

 % Any field/10 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 message is in the list of message types.
 %
undefdMsgType(Ms) :- findall(M,
	(message(M,_,_,_),
	\+ value(0076,M,_,_,_)), Mss),
	sort(Mss, Ms).

 % Check if any message, which is in the list of message types is
 % actually defined.
 %
undefdMsg(Ms) :- findall(M,
	(rdb:value(0076,M,_,_,_),
         \+ rdb:message(M,_,_,_)), Mss),
	sort(Mss, Ms).

 % Check if any used segment is in the list of segments.
 %
undefdSeg(MSs) :- findall([msg(M,E,D,B),S],
	(rdb:message(M,E,D,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),
	    writef("    for class `%t': %t\n", [Cl, TwoV]),
	    sublist(chapterTable, TwoV, CTb),
	    writef("      in the chapters: %t\n", [CTb])
	), _).

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

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

 % 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"),
	undefdTables(Uts),
	writef("  tables which are not yet defined: %t\n", [Uts]),
	table2in3(T23s),
	writef("  tables from table/2 that are not in table/3: %t\n",
    [T23s]),
	tabComp(TDs),
	writef("  tables with conflicting descriptions: %t\n",
    [TDs]),
	writef("  tables without any value definition:\n"),
	checkLonelyTabs,
	valuesWOtable(VTl),
	writef("  values without any defining table: %t\n", [VTl]),
	writef("*** Segments\n"),
	segment2in3(S23s),
	writef("  segments from segment/2 that are not in segment/3: %t\n",
    [S23s]),
	segComp(SDs),
	writef("  segments with conflicting descriptions: %t\n",
    [SDs]),
	writef("*** Data elements\n"),
	writef("  conflicts in length:\n"),
	lenCompD(LCDs),
	writef("    for data_element/9: %t\n", [LCDs]),
	lenCompF(LCFs),
	writef("    for field/10: %t\n", [LCFs]), 
        datelInField(DIFs),
	writef("  data_element/9 not in field/10: %t \n",
    [DIFs]), 
        datelEoField(DEOs),
	writef("  data_element/9 referenced by more than on field/10: %t \n",
    [DEOs]), 
	fieldDatelComp(FDCs),
	writef("  field/10 and data_element/9 conflicts: %t\n",        
    [FDCs]),
	fieldsWOsegment(FwoS),
	writef("*** Fields\n"),
	writef("  field/10 without segment/3: %t\n", [FwoS]),
        segmentsWOfield(SwoF),
	writef("  segment/3 without field/10: %t\n", [SwoF]),
	writef("*** Messages\n"),
	msgSyErr(MSyRs),
	writef("  message definition syntax errors: %t\n", [MSyRs]),
        undefdMsgType(UdMts),
	writef("  undefined message types used: %t\n", [UdMts]),
        undefdMsg(UdMs),
	writef("  undefined message: %t\n", [UdMs]),
        undefdSeg(UdSs),
	writef("  undefined segments used: %t\n", [UdSs]).
        
%
% End of check clauses