SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00037 OOP/TVVISION ROUTINES 1 05-28-9313:53ALL SWAG SUPPORT TEAM CENTRDLG.PAS IMPORT 7 d£ó {π > The title says it all. What is the accepted way of bringing up a dialogπ > box in the centre of the screen.π}πProcedure CenterDlg (HWindow : HWnd);πVarπ R : TRect;π X : Integer;π Y : Integer;π Frame : Integer;π Caption : Integer;πbeginπ Frame := GetSystemMetrics (sm_CxFrame) * 2;π Caption := GetSystemMetrics (sm_CyCaption);π GetClientRect (HWindow, R);π With R doπ beginπ X := ((GetSystemMetrics (sm_CxScreen) - (Right - Left)) div 2);π Y := ((GetSystemMetrics (sm_CyScreen) - (Bottom - Top)) div 2);π MoveWindow (HWindow, X, Y - ((Caption + Frame) div 2),π Right + Frame, Bottom + Frame + Caption, False);π end;π end;πend;π{π Execute this Function from the dialog's SetupWindow method.π} 2 05-28-9313:53ALL SWAG SUPPORT TEAM COUNTDLG.PAS IMPORT 15 d╕# {π> Some trouble-shooting With Turbo Vision, AGAIN!π> If i want to impelement this source code toπ> show x in a Window, how do i do that!!ππ> For x:=1 to 100 doπ> WriteLn (x);ππ> That means that i want show x counting in theπ> Window..........ππHere a simple method you can use to get started. It has been tested, and itπdoes not do much, except show a counting dialog box.π}ππUnit CountDlg;ππInterfaceπUsesπ Objects, dialogs, views, drivers;πTypeπ KDialog = Object(TDialog)π Count : Word;π ps : PStaticText;π Constructor Init(Var bounds:Trect;ATitle:TTitleStr);π Procedure HandleEvent(Var Event:TEvent); virtual;π end;π PKDialog = ^KDialog;ππImplementationππFunction NumStr(n:Word):String;πVarπ S : String;πbeginπ Str(n,s);π NumStr := s;πend;ππConstructor KDialog.Init(Var Bounds:TRect;ATitle:TTitleStr);πVarπ r : TRect;πbeginπ inherited init(Bounds,ATitle);π Count := 0;π GetExtent(r);π r.grow(-1,-2); r.b.y := r.a.y + 1;π new(ps,init(r,' Cyclycal counter := '+NumStr(Count)));π insert(ps);πend;ππProcedure KDialog.HandleEvent(Var Event:TEvent);πbeginπ inc(Count);π if count > 10000 then count := 0;π DisposeStr(ps^.Text);π ps^.Text := NewStr(' Cyclycal count := '+NumStr(Count));π ps^.Draw;π Inherited HandleEvent(Event);πend;ππend.ππ{πAnd... the associated application to try it With ...π}ππProgram GenApp;πUsesπ Objects, App, Views, Dialogs, CountDlg;πTypeπ GenericApp = Object(TApplication)π Procedure Run; Virtual;π end;ππProcedure GenericApp.Run;πVarπ r : TRect;πbeginπ GetExtent(R);π R.Grow(-26,-10);π ExecuteDialog(new(PKDialog,init(r,'Test Counter')),nil);πend;ππVar MyApp : GenericApp;ππbeginπ MyApp.Init;π MyApp.Run;π MyApp.Done;πend.π 3 05-28-9313:53ALL SWAG SUPPORT TEAM DELAYDLG.PAS IMPORT 11 dbÇ {π▒Hello. I was toying around With TVision, trying to make derive an Object frπ▒TDialog which would be a simple 'Delay box' (i.e. a message would display, tπ▒the box would cmOK itself after two seconds). I tried a simple Delay() commπ▒in HandleEvent, which seemed to work fine, but when I held down the mouse buπ▒on the menu, it locked up and sometimes my memory manager woudl report crazyπ▒error messages. Can anyone offer a suggestion on how to do this safely? Thπ▒are certain situations when clicking an 'OK' button is just a hassle. ThankππTry trapping the mouse events in the HandleEvent method of the dialogπbox.π}ππTypeπ tDelayDialog = Object(tDialog)π Procedure HandleEvent(Var Event : tEvent); VIRTUAL;π end;ππProcedure tDelayDialog.HandleEvent(Var Event : tEvent);πConstπ cDelay = 2000;πbeginπ if Event.What and evMouse <> 0 then (* This filters out mouse *)π (* events before they reach *)π (* the parent *)π ELSEπ beginπ Delay(cDelay);π Event.Command := cmOK; (* Set up the command *)π INHERITED HandleEvent(Event); (* Let the parent handle it *)π end;πend;π 4 05-28-9313:53ALL SWAG SUPPORT TEAM FILEDLG1.PAS IMPORT 6 dè= {π> In particular a collection of Filenames in the current directory sortedπ> and the ability to scroll these Strings vertically.ππCCompiled and tested under BP7. All Units are standard Units available withπboth TP6 and BP7 packagesπ}ππProgram ListDirProg;πUsesπ Objects,App,StdDlg;ππTypeπ MyApp = Object(TApplication)π Procedure run; Virtual;π end;ππProcedure myapp.run;πVarπ p : PFileDialog;πbeginπ New(P,init('*.*','Directory Listing', '~S~earch Specifier', fdokbutton,0));π if p <> nil thenπ beginπ execview(p);π dispose(p,done);π end;πend;ππVarπ a : myapp;ππbeginπ a.init;π a.run;π a.done;πend.π 5 05-28-9313:53ALL SWAG SUPPORT TEAM FILEDLG2.PAS IMPORT 22 d^« {π>Really like to see is a Real world example. In particular aπ>collection of Filenames in the current directory sorted and theπ>ability to scroll these Strings vertically. I don't want to goππI don't know if this will help that much, but it does what you requestedπ<g>... This Compiled in Real mode under BP7 and ran without problems. Althoughπuntested in TP6, it should run fine.π}πProgram Example;ππUsesπ App,π Dialogs,π Drivers,π Menus,π MsgBox,π Objects,π StdDlg,π Views;ππConstπ cmAbout = 101;ππTypeπ TExampleApp = Object(TApplication)π Procedure CM_About;π Procedure CM_Open;π Procedure HandleEvent(Var Event: TEvent); Virtual;π Constructor Init;π Procedure InitStatusLine; Virtual;π end;ππProcedure TExampleApp.CM_About;πbeginπ MessageBox(π ^C'Example O-O Program' + #13 + #13 +π ^C'by Bill Himmelstoss (1:112/57)', nil, mfInFormation + mfOkButtonπ );πend;ππProcedure TExampleApp.CM_Open;πVarπ FileDialog: PFileDialog;π Filename: FNameStr;π Result: Word;πbeginπ FileDialog := New(PFileDialog, Init('*.*', 'Open a File', '~N~ame',π fdOpenButton, 100));π {$ifDEF VER70}π Result := ExecuteDialog(FileDialog, @Filename);π {$endif}π {$ifDEF VER60}π Result := cmCancel;π if ValidView(FileDialog) <> nil thenπ Result := Desktop^.ExecView(FileDialog);π if Result <> cmCancel thenπ FileDialog^.GetFilename(Filename);π Dispose(FileDialog, Done);π {$endif}π if Result <> cmCancel thenπ MessageBox(^C'You chose '+Filename+'.', nil, mfInFormation + mfOkButton);πend;ππProcedure TExampleApp.HandleEvent(Var Event: TEvent); beginπ {$ifDEF VER60}π TApplication.HandleEvent(Event);π {$endif}π {$ifDEF VER70}π inherited HandleEvent(Event);π {$endif}ππ Case Event.What ofπ evCommand:π beginπ Case Event.Command ofπ cmAbout: CM_About;π cmOpen: CM_Open;π elseπ Exit;π end;π ClearEvent(Event);π end;π end;πend;ππConstructor TExampleApp.Init;πVarπ Event: TEvent;πbeginπ {$ifDEF VER60}π TApplication.Init;π {$endif}π {$ifDEF VER70}π inherited Init;π {$endif}ππ ClearEvent(Event);π Event.What := evCommand;π Event.Command := cmAbout;π PutEvent(Event);πend;ππProcedure TExampleApp.InitStatusLine;πVarπ R: TRect;πbeginπ GetExtent(R);π R.A.Y := R.B.Y - 1;π StatusLine := New(PStatusLine, Init(R,π NewStatusDef($0000, $FFFF,π NewStatusKey('~F3~ Open', kbF3, cmOpen,π NewStatusKey('~Alt+X~ Exit', kbAltX, cmQuit,π nil)),π nil)));πend;ππVarπ ExampleApp: TExampleApp;ππbeginπ ExampleApp.Init;π ExampleApp.Run;π ExampleApp.Done;πend.π 6 05-28-9313:53ALL SWAG SUPPORT TEAM NUMVIEW.PAS IMPORT 8 d╓╢ Unit NumView;ππInterfaceππUsesπ Views, Objects, Drivers;ππTypeπ PNumView = ^TNumView;π TNumView = Object(TView)π Number : LongInt;ππ Constructor init(Var Bounds: Trect);π Procedure update(num:LongInt);π Procedure draw; Virtual;π Destructor done; Virtual;π end;ππImplementationππ{---------------------------}π{ }π{ TNumView Methods }π{ }π{---------------------------}πConstructor TNumView.Init(Var Bounds: Trect);πbeginπ inherited init(Bounds);πend;ππProcedure TNumView.Update(num:LongInt);πbeginπ Number := num; Draw;πend;ππProcedure TNumView.Draw; Varπ B: TDrawBuffer;π C: Word;π Display : String;πbeginπ C := GetColor(6);π MoveChar(B, ' ', C, Size.X);π Str(Number,Display);π MoveStr(B, Display,C);π WriteLine(0, 0, Size.X,Length(Display), B);πend;ππDestructor TNumView.Done;πbeginπ inherited done;πend;ππend.ππ 7 05-28-9313:53ALL SWAG SUPPORT TEAM OBJ-DESC.PAS IMPORT 34 d? {πKEN BURROWSππWell, here I go again. There have been a few messages here and there regardingπcollections and Objects and streams. I've been trying to grapple With howπthings work, and sometimes I win and sometimes I lose. The following code is myπrendition of a useful TObject Descendent. It is completely collectable andπstreamable. Feel free to dismiss it offhand if you like.π}ππUnit TBase3; {BP 7.0}π {released to the public domain by ken burrows}πInterfaceπUsesπ Objects, memory;πTypeπ TBase = Object(TObject)π Data : Pointer;π Constructor Init(Var Buf;n:LongInt);π Constructor Load(Var S:TStream);π Procedure Store(Var S:TStream); virtual;π Destructor Done; virtual;π Privateπ Size : LongInt;π end;π PBase = ^TBase;ππConstπ RBaseRec : TStreamRec = (ObjType : 19560;π VMTLink : Ofs(TypeOf(TBase)^);π Load : @TBase.Load;π Store : @TBase.Store);ππProcedure RegisterTBase;ππImplementationππConstructor TBase.Init(Var Buf; n : LongInt);πbeginπ Data := MemAlloc(n);π if Data <> Nil thenπ beginπ size := n;π move(Buf,Data^,size);π endπ elseπ size := 0;πend;ππConstructor TBase.Load(Var S : TStream);πbeginπ size := 0;π S.Read(size,4);π if (S.Status = StOk) and (size <> 0) thenπ beginπ Data := MemAlloc(size);π if Data <> Nil thenπ beginπ S.read(Data^,size);π if S.Status <> StOk thenπ beginπ FreeMem(Data,size);π size := 0;π end;π endπ elseπ size := 0;π endπ elseπ Data := Nil;πend;ππProcedure TBase.Store(Var S : TStream);πbeginπ S.Write(size, 4);π if Data <> Nil thenπ S.Write(Data^, Size);πend;ππDestructor TBase.Done;πbeginπ if Data <> Nil thenπ FreeMem(Data, size);πend;ππProcedure RegisterTBase;πbeginπ RegisterType(RBaseRec);πend;ππend.ππππProgram TestTBase3; {bare bones make/store/load/display a collection}π {collected Type defined locally to the Program}ππUsesπ Objects, tbase3;ππProcedure ShowStuff(P : PCollection);ππ Procedure ShowIt(Pb : PBase); Far;π beginπ if Pb^.Data <> Nil thenπ Writeln(PString(Pb^.Data)^);π end;ππbeginπ P^.ForEach(@ShowIt);πend;ππVarπ A_Collection : PCollection;π A_Stream : TDosStream;π S : String;π m : LongInt;ππbeginπ m := memavail;π RegisterTBase;π New(A_Collection,init(5,2));π Repeatπ Writeln;π Write('enter some String : ');π Readln(S);π if S <> '' thenπ A_Collection^.insert(New(PBase,init(S,Length(S)+1)));π Until S = '';π Writeln;π Writeln('Storing the collection...');π A_Stream.init('Test.TB3',stCreate);π A_Collection^.Store(A_Stream);π Writeln;π Writeln('Storing Done. ');π dispose(A_Collection,done);π A_Stream.done;π Writeln;π Writeln('Disposing of Stream and Collection ...');π if m = memavail thenπ Writeln('memory fully released')π elseπ Writeln('memory not fully released');π Write('Press [ENTER] to [continue] ...');π readln;π Writeln;π Writeln('Constructing a new collection using the LOAD Constructor');π A_Stream.init('Test.TB3',stOpenRead);π New(A_Collection,Load(A_Stream));π A_Stream.done;π Writeln;π ShowStuff(A_Collection);π Writeln;π Writeln('Disposing of Stream and Collection ...');π dispose(A_Collection,done);π if m = memavail thenπ Writeln('memory fully released')π elseπ Writeln('memory not fully released');π Write('Press [ENTER] to [EXIT] ...');π readln;πend.ππ{πThe above code has been tested and works just fine. By defining what I put intoπthe Object and Typecasting it when I take it out, I can collect and store andπload just about anything Without ever haveing to descend either theπTCollection, TBase or the TDosStream Objects. In the Case of the above Program,πI elected to collect simple Strings. It might just as well have been any otherπType of complex Record structure.ππThis Program was written solely For the purpose of discovering how the Objectsπbehave and possibly to even learn something. Any comments, discussions orπflames are always welcome.π}π 8 05-28-9313:53ALL SWAG SUPPORT TEAM OOP-EXMP.PAS IMPORT 13 d░± {π I am trying to teach myself about Object orientated Programming and aboutπ'inheritence'. This is my code using Records.ππHave a look at 'Mastering Turbo Pascal 6' by tom Swan, pg. 584 and on.πBriefly, without Objects, code looks like this:π}ππDateRec = Recordπ Month: Byte;π day: Byte;π year: Word;πend;ππVarπ today: DateRec;ππbeginπ With today doπ beginπ month:= 6;π day := 6;π year := 1992;π end;π...πmore code..πend.ππWith Objects, code looks like this:ππTypeπ DateObj = Objectπ month: Byte; {note data and methods are all}π day: Byte; {part of the Object together }π year: Word;π Procedure Init(MM, DD, YY: Word);π Function StringDate: String;π end;ππVarπ today: DateObj;ππProcedure DateObj.Init(MM, DD, YY: Word); {always need to initialise}πbeginπ Month:= MM;π Day := DD;π year := YY;πend;ππFunction DateObj.StringDate: String;πVarπ MStr, Dstr, YStr: String[10];πbeginπ Str(Month, MStr);π Str(Day, DStr);π Str(Year, YStr);π StringDate := MStr + '/' + DStr + '/' + YStrπend;ππbegin {begin main Program code}π today.Init(6,6,1992);π Writeln('The date is ', today.StringDate)π Readlnπ..πother code..πend.ππHope this helps. Read all the example code you can, and try the Turbo-πvision echo (not yet on Fidonet, but nodes were listed on hereπrecently). You can fidonet sysop Pam Lagier at TurboCity BBS 1:208/2πFor a node list.π 9 05-28-9313:53ALL SWAG SUPPORT TEAM OOP-HTKY.PAS IMPORT 30 d²╞ {π> Yes, event oriented Programming is very easy using OOP, but as itπ> comes to TVision, if you need to add your own events, you're stuck. Iπ> just wanted to implement the Windows-style ALT-Press-ALT-Releaseπ> event, that activates the Window menu, and I'd had to modify theπ> Drivers.pas sourceFile to implement it, so I have to find other keysπ> to activate the menu bar :-(ππthis Really stimulated me so I sat down and implemented the following *without*πmessing around in DRIVERS.PAS in -believe it or not- 15 minutes! :-)))π}πProgram tryalt;ππUses drivers,Objects,views,menus,app,Crt;ππConst altmask = $8;πVar k4017 : Byte Absolute $40:$17;ππType tmyapp = Object (TApplication)π AltPressed,π IgnoreAlt: Boolean;π Constructor Init;π Procedure InitMenuBar; Virtual;π Procedure GetEvent (Var Event: TEvent); Virtual;π Procedure Idle; Virtual;π end;ππ{ low-level Function; returns True when <Alt> is being pressed }πFunction AltDown: Boolean;πbeginπ AltDown := (k4017 and altmask) = altmaskπend;ππConstructor tmyapp.Init;πbeginπ inherited init;π AltPressed := False;π IgnoreAlt := Falseπend;ππProcedure Tmyapp.InitMenuBar;πVarπ R: TRect;πbeginπ GetExtent(R);π R.B.Y := R.A.Y + 1;π MenuBar := New (PMenuBar, Init(R, NewMenu (π NewSubMenu ('~≡~', hcNoConText, NewMenu (π NewItem ('~A~bout LA-Copy...', '', kbNoKey, cmQuit, hcNoConText,π NewLine (π NewItem ('~D~OS Shell', '', kbNoKey, cmQuit, hcNoConText,π NewItem ('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoConText,π nil))))),π NewSubMenu ('~R~ead', hcNoConText, NewMenu (π NewItem ('~D~isk...', 'F5', kbF5, cmQuit, hcNoConText,π NewItem ('~I~mage File...', 'F6', kbF6, cmQuit, hcNoConText,π NewItem ('~S~ector...', 'F7', kbF7, cmQuit, hcNoConText,π NewLine (π NewItem ('~F~ree up used memory', 'F4', kbF4, cmQuit, hcNoConText,π nil)))))),π (* more menus in the original :-) *)π nil)))));πend;ππ{ modified GetEvent to allow direct usage of Alt-Hotkey }πProcedure tmyapp.GetEvent (Var Event: TEvent);πbeginπ inherited GetEvent (Event);π if (Event.What and (evKeyboard or evMessage)) <> evnothing thenπ IgnoreAlt := True { in Case of keypress or command ignore }πend; { Until <Alt> next time released }ππProcedure tmyapp.Idle;πVar Event: TEvent;πbeginπ inherited Idle;π if AltDown then { <Alt> key is down }π AltPressed := True { remember this }π else begin { <Alt> is released (again?) }π if AltPressed then begin { yes, again. }π if not IgnoreAlt then begin { but: did they use Alt-Hotkey? }π Event.What := evCommand; { no, let's activate the menu! }π Event.Command := cmMenu;π PutEvent (Event)π end;π end;π AltPressed := False; { however, <Alt> is up again }π IgnoreAlt := False { so we don't need to ignore it }π end; { the next time <Alt> is released }πend;ππVar myapp: tmyapp; { create an Object of class 'tmyapp' }ππbeginπ myapp.init; { you know these three lines, don't you? <g> }π myapp.run;π myapp.done;πend.ππ{πFor convenience I copied the first three menus from my diskcopy clone so don'tπget confused about the items :-). This Program does not emulate CompletelyπWindows' behaviour, however, it's a good start. Tell me if this is what youπwanted! I didn't test it excessively but it does work in this fairly simpleπProgram For activating menus by <Alt>. The only thing not implemented isπ'closing' the menu bar by a second <Alt> stroke.π} 10 05-28-9313:53ALL SWAG SUPPORT TEAM OOP-STRG.PAS IMPORT 44 dgµ {πLARRY HADLEYππ>Right now, I have an Array of Pointers that point to the beginningπ>of each page. The entire File is loaded into memory using BlockRead.π>To jump to a page, it checks the current page number, jumps to thatπ>offset (as specified by the Page Array) and dumps the contentsπ>to the screen Until it reaches the bottom.ππ I think I see. You have a monolithic block of memory...problem!ππ> There are a lot of ways to do it. One way would be to store theπ> File as Arrays of *Pointers* to Strings...this would allow 64k ofπ> *sentences*, not just 64k of Text. It's a Variation on the oldππ Actually, this is wrong. Since TP use 4 Byte Pointers, you canπ only <g> store 16k of sentences in a single Array, but evenπ though that should still be plenty, you can use linked lists toπ overcome that limitation!ππ>I have an Array of Pointers to the offset of each page. Could youπ>provide a short code fragment?ππ Instead of treating the Pointers as offsets, you should be usingπ them as actual data collections.ππ{π *****************************************************************ππ Strings Unit With StrArray Object. Manage linked lists of Stringsπ transparently.ππ By Larry Hadley - May be used freely, provided credit is givenπ wherever this code is used.ππ *****************************************************************π}πUnit Strings;ππInterfaceππTypeπ PString = ^String;ππ PStringList = ^StringList;π StringList = Recordπ P : PString;π Next : PStringList;π end;ππ pStrArray = ^oStrArray;π oStrArray = Objectπ Root : PStringList;π total : Word;π eolist : Boolean; {end of list - only valid after calling At,π AtInsert, and AtDelete}π Constructor Init;π Destructor Done;ππ Procedure Insert(s : String);π Procedure Delete;π Function At(item : Word) : PString;π Procedure AtInsert(item : Word; s : String);π Procedure AtDelete(item : Word);π Function First : PString;π Function Last : PString;ππ Privateπ Procedure NewNode(N : PStringList);π Function AllocateS(s : String) : PString;π Procedure DeallocateS(Var P : PString);π end;ππImplementationππConstructor oStrArray.Init;πbeginπ Root := NIL;π total := 0;π eolist := False;πend;ππDestructor oStrArray.Done;πVarπ T : PStringList;πbeginπ While Root <> NIL doπ beginπ T := Root^.Next;π if Root^.P <> NIL thenπ DeallocateS(Root^.P);π Dispose(Root);π Root := T;π end;πend;ππProcedure oStrArray.Insert(s : String);πVarπ T, T1 : PStringList;πbeginπ NewNode(T1);π T1^.P := AllocateS(s);π Inc(total);π if Root <> NIL thenπ beginπ T := Root;π While T^.Next <> NIL doπ T := T^.Next;π T^.Next := T1;π endπ elseπ Root := T1;πend;ππProcedure oStrArray.Delete;πVarπ T, T1 : PStringList;πbeginπ T := Root;π if T <> NIL thenπ While T^.Next <> NIL doπ beginπ T1 := T;π T := T^.Next;π end;π T1^.Next := T^.Next;π if T^.P <> NIL thenπ DeallocateS(T^.P);π Dispose(T);π Dec(total);πend;ππFunction oStrArray.At(item : Word) : PString;πVarπ count : Word;π T : PStringList;πbeginπ if item>total thenπ eolist := Trueπ elseπ eolist := False;π count := 1; {1 based offset}π T := Root;π While (count < item) and (T^.Next <> NIL) doπ beginπ T := T^.Next;π Inc(count);π end;π At := T^.P;πend;ππProcedure oStrArray.AtInsert(item : Word; s : String);πVarπ count : Word;π T, T1 : PStringList;πbeginπ if item > total thenπ eolist := Trueπ elseπ eolist := False;π NewNode(T1);π T1^.P := AllocateS(s);π Inc(total);π count := 1;π if Root <> NIL thenπ beginπ T := Root;π While (count < Item) and (T^.Next <> NIL) doπ beginπ T := T^.Next;π Inc(count);π end;π T1^.Next := T^.Next;π T^.Next := T1;π endπ elseπ Root := T1;πend;ππProcedure oStrArray.AtDelete(item : Word);πVarπ count : Word;π T, T1 : PStringList;πbeginπ if item > total then { don't delete if item bigger than list total -π explicit only! }π beginπ eolist := True;π Exit;π endπ elseπ eolist := False;ππ count := 1;π T := Root;π T1 := NIL;ππ While (count < item) and (T^.Next <> NIL) doπ beginπ T1 := T;π T := T^.Next;π Inc(count);π end;π if T1 = NIL thenπ Root := Root^.Nextπ elseπ T1^.Next := T^.Next;π DeallocateS(T^.P);π Dispose(T);π Dec(total);πend;ππFunction oStrArray.First : PString;πbeginπ First := Root^.P;πend;ππFunction oStrArray.Last : PString;πVarπ T : PStringList;πbeginπ T := Root;π if T <> NIL thenπ While T^.Next <> NIL doπ T := T^.Next;π Last := T^.P;πend;ππProcedure oStrArray.NewNode(N : PStringList);πVarπ T : PStringList;πbeginπ New(T);π T^.Next := NIL;π T^.P := NIL;π if N = NIL thenπ N := Tπ elseπ beginπ T^.Next := N^.Next;π N^.Next := T;π end;πend;ππFunction oStrArray.AllocateS(s : String) : PString;πVarπ P : PString;πbeginπ GetMem(P, Ord(s[0]) + 1);π P^ := s;π AllocateS := P;πend;ππProcedure oStrArray.DeallocateS(Var P : PString);πbeginπ FreeMem(P, Ord(P^[0]) + 1);π P := NIL; {for error checking}πend;ππend. {Unit StringS}πππ{πCode fragment :ππVarπ TextList : pStrArray;ππ...ππ New(TextList, Init);ππ...ππ Repeatπ ReadLn(TextFile, s);π TextList^.Insert(s);π Until Eof(TextFile) or LowMemory;ππ...ππ For Loop := 1 to PageLen doπ if Not(TextList^.eolist) thenπ Writeln(TextList^At(PageTop + Loop)^);π...ππetc.π} 11 05-28-9313:53ALL SWAG SUPPORT TEAM OOP-WIND.PAS IMPORT 32 d┴S {π I'm still rather new (hence unexperienced) to this developmentπenvironment. Since the number of users of the Pascal For Windows productπis very limited in Belgium, I have little opportUnity to exchange ideasπand talk about problems. ThereFore, I dare to ask the following questionπdirectly on the US-BBS.ππ I contacted Borland Belgium With the following question:πIs it possible to create an MDI-Interface, which consists of TDlgWindow'sπ(Even of different Types of DialogWindows).πThe Program printed below was their answer. However, possibly because ofπmy limited experience in the field, this Program does not seem to work onπmy Computer running the Borland Pascal 7.0 .ππ Could someone explain why the Program below does not create dialog-πWindows as MDI client Windows of the main MDI Window (when I select theπ"create"-menu element), but instead only normal client Windows.π}ππ{********************************************************}π{ MDI - Programm of TDlgWindow - ChildWindows }π{ }π{ This is an adapted version of the Borland demo }π{ Programm MDIAPP.PAS of Borland Pascal 7.0 }π{********************************************************}πProgram MDI;π{$R MDIAPP.RES}πUsesπ WinTypes, WinProcs, Strings, OWindows, ODialogs;ππTypeπ { Define a TApplication descendant }π TMDIApp = Object(TApplication)π Procedure InitMainWindow; Virtual;π end;ππ PMyMDIChild = ^TMyMDIChild;π TMyMDIChild = Object(TDlgWindow)π Num : Integer;π CanCloseCheckBox : PCheckBox;π Constructor Init(AParent: PWindowsObject; AName: PChar);π Procedure SetupWindow; Virtual;π Function CanClose: Boolean; Virtual;π end;ππ PMyMDIWindow = ^TMyMDIWindow;π TMyMDIWindow = Object(TMDIWindow)π Procedure SetupWindow; Virtual;π Function CreateChild: PWindowsObject; Virtual;π end;ππ {********************** MDI Child ************************}π Constructor TMyMDIChild.Init(AParent: PWindowsObject; AName: PChar);π beginπ inherited Init(AParent, AName);π New(CanCloseCheckBox, Init(@Self, 102, 'Can Close',π 10, 10, 200, 20, nil));π end;ππ Procedure TMyMDIChild.SetupWindow;π beginπ inherited SetupWindow;π CanCloseCheckBox^.Check;π ShowWindow(HWindow, CmdShow);π end;ππ Function TMyMDIChild.CanClose;π beginπ CanClose := CanCloseCheckBox^.GetCheck = bf_Checked;π end;ππ {***************** MDI Window ******************}π Procedure TMyMDIWindow.SetupWindow;π Varπ NewChild : PMyMDIChild;π beginπ inherited SetupWindow;π CreateChild;π end;ππ Function TMyMDIWindow.CreateChild: PWindowsObject;π beginπ CreateChild := Application^.MakeWindow(New(PMyMDIChild,π Init(@Self, PChar(1))));π end;ππProcedure TMDIApp.InitMainWindow;πbeginπ MainWindow := New(PMDIWindow, Init('MDI ConFormist',π LoadMenu(HInstance, 'MDIMenu')));πend;ππVarπ MDIApp: TMDIApp;ππ{ Run the MDIApp }πbeginπ MDIApp.Init('MDIApp');π MDIApp.Run;π MDIApp.Done;πend.ππ{π***************************************************************************π Content of the MDIAPP.RES Fileπ***************************************************************************π}πMDIMENU MENUπbeginπ POPUP "&MDI Children"π beginπ MENUITEM "C&reate", 24339π MENUITEM "&Cascade", 24337π MENUITEM "&Tile", 24336π MENUITEM "Arrange &Icons", 24335π MENUITEM "C&lose All", 24338π endπendππ1 DIALOG 18, 18, 142, 92πSTYLE DS_SYSMODAL | WS_CHILD | WS_VISIBLE | WS_CAPTION |π WS_MinIMIZEBOX | WS_MAXIMIZEBOXπCLASS "BorDlg"πCAPTION "TEST"πbeginπ CHECKBOX "Text", 101, 26, 25, 28, 12π LText "Text", -1, 34, 48, 16, 8π CONTROL "Text", 102, "BorStatic", 0 | WS_CHILD |π WS_VISIBLE, 33, 70, 66, 8πENDπ 12 05-28-9313:53ALL SWAG SUPPORT TEAM OOPCOPY.PAS IMPORT 86 d"E {************************************************}π{ }π{ Turbo Pascal 6.0 }π{ Turbo Vision Utilities }π{ Written (w) 1993 by Andres Cvitkovich }π{ }π{ Public Domain }π{ }π{************************************************}ππUnit TVUtis;ππ{$F+,O+,S-,D-,B-}ππInterfaceππUses Dos, Objects, Views, App;ππTypeπ PProgressBar = ^TProgressBar;π TProgressBar = Object (TView)π empty, filled: Char;π total: LongInt;π percent: Word;π Constructor Init (Var Bounds: TRect; ch_empty,π ch_filled: Char; totalwork: LongInt);π Procedure Draw; virtual;π Procedure SetTotal (newtotal: LongInt);π Procedure Update (nowdone: LongInt); virtual;π Procedure UpdatePercent (newpercent: Integer); virtual;π end;ππ PFileCopy = ^TFileCopy;π TFileCopy = Objectπ bufsize: Word;π buffer: Pointer;π ConstRUCTOR Init (BufferSize: Word);π Destructor Done; VIRTUAL;π Function SetBufferSize (newsize: Word): Word; VIRTUAL;π Function CopyFile (File1, File2: PathStr): Integer; VIRTUAL;π Procedure Progress (Bytesdone, Bytestotal: LongInt;π percent: Integer); VIRTUAL;π Function Error (code: Word): Integer; VIRTUAL;π end;ππImplementationππUses drivers;ππConstructor TProgressBar.Init (Var Bounds: TRect; ch_empty, ch_filled: Char;πtotalwork: LongInt);πbeginπ TView.Init (Bounds);π total := totalwork;π empty := ch_empty;π filled := ch_filled;π percent := 0;πend;ππProcedure TProgressBar.Draw;πVarπ S: String;π B: TDrawBuffer;π C: Byte;π y: Byte;π newbar: Word;πbeginπ if (Size.X * Size.Y) = 0 then Exit; { Exit if no extent }π C := GetColor (6);π MoveChar (B, empty, C, Size.X);π MoveChar (B, filled, C, Size.X * percent div 100);π WriteLine (0, 0, Size.X, Size.Y, B);πend;πππProcedure TProgressBar.SetTotal (newtotal: LongInt);πbeginπ total := newtotalπend;ππProcedure TProgressBar.Update (nowdone: LongInt);πVar newpercent: Word;πbeginπ if total=0 then Exit;π newpercent := 100 * nowdone div total;π if newpercent > 100 then newpercent := 100;π if percent <> newpercent then beginπ percent := newpercent;π DrawViewπ end;πend;ππProcedure TProgressBar.UpdatePercent (newpercent: Integer);πbeginπ if newpercent > 100 then newpercent := 100;π if percent <> newpercent then beginπ percent := newpercent;π DrawViewπ end;πend;πππ{π TFileCopy.Initπ ──────────────ππ initializes the Object and allocates memoryππ BufferSize size of buffer in Bytes to be allocated For disk i/oππ}πConstRUCTOR TFileCopy.Init (BufferSize: Word);πbeginπ If MaxAvail < BufferSize Thenπ bufsize := 0π Elseπ bufsize := BufferSize;π If bufsize > 0 Then GetMem (buffer, bufsize);πend;πππ{π TFileCopy.Doneπ ──────────────ππ Destructor, free up buffer memoryππ}πDestructor TFileCopy.Done;πbeginπ If bufsize > 0 Then FreeMem (buffer, bufsize);π { bufsize := 0; } { man weiß ja nie... }πend;πππ{π TFileCopy.SetBufferSizeπ ───────────────────────ππ change buffer sizeππ NewSize = new size of disk i/o buffer in Bytesππ}πFunction TFileCopy.SetBufferSize (newsize: Word): Word;πbeginπ If MaxAvail >= newsize Then beginπ If bufsize > 0 Then FreeMem (buffer, bufsize);π bufsize := newsize;π If bufsize > 0 Then GetMem (buffer, bufsize);π end;π SetBufferSize := bufsizeπend;πππ{π TFileCopy.CopyFileπ ──────────────────ππ copy a File onto another; no wildcards allowedπ calls Progress and Errorππ File1 source Fileπ File2 target Fileππ Error code returned:ππ 1 low on buffer memoryπ 2 error opening source Fileπ 3 error creating destination Fileπ 4 error reading from source Fileπ 5 error writing to destination Fileπ 6 error writing File date/time and/or attributesππ}πFunction TFileCopy.CopyFile (File1, File2: PathStr): Integer;πVar fsrc, fdest: File;π fsize, ftime, cnt, cnt1: LongInt;π fattr, rd, wr, iores: Word;πbeginπ {$I-}π If bufsize = 0 then begin CopyFile := 1; Exit end;π Assign (fsrc, File1);π Repeatπ Reset (fsrc, 1);π iores := IOResult;π If iores <> 0 Thenπ If Error (iores) = 1 Then beginπ CopyFile := 2;π Exitπ end;π Until iores = 0;π Assign (fdest, File2);π Repeatπ ReWrite (fdest, 1);π iores := IOResult;π If iores <> 0 Thenπ If Error (iores) = 1 Then beginπ Close (fsrc);π CopyFile := 3;π Exitπ end;π Until iores = 0;π fsize := FileSize (fsrc);π GetFTime (fsrc, ftime);π GetFAttr (fsrc, fattr);π Repeatπ Repeatπ cnt := FilePos (fsrc);π BlockRead (fsrc, buffer^, bufsize, rd);π iores := IOResult;π If iores <> 0 Then beginπ If Error (iores) = 1 Then begin {abort?}π Close (fsrc); {* }π Close (fdest); {* hier könnte man auch}π Erase (fdest); {* Error aufrufen, naja...}π CopyFile := 4;π Exit;π end;π Seek (fsrc, cnt); {step back on retry!}π end;π Until iores = 0;π if rd > 0 thenπ Repeatπ cnt1 := FilePos (fdest);π BlockWrite (fdest, buffer^, rd, wr);π iores := IOResult;π If (rd <> wr) or (iores <> 0) Then beginπ If Error (iores) = 1 Then begin {abort?}π Close (fsrc); {* }π Close (fdest); {* hier könnte man auch}π Erase (fdest); {* Error aufrufen, naja...}π CopyFile := 5;π Exit;π end;π Seek (fdest, cnt1); {step back on retry!}π end;π Until (rd = wr) and (iores = 0);π Progress (cnt, fsize, cnt * 100 div fsize);π Until (rd = 0) or (rd <> wr);π Close (fsrc);π Repeatπ Close (fdest); {close&flush}π iores := IOResult;π If iores <> 0 Then If Error (iores) = 1 Then Exit;π Until iores = 0;π Reset (fdest);π If IOResult <> 0 Then begin CopyFile := 6; Exit end;π SetFTime (fdest, ftime);π SetFAttr (fdest, fattr);π If IOResult <> 0 Then begin Close (fdest); CopyFile := 6; Exit end;π Close (fdest);πend;πππ{π TFileCopy.Progressπ ──────────────────ππ is called by CopyFile to allow displaying a progress bar or s.e.ππ Bytesdone Bytes read in and writtenπ Bytestotal Bytes to read&Write total (that is, File size)π percent amount done in percentππ}πProcedure TFileCopy.Progress (Bytesdone, Bytestotal: LongInt; percent:πInteger);πbeginπ {abstract - inherit For use!}πend;ππ{π TFileCopy.Errorπ ───────────────ππ is called by CopyFile if an error occured during the copy processππ code the IOResult code <> 0ππ should return an Integer value:ππ 0 Repeat actionπ 1 abortππ Note: TurboVision installs it's own Dos critical error handler, so youπ don't need to overWrite Error (only called if Abort is chosen fromπ the TV Error Msg) if you use CopyFile in a TV Program.ππ}πFunction TFileCopy.Error (code: Word): Integer;πbeginπ Error := 1;πend;πππend.πππ{π> Unit TVUtis;π>π> Wow...never seen so much code just to copy a File! =)ππwell, it's a quite extendable Object, and there's a lot of error-checking,πtoo. just see below... :-)ππ> I haven't tried OOP yet, and probably was lucky toππ> Anyways, I see you left out a progress display inπ> TFileCopy.Progress, but the Unit also has an a progress barπ> Object. Any way to marry the two?ππof course, that's why I put them together!πbut I didn't want to have the progress bar (and along With this Turbo Vision)πbeing an essential part of the FileCopy Object, since some guys might want toπWrite their own ProgressBars or use the whole Object in a non-TV Program.ππ> I implemented your TCopyFile like so...π>π> Uses Dos, TVUtis;π> Varπ> DoCopy: TFileCopy;π> F1, F2: PathStr;π> R: Integer;π> beginπ> F1 := 'C:\tp\copyf.pas';π> F2 := 'C:\copyf.pas';π> DoCopy.Init(4096);π> R := DoCopy.CopyFile(F1, F2);π> DoCopy.Done;π> Writeln(R);π> end.ππAbsolutely correct, no doubt. But poor Graphics... ;-)ππ> How would one modify that and TFileCopy.Progress to useπ> TProgressBar? From what I can surmise, you'd initπ> TProgressBar and then TFilecopy.Progress wouldπ> call it somehow, like TProgressBar.Update?π> I don't see what I should put For the totalwork ofπ> TProgressBar.Init; the size of the File? Then thatπ> means I must cal TProgress.Init from insideπ> TFileCopy.CopyFile (after we have the size of theπ> File.) And TFileCopy.Progress would callπ> TProgressBar.Update.ππfirst of all: The TProgressBar Object is written For Turbo Vision, you can'tπuse it within a non-TV Program. Next, you have to derive your own Object fromπTFileCopy and overWrite the method Progress that calls TProgressBar. Take theπfollowing as an example:π}ππTypeπ PXFileCopy = ^TXFileCopy;π TXFileCopy = Object (TFileCopy)π AProgressBar: PProgressBar;π ConstRUCTOR Init (BufferSize: Word; ProgBar: PProgressBar);π Procedure Progress (Bytesdone, Bytestotal: LongInt;π percent: Integer); VIRTUAL;π end;ππConstRUCTOR TXFileCopy.Init (BufferSize: Word; ProgBar: PProgressBar);πbeginπ inherited Init (BufferSize); { or TFileCopy.Init For TP 6 }π AProgressBar := ProgBar;πend;ππProcedure TXFileCopy.Progress (Bytesdone, Bytestotal: LongInt;π percent: Integer);πbeginπ if AProgressBar <> NIL thenπ AProgressBar^.UpdatePercent (percent);πend;π{πYou then would use this Object (in a Turbo Vision Program) as follows:π}ππFunction TMyApp.CopyFile (source, dest: PathStr): Integer;πVarπ Dlg: TDialog;π MyBar: PProgressBar;π R: TRect;π DoCopy: TXFileCopy;πbeginπ R.Assign (0,0,40,8);π Dlg.Init (R, 'Copying File...');π Dlg.Options := Dlg.Options or ofCentered;π Dlg.Flags := Dlg.Flags and not wfClose;π R.Assign (2,2,38,4);π Dlg.Insert (New (PStaticText, Init (R, ^C'copying '+source+#13+π ^C'to '+dest+', please wait...')));π R.Assign (2,5,38,6);π Dlg.Insert (New (PStaticText, Init (R,π '0% 50% 100%')));π R.Move (0, 1);π MyBar := New (PProgressBar, Init (R, '░', '▓', 0));π Dlg.Insert (MyBar);π Desktop^.Insert (@Dlg);π DoCopy.Init (4096, MyBar);π ErrorCode := DoCopy.CopyFile (source, dest);π DoCopy.Done;π Dlg.Done;π if ErrorCode <> 0 thenπ MessageBox ('Error copying File!', NIL, mfError+mfOkButton);πend;ππ{πIf you don't want to have any progress bar at all, just pass NIL instead ofπMyBar to DoCopy.Init. And maybe you want to add this Functionality directly toπTFileCopy rather than deriving a new Object.π}π 13 05-28-9313:53ALL SWAG SUPPORT TEAM OOPINFO.PAS IMPORT 240 dp My understanding of OOP revolves around three principles:ππ ENCAPSULATION: All data-Types, Procedures, Functions are placedπ within a new Type of wrapper called an Object.ππ This new wrapper is very simillar to a standardπ Record structure, except that it also containsπ the routines that will act on the data-Typesπ within the Object.ππ The Object-oriented style of Programming requiresπ that you should ONLY use the routines within theπ Object to modify/retrieve each Object's data-Types.π (ie: Don't access the Variables directly.)πππ Structured Style OOP Styleπ ================ =========π MyRecord = Record MyObject = Objectπ 1st Variable; 1st Variable;π 2nd Variable; 2nd Variable;π 3rd Variable 3rd Variable;π end; Procedure One;π Procedure Two;π Function One;π Function Two;π end;ππ inHERITANCE: This gives you the ability to make a new Object byπ cloning an old Object. The new Object will containπ all the abilities of the old Object.π (ie: Variables, Procedures/Functions).ππ You can add additional abilities to this new Object,π or replace old ones.ππ +--------------+π | New Object |π | +--------+ |π | | Old | |π | | Object | |π | +--------+ |π +--------------+ππ With Inheritance, you don't have to go back andπ re-Write old routines to modify them into newπ ones. Instead, simply clone the old Object andπ add or replace Variables/Procedures/Functions.ππ This makes the whole process of rewriting/modifyingπ a Program MUCH faster/easier. Also there is lessπ chance of creating new bugs from your old bug-freeπ source-code.πππ POLYMorPHISM: The name Sounds intimidating, but the concept isπ simple.ππ Polymorphism allows one Procedure/Function toπ act differently between one Object and all itsπ descendants. (Clones)ππ These Type of "polymorphic" Procedures/Functionsπ know which Object they are working on, and actπ accordingly. For example:ππ Say you've created an Object (Object-1) thatπ contains a Procedure called DrawWindow, to drawπ the main screen of a Program.ππ DrawWindow relies on another Procedure SetBorderπ within Object-1, to set the borders used in theπ main screen.ππ Now you clone Object-2 from Object-1.ππ You want to use Object-2 to handle pop-up Windows,π but you want the pop-ups to have a different borderπ style.ππ if you call the DrawWindow Procedure that Object-2π inherited from Object-1, you'll end up With a Windowπ With the wrong border-style.ππ to get around this you could change the SetBorderπ Procedure to a "Virtual" Procedure, and add aπ second identically named "Virtual" Procedureπ (SetBorder) within Object-2.ππ A "Virtual" Procedure relies on a "Virtual Table"π (Which is basicly a Chart to indicate whichπ "Virtual" routine belongs to which Object)π to, indicate which version of the identicallyπ named Procedures should be used within differentπ Objects.ππ So within Object-1, the DrawWindow routine willπ use the SetBorder Procedure within Object-1.ππ Within Object-2, the inherited DrawWindow routineπ will use the other SetBorder Procedure that belongsπ to Object-2.ππ This works because the "Virtual Table" tells theπ DrawWindow routine which SetBorder Procedure toπ use For each different Object.ππ So a call to the SetBorder Procedure now actsπ differently, depending on which Object called it.π This is "polymorphism" in action.πππ OOP LANGUAGE LinGO: The following are some of the proper names Forπ OOP syntax.ππ Structured Programming OOP Programmingπ ====================== ===============π Variables Instancesπ Procedures/Functions Methodsπ Types Classesπ Records Objectsππ{π> i have a parent Object defined With Procedure a and b.π> i have a child Object With Procedure a, b and c.ππ> when i declare say john being a child, i can use a, b, or c With noπ> problem. when i declare john as being a parent, i can use a or b.ππ> if i declare john as being a parent and initialise it withπ> new (childPTR,init) it seems i have access to the parent fieldsππAfter reading twice, I understand you mean Object classes dealing With humans,πnot trees (happen to have parents & childs too).ππ> parent a,b,c,d,e,fπ (bad)π> parent a,bπ (good)π> child a,b,cπ> child2 a,b,dπ> child3 a,b,e,fπ (redefine a, b For childs as Far as they differ from parent a,b)ππNext example could be offensive For christians, atheists and media-people.π}ππTypeπ TParent = Object { opt. (tObject) For Stream storage }π Name : String;π Constructor Init(AName: String);π Procedure Pray; { your A,π they all do it the same way }π Procedure Decease; Virtual; { your B, Virtual, some instancesπ behave different (Heaven/Hell) }π Destructor Done; Virtual;π end;π TChild1 = Object(TParent)π Disciples : Byte;π Constructor Init(AName: String; DiscipleCount: Byte);π { do not override Decease } { calling it will result in aπ call to TParent.Decease }π Procedure Resurrection; { your C }π end;π TChild2 = Object(TParent)π BulletstoGo : LongInt;π Constructor Init(DisciplesCount: Byte; Ammo: LongInt);π Procedure Decease; Virtual; { override }π Procedure Phone(Who: Caller); { your D }π end;ππ Constructor TParent.Init(AName: String);π beginπ Name := AName;π end;π Destructor TParent.Done;π beginπ {(...)}π end;π Procedure TParent.Pray;π beginπ ContactGod;π end;π Procedure TParent.Decease;π beginπ GotoHeaven;π end;ππ Constructor TChild1.Init(AName: String; DiscipleCount: Byte);π beginπ inherited Init(AName);π Disciples := DiscipleCount;π end;π Procedure TChild1.Resurrection;π beginπ RiseFromTheDead;π end;ππ Constructor TChild2.Init(AName: String;π DiscipleCount: Byte; Ammo: LongInt);π beginπ inherited Init(DiscipleCount);π BulletstoGo := Ammo;π end;π Procedure TChild2.Decease;π beginπ EternalBurn;π end;π Procedure TChild2.Phone(Who: Caller);π beginπ Case Who ofπ AFT : Ventriloquize;π Media : Say('Burp');π end;π end;π{πIn the next fragment all three Types of instances are put into a collection.π}πVarπ Christians : PCollection;ππbeginπ Christians := New(PCollection, Init(2,1));π With Christians^ do beginπ Insert(PParent, Init('Mary'));π Insert(PParent, Init('John'));π Insert(PChild1, Init('Jesus', 12));π Insert(PChild2, Init('Koresh', 80, 1000000));π end;π{πNow you can have all instances pray ...π}π Procedure DoPray(Item: Pointer); Far;π beginπ { unTyped Pointers cannot have method tables. The PParentπ Typecast Forces a lookup of Pray in the method table.π All instances With a TParent ancestor will point toπ the same (non-Virtual) method }π PParent(Item)^.Pray;π end;π { being sure all Items in Christians are derived from TParent }π Christians^.ForEach(@DoPray);π{πand because all mortals will die...π}π Procedure endVisittoEarth(Item: Pointer); Far;π beginπ { Decease is a Virtual method. The offset of a location inπ the VMT With the address of a Virtual method is determined byπ the Compiler. At run-time, For each Type of instance 1 VMTπ will be created, it's method-fields filled With theπ appropriate addresses to call.π Each instance of an Object derived from TParent will have theπ address of it's VMT at the same location. Calling a Virtualπ method results inπ 1) retrieving that VMT address at a known offset inπ the instance's data structureπ 2) calling a Virtual method at a known offset in theπ VMT found in 1)π ThereFor mr. Koresh will go to hell: PChild2's VMT containsπ at the offset For Decease the address of the overriddenπ method. Mr. Jesus, a PChild1 instance, simply inherits theπ address of PParent's Decease method at that offset in theπ VMT. }π PParent(Item)^.Decease;π end;π Christians^.ForEach(@endVisittoEarth);ππππ-> ...I've no problem posting my code, but I'm still not Really happyπ-> With it's present Implementation. I also don't think that dynamicπ-> Array Objects are very good examples of OOP. (For example, whatπ-> do extend the dynamic-Array Object into, via inheiritance???)π->π-> ...Something more like a generic "Menu" or "Line-Editor" Objectπ-> might be a better example.ππWell I don't know exactly what you are trying to do With your dynamicπArray but it can be OOP'ed. Linked lists are a prime example (I hopeπthis is close) By using OOP to Write link lists you can come up withπObjects such as:ππTypeπ ListPtr = ^List;π NodePtr = ^ListNode;ππ List (Object)π TNode : Pointer; {Pointer to the top Record}π BNode : Pointer; {Pointer ro the bottom Record}π CurNode : Pointer; {Current Pointer}ππ Constructor Init; {Initializes List Object}π Destructor Done; Virtual; {Destroys the list and all its nodes}ππ Function top (Var Node : ListNode) : NodePtr;π Function Bottom (Var Node : ListNode) : NodePtr;π Function Next (Var Node : ListNode) : NodePtr;π Function Prev (Var Node : ListNode) : NodePtr;π Function Current(Var Node : ListNode) : NodePtr;ππ Procedure AttachBeFore (Var Node : ListNode);π Procedure AttachAfter (Var Node : ListNode);π Procedure Detach (Var NodePtr : Pointer);ππ end;ππ ListNode = Object;π Prev : NodePtr;π Next : NodePtr;ππ Constructor Init;π Destructor Done; Virtual;ππ end;ππThe list Object is just that. It has the basic operations you would doπwith a list. You can have more than one list but only one set ofπmethods will be linked in. The List node Dosn't have much other thanπthe Pointers to link them into a list and an Init, done methods. Soundsπlike a ton of work just to implement a list but there is so much you canπdo easely With OOP that you would have a hard time doing conventionally.πOne example, because the ListNode's Done Destructor is Virtual the Doneπof the list can accually tranvirs the list and destroy all Objects inπthe list. One list can accually contain Objects that are not theπsame!!! Yep it sure can. As long as an Object is dirived from ListNodeπthe list can handel it. Try to do that using conventional methods!!ππI'm assuming that your dynamic Array will do something similar which isπwhy I suggested it. A Menu and Line editor Objects are High levelπObjects that should be based on smaller Objects. I'd assume that a lineπeditor would be a Complex list of Strings so the list and ListNodeπObjects would need to be built. See what I mean???ππthen you get into Abstract Objects. These are Objects that defineπcommon methods For its decendants but do not accually have any code toπsuport them. This way you have set up a standard set of routines thatπall decendants would have and Programs could be written using them. THeπresults of which would be a Program that could handel any Object basedπon the abstract.ππ-> RM>I have mixed feeling on this. I see OOP and Object as tools For aπ-> RM>Program to manipulate.π->π-> RM> IE: File Objects, Screen Objects, ect then bind them togetherπ-> RM> in a Program using conventional style coding.π->π-> ...to my understanding of the OOP style of Programming, this wouldπ-> be a "NO-NO".ππOK well With the exception of TApplication Object in Turbo Vision aπProgram is a speciaized code that more than likely can't be of any useπFor decendants. That was my reasioning at least. and the Tapp Objectπisn't a Program eather. YOu have to over ride a ton of methods to getπit to do anything.πUnit OpFile; {******* Capture this For future referance *******}ππInterfaceππTypeππDateTimeRec = Recordπ {Define the fields you want For date and time routines}π end;ππAbstractFile = Objectππ Function Open : Boolean; Virtual;π {Opens the File in the requested mode base on internal Variables }π {Returns True if sucessfull }ππ Procedure Close; Virtual;π {Flush all buffers and close the File }ππ Function Exists : Boolean; Virtual;π {Returns True is the File exists }ππ Function Create : Boolean; Virtual;π {Will create the File or overWrite it if it already exists }ππ Procedure Delete; Virtual;π {Will delete the File. }ππ Function Rename : Boolean; Virtual;π {Will rename the File returns True if successfull }ππ Function Size : LongInt; Virtual;π {Returns the size of the File. }ππ Procedure Flush; Virtual;π {Will flush the buffers without closing the File. }ππ Function Lock : Boolean; Virtual;π {Will attempt to lock the File in a network enviroment, returns }π {True if sucessfull }ππ Procedure Unlock; Virtual;π {Will unlock the File in a network enviroment }ππ Function Copy (PathName : String) : Boolean; Virtual;π {Will copy its self to another File, returns True is successfull.}ππ Function GetDateTime (Var DT : DateTimeRec) : Boolean; Virtual;π {Will get the File date/time stamp. }ππ Function SetDateTime (Var DT : DateTimeRec) : Boolean; Virtual;π {Will set the File date stamp. }ππ Function GetAttr : Byte; Virtual;π {Will get the File attributes. }ππ Function SetAttr (Atr : Byte) : Boolean; Virtual;π {Will set a File's attributes. }ππend; {of AbstractFile Object}ππImplementationππ Procedure Abstract; {Cause a run time error of 211}π beginπ Runerror (211);π end;ππ Function AbstractFile.Open : Boolean;π beginπ Abstract;π end;ππ Procedure AbstractFile.Close;π beginπ Abstract;π end;ππ Function AbstractFile.Exists : Boolean;π beginπ Abstract;π end;ππ Function AbstractFile.Create : Boolean;π beginπ Abstract;π end;ππ Procedure AbstractFile.Delete;π beginπ Abstract;π end;ππ Function AbstractFile.Rename : Boolean;π beginπ Abstract;π end;ππOk theres a few things we have to talk about here.ππ1. This is an ABSTRACT Object. It only defines a common set ofπroutines that its decendants will have.ππ2. notice the Procedure Abstract. It will generate a runtime errorπ211. This is not defined by TP. Every Method of an Object has to doπsomthing. if we just did nothing we could launch our Program intoπspace. By having all methods call Abstract it will error out theπProgram and you will know that you have called and abstract method.ππ3. I'm sure some may question why some are Procedures and some areπFunctions ie Open is a Function and close is a Boolean. What I basedπthem on is if an error check a mandatory it will be a Function Boolean;πThis way loops will be clean. Open in a network Open will require aπcheck because it may be locked. Which brings up point 4.ππ4. We are not even finished With this Object yet. We still have toπdefine a standard error reporting / checking methods and also lock loopπcontrol methods. not to mention some kind of common data and methods toπmanipulate that data. Moving to point 5.ππ5. Where does it end??? Well we hvae added quite a few Virtual methodsπWhile thsi is not bad it does have a negative side. All Virtual methodsπwill be linked in to the final EXE weather it is used or not. There areπvalid reasions For this but you don't want to make everything Virtual ifπit Dosn't have to be. My thinking is this. if it should be a standardπroutine For all decendants then it should be Virtual. if requiredπmethods call a method then why not make it Virtual (this will becomeπmore apparent in network methods and expanding this Object)ππNow personally I get a feeling that the DateTime and Attr methodsπshouldnn't be there or at least not Virtual as the vast majority ofπPrograms will not need them and its pushing the limits of Operatingπsystem spisific methods. SO it will probly be a Dos only Object. (Yesπthere are others that have this but I think its over kill) The sameπgoes For the copy and rename methods so I would lean to removing themπfrom this Object and define them in decendants.ππSo what do you think we need to have For error checking / reportingπmethods??? Do you think we could use more / different methods???πππ{π DW> I am trying to teach myself about Object orientated Programming andπ DW> about 'inheritence'. This is my code using Records.ππThe idea of Object oriented Programing is what is refered to asπencapsulation. Your data and the Functions that manipulate it areπgrouped together. As an example, in a traditional Program, a linkedπlist would look something like:π}ππTypeπ Linked_List =π Recordπ Data : Integer; {Some data}π Next : ^Linked_List; {Next data}π Prev : ^Linked_List; {Prev data}π end;ππthen you would have a whole slew of Functions that took Linked_List as aπparameter. Under OOP, it would look more likeππTypeπ Linked_List =π Objectπ Data : Integer;π Next : ^Linked_List;π Prev : ^Linked_List;ππ Constructor Init(); {Initializes Linked_List}π Destructor DeInit(); {Deinitializes Linked_List}π Procedure AddItem(aData : Integer);π Procedure GetItem(Var aData : Integer);π end;ππthen, to add an item to a particular list, the code would look like:πThis_Linked_List.AddItem(10);ππThis is easier to understand. An easy way to think about this is thatπan Object is an entity sitting out there. You tell it what you want toπdo, instead of calling a Function you can't identify. Inheritanceπallows you to make a linked list that holds a different Type, but Usesπthe same Interface funtions. More importantly, using the same methodπand Pointers, you could have both Types in the same list, depending onπhow you implemented it.ππIt helps debugging time, because if you wanted to add a Walk_ListπFunction, you could add it and get it working For the parent Object, andπ(since the mechanics of it would be the same For ANY Linked List), youπcould Write it once and use it without problems. That is a clearπadvantage. Other Uses include:ππ(For a door Type Program) and Input/Output Object that serves as a baseπFor a console Object and a modem Object, and thusly allows you to treatπthe two as the same device, allowing you to easily use both.ππ(For a BBS Message base kit) a Generic Message Object that serves as aπbase For a set of Objects, each of which implements a different BBS'πdata structures. Using this kit, a Program could send a message to anyπof the BBSes just by knowing the core Object's mechanics.ππ(For Windows) a Generic Object represents a Generic Window. Byπinheritance, you inherit the Functionality of the original Window. Byπcreating an Object derived from the generic Window, you can addπadditional Functionality, without having to first Write routines toπmirror existing Functionality.ππ(For Sound) a Generic Object represents a generic Sound device.πSpecific child Object translate basic commands (note on, note off, etc)πto device specific commands. Again, the Program doesn't have to knowπwhether there is a PC speaker or an Adlib or a SoundBlaster--all it hasπto know is that it calls note_on to start a note and note_off to end aπnote.ππThere are thousands on thousands of other examples. if you read throughπthe turbo guides to turbovision or to Object oriented Programming, theyπwill help you understand. Also, a good book on Object orientedπProgramming doesn't hurt ;>.πππππ{π> Now, the questions:π> 1. How do I discretly get the Lat & Long into separateπ> Collections? In other Words (psuedocode):ππNo need For seperate collections, put all the inFormation in a Singleπcollection.ππ> Any hints would be appreciated. Thanks!ππI'll not give any help With parsing the Text File, there will probably be a tonπof advice there, but here is a little Program that I threw together (andπtested) that will list the inFormation and present the additional data.πHave fun With it.π}ππProgram Test;πUses Objects,dialogs,app,drivers,views,menus,msgbox;ππTypeπ (*Define the Data Element Type*)π Data = Recordπ Location : PString;π Long,Lat : Real;π end;π PData = ^Data;ππ (*Define a colection of the data elements*)π DataCol = Object(TCollection)π Procedure FreeItem(Item:Pointer); Virtual;π end;π PDC =^DataCol;ππ (*Define a list to display the collection*)π DataList = Object(TListBox)π Function GetText(item:Integer;maxlen:Integer):String; Virtual;π Destructor done; Virtual;π end;π PDL = ^DataList;ππ (*Define a dialog to display the list *)π DataDlg = Object(TDialog)π Pc : PDC;π Pl : PDL;π Ps : PScrollBar;π Constructor Init(Var bounds:Trect;Atitle:TTitleStr);π Procedure HandleEvent(Var Event:TEvent); Virtual;π end;π PDD = ^DataDlg;ππConstπ CmCo = 100;π CmGo = 101;πππProcedure DataCol.FreeItem(Item:Pointer);π beginπ disposeStr(PString(PData(Item)^.Location));π dispose(PData(Item));π end;ππFunction DataList.GetText(item:Integer;maxlen:Integer):String;π beginπ GetText := PString(PData(List^.At(item))^.Location)^;π end;ππDestructor DataList.Done;π beginπ Dispose(PDC(List),Done);π TListBox.Done;π end;ππConstructor DataDLG.Init(Var bounds:Trect;Atitle:TTitleStr);π Varπ r : trect;π pd : pdata;π beginπ TDialog.Init(bounds,ATitle);π geTextent(r); r.grow(-1,-1); r.a.x := r.b.x - 1; dec(r.b.y);π new(ps,init(r)); insert(ps);ππ geTextent(r); r.grow(-1,-1); dec(r.b.x); dec(r.b.y);π new(pl,init(r,1,ps)); insert(pl);ππ geTextent(r); r.grow(-1,-1); r.a.y := r.b.y - 1;π insert(new(pstatusline,init(r,π newstatusdef(0,$FFFF,π newstatuskey('~[Esc]~ Quit ',kbesc,CmGo,π newstatuskey(' ~[Alt-C]~ Co-ordinates ',kbaltc,CmCo,π newstatuskey('',kbenter,CmCo,nil))),nil))));ππ new(Pc,init(3,0));π With pc^ do (*parse your File and fill the*)π begin (*collection here *)π new(pd);π pd^.location := newstr('Port Arthur, Texas');π pd^.long := 29.875; pd^.lat := 93.9375;π insert(pd);π new(pd);π pd^.location := newstr('Port-au-Prince, Haiti');π pd^.long := 18.53; pd^.lat := 72.33;π insert(pd);π new(pd);π pd^.location := newstr('Roswell, New Mexico');π pd^.long := 33.44118; pd^.lat := 104.5643;π insert(pd);π end;π Pl^.newlist(pc);π end;ππProcedure DataDlg.HandleEvent(Var Event:TEvent);π Varπ los,las : String;π beginπ TDialog.HandleEvent(Event);π if Event.What = EvCommand thenπ Case Event.Command ofπ CmGo : endModal(Event.Command);π CmCo : beginπ str(PData(Pl^.List^.At(Pl^.Focused))^.Long:3:3,los);π str(PData(Pl^.List^.At(Pl^.Focused))^.Lat:3:3,las);π MessageBox(π #3+PString(PData(Pl^.List^.At(Pl^.Focused))^.Location)^ +π #13+#3+'Longitude : '+los+#13+#3+'Latitude : '+las,π nil,mfinFormation+mfokbutton);π end;π end;π end;ππType (*the application layer *)π myapp = Object(Tapplication)π Procedure run; Virtual;π end;ππProcedure myapp.run;π Var r:trect;π p:PDD;π beginπ geTextent(r);π r.grow(-20,-5);π new(p,init(r,'Dialog by ken burrows'));π if p <> nil thenπ beginπ desktop^.execview(p);π dispose(p,done);π end;π end;ππVarπ a:myapp;ππbeginπ a.init;π a.run;π a.done;πend.πππππ> I am having a problem. I would like to Write an editor. Theπ> problem is I dont understand a thing about Pointers (which everyoneπ> seems to use For editors).ππ I'm certainly no TP expert, but I might be able to help out With theπPointers. Pointers are just special 4-Byte Variables that contain (πpoint to) a specific position in memory. You can also make a Pointerπact like the thing to which it is pointing is a particular Type ofπVariable (Byte, String, etc). Unlike normal Var Variables, however, theseπVariables are what's referred to as Virtual -- they aren't fixed in theπ.EXE code like Var Vars, so you can have as many of them as you like,πwithin memory Constraints. Each is created when needed using the GetMemπstatement. This statement makes a request For some more memory to beπused in the heap (all left-over memory when the Program loads usually).ππWhat you need in a editor is to be able to somehow link the Stringsπthat make up the document into what's called a list (first line, next,π... , last line). The easiest way to visualize this is a bunch of peopleπin a line holding hands, each hand being a Pointer. The hand is not theπentire person, it just connects to the next one. So, what you do isπuse a Record that contains one String For one line of Text, a Pointer toπthe previous line of Text in the document, and a Pointer to the next lineπin the document. A Record like this should do it:π {+------------------------- Usually used in starting a Type of Pointer}π {|+------------------------ Points to a String in the document }π {|| +----------- This is usedto mean that PStringItem is }π || | to be a Pointer pointing to a Record }π || | known as TStringItem }π {vv vπType PStringItem = ^TStringItem;π TStringItem : Recordπ LineOText : String [160]; {Double the screen width should do it}π NextLine : PStringItem; {Points to the next line in memory}π PrevLine : PStringItem; {Points to the previous line in memory}π end;ππIn your editor main Program, useππVar FirstLine, LastLine, StartLine, CurrLine : PStringItem;ππto create Varibles giving you `bookmarks' to the first line in theπFile, last in the File, the one the cursor is on, and the one thatπstarts the screen. All of these will change.ππto create the first line in the document, use:ππGetMem (FirstLine, Sizeof (TStringItem)); {get memory enough For one line}πCurrLine := FirstLine; {of course, only one line in the doc so Far!}πLastLine := FirstLine;πStartLine := FirstLine;πFirstLine^.NextLine := nil; {nil means no particular place-- there's no}πFirstLine^.PrevLine := nil; {line beFore of after FirstLine yet }ππNow the Variable FirstLine will contain the address of the newly createdπVariable. to address that Variable, use the carrot (^), like this:ππFirstLine^.LineOText := 'Hello World!');ππto make a new line in the list just get more memory For another line:ππGetMem (LastLine^.NextLine, Sizeof (TStringItem));πLastLine := LastLine^.NextLine;ππThis will get more memory and set the last line in the File'sπnext line Pointer to the new String, then make the new String theπlast line.ππDeleting a line is almost as simple. You use the FreeMem Procedureπto release the memory used by a Variable. if it's in the middle of theπlist, just set the to-be-deleted's next line's previous line to theπto-be deleted's previous line, and the previous line's next to the oneπafter the one to be deleted, essentially removing it from the list andπthen tieing the peices back together. You can then kill off the memoryπused by that line.ππ{Delete current line}πif CurrLine^.NextLine <> nil then {there's a line after this one}π CurrLine^.NextLine^.PrevLine := CurrLine^.PrevLine;πif CurrLine^.PrevLine <> nil then {there's a line beFore this one}π CurrLine^.PrevLine^.NextLine := CurrLine^.NextLine;πFreeMem (CurrLine, Sizeof (TStringItem));ππto insert a line, just do about the opposite.ππif you don't understand, I won't blame you, I'm half asleep anyway...πbut I hoe it clears some of the fog. if the manual isn't helpfulπenough now, try tom Swan's _Mastering Turbo Pascal_, an excellentπbook.π 14 05-28-9313:53ALL SWAG SUPPORT TEAM OOPMENU.PAS IMPORT 17 dC {πMenus in TV are instances of class tMenuBar, accessed via Pointer TypeπpMenuBar. A Complete menu is a Single-linked list, terminated With a NILπPointer. Each item or node is just a Record that holds inFormation onπwhat the node displays and responds to, and a Pointer to the next menuπnode in the list.ππI've written out a short bit of TV menu code that you can Compile andπplay With, and then you can highlight parts that you don't understandπwhen you send back your reply.π}ππProgram TestMenu;ππUsesπ Objects, Drivers, Views, Menus, App;ππConstπ cmOpen = 100; (* Command message Constants *)π cmClose = 101;ππTypeπ pTestApp = ^tTestApp;π tTestApp = Object(tApplication)π Procedure InitMenuBar; Virtual; (* Do-nothing inherited method *)π end; (* which you override *)ππ(* Set up the menu by filling in the inherited method *)πProcedure tTestApp.InitMenuBar;πVarπ vRect : tRect;ππbeginπ GetExtent(vRect);π vRect.B.Y := vRect.A.Y + 1;π MenuBar := New(pMenuBar, Init(vRect, NewMenu(π NewSubMenu('~F~ile', hcNoConText, NewMenu(π NewItem('~O~pen', 'Alt-O', kbAltO, cmOpen, hcNoConText,π NewItem('~C~lose', 'Alt-C', kbAltC, cmClose, hcNoConText,π NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoConText,π NIL)))),π NewSubMenu('~E~dit', hcNoConText, NewMenu(π NewItem('C~u~t', 'Alt-U', kbAltU, cmCut, hcNoConText,π NewItem('Cop~y~', 'Alt-Y', kbAltY, cmCopy, hcNoConText,π NewItem('~P~aste', 'Alt-P', kbAltP, cmPaste, hcNoConText,π NewItem('C~l~ear', 'Alt-L', kbAltL, cmClear, hcNoConText,π NIL))))),π NewSubMenu('~W~indow', hcNoConText, NewMenu(π NewItem('Ca~s~cade', 'Alt-S', kbAltS, cmCascade, hcNoConText,π NewItem('~T~ile', 'Alt-T', kbAltT, cmTile, hcNoConText,π NIL))),π NIL))))π ))πend;ππVarπ vApp : pTestApp;ππbeginπ New(vApp, Init);π if vApp = NIL thenπ beginπ WriteLn('Couldn''t instantiate the application');π Exit;π end;π vApp^.Run;π vApp^.Done;πend.π 15 05-28-9313:53ALL SWAG SUPPORT TEAM OOPOBJS.PAS IMPORT 46 d╧k Unit OopObjs;ππ{ OOPOBJS.PAS Version 1.1 Copyright 1992 Scott D. Ramsay }ππ{ OOPOBJS.PAS is free! Go crazy. }π{ When I was learning Linked-List in High School, I thought that I'd only }π{ need it in boring stuff like database Programming. Doubled linked-list, }π{ is a great way to handle multiple Objects For games. Throw in some OOP }π{ design and Volia! Easy managable sprites. }π{ I give this code to Public Domain. Use it as you see fit. Just include }π{ the first comment line when distributing the source code, Thanks. }ππ{ Changes from 1.0: }π{ Added new parameter in method checkhit. }π{ Var item:pobj }π{ Is a Pointer to the Object which called the checkhit }ππInterfaceππTypeπ plist = ^tlist;π PObjs = ^tobjs;π tobjs = Objectπ nx,ny, { Sprite Position }π flp, { Sprite number (For animation) }π nrx, { I Forget what this does }π num_sprite, { Num of sprites per Objects }π timeo, { How long this Object lasts }π pointage : Integer; { Score value (For gamers) }π mapcolor : Byte; { Color For radar display }π id, { I Forget this one too }π explo, { True if the Object is explodin}π overshow : Boolean; { See: Procedure DRAWITEMS }π powner : plist; { The PLIST node which this }π { Object belongs }π Constructor init(vx,vy:Integer);π Procedure drawitemObject;Virtual;π Procedure calcitemObject;Virtual;π Function checkhit(hx,hy:Integer;Var item:pobjs):Boolean;Virtual;π Destructor done; Virtual;π end;π PobjMov = ^tobjMov;π tobjMov = Object(tobjs)π ndx,ndy : Integer;π Constructor init(vx,vy,vdx,vdy:Integer);π Procedure calcitemObject; Virtual;π end;π tlist = Recordπ item : pobjs;π prev,next : plist;π end;π pkill = ^tkill;π tkill = Recordπ tk : plist;π next : pkill;π end;ππProcedure addp(Var nkbeg,nkend,p:plist);πProcedure deletep(Var nkbeg,nkend,p:plist);πProcedure calcitems(Var nkbeg:plist);πProcedure drawitems(Var nkbeg:plist;over:Boolean);πProcedure add2kill_list(Var kill:pkill;Var i:plist);πProcedure cleankill_list(Var kill:pkill;Var nkbeg,nkend:plist);πProcedure clean_plist(Var nkbeg,nkend:plist);ππImplementationππProcedure calcitems(Var nkbeg:plist);πVarπ p : plist;πbeginπ p := nkbeg;π While p<>nil doπ beginπ p^.item^.calcitemObject;π p := p^.next;π end;πend;πππProcedure drawitems(Var nkbeg:plist;over:Boolean);π{π This Procedure is usually called from: (GMorPH.PAS)π Tmorph.pre_mapπ Tmorph.post_mapπ The OVER flag tells when this Object should be drawn. Behindπ geomorph or infront of the geomorph.π}πVarπ p : plist;πbeginπ p := nkbeg;π While p<>nil doπ beginπ if (p^.item^.overshow=over)π then p^.item^.drawitemObject;π p := p^.next;π end;πend;πππProcedure clean_plist(Var nkbeg,nkend:plist);πVarπ p,p2 : plist;πbeginπ p := nkbeg;π While p<>nil doπ beginπ p2 := p;π p := p^.next;π dispose(p2^.item,done);π dispose(p2);π end;π nkbeg := nil;π nkend := nil;πend;πππProcedure addp(Var nkbeg,nkend,p:plist);πbeginπ p^.next := nil;π if nkend=nilπ thenπ beginπ nkbeg := p;π nkend := p;π p^.prev := nil;π endπ elseπ beginπ p^.prev := nkend;π nkend^.next := p;π nkend := p;π end;πend;πππProcedure deletep(Var nkbeg,nkend,p:plist);πbeginπ if nkbeg=nkendπ thenπ beginπ nkbeg := nil;π nkend := nil;π endπ elseπ if nkbeg=pπ thenπ beginπ nkbeg := nkbeg^.next;π nkbeg^.prev := nil;π endπ elseπ if nkend=pπ thenπ beginπ nkend := nkend^.prev;π nkend^.next := nil;π endπ elseπ beginπ p^.next^.prev := p^.prev;π p^.prev^.next := p^.next;π end;π dispose(p^.item,done);π dispose(p);πend;πππProcedure cleankill_list(Var kill:pkill;Var nkbeg,nkend:plist);πVarπ p,p2 : pkill;πbeginπ p := kill;π While p<>nil doπ beginπ p2 := p;π p := p^.next;π deletep(nkbeg,nkend,p2^.tk);π dispose(p2);π end;π kill := nil;πend;πππProcedure add2kill_list(Var kill:pkill;Var i:plist);πVarπ p : pkill;πbeginπ new(p);π p^.tk := i;π p^.next := kill;π kill := pπend;ππ(**) { tobjs Methods }ππConstructor tobjs.init(vx,vy:Integer);πbeginπ nx := vx; ny := vy; num_sprite := 1;π mapcolor := $fb; pointage := 0;π flp := 0; overshow := False;πend;πππDestructor tobjs.done;πbeginπend;πππProcedure tobjs.drawitemObject;πbeginπ { i.e.π fbitdraw(nx,ny,pic[flip]^);π }πend;πππProcedure tobjs.calcitemObject;πbeginπend;πππFunction tobjs.checkhit(hx,hy:Integer;Var item:pobjs):Boolean;πbeginπend;ππ(**) { tobjMov methods }ππConstructor tobjMov.init(vx,vy,vdx,vdy:Integer);πbeginπ nx := vx; ny := vy; ndx := vdx; ndy := vdy;π mapcolor := $fb; pointage := 0;π flp := 0; overshow := False;πend;πππProcedure tobjMov.calcitemObject;πbeginπ { These are just simple examples of what should go in the methods }π inc(nx,ndx); inc(ny,ndy);π flp := (flp+1)mod num_sprite;πend;ππend. 16 05-28-9313:53ALL SWAG SUPPORT TEAM SORTCOLL.PAS IMPORT 30 d░µ {πThis post is just to demonstrate a very simple sorted collection usingπnon-Object Types With the collection. If it is needed to store itselfπto a stream, it will need additional over-ridden methods to do that.πI'm just posting this, because I wrote it several days ago to implementπa simple Variable system in a script language For a menu Program that Iπwrote, and I was looking For an *easier* way to maintain the Variableπlist than With a linked list. To my astonishment, today, I needed aπsimilar structure, and (ohmygosh) I found that I could *re-use* thisπcode, by merely deriving a child class and adding another method or so.πThis is the first time that I have ever *re-used* an Object Type that Iπhave modified. Of course, I haven't been actually using TurboVision forπmore than a month or so, so I haven't had much of a chance, but it isπvery nice to see that when people talk about "Object orientedπProgramming paradigm", they are not ONLY speaking in big Words, but thatπthey also (apparently) are telling the truth.ππI'm not taking any responsibility if this overWrites your interruptπvector table, so be carefull. If you find any mistakes, or actuallyπmodify this code to become more usefull, I'd appreciate it if you couldπtell me- actually determining the best way to implement a new Objectπclass is kind of difficult For me since I've only been doing this forπabout a month, trying to squeeze it in along With school and a job.ππHere's the code...π{********* STARTS HERE **********}π{ Unit: STROBJ.PASπ WRITTEN BY: Brian Papeπ DATE: 03/28/93π Copyright 1993 by Brian Pape and Alphawave Technologiesπ This Unit contains String Type Objectsπ}π{$P+} { Enable open String parameters. Replace by $V- For TP 6.0 or lower }πUnit strobj;ππInterfaceππUsesπ Objects;ππTypeπ str20 = String[20];ππ PVarType = ^TVarType;π TVarType = Recordπ name : str20;π value : String;π end; { TVarType }ππ PVarCollection = ^TVarCollection;π TVarCollection = Object(TSortedCollection)π Constructor init(Alimit,Adelta:Integer);π Function KeyOf(item:Pointer):Pointer; virtual;π Function Compare(Key1,Key2:Pointer):Integer; virtual;π Procedure freeitem(Item:Pointer); virtual;ππ { This Function will return the value of a Variable in a TVarCollection }π Function getVar(s:String):String;ππ { Adds a PVarType Record to the collection, without having to manuallyπ create, and allocate memory for, a Record Type }π Procedure add(aname:str20;avalue:String);π end; { TVarCollection }ππImplementationππConstructor TVarCollection.init(ALimit,ADelta:Integer);πbeginπ inherited init(ALimit,ADelta);πend; { TVarCollection.init }ππFunction TVarCollection.KeyOf(item:Pointer):Pointer;πbeginπ KeyOf := @(TVarType(item^).name);πend; { TVarCollection.KeyOf }ππFunction TVarCollection.Compare(Key1,Key2:Pointer):Integer;πbeginπ if String(Key1^) > String(Key2^) thenπ Compare := 1π else if String(Key1^) = String(Key2^) thenπ Compare := 0π else Compare := -1;πend; { TVarCollection.Compare }ππProcedure TVarCollection.freeitem(Item:Pointer);πbeginπ dispose(Item);πend; { freeitem }ππFunction TVarCollection.getVar(s:String):String;πVarπ t : TVarType;π where : Integer;πbeginπ t.name := s;π if Search(@t,where) thenπ getVar := TVarType(at(where)^).valueπ elseπ getVar := '';πend; { getVar }πππProcedure TVarCollection.add(aname:str20;avalue:String);πVarπ rec : PVarType;πbeginπ rec := new(PVarType);π rec^.name := aname;π rec^.value := avalue;π insert(rec);πend; { add }ππbeginπend. { strobj }π{*********** endS HERE *************}π 17 05-28-9313:53ALL SWAG SUPPORT TEAM STATUDLG.PAS IMPORT 32 d╟ Program StatusDialogDemo;ππ Usesπ Crt,Objects,Drivers,Views,Dialogs,App;ππ Typeπ PDemo = ^TDemo;π TDemo = Object (TApplication)π Constructor Init;π end;ππ PStatusDialog = ^TStatusDialog;π TStatusDialog = Object (TDialog)π Message,Value: PStaticText;π Constructor Init;π Procedure Update (Status: Word; AValue: Word); Virtual;π end;ππ Constructor TDemo.Init;ππ Varπ D: PStatusDialog;π I: Integer;π E: TEvent;ππ beginπ TApplication.Init;π D := New (PStatusDialog,Init);π Desktop^.Insert (D);π For I := 1 to 10 doπ beginπ D^.Update (cmValid,I * 10);π if CtrlBreakHit thenπ beginπ CtrlBreakHit := False;π GetEvent (E); { eat the Ctrl-Break }π D^.Update (cmCancel,I * 10);π Repeat GetEvent (E) Until (E.What = evKeyDown)π or (E.What = evMouseDown);π Desktop^.Delete (D);π Dispose (D,Done);π Exit;π end;π Delay (1000); { simulate processing }π end;π D^.Update (cmOK,100);π Repeat GetEvent (E) Until (E.What = evKeyDown)π or (E.What = evMouseDown);π Desktop^.Delete (D);π Dispose (D,Done);π end;ππ Constructor TStatusDialog.Init;ππ Varπ R: TRect;ππ beginπ R.Assign (20,6,60,12);π TDialog.Init(R,'Processing...');π Flags := Flags and not wfClose;π R.Assign (10,2,30,3);π Insert (New (PStaticText,Init (R,'Completed Record xxx')));π R.Assign (27,2,30,3);π Value := New (PStaticText,Init (R,' 0'));π Insert (Value);π R.Assign (2,4,38,5);π Message := New (PStaticText,Init (R,π ' Press Ctrl-Break to cancel '));π Insert (Message);π end;ππ Procedure TStatusDialog.Update (Status: Word; AValue: Word);ππ Varπ ValStr: String[3];ππ beginπ Case Status ofπ cmCancel: beginπ DisposeStr (Message^.Text);π Message^.Text := NewStr (' Cancelled - press any key ');π Message^.DrawView;π end;π cmOK: beginπ DisposeStr (Message^.Text);π Message^.Text := NewStr (' Completed - press any key ');π Message^.DrawView;π end;π end;π Str (AValue:3,ValStr);π DisposeStr (Value^.Text);π Value^.Text := NewStr (ValStr);π Value^.DrawView;π end;ππ Varπ Demo: TDemo;ππ beginπ Demo.Init;π Demo.Run;π Demo.Done;π end.ππ {πGH> Can someone explain how exactly to display aπGH>parameterized Text field into a dialog Window? This is what IππHere is a dialog that I hope does what you want. It comes from Shazam,πa TV dialog editor and code generator. Also a great learning tool.πYOu can get it as SZ2.zip from Compuserve or from Jonathan Steinπdirectly at PO Box 346, Perrysburg OH 43552 fax 419-874-4922.ππ Function MakeDialog : PDialog ; Var Dlg :π PDialog ; R : TRect ; Control , Labl , Histryπ : PView ; begin R.Assign ( 0 , 10 , 37 , 23 ) ; New ( Dlg , Init ( Rπ , 'About #2' ) ) ;ππ R.Assign ( 10 , 2 , 26 , 3 ) ;π Control := New ( PStaticText , Init ( R ,π 'A Sample Program' ) ) ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 13 , 4 , 20 , 5 ) ;π Control := New ( PStaticText , Init ( R ,π 'Version' ) ) ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 21 , 4 , 28 , 5 ) ;π Control := New ( PParamText , Init ( R , '%-s ' , 1 ) )π Dlg^.Insert ( Control ) ;ππ R.Assign ( 8 , 6 , 29 , 7 ) ;π Control := New ( PStaticText , Init ( R ,π '(C) Copyright 19xx by' ) ) ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 8 , 8 , 29 , 9 ) ;π Control := New ( PStaticText , Init ( R ,π 'Anybody, Incorporated' ) ) ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 14 , 10 , 24 , 12 ) ;π Control := New ( PButton , Init ( R , ' O~K~ ' , cmOK , bfDefault));π Control^.HelpCtx := hcAbout2 ;π Dlg^.Insert ( Control ) ;ππ Dlg^.SelectNext ( False ) ;π MakeDialog := Dlg ;πend ;ππVarπ DataRec : Recordπ ParamField1 : PString ; { ParamText }π end ;ππ } 18 05-28-9313:53ALL SWAG SUPPORT TEAM STROBJ.PAS IMPORT 44 dΘ
Program KenTest;π{ a short program to check out collecting TObject Descendents, asπ opposed to binding data types directly to a collection object}ππUses Objects;πTypeπ PBaseData = ^BaseData;π BaseData = Object(TObject)π name : PString;π DType: Word;π Data : Pointer;π Constructor Init(AName:String;Var AData);π Procedure PutData(Var S:TStream); virtual;π Function GetData(Var S:TStream):Pointer; virtual;π Procedure SetData(Var ADAta); virtual;π Constructor Load(Var S:TStream);π Procedure Store(Var S:TStream); virtual;π Destructor Done; virtual;π end;πConstructor BaseData.Init(AName:String;Var AData);π Beginπ Name := NewStr(Aname);π Data := Nil;π SetData(AData);π End;πConstructor BaseData.Load(Var S:TStream);π Beginπ Name := S.ReadStr;π S.Read(DType,2);π Data := GetData(S);π End;πProcedure BaseData.SetData(Var AData);π Beginπ DType := 0;π End;πProcedure BaseData.Store(Var S:TStream);π Beginπ S.WriteStr(Name);π S.Write(DType,2);π PutData(S);π End;πFunction BaseData.GetData(Var S:TStream):Pointer;π Beginπ GetData := Nil;π End;πProcedure BaseData.PutData(Var S:TStream);π Beginπ End;πDestructor BaseData.Done;π Beginπ DisposeStr(Name);π End;ππTypeπ PStrData = ^StrData;π StrData = Object(BaseData)π Procedure PutData(Var S:TStream); virtual;π Function GetData(Var S:TStream):Pointer; virtual;π Procedure SetData(Var ADAta); virtual;π Destructor Done; virtual;π end;π LongPtr = ^LongInt;π PNumData = ^NumData;π NumData = Object(BaseData)π Procedure PutData(Var S:TStream); virtual;π Function GetData(Var S:TStream):Pointer; virtual;π Procedure SetData(Var ADAta); virtual;π Destructor Done; virtual;π end;ππProcedure StrData.PutData(Var S:TStream);π Beginπ S.WriteStr(PString(Data));π End;πFunction StrData.GetData(Var S:TStream):Pointer;π Beginπ GetData := S.ReadStr;π End;πProcedure StrData.SetData(Var AData);π Var S:String Absolute AData;π Beginπ Data := NewStr(S);π DType := 1;π End;πDestructor StrData.Done;π Beginπ DisposeStr(PString(Data));π Inherited Done;π End;ππProcedure NumData.PutData(Var S:TStream);π Beginπ S.Write(LongPtr(Data)^,SizeOf(LongInt));π End;πFunction NumData.GetData(Var S:TStream):Pointer;π Var L : LongPtr;π Beginπ New(L);π S.Read(L^,SizeOf(LongInt));π GetData := L;π End;πProcedure NumData.SetData(Var AData);π Var L:LongInt Absolute AData;π Beginπ DType := 2;π New(LongPtr(Data));π LongPtr(Data)^ := L;π End;πDestructor NumData.Done;π Beginπ Dispose(LongPtr(Data));π Inherited Done;π End;ππConstπRStrDataRec : TStreamRec = (ObjType : 19561;π VMTLink : Ofs(TypeOf(StrData)^);π Load : @StrData.Load;π Store : @StrData.Store);ππRNumDataRec : TStreamRec = (ObjType : 19562;π VMTLink : Ofs(TypeOf(NumData)^);π Load : @NumData.Load;π Store : @NumData.Store);ππProcedure ShowStuff(P:PCollection);π Procedure ShowName(P:PBaseData); far;π Beginπ if P^.Name <> Nilπ then Write(P^.Name^,' ');π Case P^.DType ofπ 1 : if PString(P^.Data) <> Nil then Writeln(PString(P^.Data)^);π 2 : writeln(LongPtr(P^.Data)^);π end;π end;π Beginπ P^.ForEach(@ShowName);π End;ππVarπ P : PCollection;π Ps : PDosStream;π m : Longint;π S : String;π I : LongInt;πBeginπ m := MaxAvail;π RegisterType(RCollection);π RegisterType(RStrDataRec);π RegisterType(RNumDataRec);π New(P,init(5,5));π if P <> Nil thenπ Beginπ S := 'String data # 1';π P^.insert(New(PStrData,init('A string data type ',S)));π S := 'String data # 2';π P^.insert(New(PStrData,init('A second string data type ',S)));π I := 1234567;π P^.Insert(New(PNumData,init('Numeric Data Type',I)));π S := 'String Data #3';π P^.Insert(New(PStrData,init('A third string data type ',S)));π I := 987654;π P^.Insert(New(PNumData,init('A second Numeric data type ',I)));π New(Ps,init('Test1.dta',StCreate));π if Ps <> Nil thenπ beginπ P^.Store(Ps^);π dispose(P,Done);π Dispose(Ps,Done);π if maxavail = m then writeln('mem disposed')π else writeln('Failed to release memory');π new(Ps,init('test1.dta',stopenread));π if Ps <> Nil thenπ Beginπ New(P,Load(Ps^));π dispose(Ps,done);π if P <> Nil then showstuff(P);π if p <> Nil then dispose(P,done);π end;π end;π end;π if maxavail = m then writeln('mem disposed')π else writeln('Failed to release memory');πEnd.ππ...kenπ---π * Origin: Telos Point of Source. Replied From Saved Mail. (Max 1:249/201.21)π 19 05-28-9313:53ALL SWAG SUPPORT TEAM TV-ANSI.PAS IMPORT 14 d╤¢ {πhere's some code to insert your one personal desktop in TurboVision.π}π{$L SBLOGO}πProcedure Logo; external;π{πThe only use of this Procedure is to link in the ansi drawing. It's a TPπCompatible Object File (you can make them With TheDraw). But every videoπdump will do. This drawing should have the dimension 22 * 80.π}πTypeπ PAnsiBackGround = ^TAnsiBackGround;π TAnsiBackGround = Object (TBackGround)π BckGrnd : Pointer;π { This is the Pointer to your video dump }ππ Constructor Init (Var Bounds : TRect; APattern : Char);π Procedure Draw; Virtual;π end;ππConstructor TAnsiBackGround.Init;πbeginπ TBackGround.Init (Bounds, APattern);π BckGrnd := @Logo;ππend;ππProcedure TAnsiBackGround.Draw;πbeginπ TView.Draw;π WriteBuf (0,0, 80, 23, BckGrnd^);π { The TV buffer Type is nothing more then a dump of the video memory }ππend;ππTypeπ PAnsiDesktop = ^TAnsiDesktop;π TAnsiDesktop = Object (TDesktop)π Procedure InitBackGround; Virtual;π end;ππProcedure TAnsiDesktop.InitBackGround;πVarπ R: TRect;π AB : PAnsiBackGround;πbeginπ GetExtent(R);π New (AB, Init(R, #176));π BackGround := AB;ππend;ππ{ Your applications InitDesktop method should look like this : }ππProcedure TGenericApp.InitDesktop ;πVarπ AB : PAnsiDesktop;π R : TRect;πbeginπ GetExtent(R);π Inc(R.A.Y);π Dec(R.B.Y);π New(AB, Init(R));π Desktop := AB;ππend;π{πThe only problem With this approach is that it doesn't work in 43 line modeπsince your background covers only 22 lines. if anyone has some nice codeπto move this ansi-picture in an buffer which fills up 43 lines mode I Reallyπappreciate it !!π} 20 05-28-9313:53ALL SWAG SUPPORT TEAM TV-HELP.PAS IMPORT 44 d%[ (*πLast week I found a bug in HELPFile.PAS and called Borland. After describingπthe error, the Borland representative agreed that it was a bug and thatπit hasn't been reported. ThereFore, I will describe the bug here and giveπa fix to the problem.ππProblem:πRecall, HELPFile.PAS is the Turbo Vision Unit that TVDEMO.PAS Uses toπprovide on-line help to Turbo Vision Programs. The problem that occurredπwas that if a help panel was brought up that did not contain a crossπreference entry (i.e. hyperText link), and the user pressed [Tab] orπShift+[Tab] then a run-time error is generated. notE: the run-timeπerror is generated if the Program is Compiled With Range Checking on.πif Range checking is off, then unpredicatable results occur.ππto see the bug in action, do the following:ππFire up Turbo Pascal 6 and load the TVDEMO.PAS Program (by default it existsπin the TVDEMOS subdirectory). Make sure Range checking is turned on.πThe option is in Options|Compiler. You will also want to turn debuggingπon in both the TVDEMO.PAS and HELPFile.PAS Files. to do this, you mustπedit the source code of both Files and change the {$D-} option to {$D+}πat the beginning of both Files.ππOnce you have done the above, press Ctrl+F9 to run TVDEMO. When TVDEMOπcomes up, press F1 to bring up the help Window. Now, press Shift+[Tab]πor [Tab] and a RunTime error 201 will occur.ππThis bug arises from the fact that the HELPFile.PAS Unit assumes thatπthere will always be at least one cross reference field on a help panel.πObviously, this is an invalid assumption.ππLuckily, there is an easy solution to the problem. The following showsπhow to change the HELPFile.PAS Program so that this error doesn't occur.πThe only Procedure that needs to be changed is THelpViewer.HandleEvent.ππ*)ππProcedure THelpViewer.HandleEvent(Var Event: TEvent);πVarπ KeyPoint, Mouse: TPoint;π KeyLength: Byte;π KeyRef: Integer;π KeyCount: Integer;π{ 1. Add the following Variable declaration }π n : Integer;ππProcedure MakeSelectVisible;πVarπ D: TPoint;πbeginπ topic^.GetCrossRef(Selected, KeyPoint, KeyLength, KeyRef);π D := Delta;π if KeyPoint.X < D.X then D.X := KeyPoint.X;π if KeyPoint.X > D.X + Size.X then D.X := KeyPoint.X - Size.X;π if KeyPoint.Y < D.Y then D.Y := KeyPoint.Y;π if KeyPoint.Y > D.Y + Size.Y then D.Y := KeyPoint.Y - Size.Y;π if (D.X <> Delta.X) or (D.Y <> Delta.Y) then Scrollto(D.X, D.Y);πend;ππProcedure Switchtotopic(KeyRef: Integer);πbeginπ if topic <> nil then Dispose(topic, Done);π topic := HFile^.Gettopic(KeyRef);π topic^.SetWidth(Size.X);π Scrollto(0, 0);π SetLimit(Limit.X, topic^.NumLines);π Selected := 1;π DrawView;πend;ππbeginπ TScroller.HandleEvent(Event);π Case Event.What ofπ evKeyDown:π beginπ Case Event.KeyCode ofπ kbTab:π beginπ{ 2. Change This...π Inc(Selected);π if Selected > topic^.GetNumCrossRefs then Selected := 1;π MakeSelectVisible;πto this... }π Inc(Selected);π n := topic^.GetNumCrossRefs;ππ if n > 0 thenπ beginπ if Selected > n thenπ Selected := 1;π MakeSelectVisible;π endπ elseπ selected := 0;π{ end of Change 2 }π end;π kbShiftTab:π beginπ{ 3. Change this ...π Dec(Selected);π if Selected = 0 then Selected := topic^.GetNumCrossRefs;π MakeSelectVisible;πto this... }π Dec(Selected);π n := topic^.GetNumCrossRefs;π if n > 0 thenπ beginπ if Selected = 0 thenπ Selected := n;π MakeSelectVisible;π endπ elseπ Selected := 0;π{ end of Change 3 }π end;π kbEnter:π beginπ{ 4. Change this...π if Selected <= topic^.GetNumCrossRefs thenπ beginπ topic^.GetCrossRef(Selected, KeyPoint, KeyLength, KeyRef);π Swithtotopic(KeyRef);π end;πto this...}π n := topic^.GetNumCrossRefs;π if n > 0 thenπ beginπ if Selected <= n thenπ beginπ topic^.GetCrossRef(Selected, KeyPoint, KeyLength, KeyRef);π Switchtotopic(KeyRef);π end;π end;π{ end of Change 4 }π end;π kbEsc:π beginπ Event.What := evCommand;π Event.Command := cmClose;π PutEvent(Event);π end;π elseπ Exit;π end;π DrawView;π ClearEvent(Event);π end;π evMouseDown:π beginπ MakeLocal(Event.Where, Mouse);π Inc(Mouse.X, Delta.X); Inc(Mouse.Y, Delta.Y);π KeyCount := 0;π Repeatπ Inc(KeyCount);π if KeyCount > topic^.GetNumCrossRefs then Exit;π topic^.GetCrossRef(KeyCount, KeyPoint, KeyLength, KeyRef);π Until (KeyPoint.Y = Mouse.Y+1) and (Mouse.X >= KeyPoint.X) andπ (Mouse.X < KeyPoint.X + KeyLength);π Selected := KeyCount;π DrawView;π if Event.Double then Switchtotopic(KeyRef);π ClearEvent(Event);π end;π evCommand:π if (Event.Command = cmClose) and (Owner^.State and sfModal <> 0) thenπ beginπ endModal(cmClose);π ClearEvent(Event);π end;π end;πend;π 21 05-28-9313:53ALL SWAG SUPPORT TEAM VIEWCOLR.PAS IMPORT 22 dΩ2 (*π> Does somebody know how to get correct colors in a view.π> That is: Exactly the colors I want to specify without mappingπ> on the colors of the views owner?ππNow you're getting even more complicated than the actual method of doing it.π(as if that wasn't complicated enough!)ππThe BP7 Turbo Vision Guide (and I'll assume the TP7 TVGuide as well) do a muchπbetter job at explaning the palette's that the TP6 version. The colors are notπas much maps, as they are indexes. Only the TProgram Object actual contains anyπcolor codes. TApplication, by design, inherits that palette as is. Any insertedπviews palette will contain a String of indexes into that palette.ππThere are a couple of ways to customize your colors. Either adjust where yourπcurrent views index points to, or adjust the actual applications palette.ππ> The manual says that such is done to get "decent colors". But theπ> problem is that defining what should be "decent" is to the Programmer,π> not to the designer of a compiler :-)ππ> How to get just Absolute colors in a view, thats the question.ππThe easiest method I've found For adjusting colors, is directly adjusting theπactual TApllications GetPalette Method.πππFunction TMyApp.GetPalette:PPalette;πConstπ P: Array[apColor..apMonochrome] of String[Length(CColor)] =π (CColor, CBlackWhite, CMonochrome);πbeginπ p[apcolor,1] := #$1A; {background}π p[apcolor,2] := #$1F; {normal Text}π p[apcolor,33] := #$74; {tdialog frame active}π p[apcolor,51] := #$1B; {inputline selected}π p[apcolor,56] := #$4F; {history Window scrollbar control}π getpalette := @p[apppalette];πend;πππThis lets you change and adjust your entire pallete, and have those changesπreflected throughout your entire application... Just consult your TVGuide toπfind the offset into the String of the item you want to change.ππHeres a nifty Program to display all the colors available, and what they lookπlike (not only tested.. but used quite a bit!) :π*)ππProgram Colourtest;ππUsesπ Crt;πTypeπ str2 = String[2];πVarπ i, y, x,π TA : Byte;ππFunction Hexit(w : Byte) : str2;πConstπ Letr : String[16] = '0123456789ABCDEF';πbeginπ Hexit := Letr[w shr 4 + 1] + Letr[w and $0F + 1];πend;ππbeginπ TA := TextAttr ;π ClrScr;π For y := 0 to 7 doπ beginπ GotoXY(1, y + 5);π For i := 0 to 15 doπ beginπ TextAttr := y * 16 + i;π Write('[', Hexit(TextAttr), ']');π end;π end;π Writeln;π Writeln;π GotoXY(1, 15);π Textattr := TA;π Write(' For ');π Textattr := TA or $80;π Write(' Flashing ');π Textattr := TA;π Writeln('Attribute : Color = Color or $80');π Writeln;π Write(' Press any key to quit : ');π ReadKey;π ClrScr;πend.ππ 22 05-28-9313:53ALL SWAG SUPPORT TEAM XCDIALOG.PAS IMPORT 16 d╦ {πJohan: this code may help you out. Keep With it, the learning curveπon TV is very steep. Try the Fidonet TV Forum in Europe, or betterπyet, the Compuserve BPascalA Forum.π}π{xcdialog.int}ππ{$X+}ππUnit xcdialog;ππInterfaceππUsesπ Objects,Drivers,Views,Menus,Dialogs,MsgBox,App,Crt,Printer,π TVXCVars, FmtLine, XCMapL, TVCalcL, TVXCHelp, File_ioL, Dos;ππTypeπ PAspDialog = ^TAspDialog;π TAspDialog = Object(TDialog)π end;ππ PExitDialog = ^TExitDialog;π TExitDialog = Object(TDialog)π end;ππProcedure ExitDialog; {asks user whether s/he want to quit or not}ππImplementationπππProcedure ExitDialog;π{■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■}πVarπ Dlg : PAspDialog ;π R : TRect ;π Control, Labl : PView ;π Event : TEvent;π iStart : Integer;πbeginπ R.Assign ( 10 , 2 , 60 , 12 ) ;π New ( Dlg , Init ( R , 'Exit Confirmation') ) ;ππ iStart:= (50 - length('Are you SURE you want to Exit?')) div 2;π {centre Text}ππ R.Assign ( iStart , 3 , 48 , 4 ) ;π Control := New ( PStaticText , Init ( R , length('Are you SURE'π +' you want to Exit?' ) ) ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 10 , 7 , 21 , 9 ) ;π Control:= New ( PButton , Init ( R , Words^.get(numYes) ,π cmOK , bfDefault ) ) ;π Control^.HelpCtx := hcEnter ;π Dlg^.Insert ( Control ) ;ππ R.Assign ( 23 , 7 , 36 , 9 ) ;π Control := New ( PButton,Init(R , 'Cancel', cmCancel , bfNormal ) ) ;π Control^.HelpCtx := hcCancelBtn ;π Dlg^.Insert ( Control ) ;ππ Dlg^.SelectNext ( False ) ;ππ if Desktop^.ExecView (Dlg) <> cmCancel thenπ beginπ Event.What := evCommand;π Event.Command := cmQuit;π Application^.PutEvent(Event);π end;π Dispose(Dlg, Done);πend;π 23 08-17-9308:47ALL SWAG SUPPORT TEAM Dynamic OPP Box Object IMPORT 33 d program Dynamic_Object_Demo;ππ { DYN-DEMO.PAS }ππuses Crt, Dos;ππtypeπ ScrPtr = ^SaveScreen;π BoxPtr = ^ReportBox;π SaveScreen = array[1..80,1..25] of word;π ReportBox = objectπ SavPtr: ScrPtr; FColor, BColor: byte;π WPosX, WPosY, WSizeX, WSizeY: integer;π constructor Init( PtX, PtY, Width, Height,π C1, C2 : integer );π destructor Done;π procedure Draw;π procedure Erase;π end;ππ{==========================================}π{ implementation for object type ReportBox }π{==========================================}ππconstructor ReportBox.Init;πvarπ i, j: integer;π Regs: Registers;πbeginπ WPosX := PtX;π WPosY := PtY;π WSizeX := Width;π WSizeY := Height;π FColor := C1;π BColor := C2;π New( SavPtr ); { allocate memory for array }π window( WPosX, WPosY, WPosX+WSizeX-1,π WPosY+WSizeY-1 );ππ {read character and attribute on video page 0}ππ for i := 1 to WSizeX doπ for j := 1 to WSizeY doπ beginπ gotoxy(i,j);π Regs.AH := 08;π Regs.BH := 00;π intr( $10, Regs );π SavPtr^[i,j] := Regs.AX;π end;π Draw;πend;ππdestructor ReportBox.Done;πbeginπ Erase;π Dispose( SavPtr );πend;ππprocedure ReportBox.Erase;πvarπ i, j : integer;π Regs : Registers;πbeginπ window( WPosX, WPosY,π WPosX+WSizeX-1, WPosY+WSizeY-1 );π ClrScr; { inner window }ππ{ Write character and attr on video page 0 }ππ{ AL stores the character value }π{ BL stores the attribute value }π{ CL stores the repititions value (1) }ππ for i := 1 to WSizeX doπ for j := 1 to WSizeY doπ beginπ gotoxy(i,j);π Regs.AH := 09;π Regs.BH := 00;π Regs.AL := lo( SavPtr^[i,j] );π Regs.BL := hi( SavPtr^[i,j] );π Regs.CL := 1;π intr( $10, Regs );π end;π window( 1, 1, 80, 25 );πend;ππprocedure ReportBox.Draw;πvarπ BoxStr : string[6];π i : integer;π MemSize : longint;πbeginπ TextColor( FColor );π TextBackground( BColor );π BoxStr := #$C9 + #$CD + #$BB +π #$BA +#$BC + #$C8;π window( WPosX, WPosY,π WPosX+WSizeX-1, WPosY+WSizeY-1 );π ClrScr;π gotoxy( 1, 1 ); write( BoxStr[1] );π for i := 1 to WSizeX-2 do write( BoxStr[2] );π write( BoxStr[3] );π gotoxy( 1, WSizeY-1 ); write( BoxStr[6] );π for i := 1 to WSizeX-2 do write( BoxStr[2] );π write( BoxStr[5] );π gotoxy( 1, 2 );π InsLine;π for i := 2 to WSizeY-1 doπ beginπ gotoxy( 1, i ); write( BoxStr[4] );π gotoxy( WSizeX, i ); write( BoxStr[4] );π end;π window( WPosX+1, WPosY+1,π WPosX+WSizeX-2, WPosY+WSizeY-2 );π ClrScr;π MemSize := MemAvail;π for i := 1 to 30 doπ write('Memory now = ',MemSize,' bytes! ');π window( 1, 1, 80, 25 );πend;ππ{ **** end of methods **** }ππvarπ Box : array[1..5] of BoxPtr;π MemSize : longint;π i : integer;ππprocedure Prompt;πbeginπ gotoxy( 1, 1 ); clreol;π write('Memory now = ', MemAvail,π '. Press ENTER to continue ');π readln;πend;ππbeginπ ClrScr;π TextColor( White );π TextBackground( Black );π MemSize := MemAvail;π for i := 1 to 100 doπ write(' Initial memory available = ',π MemSize, ' bytes! ' );π gotoxy( 1, 1 ); clreol;π write('Press ENTER to continue ');π readln;π Box[1] := New( BoxPtr, Init( 5, 12, 30, 10,π LightRed, Black ) );π gotoxy( 1, 1 ); clreol;π write('Memory now = ', MemAvail,π '. Press ENTER to continue ');π readln;π Box[2] := New( BoxPtr, Init( 40, 5, 30, 10,π LightGreen, Blue ) );π gotoxy( 1, 1 ); clreol;π write('Memory now = ', MemAvail,π '. Press ENTER to continue ');π readln;π Dispose( Box[1], Done );π Dispose( Box[2], Done );π gotoxy( 1, 1 ); clreol;π write( 'Final memory (after release) = ',π MemAvail, ' bytes...');π readln;πend.π 24 08-27-9320:37ALL STUART MACLEAN Passing method as OBJect IMPORT 8 d {πStuart MacleanππHi there, I've found a neat way of passing an Object a method of its ownπclass, which it then executes. The idea comes from Smalltalk'sπchange/update mechanism For dependencies under the MVC paradigm.ππWorks under TP6.π}ππTypeπ DependentPtr = ^Dependent;ππ Dependent = Objectπ Procedure Update(p : Pointer);π Procedure SomeMethod;π end;ππ Model = Objectπ dep : DependentPtr;π Procedure Change;π end;ππProcedure Dependent.Update; Assembler;πAsmπ les di, selfπ push esπ push diπ call dWord ptr pπend;ππProcedure Dependent.SomeMethod;πbeginπ{ do something here }πend;ππProcedure Model.Change;πbeginπ dep^.Update(@Dependent.Somemethod);πend;ππVarπ m : Model;π d : Dependent;ππbeginπ m.dep := @d; { add d as a dependent of m }π m.Change; { caUses d to be updated }πend.π 25 08-27-9321:43ALL EDWIN GROOTHUIS Password for TVision IMPORT 13 d {πEDWIN GROOTHUISππsomebody asked For a inputline For passWords. I have such one, but I'veπforgotten WHICH discussionlist... so I'll mail it to the above lists, Iπknow it's one of it, and know it can be interesting For somebody else.ππWhat I have done is overriden the Draw-Procedure For the inputline to drawπonly ***'s instead of the right Characters. The solution I gave yesterdayπwas not quitte correct: I used the Procedure SetData to put the *'s into theπData^-field, but that Procedure calls the Draw-Procedure itself so you'llπget an infinite loop and a stack-overflow error. Now I put the *'s direct toπthe Data^-field, I don't think it can give problems.π}ππUsesπ app, dialogs, views, Objects;ππTypeπ PPassWord = ^TPassWord;π TPassWord = Object(TInputLine)π Procedure Draw; Virtual;π end;πππProcedure TPassWord.Draw;ππVarπ s, t : String;π i : Byte;πbeginπ GetData(s);π t := s;π For i := 1 to length(t) doπ t[i] := '*';π Data^ := t;π inherited Draw;π Data^ := s;πend;ππProcedure about;πVarπ d : pdialog;π r : trect;π b : pview;πbeginπ r.assign(1, 1, 60, 15);π d := new(pdialog,init(r, 'About'));π With d^ doπ beginπ flags := flags or wfgrow;π r.assign(1,1,10,3);π insert(new(PButton, init(r,'~O~K', cmok, bfdefault)));π r.assign(2,4,8,5);π insert(new(PPassWord, init(r,10)));π end;π desktop^.execview(d);π dispose(d, done);πend;πππVarπ a : TApplication;πbeginπ a.init;π about;π a.run;π a.done;πend.π 26 11-02-9318:39ALL BRIAN PAPE PICKLIST in Turbo Vision SWAG9311 23 d {πFrom: BRIAN PAPEπSubj: Picklist in TVπ}ππ{************************************************}π{ }π{ Turbo Vision 2.0 Demo }π{ Copyright (c) 1992 by Borland International }π{ }π{************************************************}ππprogram PickList;ππuses Objects, Views, Dialogs, App, Drivers,editors;πconstπ cmPickClicked = 1001;πtypeπ PCityColl = ^TCityColl;π TCityColl = object(TStringCollection)π constructor Init;π end;ππ PPickLine = ^TPickLine;π TPickLine = object(TMemo)π procedure HandleEvent(var Event: TEvent); virtual;π end;ππ PPickWindow = ^TPickWindow;π TPickWindow = object(TDialog)π constructor Init;π end;ππ TPickApp = object(TApplication)π PickWindow: PPickWindow;π constructor Init;π end;ππVAR Lijst:PCityColl;π GControl: PView;π S : String[30];πππconstructor TCityColl.Init;πbeginπ inherited Init(10, 10);π Insert(NewStr('Scotts Valley'));π Insert(NewStr('Sydney'));π Insert(NewStr('Copenhagen'));π Insert(NewStr('London'));π Insert(NewStr('Paris'));π Insert(NewStr('Munich'));π Insert(NewStr('Milan'));π Insert(NewStr('Tokyo'));π Insert(NewStr('Stockholm'));πend;ππprocedure TPickLine.HandleEvent(var Event: TEvent);πVARπ Count:Integer;πbeginπ inherited HandleEvent(Event);π if (Event.What = evBroadcast) and (Event.command=cmListItemSelected) thenπ beginπ S:=PListBox(Event.InfoPtr)^.GetText(PListBox(Event.InfoPtr)^.Focused,π high(s));π with PListBox(Event.InfoPtr)^ doπ beginπ s := s + #13;π InsertText(@s[1],length(s),false);π end;π DrawView;π ClearEvent(Event);π end;πend;ππconstructor TPickWindow.Init;πvarπ R: TRect;π Control: PView;π ScrollBar: PScrollBar;πbeginπ R.Assign(0, 0, 40, 15);π inherited Init(R, 'Pick List Window');π Options := Options or ofCentered;π R.Assign(5, 2, 35, 4);π Control := New(Ppickline, Init(R,NIL,NIL,NIL, 130));π Control^.EventMask := Control^.EventMask or evBroadcast;π Insert(Control);π R.Assign(4, 1, 13, 2);π Insert(New(PLabel, Init(R, 'Picked:', Control)));π R.Assign(34, 5, 35, 11);π New(ScrollBar, Init(R));π Insert(ScrollBar);π R.Assign(5, 5, 34, 11);π gControl := New(PListBox, Init(R, 1, ScrollBar));π Insert(gControl);π PListBox(gControl)^.NewList(Lijst);π R.Assign(4, 4, 12, 5);π Insert(New(PLabel, Init(R, 'Items:', Control)));π R.Assign(15, 12, 25, 14);π Insert(New(PButton, Init(R, '~Q~uit', cmQuit, bfDefault)));πend;ππconstructor TPickApp.Init;πbeginπ inherited Init;π Lijst:=New(PCityColl,Init);π PickWindow := New(PPickWindow, Init);π InsertWindow(PickWindow);πend;ππvarπ PickApp: TPickApp;πbeginπ PickApp.Init;π PickApp.Run;π PickApp.Done;πend.ππ 27 11-02-9316:45ALL BRIAN RICHARDSON Efficient Turbo Vision SWAG9311 22 d {πFrom: BRIAN RICHARDSONπSubj: Efficient Tv2π---------------------------------------------------------------------------π On 10-08-93 FRANK DERKS wrote to ALL...ππ Hello All,ππ for those who have read my other message (Efficient TV, Thu 07). Maybeπ some of you can expand on the following idea. How do I create aπ 'dynamic' pick list box: a box that is displayed only when I haveππ Or maybe more simple : what I'm after is a sort of inputline-objectπ which can be cycled through a number of predefined values. }ππuses objects, app, dialogs, drivers;ππtypeπ PRoomInputLine = ^TRoomInputLine;π TRoomInputLine = object(TInputLine)π StatusList : PStringCollection;π Index : integer;ππ constructor Init(var Bounds: TRect; AMaxLen: integer;π AStatusList : PStringCollection);π procedure HandleEvent(var Event : TEvent); virtual;π procedure Up; virtual;π procedure Down; virtual;π end;ππ PRoomDialog = ^TRoomDialog;π TRoomDialog = object(TDialog)π constructor Init(List : PStringCollection);π end;ππconstructor TRoomInputLine.Init(var Bounds : TRect; AMaxLen: Integer;π AStatusList : PStringCollection);πbeginπ inherited Init(Bounds, AMaxLen);π StatusList := AStatusList;π Index := 0;π SetData(PString(StatusList^.At(Index))^);πend;ππprocedure TRoomInputLine.Up;πbeginπ Index := (Index + 1) Mod StatusList^.Count;π SetData(PString(StatusList^.At(Index))^);πend;πππprocedure TRoomInputLine.Down;πbeginπ if Index = 0 then Index := (StatusList^.Count - 1) elseπ Dec(Index);π SetData(PString(StatusList^.At(Index))^);πend;ππprocedure TRoomInputLine.HandleEvent(var Event: TEvent);πbeginπ if (Event.What = evKeyDown) then beginπ case Event.KeyCode ofπ kbUp : Up;π kbDown : Down;π elseπ inherited HandleEvent(Event);π end; end elseπ inherited HandleEvent(Event);πend;ππconstructor TRoomDialog.Init(List : PStringCollection);πvar R: TRect;πbeginπ R.Assign(20, 5, 60, 20);π inherited Init(R, '');π R.Assign(15, 7, 25, 8);π Insert(New(PRoomInputLine, Init(R, 20, List)));π R.Assign(15, 9, 25, 10);π Insert(New(PRoomInputLine, Init(R, 20, List)));ππend;ππvarπ RoomApp : TApplication;π List : PStringCollection;πbeginπ RoomApp.Init;π List := New(PStringCollection, Init(3, 1));π with List^ do beginπ Insert(NewStr('Vacant')); Insert(NewStr('Occupied'));π Insert(NewStr('Cleaning'));π end;π Application^.ExecuteDialog(New(PRoomDialog, Init(List)), nil);π Dispose(List, Done);π RoomApp.Done;πend.ππ 28 11-02-9318:37ALL TODD HOLMES Flexible OOP Array SWAG9311 21 d {πFrom: TODD HOLMESπHeres a flexible OOP array...}ππ{ $TESTED}ππUses Objects;πTypeππ TestRec = Recordπ Name: String[20];π Age : Word;π end;π {A TestRecord}ππ PAByte = ^TAByte;π TAByte = Array[0..65519] of byte;π {General byte array}ππ{TArray is limited to 65520 bytes of data, and may store any typeπof data.}ππ PArray = ^TArray;π TArray = Object(TObject)π Data : PAByte;π DataSize: Word; {Size of the Data to hold}π MaxCount: Word; {Maximum amount of items of DataSize}π Count : Word; {How many items in Array}π Constructor Init(ADataSize,ACount:Word);π Constructor Load(Var S:TStream);π Procedure Store(VAR S:TStream); Virtual;π Destructor Done;Virtual;π Procedure GetItem(Index:Word;Var Item);π Procedure PutItem(Index:Word;Var Item);π end;ππConstructor TArray.Init(ADataSize,ACount:Word);π beginπ Inherited Init; {TP6 Tobject.init}π DataSize := ADataSize;π MaxCount := 65520 div ADataSize; {For Error Checking}π If Acount > MaxCount then Fail; {Array is too big}π Count := ACount;π GetMem(Data,Count * DataSize); {Get Mem for the array}π FillChar(Data^,Count * DataSize,0);{Clear the Array}π end;ππConstructor TArray.Load(Var S:TStream);π beginπ With S do beginπ Read(DataSize,SizeOf(DataSize));π Read(MaxCount,SizeOf(MaxCount));π Read(Count,SizeOf(MaxCount));π GetMem(Data,Count * DataSize);π Read(Data^,Count * DataSize);π end;π end;ππProcedure TArray.Store(Var S:TStream);π beginπ With S do Beginπ Write(DataSize,SizeOf(DataSize));π Write(MaxCount,SizeOf(MaxCount));π Write(Count,sizeOf(Count));π Write(Data^,Count * DataSize);π end;π end;ππDestructor TArray.done;π beginπ FreeMem(Data,Count*DataSize);π Inherited Done;π end;ππProcedure TArray.GetItem(Index:Word;Var Item);π beginπ If Index > count then Exit;π Move(Data^[(Index - 1) * DataSize],Item,DataSize);π end;ππProcedure TArray.PutItem(Index:Word;Var Item);π beginπ If Index > count then exit;π Move(Item,Data^[(Index - 1) * DataSize],DataSize);π end;ππVarπ Flexable:PArray;π TR:TestRec;π I:Integer;ππbeginπ Randomize;π Flexable := New(PArray,Init(SizeOf(TR),10));π If Flexable <> Nil then begin; {Array to big}π For I := 1 to Flexable^.Count do beginπ With TR do beginπ Name := 'Bobby Sue';π Age := I;π end;π Flexable^.PutItem(I,TR);π end;π For I := 1 to FlexAble^.Count do beginπ FlexAble^.GetItem(I,TR);π With Tr doπ Writeln('Rec ',I:2,' is Name: ',Name:20,' Age: ',Age:8);π end;π end;π Dispose(Flexable,Done);πend.π 29 01-27-9411:58ALL LARRY HADLEY Valid Directories SWAG9402 13 d {π For you TV programmers out there, here is a neat littleπ TValidator object for you - it verifies that the DIRECTORYπ entered in a TInputLine is valid and currently exists.π}ππUnit DirValid;ππINTERFACEππUsesπ Objects,π Validate;ππTypeπ PDirValidator = ^TDirValidator;π TDirValidator = OBJECT(TValidator)π constructor Init;ππ procedure Error; virtual;π function IsValid(const S : string) : boolean; virtual;π end;ππIMPLEMENTATIONππUsesπ Dos,π MsgBox;ππFunction ExistDir(d : string) : boolean;πVARπ S : SearchRec;πBEGINπ {$I-}π FindFirst(d, Directory, S);π {$I+}π if DOSError = 0 thenπ BEGINπ if Directory = (S.attr and Directory) thenπ ExistDir := TRUEπ ELSEπ ExistDir := FALSE;π ENDπ ELSEπ ExistDir := FALSE;π END;ππconstructor TDirValidator.Init;πbeginπ inherited Init;πend;ππprocedure TDirValidator.Error;πbeginπ MessageBox('Directory does not exist!', nil, mfError + mfOKButton);πend;ππfunction TDirValidator.IsValid(const S : string) : boolean;πvarπ d : string;πbeginπ if s='' then {always return TRUE when entry string is empty}π beginπ IsValid := TRUE;π EXIT;π end;π d := s;π if s[Length(d)] = '\' thenπ Delete(d, Length(d), 1); {allows flexibility - TV & TP expectπ paths to NOT terminate in a \ }π if ExistDir(d) thenπ IsValid := TRUE {directory exists}π elseπ IsValid := FALSE; {directory does not exist}πend;ππend. 30 01-27-9412:16ALL DJ MURDOCH Object Checking SWAG9402 10 d {π> But it's not bad if they DON'T have them, is it? Defining what is good orπ> bad from reading the manual is the single most difficult problem I haveπ> with them for anything (not just TP). I wouldn't supposeπ> it would be if you can do it.ππI'm not sure what you mean by good or bad. If you want to use virtual methods,πyou need a VMT. Not having one would be very bad. If you don't want to useπvirtual methods, then you probably don't need a VMT. The only reason you mightπwant one is for debugging: you can check whether an object has beenπinitialized by checking whether its VMT is valid. Here's the check I use:π}ππFunction ObjCheck(o:PObject;msg:string):boolean;πtypeπ VMT = recordπ size, negsize : integer;π end; varπ PVmt : ^VMT;πbeginπ PVmt := Ptr(DSeg, word(Pointer(o)^));π with PVmt^ doπ if (size = 0) or (size + negsize <> 0) thenπ beginπ write(msg,': Not initialized');π ObjCheck := false;π endπ elseπ ObjCheck := true; end;ππ{ This is pretty close to the same check that $R+ does. }π 31 01-27-9412:19ALL DJ MURDOCH TVision Extension SWAG9402 27 d {π>try using resource files with TurboVision. When opening a resource file withπ>extension EXE, TV will append it to the file during write operations.π>I did it already for registration stuff and it works fine.ππThe trouble with this approach is that each write operation appends aπrecord, it doesn change the existing one. For something you do only onceπlike registration, that's okay, but for config changes, you need to doπsomething to pack the records. With Resource files that's complicated, butπpossible. Here's the unit I use to do it.π}ππunit resources;ππ{ Unit to provide extra functions to TVision TResourceFiles }ππinterfaceππusesπ objects;ππtypeπ PPackableResource = ^TPackableResource;π TPackableResource = object(TResourceFile)π function pack : boolean;π { Packs the resource file by reading all resources and rewriting them toπ the stream. Returns false if it fails. }π end;ππimplementationππtypeπ { Type here to get at the secret fields of the TResourceFile }π TResourceSecrets = object(TObject)π Stream : PStream;π Modified : Boolean;π BasePos : Longint;π IndexPos : Longint;π Index : TResourceCollection;π end;ππ PNamedItem = ^TNamedItem;π TNamedItem = object(TObject)π Item : PObject;π Name : PString;π destructor done; virtual;π end;ππdestructor TNamedItem.done;πbeginπ DisposeStr(Name);π inherited done;πend;ππprocedure Deletechars(var S : TStream; count : Longint);π{ Deletes the given number of characters from the stream }πvarπ copy : longint;π buffer : array [1..1024] of byte;π bufsize : word;π pos : longint;πbeginπ pos := S.GetPos;π copy := S.GetSize - pos - count;π bufsize := sizeof(buffer);ππ while copy > 0 doπ beginπ if copy < sizeof(buffer) thenπ bufsize := copy;π S.Seek(pos + count);π S.Read(Buffer, bufsize);π S.Seek(pos);π S.write(Buffer, bufsize);π inc(pos, bufsize);π dec(copy, bufsize);π end;π S.Truncate;πend;ππfunction TPackableResource.Pack : boolean;πvarπ contents : TCollection;π i : integer;π item : PObject;π nameditem : PNamedItem;π OldSize : longint;πbeginπ Flush;π pack := false; { Assume failure }π if Stream^.status <> stOk thenπ exit;ππ { First, make a copy of all the contents in memory }ππ contents.init(Count, 10);π for i := 0 to pred(Count) doπ beginπ item := Get(KeyAt(i));π New(NamedItem, init);π if (NamedItem = nil) or (item = nil) thenπ beginπ contents.done;π exit;π end;π NamedItem^.item := item;π NamedItem^.name := Newstr(Keyat(i));π contents.atinsert(i, nameditem);π end;ππ { Now, remove all traces of the original. }ππ with TResourceSecrets(Self) doπ beginπ Stream^.Seek(BasePos + 4);π Stream^.Read(OldSize, Sizeof(OldSize));π Stream^.Seek(BasePos);π DeleteChars(Stream^, OldSize + 8);π end;ππ { Now, close down and restart }π TResourceSecrets(Self).Index.Done;π Stream^.Seek(0);π inherited init(Stream);ππ { Now rewrite all those saved objects. }π for i := 0 to pred(contents.count) doπ beginπ nameditem := PNamedItem(contents.At(i));π Put(nameditem^.item, nameditem^.name^);π end;ππ { Get rid of the copies from memory }π contents.done;ππ if Stream^.Status = stOk thenπ pack := true;πend;ππend.ππ 32 01-27-9412:22ALL LARRY HADLEY OOP Stack Object SWAG9402 42 d {π> If you want, I can post a few good and simple examples of OOPπ> concepts to get you started.ππ{π -- A simple stack object with the nice flexibility that only OOPπ can provide.ππ Data structuresππ StackItem: node for a doubly linked list containing an untyped pointerπ to hold data. It is the responsibility of descendant typesπ to type this pointer. (override push and pop)ππ StackTop :pointer to available stack itemπ StackBottom :pointer to the bottom (end/root) of the stackπ StackHt :number of items on stackπ StackST :status variableππ Methodsππ Init - initializes the stack object, StackHt = 0, all pointers = nilπ *** YOU MUST CALL THIS BEFORE ACCESSING STACK ***ππ done - destructor deallocates the stack by doing successive pops untilπ the stack is empty.π *** YOU MUST OVERRIDE THIS METHOD WHEN YOU OVERRIDE ***π *** PUSH AND POP. ITEMS POPPED ARE NOT DEALLOCATED ***ππ Push - Pushes an item onto the stack by:π 1) Allocating a new StackItem (if StackHt>0)π 2) Assigning pointer dta to data fieldπ 3) Incrementing StackHtππ Pop - Pops by reversing push method:π 1) Recovering dta pointer from data fieldπ 2) Deallocating "top" StackItem (if StackHt>1)π 3) Decrementing StackHtππ Most decendant types will override push and pop to type the data field, andπ call STACK.push or STACK.pop to do the "basic" operations.ππ IsError - shows if an error condition existsππ MemoryOK - internally used function to check available heap.π}ππUnit OSTACK;ππINTERFACEππCONSTπ MAX_STACK = 100;π MIN_MEMORY = 4096;ππ StatusOK = 0;π StatusOFlow = 1;π StatusEmpty = 2;π StatHeapErr = 3;ππTYPEπ ItemPtr = ^StackItem;π StackItem = RECORDπ data :pointer;π prev, next :ItemPtr;π END; { StackItem }ππ STACK = OBJECTπ StackTop, StackBottom :ItemPtr;π StackST :integer;π StackHt :byte;ππ constructor init;π destructor done; virtual;π procedure push(var d); virtual;π procedure pop(var d); virtual;π function IsError:boolean;π privateπ function MemoryOK:boolean;π END; { STACK }ππIMPLEMENTATIONππconstructor STACK.init;π BEGINπ New(StackBottom);π StackTop := StackBottom;π StackBottom^.prev := NIL;π StackBottom^.next := NIL;π StackBottom^.data := NIL;π StackHt := 0; StackST := StatusOK;π END;ππdestructor STACK.done;π VAR val :pointer;π BEGINπ if StackHt>0 thenπ repeatπ pop(val);π until val = nil;π Dispose(StackBottom);π END;ππprocedure STACK.push(var d);π VAR TemPtr :ItemPtr;π dta :pointer ABSOLUTE d;π BEGINπ if not MemoryOK then EXIT;ππ if (StackHt>=MAX_STACK) thenπ beginπ StackST := StatusOFlow;π EXIT;π end;ππ If StackHt>0 thenπ BEGINπ New(StackTop^.next);π TemPtr := StackTop;π StackTop := TemPtr^.next;π StackTop^.prev := TemPtr;π StackTop^.next := NIL;π END;ππ StackTop^.data := dta;π Inc(StackHt);π END;ππprocedure STACK.pop(var d);π VAR dta :pointer ABSOLUTE d;π BEGINπ if StackHt>1 thenπ BEGINπ dta := StackTop^.data;π StackTop := StackTop^.prev;π Dispose(StackTop^.next);π StackTop^.next := NIL;π Dec(StackHt);π if StackST = StatusOFlow then StackST := StatusOK;π ENDπ ELSEπ BEGINπ if StackHt = 1 thenπ BEGINπ dta := StackBottom^.data;π StackBottom^.data := nil;π Dec(StackHt);π ENDπ ELSEπ beginπ dta := StackBottom^.data;π StackST := StatusEmpty;π end;π END;π END;ππfunction STACK.IsError:boolean;πbeginπ if StackST = StatusOK thenπ IsError := FALSEπ elseπ IsError := TRUE;πend;ππfunction STACK.MemoryOK:boolean;πbeginπ if MaxAvail<MIN_MEMORY thenπ MemoryOK := FALSEπ elseπ MemoryOK := TRUE;π StackST := StatHeapErr;πend;ππEND. { unit OSTACK }πππ{ Here's an example of how easy it is to extend the STACK objectπ using iheritance and virtual methods. }πππTYPEπ RegisterStack = OBJECT(STACK)π destructor Done; virtual;ππ procedure push(var d); virtual;π procedure pop(var d); virtual;π end;ππdestructor Done;πvarπ tmp :OpRec;πbeginπ if StackHt>0 thenπ repeatπ pop(tmp);π until tmp = NOREG;πend;ππprocedure RegisterStack.push(var d);πvarπ tmp :pOpRec;π dta :OpRec ABSOLUTE d;πbeginπ New(tmp);π tmp^ := dta;π inherited push(tmp);πend;ππprocedure RegisterStack.pop(var d);πvarπ tmp :pOpRec;π dta :OpRec ABSOLUTE d;πbeginπ inherited pop(tmp);π if StackST = StatusEmpty thenπ beginπ dta := NOREG;π EXIT;π endπ elseπ if tmp<>nil thenπ beginπ dta := tmp^;π Dispose(tmp);π endπ elseπ dta := NOREG;πend;ππ 33 01-27-9412:23ALL MARTIN WERNER TVision Backgrounds SWAG9402 6 d {π> I'm starting to play with TVision 1 and I would like to know howπ> to change the background fill character.ππWorking example:π}ππprogram otherbackground;ππusesπ app, objects;ππtypeπ pmyapp=^tmyapp;π tmyapp=object(tapplication)π constructor init;π end;ππconstructor tmyapp. init;ππ varπ r: trect;ππ beginπ tapplication. init;π desktop^. getextent(r);π dispose(desktop^. background, done);π desktop^. background:=new(pbackground, init(r, #1));π desktop^. insert(desktop^. background);π end;ππvarπ myapp: tmyapp;ππbeginπ myapp. init;π myapp. run;π myapp. done;πend.π 34 01-27-9412:23ALL KEN BURROWS Dialogs in TVision SWAG9402 36 d {π>>> In a Turbo Vision DIALOG form, how do you (re)select the FIRST editableπ>>> data field FROM ANYWHERES IN the DIALOG?ππ>> You don't select it. You let IT select itself. Since all the viewsπ>> inserted into the dialog are descendents of TView, then they allπ>> have a select method.ππ> Nice Idea, too bad it's not that simple 8-(ππIt rarely is with TV.π}πProgram SelectAView_2; {tested. The only thing this does, is work}ππ { If you want to have an object select itself, without haveingπ to explicitly define itself first, you must begin with anπ object that KNOWS how to select itself.π Since Select is a method of the TView object, any descendentπ will know how.ππ A method is then needed by the object,π that contains the object that must select itself,π to get its, request that it select itselfπ to the object that must select itself.ππ Use the evBroadcast event.ππ The object, that contain the object that must select itself,π generates a broadcast event onto it's event tree. (random shotπ in the dark) This broadcast, requests that any object thatπ is set to select itself on the events command, should accept theπ broadcast.... , and then select itself.ππ This is accomplished by taking your last instance definitionπ of a object that you are inserting into your event queue andπ descending it once more to overide its HandleEvent method.ππ In my example, I've used a simple TDialog and inserted aπ bunch of of TInputLine's and a TButton that generates anπ EvCommand of 'SelectFirst', and descended the HandleEventπ to generate a evBroadCast event, to broadcast the SelectFirstπ Command.ππ The TinputLine descendent, TMyLine, is directly descendedπ from the type of object that I am linking into this TDialogπ objects event queue.ππ Within a 'For i = 1 to 4' Loop, the TDialogs constructorπ will insert a TMyLine type, that will select itself wheneverπ an evBroadCast event, broadcasts a SelectFirst command.ππ As long as this object is a descendent of a TView, theπ TDialog will accept it, and treat like any other object.ππ A TButton is installed to provide a method of generatingπ an evBroadCast event that broadcasts a SelectFirst command.π }πππuses Objects,App,Dialogs,Views,Drivers;ππtypeπ MyDlg = object(TDialog)π constructor init;π procedure HandleEvent(var Event:TEvent); virtual;π end;ππ MyLine = Object(TInputLine)π Selector : Word;π Constructor Init(var bounds:Trect;AMaxLen:Integer;π SelectKey:Word);π Procedure HandleEvent(Var Event:TEvent); virtual;π end;π PMyLine = ^MyLine;ππconstπ SelectFirst = 1000;ππConstructor MyLine.Init(var bounds:Trect;AMaxLen:Integer;π SelectKey:Word);π Beginπ Inherited Init(Bounds,AMaxLen);π EventMask := EventMask or evBroadcast;π Selector := SelectKey;π End;ππProcedure MyLine.HandleEvent(Var Event:TEvent);π Beginπ inherited HandleEvent(Event);π if (Event.What = EvBroadcast) andπ (Event.Command = Selector)π then Select;π End;ππConstructor MyDlg.Init;π var r:trect;π i:integer;π Beginπ r.assign(0,0,50,13);π inherited init(r,'test dialog');π options := options or ofcentered;π getextent(r);π r.grow(-3,-2);π r.b.y := r.a.y + 1;π for i := 1 to 4 doπ beginπ if i = 2π then insert(new(PMyLine,init(r,size.x,SelectFirst)))π else insert(New(PInputLine,init(r,size.x)));π inc(r.a.y,2); inc(r.b.y,2);π end;π inc(r.b.y);π inc(r.a.x,(size.x div 2) - 14);π dec(r.b.x,(size.x div 2) - 13);π insert(new(Pbutton,init(r,'~S~elect FirstLine',π SelectFirst,bfdefault)));π SelectNext(False);π end;ππProcedure MyDlg.HandleEvent(Var Event:TEvent);π Beginπ inherited HandleEvent(Event);π if (Event.What = EvCommand) andπ (Event.Command = SelectFirst)π then Message(owner,evBroadcast,Event.Command,nil);π end;ππvarπ a : TApplication;π m : longint;πtypeπ PMyDlg = ^MyDlg;ππbeginπ m := memavail;π with a doπ beginπ Init;π ExecuteDialog(new(PMyDlg,init),nil);π done;π end;π if memavail <> m then writeln('memory allocation/deallocation error');πend.π 35 02-15-9408:09ALL DONN AULT Extended TV GADGETS SWAG9402 22 d {********************************************************************}π{ }π{ Author: Donn Ault }π{ Date: 12/18/91 }π{ Purpose: Extend clock view to show am/pm }π{ Extend heap view to include commas (more readable) }π{ Copyright: Donated to the public domain }π{ }π{ Notes: }π{ + In your main program you will need more space for the expanded }π{ views. The old clock uses 9 characters while the new }π{ clock uses 12. The old heap viewer uses 9 while the new one }π{ uses 13. Change the R.B.X occordingly. }π{ }π{********************************************************************}ππunit xgadgets;ππ{$F+,O+,S-,D-}ππinterfaceππuses Dos, Objects, Views, App, gadgets;ππtypeπ PXHeapView = ^TXHeapView;π TXHeapView = object (THeapView)π Procedure Draw; Virtual;π Function Comma ( N : LongInt ) : String;π End;ππ PXClockView = ^TXClockView;π TXClockView = Object (TClockView)π am : Char;π Function FormatTimeStr (h,m,s : word) : String; Virtual;π Procedure Draw; Virtual;π End;ππimplementationππuses Drivers;ππFunction TXHeapView.Comma ( n : LongInt) : String;πVar num, loc : Byte;π s : String;π t : String;πBeginπ Str (n,s);π Str (n:Size.X,t);ππ num := length(s) div 3;π if (length(s) mod 3) = 0 then dec (num);ππ delete (t,1,num);π loc := length(t)-2;ππ while num > 0 doπ Beginπ Insert (',',t,loc);π dec (num);π dec (loc,3);π End;ππ Comma := t;πEnd;ππprocedure TXHeapView.Draw;πvarπ S: String;π B: TDrawBuffer;π C: Byte;ππbeginπ OldMem := MemAvail;ππ S := Comma (OldMem);π C := GetColor(2);π MoveChar(B, ' ', C, Size.X);π MoveStr(B, S, C);π WriteLine(0, 0, Size.X, 1, B);πend;ππprocedure TXClockView.Draw;πvarπ B: TDrawBuffer;π C: Byte;πbeginπ C := GetColor(2);π MoveChar(B, ' ', C, Size.X);π MoveStr(B, TimeStr + ' '+am+'m', C); { Modified line }π WriteLine(0, 0, Size.X, 1, B);πend;ππFunction TXClockView.FormatTimeStr (h,m,s: Word) : String;πBeginπ if h = 0 thenπ Beginπ h := 12;π am := 'a';π Endπ Else if h > 12 thenπ Beginπ dec (h,12);π am := 'p';π Endπ Else am := 'a';π FormatTimeStr := TClockView.FormatTimeStr (h,m,s);πEnd;ππEnd.ππ 36 02-15-9408:40ALL M. FIEL ScreenSaver Object SWAG9402 31 d UNIT ScrSaver;ππ{π ScreenSaver Object based on the ScreenSaver byπ Stefan Boether in the TurboVision Forum of CompuServeππ (C) M.Fiel 1993 Vienna - Austriaπ CompuServe ID : 100041,2007ππ Initialize it with a string (wich is printed on the screen) and the timeπ in seconds when it should start.ππ To see how it works start the menupoint 'ScreenSave' in theπ demo.exeππ to see how to initialisze the saver watch the demo source.ππ to increase or decrease the speed of the printed string use theπ '+' and '-' key (the gray ones);ππ Use freely if you find it useful.ππ}πππINTERFACEππUSES Dos, Objects, Drivers, Views, App ;ππTYPEππ PScreenSaver = ^TScreenSaver;π TScreenSaver = object( TView )ππ Activ : Boolean;π Seconds : Integer;ππ constructor Init(FName:String;StartSeconds:Integer);π procedure GetEvent(var Event : TEvent); virtual;π function itsTimeToAct : Boolean;ππ PRIVATEππ LastPos : Integer;π Factory : PString;π DelayTime : Integer;π IdleTime : LongInt;ππ procedure Action; virtual;π procedure SetIdleTime; virtual;ππ END;ππIMPLEMENTATIONππ USESπ Crt;ππ constructor TScreenSaver.Init(FName:String;StartSeconds:Integer);π varπ R : TRect;π beginππ R.Assign(ScreenWidth-1,0,ScreenWidth,1);π inherited Init(R);ππ LastPos:=(ScreenWidth DIV 2);π Factory:=NewStr(FName);π DelayTime:=100;π Seconds :=StartSeconds;π SetIdleTime;ππ end;ππ procedure TScreenSaver.GetEvent(var Event:TEvent);π beginππ if (Event.What=evNothing) then beginππ if not Activ then beginππ if itsTimeToAct then beginπ Activ := True;π DoneVideo;π end;ππ end else Action;ππ end else if Activ then beginππ if ((Event.What=evKeyDown) and ((Event.KeyCode=kbGrayPlus) orπ (Event.KeyCode=kbGrayMinus)) ) then beginπ case Event.KeyCode ofπ kbGrayPlus:if DelayTime>0 then dec(DelayTime);π kbGrayMinus:if DelayTime<4000 then inc(DelayTime);π end;ππ ClearEvent(Event);ππ end else beginπ Activ := False;π InitVideo;π Application^.ReDraw;π SetIdleTime;π end;π end elseπ SetIdleTime;π end;ππ procedure TScreenSaver.SetIdleTime;π varπ h,m,s,mm: word;π beginπ GetTime(h,m,s,mm);π IdleTime:=(h*3600)+(m*60)+s;π end;ππ function TScreenSaver.itsTimeToAct : Boolean;π varπ h,m,s,mm: word;π beginπ GetTime(h,m,s,mm);π itsTimeToAct:=( ((h*3600)+(m*60)+s) > (IdleTime+Seconds) )π end;ππ procedure TScreenSaver.Action;π varπ Reg:Registers;π PrStr : String;π beginπ Dec(LastPos);ππ if LastPos>0 then beginππ if LastPos<=ScreenWidth then beginπ if LastPos=ScreenWidth then LastPos:=ScreenWidth-length(Factory^);π Reg.DL:=LastPos;π PrStr:=Factory^+' ';π end else beginπ PrStr:=(Copy(Factory^,1,ScreenWidth+length(Factory^)-LastPos));π Reg.DL:=ScreenWidth-length(PrStr);π end;ππ end else beginππ if length(Factory^)+LastPos=0 then beginπ PrStr:=' ';π Reg.DL:=0;π LastPos:=ScreenWidth+length(Factory^);π end else beginπ Reg.DL := $00;π PrStr:=Copy(Factory^,Abs(LastPos)+1,80)+' ';π end;ππ end;ππ with Reg do beginπ AH := $02;π BH := $00;π DH := (ScreenHeight DIV 2) + (ScreenHeight DIV 4);π end;π Intr($10,Reg); (* Set Cursor Position *)ππ PrintStr(PrStr);ππ with Reg do beginπ AH:=$02;π BH:=$00;π DH:=(ScreenHeight+1);π DL:=$00;π end;π Intr($10,Reg); (* Set Cursor Position outside -> Cursor not visible *)ππ Delay(DelayTime);ππ end;ππEND. 37 02-15-9408:41ALL M. FIEL Recursive Expression ParsSWAG9402 119 d UNIT PARSER;ππ{ recursive descent expression Parser.ππ Based on the parser by Herbert Shildt as shown inπ Advanced Cπ Osborn McGraw-Hillππ Ported to Pascal byππ (C) M.Fiel 1993 Vienna - Austriaπ CompuServe ID : 100041,2007ππ for further infos refer to this book.ππ Use freely if you find it useful.ππ}π{$R+}ππINTERFACEππ USESπ Objects,ParTools;ππ CONSTπ MaxParserVars = 100; { Max Count of Variables fo PVarParser }ππ TYPEππ{ PMathParser evaluates expressions like (-(10*5)/27) * 128 no variables }ππ PMathParser = ^TMathParser;π TMathParser = object(TObject)ππ ToParse : PString; { the string to parse }π ExprPos : Integer; { aktuall position in the string }π TokenType : Integer; { Variable delimiter...}π Token : String; { the aktuell token }ππ Result : Real; { the result of the expression }ππ constructor Init;π destructor Done; virtual;ππ function Evaluate(Expression:String) : Real;π { expression is the string which is to be evaluatedπ calls function Parse}ππ function GetNextToken : Boolean; virtual;π function GetPart : String; virtual;π function isDelimiter : Boolean; virtual;ππ function AddSub : Boolean; virtual;π { checks for Addition or Substr and calls MulDiv }π function MulDiv : Boolean; virtual;π { checks for Multiplikation or Div. and calls Unary }π function Unary : Boolean; virtual;π { checks for Unary (+/-) and calls Parant }π function Parant : Boolean; virtual;π { checks for paratheses and if necessary calls Parse --> go recursive }ππ function Primitive : Boolean; virtual;π { evaluates constatn value }ππ function Parse : Boolean; virtual;π { parse not necessary in this version (call addsub instead) but isπ needed in descents }ππ end;ππ{ VarParser can Handle Variables and epressions likeπ A=10.78π B=20.45π A*(B-10)+5π .π .π .π}π PVarParser = ^TVarParser;π TVarParser = object(TMathParser)ππ Vars : PParserVarColl;{Container of Variables defined in Unit ParTools}ππ constructor Init;π destructor Done; virtual;ππ function Primitive : Boolean; virtual;π function Parse : Boolean; virtual;π { Calls Checckassign }ππ function CheckAssign : Boolean; virtual;π { checks assignments : ex. A=12 }π procedure ClearVars; virtual;π { clears all variables }ππ end;ππIMPLEMENTATIONππ CONST { defines wich type a token is }π tError = 0;π tVariable = 1;π tDelimiter = 2;π tNumber = 3;π tConstValue = 4;ππ constructor TMathParser.Init;π beginπ if not inherited Init then FAIL;π ExprPos:=0;π Token:='';π end;ππ destructor TMathParser.Done;π beginπ if (ToParse<>NIL) then DisposeStr(ToParse);π inherited Done;π end;ππ function TMathParser.Evaluate(Expression:String) : Real;ππ beginππ if (ToParse<>NIL) then DisposeStr(ToParse);π ToParse:=NewStr(Expression);ππ result:=0.00;π ExprPos:=1;ππ if GetNextToken then Parse;ππ Evaluate:=result;ππ end;ππ function TMathParser.Parse : Boolean;π beginπ Parse:=AddSub;π end;ππ function TMathParser.GetNextToken : Boolean;π beginππ GetNextToken:=True;ππ while ToParse^[ExprPos] = ' ' do inc(ExprPos);ππ if (isDelimiter) then beginππ TokenType := tDelimiter;π Token:=ToParse^[ExprPos];π inc(ExprPos);ππ end else beginππ case ToParse^[ExprPos] ofππ '0'..'9':beginπ TokenType := tNumber;π Token :=GetPart;π end;ππ 'A'..'Z','a'..'z' : beginπ TokenType := tVariable;π Token:=GetPart;π end;ππ else beginπ TokenType := tError;π GetNextToken:=False;π end;ππ end;ππ end;ππ end;ππ function TMathParser.GetPart : String;π varπ RetVal : String;π beginππ RetVal:='';ππ while not(isDelimiter) do beginππ RetVal:=RetVal+ToParse^[ExprPos];ππ if ExprPos<length(ToParse^) thenπ inc(ExprPos)π else beginπ RetVal:=Trim(RetVal);π GetPart:=RetVal;π Exit;π end;ππ end;ππ RetVal:=Trim(RetVal);ππ GetPart:=RetVal;ππ end;ππ function TMathParser.isDelimiter : Boolean;π beginπ isDelimiter:=(Pos(ToParse^[ExprPos],'+-*/()=%')<>0);π end;ππ function TMathParser.AddSub : Boolean;π varπ Hold : Real;π OldToken : String;π beginππ AddSub:=True;ππ if (MulDiv) then beginππ while (Pos(Token,'+-') > 0) do beginππ OldToken:=Token;π GetNextToken;ππ Hold:=Result;ππ if (MulDiv) then beginπ if OldToken='+' then Result:=(Hold+Result) else Result:=(Hold-Result);π end elseπ AddSub:=False;ππ end;ππ end elseπ AddSub:=False;ππ end;ππ function TMathParser.MulDiv : Boolean;π varπ Hold : Real;π PerHelp : Real;π OldToken : String;π beginππ MulDiv:=True;ππ if (Unary) then beginππ while (Pos(Token,'*/%') > 0) do beginππ OldToken:=Token;π GetNextToken;π Hold:=Result;ππ if (Unary) then beginππ case OldToken[1] ofπ '*':Result:=Hold*Result;ππ '/':beginπ if (Result<> 0) thenπ Result:=Hold/Resultπ else beginπ OwnError('Division by zero');π MulDiv:=False;π end;π end;ππ '%':beginπ PerHelp:=Hold/Result;π Result:=Hold-(PerHelp*Result);π end;ππ end;ππ end elseπ MulDiv:=False;ππ end;ππ end elseπ MulDiv:=False;ππ end;ππ function TMathParser.Unary : Boolean;π varπ UnaryHelp:Boolean;π OldToken : String;π beginππ Unary:=True;ππ UnaryHelp:=False;ππ if (Pos(Token,'-+') >0) then beginπ OldToken:=Token;π UnaryHelp:=True;π GetNextToken;π end;ππ if (Parant) then beginπ if (UnaryHelp and (OldToken = '-')) then Result:=-(Result);π end elseπ Unary:=False;ππ end;ππ function TMathParser.Parant : Boolean;π beginππ Parant:=True;ππ if ((TokenType = tDelimiter) and (Token = '(')) then beginππ GetNextToken;ππ if (Parse) then beginππ if (Token <> ')') then beginπ OwnError('unbalanced parantheses');π Parant:=False;π end;ππ end elseπ Parant:=False;ππ GetNextToken;ππ end elseππ Parant:=Primitive;ππ end;ππ function TMathParser.Primitive : Boolean;π varπ e:Integer;π beginππ Primitive:=True;ππ if (TokenType = tNumber) then beginππ val(Token,Result,e);ππ if (e<>0) then beginπ OwnError('syntax error');π Primitive:=False;π end;ππ GetNextToken;ππ end;ππ end;πππ{****************************************************************************}π{ TVARPARSER }π{****************************************************************************}ππ constructor TVarParser.Init;π beginπ if not inherited Init then FAIL;π Vars:=New(PParserVarColl,Init(MaxParserVars,0));π end;ππ destructor TVarParser.Done;π beginπ Dispose(Vars,Done);π inherited Done;π end;ππ function TVarParser.Primitive : Boolean;π beginππ Primitive:=True;ππ if (inherited Primitive) then beginππ if (TokenType = tVariable) then beginπ result:=Vars^.GetVar(Token);π GetNextToken;π end;ππ end elseπ Primitive:=False;ππ end;ππ function TVarParser.Parse : Boolean;π beginπ Parse:=CheckAssign;π end;ππ function TVarParser.CheckAssign : Boolean;π varπ OldToken : String;π OldType : Integer;π beginππ if (TokenType = tVariable) then beginππ OldToken :=Token;π OldType := TokenType;ππ GetNextToken;ππ if (Token = '=') then beginππ GetNextToken;ππ CheckAssign:=AddSub;π Vars^.SetValue(OLdToken,result);ππ Exit;ππ end else beginππ dec(ExprPos,length(Token));π Token:=OldToken;π TokenType:=OldType;ππ end;ππ end;ππ CheckAssign := AddSub;ππ end;ππ procedure TVarParser.ClearVars;π beginπ Vars^.FreeAll;π end;ππEND.ππ{ -------------------------------- CUT HERE -----------------------}ππUNIT PARTOOLS;ππ{π (C) M.Fiel 1993 Vienna - Austriaπ CompuServe ID : 100041,2007ππ Use freely if you find it useful.π}ππINTERFACEππ USESπ Objects;ππ TYPEππ {Object to hold variable data for the TVarParser defined in Unit Parser}ππ PParserVar = ^TParserVar;π TParserVar = object(TObject)ππ Name : PString;π Value : Real;ππ constructor Init(aName:String;aValue:Real);π destructor Done; virtual;ππ function GetName : String; virtual;π function GetValue : Real; virtual;π procedure SetValue(NewValue : Real); virtual;ππ end;ππ {Container to hold TParserVar objects }ππ PParserVarColl = ^TParserVarColl;π TParserVarColl = object(TCollection)ππ procedure FreeItem(Item:Pointer); virtual;π function GetVarIndex(Name:String) : Integer; virtual;π function GetVar(Name:String) : Real; virtual;π procedure SetValue(Name:String;NewValue:Real); virtual;ππ end;ππ PStrColl = ^TStrColl; { Container for Strings }π TStrColl = object(TCollection)π procedure FreeItem(Item: Pointer); virtual;π end;ππ procedure OwnError(S:String); { Shows a MsgBox with S }π function Trim(Line:String) : String; { Pads a String from End }π function MkStr(Len,Val:Byte): String;π { makes a String of length len and fills it with val }ππIMPLEMENTATIONππ USESπ MsgBox;ππ constructor TParserVar.Init(aName:String;aValue:Real);π beginπ inherited Init;π Name:=NewStr(aName);π Value:=aValue;π end;ππ destructor TParserVar.Done;π beginπ DisposeStr(Name);π inherited Done;π end;ππ function TParserVar.GetName : String;π beginπ if Name<>NIL then GetName:=Name^ else GetName:='';π end;ππ function TParserVar.GetValue : Real;π beginπ GetValue:=Value;π end;ππ procedure TParserVar.SetValue(NewValue : Real);π beginπ Value:=NewValue;π end;ππ procedure TParserVarColl.FreeItem(Item:Pointer);π beginπ if (Item <> NIL) then Dispose(PParserVar(Item),Done);π end;πππ function TParserVarColl.GetVar(Name:String) : Real;π varπ Index:Integer;π beginπ Index:=GetVarIndex(Name);ππ if (Index<>-1) thenπ GetVar:=PParserVar(At(Index))^.GetValueπ else beginπ OwnError('invalid variable');π GetVar:=0;π end;ππ end;ππ function TParserVarColl.GetVarIndex(Name:String) : Integer;ππ function isName(P:PParserVar):Boolean;π beginπ isName:=(P^.GetName = Name);π end;ππ beginπ GetVarIndex:=IndexOf(FirstThat(@isName));π end;ππ procedure TParserVarColl.SetValue(Name:String;NewValue:Real);π varπ Index : Integer;ππ beginππ Index:=GetVarIndex(Name);ππ if (Index <> -1) thenπ PParserVar(At(Index))^.SetValue(NewValue)π elseπ Insert(New(PParserVar,Init(Name,NewValue)));ππ end;ππ procedure OwnError(S:String);π beginπ MessageBox(S,nil,mfError + mfOkButton);π end;ππ function Trim(Line:String) : String;π varπ Len: BYTE ABSOLUTE Line;π beginπ while (Len > 0) AND (Line[Len] = ' ') DO Dec(Len);π Trim := Line;π end ;ππ function MkStr (Len,Val:Byte): String;π varπ S:String;π beginπ S[0]:=chr(Len);π fillchar (S[1],Len,Val);π MkStr:=s;π end;ππ procedure TStrColl.FreeItem(Item: Pointer);π beginπ if Item<>Nil then DisposeStr(Item);π end;ππEND.ππ{ -------------------------------- DEMO PROGRAM -----------------------}ππPROGRAM PARDEMO;ππ{π (C) M.Fiel 1993 Vienna - Austriaπ CompuServe ID : 100041,2007ππ Use freely if you find it useful.ππ Demonstration of a Recursive descent Parser and a new Screensaverπ object.ππ Infos watch the units and the parser.txt fileππ if problems or comments leave me a message or mail me.ππ}ππππUSESπ Objects,Drivers,Menus,Views,App,Dialogs,ScrSaver,TVParser;ππ { NOTE - SCRSAVER UNIT CAN BE FOUND IN SWAG DISTRIBUTION ALSO !!}π { AND WILL BE NEED BY THIS MODULE }ππCONSTπ cmParser = 1001;π cmScreenSave = 1002;ππTYPEππ PApp = ^Tapp;π TApp = object(TApplication)ππ ScreenSaver : PScreenSaver; { defined in unit ScrSav }π {add the screensaver object to the application}ππ constructor Init;ππ procedure HandleEvent (var event:Tevent); virtual;π procedure InitMenuBar; virtual;π procedure InitStatusLine; virtual;π procedure ShowParser;π procedure GetEvent(var Event: TEvent); virtual;ππ end;ππ VARπ XApplic: TApp;ππ constructor TApp.Init;π beginπ if not inherited Init then FAIL;ππ ScreenSaver:=New(PScreenSaver,Init('I''m the Screensaver',180));π Insert(ScreenSaver);ππ end;ππ procedure TApp.GetEvent(var Event: TEvent);π beginπ inherited GetEvent(Event);π ScreenSaver^.GetEvent(Event); { don't forget this line }π end;ππ procedure Tapp.InitStatusLine;ππ varπ R: TRect;π beginππ GetExtent(r);π R.A.Y := R.B.Y - 1;ππ StatusLine:=New(PStatusLine, Init(R,ππ NewStatusDef (0, 1000,π newstatuskey ('~F10~-Menu',kbF10,cmmenu,π newstatuskey ('~Alt-X~ Exit', kbaltx, cmQuit,π NIL)),ππ NIL)));ππ end;ππ procedure Tapp.InitMenuBar;ππ varπ R : TRect;π beginππ GetExtent(R);π R.B.Y := R.A.Y + 1;ππ MenuBar:=New(PMenuBar,Init(R,NewMenu(ππ NewSubMenu('~≡~ ',hcNoContext,NewMenu(π NewItem('~Alt-X~ Exit','',kbAltX,cmQuit,hcNoContext,π NIL)),ππ NewItem('~P~arser','',0,cmParser,hcNoContext,π NewItem('~S~creensave','',0,cmScreenSave,hcNoContext,ππ Nil))))));π end;ππ procedure TApp.ShowParser;π varπ Parser:PVisionParser;π beginπ Parser:=New(PVisionParser,Init);π if Parser<>NIL then beginπ DeskTop^.ExecView(Parser);π Dispose(Parser,Done);π end;π end;πππ procedure Tapp.HandleEvent (var Event:TEvent);π beginππ case Event.What ofππ evCommand : beginππ case (Event.Command) ofππ cmParser : ShowParser;π cmScreenSave : beginπ DoneVideo;π ScreenSaver^.Activ:=True;π end;π else inherited HandleEvent (Event);ππ end;ππ end;ππ else inherited HandleEvent (Event);ππ end;ππ end;πππbeginππ XApplic.Init;π XApplic.Run;π XApplic.Done;ππend.π
