home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Supreme Volume 6 #1
/
swsii.zip
/
swsii
/
215
/
DDJ11A92.ZIP
/
EXPWIN.ASC
< prev
next >
Wrap
INI File
|
1992-11-04
|
21KB
|
756 lines
[LISTING ONE]
program ExpertWin;
{$R WINXPERT.RES}
uses WinDOS, WObjects, WinTypes, Strings, WinProcs, StdDlgs, CommDlg, BWCC, Lists;
const
id_Menu = 100; id_About = 100;
cm_FileOpen = 102; cm_FileSaveAs = 104;
cm_Insert = 201; cm_Search = 202;
cm_FindAttr = 203; cm_ForChain = 212;
cm_BackChain = 204; cm_ClearFacts = 205;
cm_About = 999; cm_Quit = 108;
id_EC1 = 106; id_EC2 = 107;
id_EC3 = 108; id_CB2 = 109;
id_ST1 = 110; id_ST2 = 111;
id_ST3 = 155; id_ST4 = 160;
id_LB1 = 151; id_BN1 = 152;
id_BN2 = 153; id_BN3 = 154;
id_YesBtn = 161; id_NoBtn = 162;
NotFound = 97; YesBtn = 98;
NoBtn = 99;
Type
TFilename = array [0..255] of Char;
DataFile = file of Item;
{--- Application Objects ---}
type
StatTxtRec = record
StaticText : array [0..40] of Char;
end;
TExpertApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
PExpert = ^TExpert;
TExpert = object(TWindow)
DC : HDC;
EC1, EC2, EC3 : PEdit;
LB1 : PListBox;
Head, Tail : PItem;
AHead, ATail : Pattr;
FileName : TFileName;
IName, AName : array[0..40] of Char;
constructor Init(AParent: PWindowsObject; ATitle: PChar);
destructor Done; virtual;
function Inference(Query : PChar; Rules : PItem) : Integer;
procedure Show; virtual;
procedure CmInsert(var Msg: TMessage); virtual cm_First + cm_Insert;
procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
procedure CMFileSaveAs(var Msg: TMessage); virtual cm_First + cm_FileSaveAs;
procedure CMSearch(var Msg: TMessage); virtual cm_First + cm_Search;
procedure CMFindAttr(var Msg: TMessage); virtual cm_First + cm_FindAttr;
procedure CMForChain(var Msg: TMessage); virtual cm_First + cm_ForChain;
procedure CMBackChain(var Msg: TMessage); virtual cm_First + cm_BackChain;
procedure ClearFacts(var Msg : TMessage); virtual cm_First + cm_ClearFacts;
procedure CMAbout(var Msg: TMessage); virtual cm_First + cm_About;
procedure CMQuit(var Msg: TMessage); virtual cm_First + cm_Quit;
end;
PTDialog = ^TTDialog;
TTDialog = object(TDialog)
constructor Init(AParent: PWindowsObject; ATitle: PChar);
procedure IDBN1(var Msg: TMessage); virtual id_First + id_BN1;
procedure IDLB1(var Msg: TMessage); virtual id_First + id_LB1;
end;
PQueryDlg = ^TQueryDlg;
TQueryDlg = object(TTDialog)
procedure IDBN2(var Msg: TMessage); virtual id_First + id_BN2;
procedure IDBN3(var Msg: TMessage); virtual id_First + id_BN3;
end;
PGetFact = ^TGetFact;
TGetFact = object(TDialog)
constructor Init(AParent: PWindowsObject; ATitle: PChar);
procedure IDYesBtn(var Msg: TMessage); virtual id_First + id_YesBtn;
procedure IDNoBtn(var Msg: TMessage); virtual id_First + id_NoBtn;
end;
Var
APtr : PAttr; {Global ptr to PAttr}
KnowledgeBase : Text;
InFile, OutFile : Text;
{ --- TGetFact Methods ---}
constructor TGetFact.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TDialog.Init(AParent, ATitle);
end;
procedure TGetFact.IDYesBtn(var Msg: TMessage);
begin
EndDlg(YesBtn); {Return YesBtn to ExecDialog and end dialog}
end;
procedure TGetFact.IDNoBtn(var Msg: TMessage);
begin
EndDlg(NoBtn); {Return NoBtn to ExecDialog and end dialog}
end;
{--- TTestDialog Methods ---}
constructor TTDialog.Init(AParent: PWindowsObject; ATitle: PChar);
begin
TDialog.Init(AParent, ATitle);
end;
procedure TTDialog.IDBN1(var Msg: TMessage);
var
TextItem : PChar;
TmpStr : array[0..40] of Char;
IList : PItem;
begin
IList := ListPtr;
While IList <> nil do
begin
TextItem := StrNew(IList^.ItemName);
SendDlgItemMsg(id_LB1, lb_AddString, 0, LongInt(TextItem));
StrDispose(TextItem); { Don't forget to dispose TextItem }
IList := IList^.Next;
end;
end;
procedure TTDialog.IDLB1(var Msg: TMessage);
var
RDlg, Idx : Integer;
SelectedText: array[0..40] of Char;
ExpList : SList;
AttrTxtRec : StatTxtRec;
D: PDialog;
S1: PStatic;
begin
if Msg.LParamHi = lbn_SelChange then
begin
Idx := SendDlgItemMsg(id_LB1, lb_GetCurSel, 0, LongInt(0));
SendDlgItemMsg(id_LB1, lb_GetText, Idx, LongInt(@SelectedText));
APtr := ExpList.GetAttr(SelectedText);
D := New(PQueryDlg, Init(@Self, 'DIAL2'));
StrCopy(AttrTxtRec.StaticText, APtr^.Attribute);
New(S1, InitResource(D, id_ST3, SizeOf(AttrTxtRec.StaticText)));
D^.TransferBuffer := @AttrTxtRec;
RDlg := Application^.ExecDialog(D);
end;
end;
{--- TQueryDlg Methods ---}
procedure TQueryDlg.IDBN2(var Msg: TMessage);
begin
If APtr^.ANext <> nil then
begin
APtr := APtr^.ANext;
SetWindowText(GetItemHandle(id_ST3), APtr^.Attribute);
end
else
begin
MessageBox(HWindow, 'Item is True', 'List Check completed', MB_OK);
EndDlg(MB_OK);
end;
end;
procedure TQueryDlg.IDBN3(var Msg: TMessage);
begin
MessageBox(HWindow, 'Cannot prove item', 'Item not proved', MB_OK);
EndDlg(0);
end;
{--- TExpertApp Methods ---}
procedure TExpertApp.InitMainWindow;
begin
MainWindow := New(PExpert, Init(nil, 'ExpertWin 1.0'));
end;
{--- TExpert Methods ---}
constructor TExpert.Init(AParent: PWindowsObject; ATitle: PChar);
var
AStat : PStatic;
begin
Head := nil;
Tail := nil;
AHead := nil;
TWindow.Init(AParent, ATitle);
With Attr do
Begin
Menu := LoadMenu(HInstance, PChar(100));
Style := ws_SysMenu or ws_VScroll or ws_HScroll or ws_MaximizeBox
or ws_MinimizeBox or ws_SizeBox;
X := 0; Y := 0;
W := 640; H := 450;
end;
EC1 := New(PEdit,Init(@Self, id_EC1, '', 20, 50, 100, 30, 0, False));
EC2 := New(PEdit, Init(@Self, id_EC2, '', 121, 50, 150, 30, 0, False));
AStat := New(PStatic, Init(@Self, id_ST1, 'Classification:', 20, 30, 150, 20, 0));
AStat := New(PStatic, Init(@Self, id_ST2, 'Attributes:', 121, 30, 150, 20, 0));
end;
destructor TExpert.Done;
begin
TWindow.Done;
end;
function TExpert.Inference(Query : PChar; Rules : PItem) : Integer;
var
Goal : PItem;
Conditions : PAttr;
MBoxText : array[0..40] of Char;
RVal, InferFlag : Integer;
D: PDialog;
S1: PStatic;
STxtRec : StatTxtRec;
Begin
Inference := NotFound;
Goal := Rules;
{ Pattern Matcher }
While (Goal <> nil) and (StrIComp(Goal^.ItemName, Query) <> 0) do
Goal := Goal^.Next;
If Goal <> nil then { This is necessary because TPW's StrIComp() }
begin { does no checking & crashes when Goal is nil }
If StrIComp(Goal^.ItemName, Query) = 0 then
begin { Goal Matches }
Conditions := Goal^.Prop;
While Conditions <> nil do
begin
InferFlag := Inference(Conditions^.Attribute, Rules);
If InferFlag = YesBtn then
Conditions := Conditions^.ANext
Else If InferFlag = NoBtn then
begin
Inference := NoBtn;
exit;
end
Else If InferFlag = NotFound then
begin {prove attribute by asking; if true get next and prove }
StrCopy(MBoxText, 'is ');
StrCat(MBoxText, Goal^.ItemName);
StrCat(MBoxText, ' ');
StrCat(MBoxText, Conditions^.Attribute);
StrCopy(STxtRec.StaticText, MBoxText);
D := New(PGetFact, Init(@Self, 'DIAL3'));
New(S1, InitResource(D, id_ST4, SizeOf(STxtRec.StaticText)));
D^.TransferBuffer := @STxtRec;
RVal := Application^.ExecDialog(D);
If RVal = YesBtn then
begin
Conditions := Conditions^.ANext;
end
else {Condition Failed--Backtrack for other solutions}
begin
Inference := NoBtn;
exit;
end; { else }
end; { Else If}
end; { While }
{if all True then Inference := True }
If (RVal = YesBtn) or (Conditions = nil) then
Inference := YesBtn
else Inference := NotFound;
end; {While}
end; {If}
end; { Inference }
procedure TExpert.CMInsert;
var
AttrList : NestedList;
Attribute : array[0..40] of Char;
StartPos, EndPos: Integer;
TxtField1, TxtField2 : array[0..40] of Char;
begin
EC1^.GetSelection(StartPos, EndPos);
if StartPos = EndPos then
EC1^.GetText(@TxtField1, 20)
Else
EC1^.GetSubText(@TxtField1, StartPos, EndPos);
StrCopy(IName, TxtField1);
EC2^.GetText(@TxtField2, 20);
StrCopy(Attribute, TxtField2);
If Length(Attribute) > 0 then
AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
Show;
end;
procedure TExpert.Show;
var
PStr : array[0..40] of Char;
Y1 : Integer;
Node : PItem;
begin
Node := ListPtr;
Y1 := 100;
DC := GetDC(HWindow);
TextOut(DC, 2,99, 'Items in list: ',14);
While Node <> nil do
begin
Y1 := Y1 + 15;
StrCopy(PStr,Node^.ItemName);
TextOut(DC, 31,Y1, PStr, StrLen(PStr));
Node := Node^.Next;
end;
ReleaseDC(HWindow, DC);
end;
procedure TExpert.CMFileOpen(var Msg: TMessage);
const
DefExt = 'dat';
var
OpenFN : TOpenFileName;
Filter : array [0..100] of Char;
FullFileName: TFilename;
WinDir : array [0..145] of Char;
Node : PItem;
AttrList : NestedList;
Attribute : array[0..40] of Char;
Ch : Char;
Str : array[0..40] of Char;
I : Integer;
begin
GetWindowsDirectory(WinDir, SizeOf(WinDir));
SetCurDir(WinDir);
StrCopy(FullFileName, '');
{ Set up a filter buffer to look for Wave files only. Recall that filter
buffer is a set of string pairs, with the last one terminated by a
double-null. }
FillChar(Filter, SizeOf(Filter), #0); { Set up for double null at end }
StrCopy(Filter, 'Dat Files');
StrCopy(@Filter[StrLen(Filter)+1], '*.dat');
FillChar(OpenFN, SizeOf(TOpenFileName), #0);
with OpenFN do
begin
hInstance := HInstance;
hwndOwner := HWindow;
lpstrDefExt := DefExt;
lpstrFile := FullFileName;
lpstrFilter := Filter;
lpstrFileTitle:= FileName;
flags := ofn_FileMustExist;
lStructSize := sizeof(TOpenFileName);
nFilterIndex := 1; {Index into Filter String in lpstrFilter}
nMaxFile := SizeOf(FullFileName);
end;
If GetOpenFileName(OpenFN) then
begin
I := 0;
FillChar(IName, sizeOf(IName), #0);
FillChar(Attribute, sizeOf(Attribute), #0);
Assign(InFile, FileName);
Reset(InFile);
While not eof(InFile) do
begin
Read(InFile, Ch);
While Ch <> '[' do {construct class name from file}
begin
Move(Ch, IName[I], sizeOf(Ch));
I := I + 1;
Read(InFile, Ch);
end; {While}
I := 0;
Read(InFile, Ch); {Now get Attributes}
While Ch <> ']' do
begin
If Ch <> ',' then
begin
FillChar(Attribute[I], sizeOf(Ch), Ch);
I := I + 1;
end {If <> ','}
else begin
If Length(Attribute) > 0 then
AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
FillChar(Attribute, sizeOf(Attribute), #0);
I := 0;
end; {else}
Read(InFile, Ch);
end; {While <> ']'}
If Length(Attribute) > 0 then
AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
Read(InFile, Ch);
Read(InFile, Ch);
I := 0;
FillChar(IName, sizeOf(IName), #0);
FillChar(Attribute, sizeOf(Attribute), #0);
end; {While not eof}
close(Infile);
Show;
end; {If}
end;
procedure TExpert.CMFileSaveAs(var Msg: TMessage);
const
DefExt = 'dat';
var
SaveFN : TOpenFileName;
Filter : array [0..100] of Char;
FullFileName: TFilename;
WinDir : array [0..145] of Char;
Goal : PItem;
Conditions : PAttr;
begin
GetWindowsDirectory(WinDir, SizeOf(WinDir));
SetCurDir(WinDir);
StrCopy(FullFileName, '');
FillChar(Filter, SizeOf(Filter), #0); { Set up for double null at end }
StrCopy(Filter, 'Dat Files');
StrCopy(@Filter[StrLen(Filter)+1], '*.dat');
FillChar(SaveFN, SizeOf(TOpenFileName), #0);
with SaveFN do
begin
hInstance := HInstance;
hwndOwner := HWindow;
lpstrDefExt := DefExt;
lpstrFile := FullFileName;
lpstrFilter := Filter;
lpstrFileTitle:= FileName;
flags := ofn_FileMustExist;
lStructSize := sizeof(TOpenFileName);
nFilterIndex := 1; {Index into Filter String in lpstrFilter}
nMaxFile := SizeOf(FullFileName);
end;
if GetSaveFileName(SaveFN) then
begin
Goal := ListPtr;
Conditions := Goal^.Prop;
Assign(OutFile, FileName);
Rewrite(OutFile);
while Goal <> nil do
begin
write(OutFile, Goal^.ItemName);
write(OutFile,'[');
while Conditions <> nil do
begin
write(OutFile, Conditions^.Attribute);
Conditions := Conditions^.ANext;
If Conditions <> nil Then
write(OutFile, ',');
end;
writeln(OutFile, ']');
Goal := Goal^.Next;
If Goal <> nil then
Conditions := Goal^.Prop;
end;
close(Outfile);
end;
end;
procedure TExpert.CMSearch;
var
ExpList : SList;
SearchStr : array[0..40] of Char;
begin
StrPCopy(SearchStr,'');
Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
'Enter Item:', SearchStr, Sizeof(SearchStr))));
If ExpList.Search(Head, SearchStr) <> nil Then
MessageBox(HWindow, SearchStr, 'Item found: ',mb_OK)
Else
MessageBox(HWindow, SearchStr, 'Item NOT found: ',mb_OK);
Show;
end;
procedure TExpert.CMFindAttr;
var
TmpPStr, SearchStr : array[0..40] of Char;
Classification : String;
begin
StrPCopy(SearchStr,'');
Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
'Enter Item:', SearchStr, Sizeof(SearchStr))));
StrCopy(AName, SearchStr);
If (Length(AName) <> 0) and (Head <> nil) then
Begin
Classification := SearchItemList(Head, AName);
If Length(Classification) <> 0 Then
Begin
StrCat(SearchStr,' is an attribute of ');
StrPCopy(TmpPStr, Classification);
StrCat(SearchStr, TmpPStr);
MessageBox(HWindow, SearchStr, 'Attribute found: ',mb_OK)
end
else
MessageBox(HWindow, SearchStr, 'Attribute NOT found: ',mb_OK);
end;
Show;
end;
procedure TExpert.CMForChain;
begin
Application^.ExecDialog(New(PTDialog, Init(@Self, 'DIAL1')));
end;
procedure TExpert.CMBackChain(var Msg: TMessage);
var
TmpPStr, SearchStr : array[0..40] of Char;
Inferred : Integer;
begin
StrPCopy(SearchStr,'');
Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
'Enter Item:', SearchStr, Sizeof(SearchStr))));
Inferred := Inference(SearchStr, ListPtr);
If Inferred = YesBtn then
MessageBox(HWindow, 'Goal proved', 'Message', MB_OK)
else
MessageBox(HWindow, 'Cannot prove Goal', 'Message', MB_OK);
Show;
end;
procedure TExpert.ClearFacts(var Msg : TMessage);
var
Expert : TExpertApp;
ExpList : SList;
AttrList : NestedList;
begin
ExpList.FreeList;
ListPtr := nil;
NListPtr := nil;
Head := nil; AHead := nil;
Tail := nil; ATail := nil;
MessageBox(HWindow, 'Knowledge Base Cleared!', '',mb_OK);
end;
procedure TExpert.CMQuit;
begin
PostQuitMessage(0);
end;
{ Displays the program's About Box dialog.}
procedure TExpert.CMAbout(var Msg: TMessage);
begin
Application^.ExecDialog(New(PDialog, Init(@Self, PChar('DIAL4'))));
end;
{ Main }
var
Expert : TExpertApp;
Begin
Expert.Init('ExpertWin');
Expert.Run;
Expert.Done;
end.
[LISTING TWO]
Unit Lists;
Interface
Type
PAttr = ^Attr;
Attr = record
Attribute : array[0..40] of Char;
ANext : PAttr;
end;
PItem = ^Item;
Item = record
ItemName : array[0..40] of Char;
Prop : PAttr;
Next : PItem;
end;
PList = ^SList;
SList = object
Node : PItem;
constructor Init;
destructor Done; virtual;
procedure FreeList;
procedure AddNode(var Head, Tail : PItem; NewName : PChar);
function Search(Head : PItem; Name : PChar) : PItem;
function GetAttr(Key : PChar) : PAttr;
end;
PNestedList = ^NestedList;
NestedList = object(SList)
NNode : PAttr;
constructor Init;
procedure FreeList;
procedure NewNode(var AHead, ATail : PAttr; var Head, Tail : PItem;
IName, NewAttr : PChar);
function Search(Head : PAttr; Attribute : PChar) : Boolean;
end;
function SearchItemList( Head : PItem; Attribute : PChar): String;
var
ListPtr : PItem;
NListPtr : PAttr;
Implementation
Uses WinDOS, WObjects, WinTypes, Strings, WinProcs;
{ ----------------------- }
{ NestedList methods }
{ ----------------------- }
constructor NestedList.Init;
begin
NNode := nil;
end;
procedure NestedList.FreeList;
begin
NNode := NListPtr;
while NNode <> nil do
begin
Dispose(NNode);
NNode := NNode^.ANext;
end;
end;
procedure NestedList.NewNode (var AHead, ATail : PAttr; var Head, Tail : PItem;
IName, NewAttr : PChar);
var
ANode : PAttr;
LPtr : PItem;
begin
LPtr := SList.Search(Head, IName);
If LPtr = nil Then
begin
AddNode(Head, Tail, IName);
New(ANode);
AHead := ANode;
ATail := ANode;
ANode^.ANext := nil;
StrCopy(ANode^.Attribute, NewAttr);
LPtr := SList.Search(Head, IName);
LPtr^.Prop := ANode;
end
Else {Item already exists-add ANode to existing}
begin
New(ANode);
AHead := LPtr^.Prop;
ATail^.ANext := ANode;
ATail := ANode;
ANode^.ANext := nil;
StrCopy(ANode^.Attribute, NewAttr);
end;
end;
function NestedList.Search ( Head : PAttr; Attribute : PChar) : Boolean;
var
I : Integer;
begin
Search := False;
NNode := Head;
While NNode <> nil do
begin
I := StrIComp(NNode^.Attribute, Attribute);
If I = 0 then
begin
Search := True;
Exit;
end;
NNode := NNode^.ANext;
end;
end;
function SearchItemList( Head : PItem; Attribute : PChar): String;
var
Node : PItem;
ANode : PAttr;
AttrList : NestedList;
begin
Node := Head;
ANode := Node^.Prop;
SearchItemList := '';
While Node <> nil do
begin
If not AttrList.Search(ANode, Attribute) then
begin
Node := Node^.Next;
If Node <> nil Then
ANode := Node^.Prop;
end
else
begin
SearchItemList := Node^.ItemName;
Exit;
end;
end;
end;
{ ----------------------- }
{ List methods }
{ ----------------------- }
constructor SList.Init;
begin
ListPtr := nil;
Node := nil;
end;
Destructor SList.Done;
begin
FreeList;
end;
procedure SList.FreeList;
var
AttrList : NestedList;
begin
Node := ListPtr;
while Node <> nil do
begin
NListPtr := Node^.Prop;
Dispose(Node);
AttrList.FreeList;
Node := Node^.Next;
end;
end;
{ Insert a New Item in the list }
procedure SList.AddNode (var Head, Tail : PItem; NewName : PChar);
var
Added : PItem;
begin
New(Added);
If Head = nil then
begin
Head := Added;
Tail := Added;
ListPtr := Added;
end
Else begin
Tail^.Next := Added;
Tail := Added;
end;
Node := Head;
Added^.Next := nil;
StrCopy(Added^.ItemName, NewName);
end;
{ Search for a specified Item - return pointer if found }
function SList.Search ( Head : PItem; Name : PChar) : PItem;
var
I : Integer;
begin
Search := nil;
Node := Head;
While Node <> nil do
begin
I := StrIComp(Node^.ItemName, Name);
If I = 0 then
begin
Search := Node;
Exit;
end;
Node := Node^.Next;
end;
end;
{Search for an Attribute and return pointer to its list}
function SList.GetAttr(Key : PChar) : PAttr;
var
I : Integer;
Begin
GetAttr := nil;
Node := ListPtr;
While Node <> nil do
begin
I := StrIComp(Node^.ItemName, Key);
If I = 0 then
begin
GetAttr := Node^.Prop;
Exit;
end
else
Node := Node^.Next
end;
end;
end.