Channels ▼
RSS

.NET

Examining Turbo Pascal for Windows

Source Code Accompanies This Article. Download It Now.


NOV92: EXAMINING TURBO PASCAL FOR WINDOWS

Mike is executive editor at DDJ. He can be reached at the DDJ offices, on CompuServe at 76703,4057, or on MCI Mail at mfloyd.


There's an old saying among veteran programmers that real programmers don't eat quiche, code only in assembly language, and eschew languages like Basic, Fortran, and (especially) Cobol. Over the past few years, however, C (and more recently C++) has replaced assembler as the "macho" language of choice.

Windows developers in particular have been led to believe that C and C++ are their only options. But a recent encounter with Borland's Turbo Pascal for Windows (TPW) leads me to believe that you can have your quiche and eat it too--and do some real programming in the process.

To test TPW's suitability as a Windows programming tool, I wrote ExpertWin, a general-purpose expert shell. This seemed appropriate because expert systems are typically UI intensive. In addition to examining TPW, I use Borland's ObjectWindows Library (OWL) and explore issues relating to common user-interface design. ExpertWin makes no attempt to use every feature in OWL; it does what it needs to with pull-down menus and dialog boxes.

The ExpertWin System

ExpertWin is a "backward chaining" system, meaning it starts with a conclusion (or goal) and a set of rules leading to that conclusion. The system then attempts to prove the goal by matching the rules with known facts from a database. If a needed fact is not contained in the database, the system queries the user for information.

Each conclusion is stored along with its associated attributes in a database (called either a "rule" or a "knowledge base") in the form: conclusion[attr1, attr2,...attrN]. The square brackets denote a list of attributes, and commas are used to AND two attributes. The rule reads as "conclusion is true if attr1 and attr2 and everything up to attrN are true." Upon opening a file, ExpertWin parses each rule and stores the resulting rule components into a nested linked-list structure. Once the rule base is loaded, the user can insert additional rules, search for either a conclusion or an attribute, list rules in the knowledge base, implement a query, or clear the rule base from memory so that a new database can be loaded.

Any given rule can inherit attributes from an ancestor rule, much as an object inherits features from its parent. The user creates this relationship by specifying the parent's rule name in the child's attribute list. During a query, ExpertWin looks at each attribute and first determines whether it is another rule. If so, ExpertWin goes to that rule and attempts to prove it before continuing through the list. I won't spend much time on the code, but the entire inference engine is contained in the TExpert.Inference method; see Listing One, page 145.

Some Assembly Required

ExpertWin uses OWL, Borland's application framework; for more on this, see the text box entitled "Application Frameworks." From the term framework, you might expect a superstructure--a skeleton program from which to build your application--that contains all common elements required for compliance with user-interface guidelines. However, every application framework I've worked with requires you to assemble various components to create a skeleton program. Figure 1 (page 149) shows a template for a generic application that includes the basic elements an ObjectWindows application requires. Although the template has been abbreviated for clarity, I maintain an expanded version of this template that includes all standard menus, such as File and Help, and all common dialogs, such as FileOpen and About. It's a living, breathing Windows application complete with all standard Windows interface objects.

The generic template in Figure 1 also details the basic structure of an OWL application. All apps must define an application object (TGenericApp), which is derived from the standard OWL type TApplication. TApplication initializes the first instance of your application, creates and displays the main window, and handles the processing of Windows messages. It also handles cleanup when the app is closed.

These routines are invoked from the main body of the program, which first creates an instance of TGeneric, then calls Init, Run, and Done. Init constructs the application object, then calls InitMainWindow to construct the main window. You'll usually find it necessary to override the InitMainWindow method defined in TApplication, so I've included a definition in the template.

Run invokes a message-processing loop which intercepts Windows messages and dispatches them to methods in your program. These methods, called "message-response methods," are contained in TGeneric and represent all behavior within main window. A message-response method is analogous to a Windows callback function--a function called by Windows. In this case, however, your message-response method is called via TApplication. By convention, message-response methods are given a name corresponding to the command message they respond to. For example, TGeneric.CMAbout is a message-response method that invokes the About dialog box when it receives the cm_About message (defined as Const in Figure 1).

