home *** CD-ROM | disk | FTP | other *** search
/ Shareware Supreme Volume 6 #1 / swsii.zip / swsii / 215 / DDJ11A92.ZIP / EXPWIN.ASC < prev    next >
INI File  |  1992-11-04  |  21KB  |  756 lines
  1. [LISTING ONE] 
  2.  
  3. program ExpertWin;
  4.  
  5. {$R WINXPERT.RES}
  6.  
  7. uses WinDOS, WObjects, WinTypes, Strings, WinProcs, StdDlgs, CommDlg, BWCC, Lists;
  8.  
  9. const
  10.   id_Menu     = 100;  id_About    = 100;
  11.   cm_FileOpen = 102;  cm_FileSaveAs = 104;
  12.   cm_Insert   = 201;  cm_Search   = 202;
  13.   cm_FindAttr = 203;  cm_ForChain = 212;
  14.   cm_BackChain = 204; cm_ClearFacts = 205;
  15.   cm_About    = 999;  cm_Quit     = 108;
  16.   id_EC1      = 106;  id_EC2      = 107;
  17.   id_EC3      = 108;  id_CB2      = 109;
  18.   id_ST1      = 110;  id_ST2      = 111;
  19.   id_ST3      = 155;  id_ST4      = 160;
  20.   id_LB1      = 151;  id_BN1      = 152;
  21.   id_BN2      = 153;  id_BN3      = 154;
  22.   id_YesBtn   = 161;  id_NoBtn    = 162;
  23.   NotFound    = 97;   YesBtn      = 98;
  24.   NoBtn       = 99; 
  25. Type
  26.   TFilename = array [0..255] of Char;
  27.   DataFile = file of Item;
  28.  
  29. {--- Application Objects ---}
  30.  type
  31.   StatTxtRec = record
  32.     StaticText : array [0..40] of Char;
  33.   end;
  34.  
  35.   TExpertApp = object(TApplication)
  36.     procedure InitMainWindow; virtual;
  37.   end;
  38.   PExpert = ^TExpert;
  39.   TExpert = object(TWindow)
  40.     DC            : HDC;
  41.     EC1, EC2, EC3 : PEdit;
  42.     LB1           : PListBox;
  43.     Head, Tail    : PItem;
  44.     AHead, ATail  : Pattr;
  45.     FileName      : TFileName;
  46.     IName, AName  : array[0..40] of Char;  
  47.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  48.     destructor Done; virtual;
  49.     function Inference(Query : PChar; Rules : PItem) : Integer;
  50.     procedure Show; virtual;
  51.     procedure CmInsert(var Msg: TMessage); virtual cm_First + cm_Insert;
  52.     procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
  53.     procedure CMFileSaveAs(var Msg: TMessage); virtual cm_First + cm_FileSaveAs;
  54.     procedure CMSearch(var Msg: TMessage); virtual cm_First + cm_Search;
  55.     procedure CMFindAttr(var Msg: TMessage); virtual cm_First + cm_FindAttr;
  56.     procedure CMForChain(var Msg: TMessage); virtual cm_First + cm_ForChain;
  57.     procedure CMBackChain(var Msg: TMessage); virtual cm_First + cm_BackChain;
  58.     procedure ClearFacts(var Msg : TMessage); virtual cm_First + cm_ClearFacts;
  59.     procedure CMAbout(var Msg: TMessage); virtual cm_First + cm_About;
  60.     procedure CMQuit(var Msg: TMessage); virtual cm_First + cm_Quit;
  61.   end;
  62.   PTDialog = ^TTDialog;
  63.   TTDialog = object(TDialog)
  64.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  65.     procedure IDBN1(var Msg: TMessage); virtual id_First + id_BN1;
  66.     procedure IDLB1(var Msg: TMessage); virtual id_First + id_LB1;
  67.   end;
  68.   PQueryDlg = ^TQueryDlg;
  69.   TQueryDlg = object(TTDialog)
  70.     procedure IDBN2(var Msg: TMessage); virtual id_First + id_BN2;
  71.     procedure IDBN3(var Msg: TMessage); virtual id_First + id_BN3;
  72.   end;
  73.   PGetFact = ^TGetFact;
  74.   TGetFact = object(TDialog)
  75.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  76.     procedure IDYesBtn(var Msg: TMessage); virtual id_First + id_YesBtn;
  77.     procedure IDNoBtn(var Msg: TMessage); virtual id_First + id_NoBtn;
  78.   end;
  79. Var
  80.   APtr : PAttr;              {Global ptr to PAttr}
  81.   KnowledgeBase : Text;
  82.   InFile, OutFile : Text; 
  83.  
  84. { --- TGetFact Methods ---}
  85. constructor TGetFact.Init(AParent: PWindowsObject; ATitle: PChar);
  86. begin
  87.   TDialog.Init(AParent, ATitle);
  88. end;
  89.  
  90. procedure TGetFact.IDYesBtn(var Msg: TMessage);
  91. begin
  92.   EndDlg(YesBtn); {Return YesBtn to ExecDialog and end dialog}
  93. end;
  94. procedure TGetFact.IDNoBtn(var Msg: TMessage);
  95. begin
  96.   EndDlg(NoBtn);   {Return NoBtn to ExecDialog and end dialog}
  97. end;
  98.  
  99. {--- TTestDialog Methods ---}
  100. constructor TTDialog.Init(AParent: PWindowsObject; ATitle: PChar);
  101. begin
  102.   TDialog.Init(AParent, ATitle);
  103. end;
  104. procedure TTDialog.IDBN1(var Msg: TMessage);
  105. var
  106.   TextItem : PChar;
  107.   TmpStr : array[0..40] of Char;
  108.   IList : PItem;
  109. begin
  110.   IList := ListPtr;
  111.   While IList <> nil do
  112.   begin
  113.     TextItem := StrNew(IList^.ItemName);
  114.     SendDlgItemMsg(id_LB1, lb_AddString, 0, LongInt(TextItem));
  115.     StrDispose(TextItem);        { Don't forget to dispose TextItem }
  116.     IList := IList^.Next;
  117.   end;
  118. end;
  119. procedure TTDialog.IDLB1(var Msg: TMessage);
  120. var
  121.   RDlg, Idx : Integer;
  122.   SelectedText: array[0..40] of Char;
  123.   ExpList : SList;
  124.   AttrTxtRec : StatTxtRec;
  125.   D: PDialog;
  126.   S1: PStatic;
  127. begin
  128.   if Msg.LParamHi = lbn_SelChange then
  129.   begin
  130.     Idx := SendDlgItemMsg(id_LB1, lb_GetCurSel, 0, LongInt(0));
  131.     SendDlgItemMsg(id_LB1, lb_GetText, Idx, LongInt(@SelectedText));
  132.     APtr := ExpList.GetAttr(SelectedText);
  133.     D := New(PQueryDlg, Init(@Self, 'DIAL2'));
  134.     StrCopy(AttrTxtRec.StaticText, APtr^.Attribute);
  135.     New(S1, InitResource(D, id_ST3, SizeOf(AttrTxtRec.StaticText)));
  136.     D^.TransferBuffer := @AttrTxtRec;
  137.     RDlg := Application^.ExecDialog(D);
  138.   end;
  139. end;
  140.  
  141. {--- TQueryDlg Methods ---}
  142. procedure TQueryDlg.IDBN2(var Msg: TMessage);
  143. begin
  144.   If APtr^.ANext <> nil then
  145.   begin
  146.     APtr := APtr^.ANext;
  147.     SetWindowText(GetItemHandle(id_ST3), APtr^.Attribute);
  148.   end
  149.   else
  150.   begin
  151.     MessageBox(HWindow, 'Item is True', 'List Check completed', MB_OK);
  152.     EndDlg(MB_OK);
  153.   end;
  154. end;
  155. procedure TQueryDlg.IDBN3(var Msg: TMessage);
  156. begin
  157.   MessageBox(HWindow, 'Cannot prove item', 'Item not proved', MB_OK);
  158.   EndDlg(0);
  159. end;
  160.  
  161.  
  162. {--- TExpertApp Methods ---}
  163. procedure TExpertApp.InitMainWindow;
  164. begin
  165.   MainWindow := New(PExpert, Init(nil, 'ExpertWin 1.0'));
  166. end;
  167.  
  168. {--- TExpert Methods ---}
  169. constructor TExpert.Init(AParent: PWindowsObject; ATitle: PChar);
  170. var
  171.   AStat : PStatic;
  172. begin
  173.   Head := nil;
  174.   Tail := nil;
  175.   AHead := nil;
  176.   TWindow.Init(AParent, ATitle);
  177.   With Attr do
  178.   Begin
  179.     Menu := LoadMenu(HInstance, PChar(100));
  180.     Style := ws_SysMenu or ws_VScroll or ws_HScroll or ws_MaximizeBox
  181.     or ws_MinimizeBox or ws_SizeBox;
  182.     X := 0; Y := 0;
  183.     W := 640; H := 450;
  184.   end;
  185.   EC1 := New(PEdit,Init(@Self, id_EC1, '', 20, 50, 100, 30, 0, False));
  186.   EC2 := New(PEdit, Init(@Self, id_EC2, '', 121, 50, 150, 30, 0, False));
  187.   AStat := New(PStatic, Init(@Self, id_ST1, 'Classification:', 20, 30, 150, 20, 0));
  188.   AStat := New(PStatic, Init(@Self, id_ST2, 'Attributes:', 121, 30, 150, 20, 0));
  189. end;
  190. destructor TExpert.Done;
  191. begin
  192.   TWindow.Done;
  193. end;
  194. function TExpert.Inference(Query : PChar; Rules : PItem) : Integer;
  195. var
  196.   Goal : PItem;
  197.   Conditions : PAttr;
  198.   MBoxText : array[0..40] of Char;
  199.   RVal, InferFlag : Integer;
  200.   D: PDialog;
  201.   S1: PStatic;
  202.   STxtRec : StatTxtRec;
  203. Begin
  204.   Inference := NotFound;
  205.   Goal := Rules;
  206.  
  207.   { Pattern Matcher }
  208.   While (Goal <> nil) and (StrIComp(Goal^.ItemName, Query) <> 0) do
  209.       Goal := Goal^.Next;
  210.   If Goal <> nil then       { This is necessary because TPW's StrIComp()  }
  211.   begin                     { does no checking & crashes when Goal is nil }
  212.     If StrIComp(Goal^.ItemName, Query) = 0 then
  213.     begin                      { Goal Matches }
  214.       Conditions := Goal^.Prop;
  215.         While Conditions <> nil do
  216.         begin
  217.          InferFlag := Inference(Conditions^.Attribute, Rules);
  218.          If InferFlag = YesBtn then
  219.            Conditions := Conditions^.ANext
  220.          Else If InferFlag = NoBtn then
  221.          begin
  222.            Inference := NoBtn;
  223.            exit;
  224.          end
  225.          Else If InferFlag = NotFound then
  226.          begin    {prove attribute by asking; if true get next and prove }
  227.           StrCopy(MBoxText, 'is ');
  228.           StrCat(MBoxText, Goal^.ItemName);
  229.           StrCat(MBoxText, ' ');
  230.           StrCat(MBoxText, Conditions^.Attribute);
  231.           StrCopy(STxtRec.StaticText, MBoxText);
  232.           D := New(PGetFact, Init(@Self, 'DIAL3'));
  233.           New(S1, InitResource(D, id_ST4, SizeOf(STxtRec.StaticText)));
  234.           D^.TransferBuffer := @STxtRec;
  235.           RVal := Application^.ExecDialog(D);
  236.           If RVal = YesBtn then
  237.           begin
  238.             Conditions := Conditions^.ANext;
  239.           end
  240.           else    {Condition Failed--Backtrack for other solutions}
  241.           begin
  242.             Inference := NoBtn;
  243.             exit;
  244.           end; { else }
  245.          end; { Else If}
  246.         end;  { While }
  247.          {if all True then Inference := True }
  248.         If (RVal = YesBtn) or (Conditions = nil) then
  249.           Inference := YesBtn
  250.         else Inference := NotFound;
  251.        end;  {While}
  252.     end; {If} 
  253. end; { Inference }
  254. procedure TExpert.CMInsert;
  255. var
  256.   AttrList : NestedList;
  257.   Attribute : array[0..40] of Char;
  258.   StartPos, EndPos: Integer;
  259.   TxtField1, TxtField2 : array[0..40] of Char;
  260. begin
  261.   EC1^.GetSelection(StartPos, EndPos);
  262.   if StartPos = EndPos then
  263.     EC1^.GetText(@TxtField1, 20)
  264.   Else
  265.     EC1^.GetSubText(@TxtField1, StartPos, EndPos);
  266.   StrCopy(IName, TxtField1);
  267.   EC2^.GetText(@TxtField2, 20);
  268.   StrCopy(Attribute, TxtField2);
  269.   If Length(Attribute) > 0 then
  270.     AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
  271.   Show;
  272. end;
  273. procedure TExpert.Show;
  274. var
  275.   PStr : array[0..40] of Char;
  276.   Y1 : Integer;
  277.   Node : PItem;
  278. begin
  279.   Node := ListPtr;
  280.   Y1 := 100;
  281.   DC := GetDC(HWindow);
  282.   TextOut(DC, 2,99, 'Items in list: ',14);
  283.   While Node <> nil do
  284.   begin
  285.     Y1 := Y1 + 15;
  286.     StrCopy(PStr,Node^.ItemName);
  287.     TextOut(DC, 31,Y1, PStr, StrLen(PStr));
  288.     Node := Node^.Next;
  289.   end;
  290.   ReleaseDC(HWindow, DC);
  291. end;
  292. procedure TExpert.CMFileOpen(var Msg: TMessage);
  293. const
  294.   DefExt = 'dat';
  295. var
  296.   OpenFN      : TOpenFileName;
  297.   Filter      : array [0..100] of Char;
  298.   FullFileName: TFilename;
  299.   WinDir      : array [0..145] of Char;
  300.   Node        : PItem;
  301.   AttrList    : NestedList;
  302.   Attribute   : array[0..40] of Char;
  303.   Ch          : Char;
  304.   Str         : array[0..40] of Char;
  305.   I           : Integer;
  306. begin
  307.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  308.   SetCurDir(WinDir);
  309.   StrCopy(FullFileName, '');
  310.  
  311. { Set up a filter buffer to look for Wave files only.  Recall that filter
  312.   buffer is a set of string pairs, with the last one terminated by a
  313.   double-null.                                                           }
  314.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  315.   StrCopy(Filter, 'Dat Files');
  316.   StrCopy(@Filter[StrLen(Filter)+1], '*.dat');
  317.   FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  318.   with OpenFN do
  319.   begin
  320.     hInstance     := HInstance;
  321.     hwndOwner     := HWindow;
  322.     lpstrDefExt   := DefExt;
  323.     lpstrFile     := FullFileName;
  324.     lpstrFilter   := Filter;
  325.     lpstrFileTitle:= FileName;
  326.     flags         := ofn_FileMustExist;
  327.     lStructSize   := sizeof(TOpenFileName);
  328.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  329.     nMaxFile      := SizeOf(FullFileName);
  330.   end;
  331.   If GetOpenFileName(OpenFN) then
  332.   begin
  333.     I := 0;
  334.     FillChar(IName, sizeOf(IName), #0);
  335.     FillChar(Attribute, sizeOf(Attribute), #0);
  336.     Assign(InFile, FileName);
  337.     Reset(InFile);
  338.     While not eof(InFile) do
  339.     begin
  340.       Read(InFile, Ch);
  341.       While Ch <> '[' do   {construct class name from file}
  342.       begin
  343.         Move(Ch, IName[I], sizeOf(Ch));
  344.         I := I + 1;
  345.         Read(InFile, Ch);
  346.       end; {While}
  347.       I := 0;
  348.       Read(InFile, Ch);    {Now get Attributes}
  349.       While Ch <> ']' do
  350.       begin
  351.         If Ch <> ',' then
  352.         begin
  353.           FillChar(Attribute[I], sizeOf(Ch), Ch);
  354.           I := I + 1;
  355.         end {If <> ','}
  356.         else begin
  357.           If Length(Attribute) > 0 then
  358.             AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
  359.           FillChar(Attribute, sizeOf(Attribute), #0);
  360.           I := 0;
  361.         end; {else}
  362.         Read(InFile, Ch);
  363.       end; {While <> ']'}
  364.       If Length(Attribute) > 0 then
  365.         AttrList.NewNode(AHead, ATail, Head, Tail, IName, Attribute);
  366.       Read(InFile, Ch);
  367.       Read(InFile, Ch);
  368.       I := 0;
  369.       FillChar(IName, sizeOf(IName), #0);
  370.       FillChar(Attribute, sizeOf(Attribute), #0);
  371.     end; {While not eof}
  372.     close(Infile);
  373.     Show;
  374.   end; {If}
  375. end;
  376. procedure TExpert.CMFileSaveAs(var Msg: TMessage);
  377. const
  378.   DefExt = 'dat';
  379. var
  380.   SaveFN      : TOpenFileName;
  381.   Filter      : array [0..100] of Char;
  382.   FullFileName: TFilename;
  383.   WinDir      : array [0..145] of Char;
  384.   Goal        : PItem;
  385.   Conditions  : PAttr;
  386. begin
  387.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  388.   SetCurDir(WinDir);
  389.   StrCopy(FullFileName, '');
  390.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  391.   StrCopy(Filter, 'Dat Files');
  392.   StrCopy(@Filter[StrLen(Filter)+1], '*.dat');
  393.   FillChar(SaveFN, SizeOf(TOpenFileName), #0);
  394.   with SaveFN do
  395.   begin
  396.     hInstance     := HInstance;
  397.     hwndOwner     := HWindow;
  398.     lpstrDefExt   := DefExt;
  399.     lpstrFile     := FullFileName;
  400.     lpstrFilter   := Filter;
  401.     lpstrFileTitle:= FileName;
  402.     flags         := ofn_FileMustExist;
  403.     lStructSize   := sizeof(TOpenFileName);
  404.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  405.     nMaxFile      := SizeOf(FullFileName);
  406.   end;
  407.   if GetSaveFileName(SaveFN) then
  408.   begin
  409.     Goal := ListPtr;
  410.     Conditions := Goal^.Prop;
  411.     Assign(OutFile, FileName);
  412.     Rewrite(OutFile);
  413.     while Goal <> nil do
  414.     begin
  415.       write(OutFile, Goal^.ItemName);
  416.       write(OutFile,'[');
  417.       while Conditions <> nil do
  418.       begin
  419.         write(OutFile, Conditions^.Attribute);
  420.         Conditions := Conditions^.ANext;
  421.         If Conditions <> nil Then
  422.           write(OutFile, ',');
  423.       end;
  424.       writeln(OutFile, ']');
  425.       Goal := Goal^.Next;
  426.       If Goal <> nil then
  427.         Conditions := Goal^.Prop;
  428.     end;
  429.     close(Outfile);
  430.   end;
  431. end;
  432. procedure TExpert.CMSearch;
  433. var
  434.   ExpList : SList;
  435.   SearchStr : array[0..40] of Char;
  436. begin
  437.   StrPCopy(SearchStr,'');
  438.   Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
  439.                 'Enter Item:', SearchStr, Sizeof(SearchStr))));
  440.   If ExpList.Search(Head, SearchStr) <> nil Then
  441.     MessageBox(HWindow, SearchStr, 'Item found: ',mb_OK)
  442.   Else
  443.     MessageBox(HWindow, SearchStr, 'Item NOT found: ',mb_OK);
  444. Show;
  445. end;
  446. procedure TExpert.CMFindAttr;
  447. var
  448.   TmpPStr, SearchStr : array[0..40] of Char;
  449.   Classification : String;
  450. begin
  451.   StrPCopy(SearchStr,'');
  452.   Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
  453.                 'Enter Item:', SearchStr, Sizeof(SearchStr))));
  454.   StrCopy(AName, SearchStr);
  455.   If (Length(AName) <> 0) and (Head <> nil) then
  456.   Begin
  457.     Classification := SearchItemList(Head, AName);
  458.     If Length(Classification) <> 0 Then
  459.     Begin
  460.       StrCat(SearchStr,' is an attribute of ');
  461.       StrPCopy(TmpPStr, Classification);
  462.       StrCat(SearchStr, TmpPStr);
  463.       MessageBox(HWindow, SearchStr, 'Attribute found: ',mb_OK)
  464.     end
  465.     else
  466.       MessageBox(HWindow, SearchStr, 'Attribute NOT found: ',mb_OK);
  467.   end;
  468.   Show;
  469. end;
  470. procedure TExpert.CMForChain;
  471. begin
  472.   Application^.ExecDialog(New(PTDialog, Init(@Self, 'DIAL1')));
  473. end;
  474. procedure TExpert.CMBackChain(var Msg: TMessage);
  475. var
  476.   TmpPStr, SearchStr : array[0..40] of Char;
  477.   Inferred : Integer;
  478. begin
  479.   StrPCopy(SearchStr,'');
  480.   Application^.ExecDialog(New(PInputDialog, Init(@Self,'Search Item',
  481.                 'Enter Item:', SearchStr, Sizeof(SearchStr))));
  482.   Inferred := Inference(SearchStr, ListPtr);
  483.   If Inferred = YesBtn then
  484.     MessageBox(HWindow, 'Goal proved', 'Message', MB_OK)
  485.   else
  486.     MessageBox(HWindow, 'Cannot prove Goal', 'Message', MB_OK);
  487.   Show;
  488. end;
  489. procedure TExpert.ClearFacts(var Msg : TMessage);
  490. var
  491.   Expert : TExpertApp;
  492.   ExpList : SList;
  493.   AttrList : NestedList;
  494. begin
  495.   ExpList.FreeList;
  496.   ListPtr := nil;
  497.   NListPtr := nil;
  498.   Head := nil; AHead := nil;
  499.   Tail := nil; ATail := nil;
  500.   MessageBox(HWindow, 'Knowledge Base Cleared!', '',mb_OK);
  501. end;
  502. procedure TExpert.CMQuit;
  503. begin
  504.   PostQuitMessage(0);
  505. end;
  506.  
  507. { Displays the program's About Box dialog.}
  508. procedure TExpert.CMAbout(var Msg: TMessage);
  509. begin
  510.   Application^.ExecDialog(New(PDialog, Init(@Self, PChar('DIAL4'))));
  511. end;
  512.  
  513. { Main }
  514. var
  515.   Expert : TExpertApp;
  516. Begin
  517.   Expert.Init('ExpertWin');
  518.   Expert.Run;
  519.   Expert.Done;
  520. end.
  521.  
  522.  
  523. [LISTING TWO]
  524.  
  525. Unit Lists;
  526.  
  527. Interface
  528.  
  529. Type
  530.  
  531.   PAttr = ^Attr;
  532.   Attr = record
  533.     Attribute : array[0..40] of Char;
  534.     ANext : PAttr;
  535.   end;
  536.  
  537.   PItem = ^Item;
  538.   Item = record
  539.     ItemName : array[0..40] of Char;
  540.     Prop : PAttr;
  541.     Next : PItem;
  542.   end;
  543.  
  544.   PList = ^SList;
  545.   SList = object
  546.     Node : PItem;
  547.     constructor Init;
  548.     destructor Done; virtual;
  549.     procedure FreeList;
  550.     procedure AddNode(var Head, Tail : PItem; NewName : PChar);
  551.     function Search(Head : PItem; Name : PChar) : PItem;
  552.     function GetAttr(Key : PChar) : PAttr;
  553.   end;
  554.  
  555.   PNestedList = ^NestedList;
  556.   NestedList = object(SList)
  557.     NNode : PAttr;
  558.     constructor Init;
  559.     procedure FreeList;
  560.     procedure NewNode(var AHead, ATail : PAttr; var Head, Tail : PItem;
  561.                        IName, NewAttr : PChar);
  562.     function Search(Head : PAttr; Attribute : PChar) : Boolean;
  563.   end;
  564.  
  565.   function SearchItemList( Head : PItem; Attribute : PChar): String;
  566.  
  567. var
  568.   ListPtr  : PItem;
  569.   NListPtr : PAttr;
  570.  
  571.  
  572. Implementation
  573.  
  574. Uses WinDOS, WObjects, WinTypes, Strings, WinProcs;
  575.  
  576. { ----------------------- }
  577. { NestedList methods      }
  578. { ----------------------- }
  579. constructor NestedList.Init;
  580. begin
  581.   NNode := nil;
  582. end;
  583.  
  584. procedure NestedList.FreeList;
  585. begin
  586.   NNode := NListPtr;
  587.   while NNode <> nil do
  588.   begin
  589.     Dispose(NNode);
  590.     NNode := NNode^.ANext;
  591.   end;
  592. end;
  593.  
  594. procedure NestedList.NewNode (var AHead, ATail : PAttr; var Head, Tail : PItem;
  595.                               IName, NewAttr : PChar);
  596. var
  597.   ANode : PAttr;
  598.   LPtr : PItem;
  599. begin
  600.   LPtr := SList.Search(Head, IName);
  601.   If LPtr = nil Then
  602.   begin
  603.     AddNode(Head, Tail, IName);
  604.     New(ANode);
  605.     AHead := ANode;
  606.     ATail := ANode;
  607.     ANode^.ANext := nil;
  608.     StrCopy(ANode^.Attribute, NewAttr);
  609.     LPtr := SList.Search(Head, IName);
  610.     LPtr^.Prop := ANode;
  611.   end
  612.   Else {Item already exists-add ANode to existing}
  613.   begin
  614.     New(ANode);
  615.     AHead := LPtr^.Prop;
  616.     ATail^.ANext := ANode;
  617.     ATail := ANode;
  618.     ANode^.ANext := nil;
  619.     StrCopy(ANode^.Attribute, NewAttr);
  620.   end;
  621. end;
  622.  
  623. function NestedList.Search ( Head : PAttr; Attribute : PChar) : Boolean;
  624. var
  625.   I : Integer;
  626. begin
  627.   Search := False;
  628.   NNode := Head;
  629.   While NNode <> nil do
  630.   begin
  631.     I := StrIComp(NNode^.Attribute, Attribute);
  632.     If I = 0 then
  633.     begin
  634.       Search := True;
  635.       Exit;
  636.     end;
  637.     NNode := NNode^.ANext;
  638.   end;
  639. end;
  640.  
  641. function SearchItemList( Head : PItem; Attribute : PChar): String;
  642. var
  643.   Node : PItem;
  644.   ANode : PAttr;
  645.   AttrList : NestedList;
  646. begin
  647.   Node := Head;
  648.   ANode := Node^.Prop;
  649.   SearchItemList := '';
  650.   While Node <> nil do
  651.   begin
  652.     If not AttrList.Search(ANode, Attribute) then
  653.     begin
  654.       Node := Node^.Next;
  655.       If Node <> nil Then
  656.         ANode := Node^.Prop;
  657.     end
  658.     else
  659.     begin
  660.       SearchItemList := Node^.ItemName;
  661.       Exit;
  662.     end;
  663.   end;
  664. end;
  665.  
  666. { ----------------------- }
  667. { List methods            }
  668. { ----------------------- }
  669.  
  670. constructor SList.Init;
  671. begin
  672.   ListPtr := nil;
  673.   Node := nil;
  674. end;
  675.  
  676. Destructor SList.Done;
  677. begin
  678.   FreeList;
  679. end;
  680.  
  681. procedure SList.FreeList;
  682. var
  683.    AttrList : NestedList;
  684. begin
  685.   Node := ListPtr;
  686.   while Node <> nil do
  687.   begin
  688.     NListPtr := Node^.Prop;
  689.     Dispose(Node);
  690.     AttrList.FreeList;
  691.     Node := Node^.Next;
  692.   end;
  693.  
  694. end;
  695.  
  696. { Insert a New Item in the list }
  697. procedure SList.AddNode (var Head, Tail : PItem; NewName : PChar);
  698. var
  699.   Added : PItem;
  700. begin
  701.   New(Added);
  702.   If Head = nil then
  703.   begin
  704.     Head := Added;
  705.     Tail := Added;
  706.     ListPtr := Added;
  707.   end
  708.   Else begin
  709.     Tail^.Next := Added;
  710.     Tail := Added;
  711.   end;
  712.   Node := Head;
  713.   Added^.Next := nil;
  714.   StrCopy(Added^.ItemName, NewName);
  715. end;
  716.  
  717. { Search for a specified Item - return pointer if found }
  718. function SList.Search ( Head : PItem; Name : PChar) : PItem;
  719. var
  720.   I : Integer;
  721. begin
  722.   Search := nil;
  723.   Node := Head;
  724.   While Node <> nil do
  725.   begin
  726.     I := StrIComp(Node^.ItemName, Name);
  727.     If I = 0 then
  728.     begin
  729.       Search := Node;
  730.       Exit;
  731.     end;
  732.     Node := Node^.Next;
  733.   end;
  734. end;
  735.  
  736. {Search for an Attribute and return pointer to its list}
  737. function SList.GetAttr(Key : PChar) : PAttr;
  738. var
  739.   I : Integer;
  740. Begin
  741.   GetAttr := nil;
  742.   Node := ListPtr;
  743.   While Node <> nil do
  744.   begin
  745.     I := StrIComp(Node^.ItemName, Key);
  746.     If I = 0 then
  747.     begin
  748.       GetAttr := Node^.Prop;
  749.       Exit;
  750.     end
  751.     else
  752.       Node := Node^.Next
  753.   end;
  754. end;
  755. end.
  756.