Category : Files from Magazines
Archive   : NOV92_1.ZIP
Filename : EXPWIN.ASC

 
Output of file : EXPWIN.ASC contained in archive : NOV92_1.ZIP
[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.


  3 Responses to “Category : Files from Magazines
Archive   : NOV92_1.ZIP
Filename : EXPWIN.ASC

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/