The message-processing loop runs until the user terminates the application. At this point, the destructor Done is called to free memory and terminate the program.

OWL Hierarchy

There's a significant learning curve to both Windows and OWL programming. Fortunately, with OWL you can take it in bites. Once you learn to create the main window and you're comfortable with basic message-loop processing, you begin to learn how to create window, menu, dialog, and control objects--the interface objects. Be especially prepared to spend time with the plethora of controls, which include edit controls, list boxes, radio buttons, combo boxes, check boxes, and scroll bars.

Seemingly unrelated to user-interface objects is the support for simple container objects called collections. Collections provide a powerful means to implement data structures such as dynamic arrays and lists, as well as collections of objects in a generic, yet consistent manner. The TCollection object type includes over 20 collection-manipulation methods such as Load, GetItem, PutItem, and Delete, and iterator methods that can apply a function or procedure to each item in the collection. There are also subtypes that allow you to work with sorted collections and collections of strings.

More Details.

OWL also provides support for object-oriented I/O using streams. You can create your own stream types, but you must override many of the basic I/O methods. My guess is that most newcomers will spend time learning to create the other interface objects before getting into TStream and its descendants, TDosStream and TEmsStream.

With OWL, you can create an app without really getting the Windows dirt under your fingernails. But there's more to a Windows app than windows, menus, and dialogs. Although OWL supports MDI, you must make calls directly to the Windows API to support GDI, DDE, or OLE. This isn't a complaint, just an observation that OWL does not completely insulate you from the Windows API. It does, however, reduce the number of API calls you must learn.

Reusable vs. Roll Your Own

Two singly linked lists are used to handle the rule base; see Listing Two, page 148. Attr is a simple record that uses a character array to store a rule, and ANext is a pointer to the next rule in the list. The second linked list, Item, also uses a character array to store the conclusion and a pointer to the next conclusion. But Item also contains a pointer to Attr, which links the rule list to the conclusion. The net effect is that Attr is a nested linked list.

SList is an object that handles list manipulation of conclusions. NestedList is derived from SList and handles the rule list. Most of this is straight linked-list manipulation with the twist that list traversals must often pass through both lists.

I'd originally decided to use a stream to read the rules from disk file into a collection. As mentioned, both collections and streams are provided for in OWL. But there's an inherent problem in trying to manufacture something new while you're still learning the framework. Recall that the inference engine requires synchronized list traversal. At this point, I didn't know enough about OWL internals to create a collection of collections, much less write a routine to synchronously traverse two collections. I could have grabbed the source, picked it apart, and modified the general collection routines to suit my specific needs. Or I could write my own in half the time. So much for reusability.

Once that decision was made, it became evident that using streams to read the data into a record was overkill. Streams are great for dealing with the complexities of storing objects to disk, but straightforward Turbo Pascal I/O would serve better. In all fairness, you gain a great deal of power using streams. For example, storing the current state of a query would best be implemented using streams.

Strings vs. PChars

Because Windows requires null-terminated strings, TPW introduces the pointer type PChar. Note that the string types in Listing Two are all null-terminated. Though the changes are relatively easy, PChars require some adjustments in the way you work with strings. Most problems you encounter will result from confusing PChars with normal strings.

A PChar is a pointer to a null-terminated string and is equivalent to the declaration PChar=^Char. You create a null-terminated string variable either by declaring the variable as type PChar or by declaring it as a zero-based array of characters. If the variable is declared as a PChar, you must allocate memory for the string using the StrNew function. Further, you must dispose of the string using StrDispose before assigning a different string to the variable. Failure to do so can have disastrous consequences. On the other hand, the compiler automatically allocates memory when the string is declared as a zero-based array. Note that despite the array of Char declaration, this is an array of pointers, not of characters.

PChars require that you use functions to manipulate strings instead of using familiar TP syntax. For example, with normal Turbo Pascal strings, you assign a string to a variable using the assignment operator: Str:='foo. To assign the same string to a PChar, you must use the StrCopy function: StrCopy(Str, 'foo').

Also note that because PChars are pointers, you are passing by reference when calling a procedure or function. Normal strings, however, are usually passed by value unless you use the Var keyword in the function header. If you need to work on a copy of the PChar string rather than the string itself, you must create a local variable and copy the string to that variable.

Finally, make sure you set the $X+ compiler directive to enable extended syntax. This is the default setting, but it may on occasion be turned off.

UI Design

IBM formalized its guidelines for OS/2 Presentation Manager interface design in its common user access (CUA) guidelines, published in 1989. Windows developers have used these guidelines as a road map in developing their applications. (Note that IBM updated these guidelines in 1991, but the revisions are specific to OS/2 2.0.) For the purposes of this article, I've used The Windows Interface (Microsoft Press, 1992) to aid in the design of the ExpertWin UI.

Conformance to user-interface guidelines is important for visual and functional consistency. Guidelines also take much of the guesswork out of your design and will probably keep your boss happy when the product ships.

In browsing this design guide, however, you quickly realize the enormity of detail in such an undertaking. Fortunately, the components of TPW are a big help in creating interface objects that conform to the Microsoft (and CUA '89) guidelines. For example, I found the Resource Workshop extremely helpful in implementing conforming menus. According to the guidelines, any menu item that leads to a dialog box should contain three trailing ellipses. Further, menu items that fall into logical groups should use a separator line to distinguish the groups. There are also specific recommendations for features within File, Edit, View, Options, and Help menus. Returning to ExpertWin with guidelines in hand, I was prepared to go through the process of updating the menus starting with the File menu. To my surprise, I was able to automatically generate the standard File menu complete with ellipses, separators, keyboard accelerators--the works.

There are also recommendations for "common dialogs" like Open, Save As, Print, and so on. As you might expect, TPW includes a Common Dialogs DLL (CommDlg) that you include in a USES statement. Once included, you can display the dialog via a single call rather than the traditional method of creating a dialog resource and dialog-box procedure. I was able to implement the File menu, all common dialogs, and processing code (such as parsing the rules after opening a file) all in one day.

You also have access to the Borland Windows Custom Controls (BWCC), which include various controls that have a chiseled-steel, 3-D look. Accessing the custom controls is a simple matter of including BWCC in the USES clause and recompiling. Now all standard controls will take on the Borland look. My primary complaint is that they're non-standard UI components. But if you can live with this nonstandard appearance, they can spice up an otherwise ordinary interface.

Conclusion

I didn't spend much time talking about the typical tools like the Windows-hosted development environment, which features integrated debugging, a configurable desktop and toolbar, and syntax-directed highlighting. These are features you should expect. And although I'd still like to see an integrated class browser that lets me move to and edit objects, or a debugger that doesn't have to switch to character mode, the feature list isn't what's important. More important is getting a developer-class tool for creating real-world Windows applications. Turbo Pascal for Windows fits the bill.

References

The Windows Interface. An Application Design Guide. Redmond, WA: Microsoft Press, 1992.

SAA CUA Basic Interface Design Guide, Document SC26-4582. IBM: 1989.

SAA CUA Advanced Interface Design Guide, Document SC26-4583. IBM: 1989.

Products Mentioned

Turbo Pascal for Windows Borland International 1800 Green Hills Road Scotts Valley, CA 95066 408-438-8400 $149.95

Application Frameworks

There are a number of so-called application frameworks bouncing around, among them Symantec's yet-to-be-released Bedrock, Borland's OWL, and Inmark's zApp. Microsoft, too, has dabbled with the "application framework" moniker, originally tagging its C++ class library "AFX" before releasing it as "MFC."

With all these diverse tools making the rounds, I began looking for a precise definition of an application framework. What I discovered was that, while all tool vendors could describe their application framework, none could come up with a general, yet succinct definition of one. (This caused me to wonder if, when it comes to application frameworks, marketing gurus were indeed engaging in "fuzzy logic.")

The original application framework might have been the user-interface class library for Smalltalk-80. In the days that predate GUIs, Smalltalk-80 was exceptional at constructing highly interactive, easy-to-use user interfaces. It's no accident that both Smalltalk-80 and much of the UI design in the Macintosh was pioneered at Xerox PARC. Nor is it surprising that an object-oriented approach based on Smalltalk's Model-View-Controller (MVC) was adopted in the Lisa Toolkit and later MacApp.

Eventually, Apple Computer coined the term "application framework" to describe MacApp. But when DDJ asked Apple for the "official" definition of the term, we were surprised to learn that Apple didn't have one either--even in the MacApp documentation. After some discussion, an Apple spokesperson provided us with the following: "An application framework is an extended collection of classes that cooperate to support a complete application architecture or model, providing more complete application development support than a simple set of classes."

Borland's ObjectWindows Library (discussed in this article) not only generally conforms to the Apple definition, but looks remarkably similar to MacApp. For example, both rely on an event-based processing loop that is built into the framework and use a naming convention that prefixes all framework objects with a T and pointers to that object with a P. Also like MacApp, OWL combines interface objects that make it difficult to create an application that does not conform to user-interface guidelines. While the OWL class hierarchy differs somewhat from MacApp, every object in the hierarchy is derived from the base object TObject. This design also bears striking similarity to Smalltalk.

-- M.F.



_EXAMINING TURBO PASCAL FOR WINDOWS_
by Michael Floyd


[LISTING ONE]
<a name="0295_0010">

program ExpSys;

{$R WINXPERT.RES}

uses WinDOS, WObjects, WinTypes, Strings, WinProcs, StdDlgs, CommDlg, BWCC, Lists;

const
  id_Menu     = 200;
  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;

  PTestDialog = ^TTestDialog;
  TTestDialog = 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(TTestDialog)
    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 TTestDialog.Init(AParent: PWindowsObject; ATitle: PChar);
begin
  TDialog.Init(AParent, ATitle);
end;

procedure TTestDialog.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 TTestDialog.IDLB1(var Msg: TMessage);
var
  RDlg, Idx : Integer;
  SelectedText: array[0..20] 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, 'WinExpert 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, 'foo', 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..19] 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, '');

{ 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(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(PTestDialog, 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('WinExpert');
  Expert.Run;
  Expert.Done;

end.

<a name="0295_0011">
<a name="0295_0012">
[LISTING TWO]
<a name="0295_0012">


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.









Copyright © 1992, Dr. Dobb's Journal


Related Reading


More Insights






Currently we allow the following HTML tags in comments:

Single tags

These tags can be used alone and don't need an ending tag.

<br> Defines a single line break

<hr> Defines a horizontal line

Matching tags

These require an ending tag - e.g. <i>italic text</i>

<a> Defines an anchor

<b> Defines bold text

<big> Defines big text

<blockquote> Defines a long quotation

<caption> Defines a table caption

<cite> Defines a citation

<code> Defines computer code text

<em> Defines emphasized text

<fieldset> Defines a border around elements in a form

<h1> This is heading 1

<h2> This is heading 2

<h3> This is heading 3

<h4> This is heading 4

<h5> This is heading 5

<h6> This is heading 6

<i> Defines italic text

<p> Defines a paragraph

<pre> Defines preformatted text

<q> Defines a short quotation

<samp> Defines sample computer code text

<small> Defines small text

<span> Defines a section in a document

<s> Defines strikethrough text

<strike> Defines strikethrough text

<strong> Defines strong text

<sub> Defines subscripted text

<sup> Defines superscripted text

<u> Defines underlined text

Dr. Dobb's encourages readers to engage in spirited, healthy debate, including taking us to task. However, Dr. Dobb's moderates all comments posted to our site, and reserves the right to modify or remove any content that it determines to be derogatory, offensive, inflammatory, vulgar, irrelevant/off-topic, racist or obvious marketing or spam. Dr. Dobb's further reserves the right to disable the profile of any commenter participating in said activities.

 
Disqus Tips To upload an avatar photo, first complete your Disqus profile. | View the list of supported HTML tags you can use to style comments. | Please read our commenting policy.
 

Video