SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00028 POINTERS, LINKING, LISTS, TREES 1 05-28-9313:54ALL SWAG SUPPORT TEAM DLLIST1.PAS IMPORT 9 ╙═√d { > Does anybody have any good source/Units For Turboπ > Pascal 6.0/7.0 For doing Double Linked List Fileπ > structures?π}ππTypeππ DLinkPtr = ^DLinkRecord;ππ DLinkRecord = Recordπ Data : Integer;π Next : DLinkPtr;π Last : DLinkPtr;π end;ππVarπ Current,π First,π Final,π Prev : DLinkPtr;π X : Byte;ππProcedure AddNode;πbeginπ if First = Nil thenπ beginπ New(Current);π Current^.Next:=Nil;π Current^.Last:=Nil;π Current^.Data:=32;π First:=Current;π Final:=Current;π endπ elseπ beginπ Prev:=Current;π New(Current);π Current^.Next:=Nil;π Current^.Last:=Prev;π Current^.Data:=54;π Prev^.Next:=Current;π Final:=Current;π end;πend;ππbeginπ First:=Nil;π For X:=1 to 10 Do AddNode;π Writeln('First: ',first^.data);π Writeln('Final: ',final^.data);π Writeln('Others:');π Writeln(first^.next^.data);ππend.π 2 05-28-9313:54ALL SWAG SUPPORT TEAM LINKLIST.PAS IMPORT 63 ╙═╖─ {πThe following is the LinkList Unit written by Peter Davis in his wonderfulπbut, unFortunately, short-lived newsletter # PNL002.ZIP. I have used thisπUnit to Write tests of three or four of the Procedures but have stumped my toeπon his DELETE_HERE Procedure, the last one in the Unit. I will post my testsπin the next message For any who may wish to see it: Pete's Unit is unmodified.π I almost think there is some kind of error in DELETE_HERE but he was tooπthorough For that. Can you, or someone seeing this show me how to use thisπProcedure? It will help me both With Pointers and With Units.ππHere is the Unit:π}ππUnit LinkList;ππ{ This is the linked list Unit acCompanying The Pascal NewsLetter, Issue #2.π This Unit is copyrighted by Peter Davis.π It may be freely distributed in un-modified Form, or modified For use inπ your own Programs. Programs using any modified or unmodified Form of thisπ(107 min left), (H)elp, More? Unit must include a run-time and source visible recognition of the author,π Peter Davis.π}ππ{ The DataType used is Integer, but may be changed to whatever data Typeπ that you want.π}ππInterfaceπππTypeπ DataType = Integer; { Change this data-Type to whatever you want }ππ Data_Ptr = ^Data_Rec; { Pointer to our data Records }ππ Data_Rec = Record { Our Data Record Format }π OurData : DataType;π Next_Rec : Data_Ptr;π end;πππProcedure Init_List(Var Head : Data_Ptr);πProcedure Insert_begin(Var Head : Data_Ptr; Data_Value : DataType);πProcedure Insert_end(Var Head : Data_Ptr; Data_Value : DataType);πProcedure Insert_In_order(Var Head : Data_Ptr; Data_Value : DataType);πFunction Pop_First(Var Head : Data_Ptr) : DataType;πFunction Pop_Last(Var Head : Data_Ptr) : DataType;πProcedure Delete_Here(Var Head : Data_Ptr; Our_Rec : Data_Ptr);ππππImplementationππProcedure Init_List(Var Head : Data_Ptr);ππbeginπ Head := nil;πend;ππProcedure Insert_begin(Var Head : Data_Ptr; Data_Value : DataType);ππ{ This Procedure will insert a link and value into theπ beginning of a linked list. }ππVarπ Temp : Data_Ptr; { Temporary Pointer. }ππbeginπ new(Temp); { Allocate our space in memory. }π Temp^.Next_Rec := Head; { Point to existing list. }π Head:= Temp; { Move head to new data item. }π Head^.OurData := Data_Value; { Insert Data_Value. }πend;ππProcedure Insert_end(Var Head : Data_Ptr; Data_Value : DataType);ππ{ This Procedure will insert a link and value into theπ end of the linked list. }ππVarπ Temp1, { This is where we're going to put new data }π Temp2 : Data_Ptr; { This is to move through the list. }ππbeginπ new(Temp1);π Temp2 := Head;π if Head=nil thenπ beginπ Head := Temp1; { if list is empty, insert first }π Head^.OurData := Data_Value; { and only Record. Add value and }π Head^.Next_Rec := nil; { then put nil in Next_Rec Pointer }π endπ elseπ beginπ { Go to the end of the list. Since Head is a Variable parameter,π we can't move it through the list without losing Pointer to theπ beginning of the list. to fix this, we use a third Variable:π Temp2.π }π While Temp2^.Next_Rec <> nil do { Find the end of the list. }π Temp2 := Temp2^.Next_Rec;ππ Temp2^.Next_Rec := Temp1; { Insert as last Record. }π Temp1^.Next_Rec := nil; { Put in nil to signify end }π Temp1^.OurData := Data_Value; { and, insert the data }π end;πend;ππProcedure Insert_In_order(Var Head : Data_Ptr; Data_Value : DataType);ππ{ This Procedure will search through an ordered linked list, findπ out where the data belongs, and insert it into the list. }ππVarπ Current, { Where we are in the list }π Next : Data_Ptr; { This is what we insert our data into. }ππbeginπ New(Next);π Current := Head; { Start at the top of the list. }ππ if Head = Nil thenπ beginπ Head:= Next;π Head^.OurData := Data_Value;π Head^.Next_Rec := Nil;π endπ elseπ { Check to see if it comes beFore the first item in the list }π if Data_Value < Current^.OurData thenπ beginπ Next^.Next_Rec := Head; { Make the current first come after Next }π Head := Next; { This is our new head of the list }π Head^.OurData := Data_Value; { and insert our data value. }π endπ elseπ beginπ { Here we need to go through the list, but always looking one stepπ ahead of where we are, so we can maintain the links. The methodπ we'll use here is: looking at Current^.Next_Rec^.OurDataπ A way to explain that in english is "what is the data pointed toπ by Pointer Next_Rec, in the Record pointed to by Pointerπ current." You may need to run that through your head a few timesπ beFore it clicks, but hearing it in English might make it a bitπ easier For some people to understand. }ππ While (Data_Value >= Current^.Next_Rec^.OurData) andπ (Current^.Next_Rec <> nil) doπ Current := Current^.Next_Rec;π Next^.OurData := Data_Value;π Next^.Next_Rec := Current^.Next_Rec;π Current^.Next_Rec := Next;π end;πend;ππFunction Pop_First(Var Head : Data_Ptr) : DataType;ππ{ Pops the first item off the list and returns the value to the caller. }ππVarπ Old_Head : Data_Ptr;ππbeginπ if Head <> nil then { Is list empty? }π beginπ Old_Head := Head;π Pop_First := Head^.OurData; { Nope, so Return the value }π Head := Head^.Next_Rec; { and increment head. }π Dispose(Old_Head); { Get rid of the old head. }π endπ elseπ beginπ Writeln('Error: Tried to pop an empty stack!');π halt(1);π end;πend;πππFunction Pop_Last(Var Head : Data_Ptr) : DataType;ππ{ This Function pops the last item off the list and returns theπ value of DataType to the caller. }ππVarπ Temp : Data_Ptr;ππbeginπ Temp := Head; { Start at the beginning of the list. }π if head = nil then { Is the list empty? }π beginπ Writeln('Error: Tried to pop an empty stack!');π halt(1);π endπ elseπ if head^.Next_Rec = Nil then { if there is only one item in list, }π beginπ Pop_Last := Head^.OurData; { Return the value }π Dispose(Head); { Return the memory to the heap. }π Head := Nil; { and make list empty. }π endπ elseπ beginπ While Temp^.Next_Rec^.Next_Rec <> nil do { otherwise, find the end }π Temp := Temp^.Next_rec;π Pop_Last := Temp^.Next_Rec^.OurData; { Return the value }π Dispose(Temp^.Next_Rec); { Return the memory to heap }π Temp^.Next_Rec := nil; { and make new end of list. }π end;πend;πππProcedure Delete_Here(Var Head : Data_Ptr; Our_Rec : Data_Ptr);πππ{ Deletes the node Our_Rec from the list starting at Head. The Procedureπ does check For an empty list, but it assumes that Our_Rec IS in the list.π}ππVarπ Current : Data_Ptr; { Used to move through the list. }ππbeginπ Current := Head;π if Current = nil then { Is the list empty? }π beginπ Writeln('Error: Cant delete from an empty stack.');π halt(1);π endπ elseπ begin { Go through list Until we find the one to delete. }π While Current^.Next_Rec <> Our_Rec doπ Current := Current^.Next_Rec;π Current ^.Next_Rec := Our_Rec^.Next_Rec; { Point around old link. }π Dispose(Our_Rec); { Get rid of the link.. }π end;πend;πππend.π 3 05-28-9313:54ALL SWAG SUPPORT TEAM LL-INSRT.PAS IMPORT 13 ╙═#t { The following Program yields output that indicates that I have it set upπcorrectly but With my scanty understanding of exactly how to handle a linkedπlist I would be surprised if it is. This is one difficult area in which Swanπis not quite as expansive as he might be.ππ I will appreciate critique and commentary on this if you are anybodyπwould be so kind as to give it:π}ππProgram InsertLink;πUses Crt;ππTypeπ Str15 = String[15];π Aptr = ^Link;π Link = Recordπ Data : Str15;π Node : Aptr;π end;ππVarπ FirstItem, NewItem, OldItem : Aptr;ππProcedure CreateList;πbeginπ Writeln('Linked list BEForE insertion of node.');π Writeln;π New(FirstItem);π FirstItem^.Data := 'inSERT ';π Write(FirstItem^.Data);π Write(' ');π New(FirstItem^.Node);π FirstItem^.Node^.Data := 'HERE';π Writeln(FirstItem^.Node^.Data);π FirstItem^.Node^.Node := NIL;πend;ππProcedure InsertALink;πbeginπ Writeln; Writeln;π Writeln('Linked list AFTER insertion of node.');π Writeln;π Write(FirstItem^.Data);π New(NewItem);π NewItem^.Node := OldItem^.Node;π OldItem^.Node := NewItem;π FirstItem^.Node^.Data := 'inSERTEDLinK';π Write(FirstItem^.Node^.Data);π New(FirstItem^.Node^.Node);π FirstItem^.Node^.Node^.Data := ' HERE';π Writeln(FirstItem^.Node^.Node^.Data);π FirstItem^.Node^.Node^.Node := NIL;πend;ππProcedure DisposeList;πbeginπ Dispose(FirstItem^.Node^.Node);π FirstItem^.Node := NIL;πend;ππbeginπ ClrScr;π CreateList;π Writeln;π InsertALink;π DisposeList;πend.π 4 05-28-9313:54ALL SWAG SUPPORT TEAM LL_TEST.PAS IMPORT 20 ╙═±O {πThis is the test Program that I drew up to test the Procedures in PeteπDavis' LinkList.Pas posted in the previous message. It could be a little moreπdressed up but it does work and offers some insight, I think, into the use ofπPointers and linked lists: note that I ran a little manual test to locate aπdesignated Pointer in a given list. Here it is:π}ππUsesπ Crt, LinkList;ππVarπ AList1, AList2, AList3, AList4 : Data_Ptr;π ANum : DataType;π Count : Integer;ππbeginπ ClrScr;π Init_List(AList1);π Writeln('Results of inserting links at the beginning of a list: ');π For Count := 1 to 20 doπ beginπ ANum := Count;π Write(' ',ANum);π Insert_begin(AList1, ANum); {pay out first link (1) to last (20) like}π {a fishing line With #-cards. You end up}π end; {with 20 in your hand going up to 1}π Writeln;π Writeln('Watch - Last link inserted is the highest number.');π Writeln('You are paying out the list like reeling out a fishing line,');π Writeln('Foot 1, Foot 2, Foot 3, etc. - last one is Foot 20.');π Writeln('Now, mentally reel in the line to the fourth number.');π Writeln(' ',alist1^.Next_Rec^.Next_Rec^.Next_Rec^.OurData);π Writeln;π Writeln('Now insert one additional number at beginning of list');π beginπ ANum := 21;π Insert_begin(AList1,ANum);π end;π Writeln(' ',AList1^.OurData);π Writeln;πππ Init_List(Alist2);π Writeln('Results of Inserting links in turn at the end of a list: ');π For Count := 1 to 20 doπ beginπ ANum := Count;π Write(' ',ANum);π Insert_end(Alist2,ANum);π end;π Writeln;π Writeln('note, just the reverse situation of the process above.');π Writeln('Reel in the line to the fourth number.');π Writeln(' ',Alist2^.Next_Rec^.Next_Rec^.Next_Rec^.OurData);π {We inserted at the end so we are now going out toward the 20}ππππ Init_List(Alist3);π Writeln('Results of Inserting links in turn in orDER');π For Count := 1 to 20 doπ beginπ Anum := Count;π Write(' ',ANum);π Insert_In_order(Alist3,ANum);π end;π Writeln;π Writeln(' ',Alist3^.Next_Rec^.Next_Rec^.Next_Rec^.OurData);ππend.π{π In Case anybody missed Pete Davis' Linklist Unit in the previousπmessage but may have it in her/his library (PNL002.ZIP) what I was asking isπsome help With writing code to test the Procedure DELETE_HERE which is the lastπProcedure in the Unit.π} 5 05-28-9313:54ALL SWAG SUPPORT TEAM OOP-LLST.PAS IMPORT 90 ╙═û┴ Program Linked;ππTypeπ FileDescriptor =π Objectπ Fpt : File;π Name : String[80];π HeaderSize: Word;π RecordSize: Word;π RecordPtr : Pointer;π SoftPut : Boolean;π IsOpen : Boolean;π CurRec : LongInt;ππ Constructor Init(Nam : String; Hdr : Word; Size : Word; Buff : Pointer;πPut : Boolean);π Destructor Done; Virtual;π Procedure OpenFile; Virtual;π Procedure CloseFile; Virtual;π Procedure GetRecord(Rec : LongInt);π Procedure PutRecord(Rec : LongInt);π end;ππ FileLable =π Recordπ Eof : LongInt;π MRD : LongInt;π Act : LongInt;π Val : LongInt;π Sync: LongInt;π end;ππ LabeledFile =π Object(FileDescriptor)π Header : FileLable;ππ Constructor Init(Nam : String; Size : Word; Buff : Pointer; Put :πBoolean);π Destructor Done; Virtual;π Procedure OpenFile; Virtual;π Procedure CloseFile; Virtual;π Procedure WriteHeader;π Procedure ReadHeader;π Procedure AddRecord;π Procedure DelRecord(Rec : LongInt);π end;ππ DetailHeaderPtr = ^DetailHeader;π DetailHeader =π Recordπ Master : LongInt;π Prev : LongInt;π Next : LongInt;π end;ππ MasterHeaderPtr = ^MasterHeader;π MasterHeader =π Recordπ First : LongInt;π Last : LongInt;π end;ππ DetailFileDetailPtr = ^DetailFileDetail;π DetailFileDetail =π Object(LabeledFile)π Constructor Init(Nam : String; Size : Word; Buff : Pointer; Put :πBoolean);π Procedure LinkChain(MR, Last, Curr : LongInt);π Procedure DelinkChain(Rec : LongInt);π end;ππ DetailFileMaster =π Object(LabeledFile)π Constructor Init(Nam : String; Size : Word; Buff : Pointer; Put :πBoolean);π Procedure LinkDetail(DF : DetailFileDetailPtr);π Procedure DelinkDetail(DF : DetailFileDetailPtr; DR : LongInt);π Procedure GetFirst(DF : DetailFileDetailPtr);π Procedure GetLast(DF : DetailFileDetailPtr);π Procedure GetNext(DF : DetailFileDetailPtr);π Procedure GetPrev(DF : DetailFileDetailPtr);π end;ππ{---------------------------------------------------------------------------}ππConstructor FileDescriptor.Init(Nam : String; Hdr : Word; Size : Word; Buff :π Pointer; Put : Boolean);π beginπ IsOpen := False;π Name := Nam;π HeaderSize := Hdr;π RecordSize := Size;π RecordPtr := Buff;π SoftPut := Put;π CurRec := -1;π end;ππDestructor FileDescriptor.Done;π beginπ if SoftPut and (CurRec <> -1) thenπ PutRecord(CurRec);π if IsOpen thenπ CloseFile;π end;ππProcedure FileDescriptor.OpenFile;π beginπ if IsOpen thenπ Exit;π Assign(Fpt,Name);π {$I-}π Reset(Fpt,1);π if IoResult <> 0 thenπ ReWrite(Fpt,1);π if IoResult = 0 thenπ IsOpen := True;π {$I+}π CurRec := -1;π end;ππProcedure FileDescriptor.CloseFile;π beginπ if not IsOpen thenπ Exit;π {$I-}π Close(Fpt);π if IoResult = 0 thenπ IsOpen := False;π {$I+}π CurRec := -1;π end;ππProcedure FileDescriptor.GetRecord(Rec : LongInt);π Varπ Result : Word;π beginπ if not IsOpen thenπ Exit;π if CurRec = Rec thenπ Exit;π if SoftPut and (CurRec <> -1) thenπ PutRecord(CurRec);π {$I-}π if Rec = 0 thenπ beginπ Seek(Fpt,0);π if IoResult = 0 thenπ beginπ BlockRead(Fpt,RecordPtr^,HeaderSize,Result);π if (Result <> HeaderSize) or (IoResult <> 0) thenπ {Error Routine};π end;π endπ elseπ beginπ Seek(Fpt,HeaderSize + (Rec - 1) * RecordSize);π if IoResult = 0 thenπ beginπ BlockRead(Fpt,RecordPtr^,RecordSize,Result);π if (Result <> RecordSize) or (IoResult <> 0) thenπ {Error Routine};π end;π end;π {$I+}π CurRec := Rec;π end;ππProcedure FileDescriptor.PutRecord(Rec : LongInt);π Varπ Result : Word;π beginπ if not IsOpen thenπ Exit;π {$I-}π if Rec = 0 thenπ beginπ Seek(Fpt,0);π if IoResult = 0 thenπ beginπ BlockWrite(Fpt,RecordPtr^,HeaderSize,Result);π if (Result <> HeaderSize) or (IoResult <> 0) thenπ {Error Routine};π end;π endπ elseπ beginπ Seek(Fpt,HeaderSize + (Rec - 1) * RecordSize);π if IoResult = 0 thenπ beginπ BlockWrite(Fpt,RecordPtr^,RecordSize,Result);π if (Result <> RecordSize) or (IoResult <> 0) thenπ {Error Routine};π end;π end;π CurRec := Rec;π {$I+}π end;ππ{---------------------------------------------------------------------------}ππConstructor LabeledFile.Init(Nam : String; Size : Word; Buff : Pointer; Put :πBoolean);π beginπ if Size < 4 thenπ beginπ WriteLN('Record size must be 4 or larger');π Fail;π end;π FileDescriptor.Init(Nam,Sizeof(Header),Size,Buff,Put);π Header.Eof := 0;π Header.MRD := 0;π Header.Act := 0;π Header.Val := 0;π Header.Sync:= 0;π end;ππDestructor LabeledFile.Done;π beginπ CloseFile;π FileDescriptor.Done;π end;ππProcedure LabeledFile.OpenFile;π beginπ FileDescriptor.OpenFile;π if IsOpen thenπ ReadHeader;π end;ππProcedure LabeledFile.CloseFile;π beginπ {$I-}π if IsOpen thenπ beginπ if SoftPut and (CurRec <> -1) thenπ PutRecord(CurRec);π Header.Val := 0;π WriteHeader;π CurRec := -1;π end;π FileDescriptor.CloseFile;π {$I+}π end;ππProcedure LabeledFile.ReadHeader;π Varπ Result : Word;π beginπ {$I-}π Seek(Fpt,0);π if IoResult = 0 thenπ beginπ BlockRead(Fpt,Header,HeaderSize,Result);π if (Result <> HeaderSize) or (IoResult <> 0) thenπ {Error Routine};π end;π {$I+}π end;ππProcedure LabeledFile.WriteHeader;π Varπ Result : Word;π beginπ {$I-}π Seek(Fpt,0);π if IoResult = 0 thenπ beginπ BlockWrite(Fpt,Header,HeaderSize,Result);π if (Result <> HeaderSize) or (IoResult <> 0) thenπ {Error Routine};π end;π {$I+}π end;ππProcedure LabeledFile.AddRecord;π Varπ TmpRec : Pointer;π Result : Word;π Next : LongInt;π beginπ {$I-}π if Header.MRD <> 0 thenπ beginπ GetMem(TmpRec,RecordSize);π Seek(Fpt,HeaderSize + (Header.MRD - 1) * RecordSize);π if IoResult = 0 thenπ beginπ BlockRead(Fpt,TmpRec^,RecordSize,Result);π if (Result <> RecordSize) or (IoResult <> 0) thenπ {Error Routine};π Next := LongInt(TmpRec^);π PutRecord(Header.MRD);π Header.MRD := Next;π Header.Act := Header.Act + 1;π end;π FreeMem(TmpRec,RecordSize);π endπ elseπ beginπ PutRecord(Header.Eof);π Header.Eof := Header.Eof + 1;π Header.Act := Header.Act + 1;π end;π WriteHeader;π {$I+}π end;ππProcedure LabeledFile.DelRecord(Rec : LongInt);π Varπ TmpRec : Pointer;π Result : Word;π beginπ {$I-}π GetMem(TmpRec,RecordSize);π Seek(Fpt,HeaderSize + (Rec - 1) * RecordSize);π if IoResult = 0 thenπ beginπ BlockRead(Fpt,TmpRec^,RecordSize,Result);π LongInt(TmpRec^) := Header.MRD;π BlockWrite(Fpt,TmpRec^,RecordSize,Result);π if (Result <> RecordSize) or (IoResult <> 0) thenπ {Error Routine};π Header.MRD := Rec;π Header.Act := Header.Act - 1;π WriteHeader;π end;π {$I+}π end;ππ{---------------------------------------------------------------------------}ππConstructor DetailFileDetail.Init(Nam : String; Size : Word; Buff : Pointer;πPut : Boolean);π beginπ if Size < 12 thenπ beginπ WriteLn('Detail File Records must be 12 Bytes or more');π Fail;π end;π LabeledFile.Init(Nam,Size,Buff,Put);π end;ππProcedure DetailFileDetail.LinkChain(MR, Last, Curr : LongInt);π Varπ Hdr : DetailHeaderPtr;π beginπ Hdr := RecordPtr;π if Last <> 0 thenπ beginπ GetRecord(Last);π Hdr^.Next := Curr;π PutRecord(Last);π end;π GetRecord(Curr);π Hdr^.Prev := Last;π Hdr^.Master := MR;π Hdr^.Next := 0;π PutRecord(Curr);π end;ππProcedure DetailFileDetail.DelinkChain(Rec : LongInt); Varπ Hdr : DetailHeaderPtr;π Tmp : LongInt;π beginπ Hdr := RecordPtr;π GetRecord(Rec);π if Hdr^.Next <> 0 thenπ beginπ Tmp := Hdr^.Prev;π GetRecord(Hdr^.Next);π Hdr^.Prev := Tmp;π PutRecord(CurRec);π GetRecord(Rec);π end;π if Hdr^.Prev <> 0 thenπ beginπ Tmp := Hdr^.Next;π GetRecord(Hdr^.Prev);π Hdr^.Next := Tmp;π PutRecord(CurRec);π GetRecord(Rec);π end;π Hdr^.Master := 0;π Hdr^.Next := 0;π Hdr^.Prev := 0;π PutRecord(Rec);π end;ππ{---------------------------------------------------------------------------}ππConstructor DetailFileMaster.Init(Nam : String; Size : Word; Buff : Pointer;πPut : Boolean);π beginπ if Size < 8 thenπ beginπ WriteLn('Master File Records must be 8 Bytes or more');π Fail;π end;π LabeledFile.Init(Nam,Size,Buff,Put);π end;ππProcedure DetailFileMaster.LinkDetail(DF : DetailFileDetailPtr);π Varπ Hdr : MasterHeaderPtr;π beginπ Hdr := RecordPtr;π DF^.AddRecord;π DF^.LinkChain(CurRec,Hdr^.Last,DF^.CurRec);π Hdr^.Last := DF^.CurRec;π if Hdr^.First = 0 then Hdr^.First := DF^.CurRec;π PutRecord(CurRec);π end;ππProcedure DetailFileMaster.DelinkDetail(DF : DetailFileDetailPtr; DR :πLongInt);π Varπ Hdr : MasterHeaderPtr;π beginπ Hdr := RecordPtr;π DF^.GetRecord(DR);π if Hdr^.Last = DR thenπ Hdr^.Last := DetailHeader(DF^.RecordPtr^).Prev;π if Hdr^.First = DR thenπ Hdr^.First := DetailHeader(DF^.RecordPtr^).Next;π DF^.DelinkChain(DR);π PutRecord(CurRec);π end;ππProcedure DetailFileMaster.GetFirst(DF : DetailFileDetailPtr);π Varπ Hdr : MasterHeaderPtr;π beginπ Hdr := RecordPtr;π if Hdr^.First = 0 thenπ beginπ FillChar(DF^.RecordPtr^,DF^.RecordSize,#0);π DF^.CurRec := -1;π Exit;π end;π DF^.GetRecord(Hdr^.First);π end;ππProcedure DetailFileMaster.GetLast(DF : DetailFileDetailPtr);π Varπ Hdr : MasterHeaderPtr;π beginπ Hdr := RecordPtr;π if Hdr^.Last = 0 thenπ beginπ FillChar(DF^.RecordPtr^,DF^.RecordSize,#0);π DF^.CurRec := -1;π Exit;π end;π DF^.GetRecord(Hdr^.Last);π end;ππProcedure DetailFileMaster.GetNext(DF : DetailFileDetailPtr);π Varπ Hdr : DetailHeaderPtr;π beginπ Hdr := DF^.RecordPtr;π if Hdr^.Next = 0 thenπ beginπ FillChar(DF^.RecordPtr^,DF^.RecordSize,#0);π DF^.CurRec := -1;π Exit;π end;π DF^.GetRecord(Hdr^.Next);π end;ππProcedure DetailFileMaster.GetPrev(DF : DetailFileDetailPtr);π Varπ Hdr : DetailHeaderPtr;π beginπ Hdr := DF^.RecordPtr;π if Hdr^.Prev = 0 thenπ beginπ FillChar(DF^.RecordPtr^,DF^.RecordSize,#0);π DF^.CurRec := -1;π Exit;π end;π DF^.GetRecord(Hdr^.Prev);π end;ππ{---------------------------------------------------------------------------}ππbeginπend.ππ 6 05-28-9313:54ALL SWAG SUPPORT TEAM PTR-MEM.PAS IMPORT 5 ╙═ñ5 Program Test_Pointers;ππTypeπ Array_Pointer = ^MyArray;π MyArray = Array[1..10] of String;ππVarπ MyVar : Array_Pointer;ππbeginπ Writeln('Memory beFore initializing Variable : ',MemAvail);ππ New(MyVar);ππ Writeln('Memory after initializiation : ',MemAvail);ππ MyVar^[1] := 'Hello';π MyVar^[2] := 'World!';ππ Writeln(MyVar^[1], ' ', MyVar^[2]);ππ Dispose(MyVar);ππ Writeln('Memory after Variable memory released : ',MemAvail);πend.π 7 05-28-9313:54ALL SWAG SUPPORT TEAM PTRARRAY.PAS IMPORT 13 ╙═x DS> Hi, I've recently encountered a problem With not having enough memoryπDS> to open a large sized Array [ie: 0..900]. Is there any way toπDS> allocate more memory to the Array as to make larger ArraysππArray of what? if the total size of the Array (i.e. 901 *πsizeof(whatever_it_is_you're_talking_about)) is less than 64K, it's a snap.πRead your dox on Pointers and the heap. You'll end up doing something likeπthis:ππTypeπ tWhatever : whatever_it_is_you're_talking_about;π tMyArray : Array[0..900] of tWhatever;π tPMyArray : ^MyArray;ππVarπ PMyArray : tPMyArray;ππbeginπ getmem(PMyArray,sizeof(tMyArray));ππ { now access your Array like this:π PMyArray^[IndexNo] }ππif your Array is >64K, you can do something like this:ππTypeπ tWhatever : whatever_it_is_you're_talking_about;π tPWhatever : ^tWhatever;ππVarπ MyArray : Array[0..900] of tPWhatever;π i : Word;ππbeginπ For i := 0 to 900 doπ getmem(MyArray[i],sizeof(tWhatever));ππ { now access your Array like this:π MyArray[IndexNo]^ }ππif you don't have enough room left in your data segment to use this latterπapproach (and I'll bet you do), you'll just need one more level of indirection.πDeclare one Pointer in the data segment that points to the Array of Pointers onπthe heap, which in turn point to your data.ππif you're a beginner, this may seem impossibly Complex (it did to me), but keepπat it and it will soon be second nature.π 8 05-28-9313:54ALL SWAG SUPPORT TEAM TREEHITE.PAS IMPORT 7 ╙═£ {πAuthors: Chet Kress and Jerome Tonnesonππ>Help !!! I need a Function or Procedure in standard pascal that willπ>calculate the height of a binary tree. It must be able to calculate theπ>height of the tree if the tree is either balanced, unbalanced or full.π>The Procedure must be recursive.ππHere are the only two Functions you will need.π}ππFunction Max(A, B : Integer) : Integer;πbegin {Max}π If A > B thenπ Max := A;π elseπ Max := B;πend; {Max}ππFunction Height (Tree : TreeType) : Integer;πbegin {Height}π If Tree = Nil thenπ Height := 0π elseπ Height := Max(Height(Tree^.Right), Height(Tree^.Left)) + 1;πend; {Height}π 9 06-22-9309:20ALL SWAG SUPPORT TEAM Generic Linked List IMPORT 34 ╙═]D UNIT LinkList;ππ{-------------------------------------------------π Generic linked list object -π-------------------------------------------------}ππ{***************************************************************}π INTERFACEπ{***************************************************************}ππTYPEππ { Generic Linked List Handler Definition }ππ NodeValuePtr = ^NodeValue;ππ NodeValue = OBJECTπ CONSTRUCTOR Init;π DESTRUCTOR Done; VIRTUAL;π END;ππ NodePtr = ^Node;π Node = RECORDπ Retrieve : NodeValuePtr;π Next : NodePtr;π END;πππ { Specific Linked List Handler Definition }ππ NodeListPtr = ^NodeList;ππ NodeList = OBJECTπ Items : NodePtr;π CONSTRUCTOR Init;π DESTRUCTOR Done; VIRTUAL;π PROCEDURE Add (A_Value : NodeValuePtr);ππ (* Iterator Functions *)ππ PROCEDURE StartIterator (VAR Ptr : NodePtr);π PROCEDURE NextValue (VAR Ptr : NodePtr);π FUNCTION AtEndOfList (Ptr : NodePtr) : Boolean;π END;ππ{***************************************************************}π IMPLEMENTATIONπ{***************************************************************}πππCONSTRUCTOR NodeValue.Init;πBEGINπEND;ππDESTRUCTOR NodeValue.Done;πBEGINπEND;ππCONSTRUCTOR NodeList.Init;πBEGINπ Items := NIL;πEND;ππDESTRUCTOR NodeList.Done;π VARπ Temp : NodePtr;πBEGINπ WHILE Items <> NIL DOπ BEGINπ Temp := Items;π IF Temp^.Retrieve <> NIL THENπ Dispose (Temp^.Retrieve, Done);π Items := Items^.Next;π Dispose (Temp);π END;πEND;ππPROCEDURE NodeList.Add (A_Value : NodeValuePtr);π VARπ Cell : NodePtr;π Temp : NodePtr;πBEGINπ (* Go TO the END OF the linked list. *)π Cell := Items;π IF Cell <> NIL THENπ WHILE Cell^.Next <> NIL DOπ Cell := Cell^.Next;ππ New (Temp);π Temp^.Retrieve := A_Value;π Temp^.Next := NIL;π IF Items = NILπ THENπ Items := Tempπ ELSEπ Cell^.Next := Temp;πEND;ππPROCEDURE NodeList.StartIterator (VAR Ptr : NodePtr);πBEGINπ Ptr := Items;πEND;ππPROCEDURE NodeList.NextValue (VAR Ptr : NodePtr);πBEGINπ IF Ptr <> NIL THENπ Ptr := Ptr^.Next;πEND;ππFUNCTION NodeList.AtEndOfList (Ptr : NodePtr) : Boolean;πBEGINπ AtEndOfList := (Ptr = NIL);πEND;ππEND.ππ{ DEMO PROGRAM }ππPROGRAM LL_Demo;ππUSES LinkList;ππ{ Turbo Pascal Linked List Object Example }ππTYPEππ DataValuePtr = ^DataValue;ππ DataValue = OBJECT (NodeValue)π Value : Real;π CONSTRUCTOR Init (A_Value : Real);π FUNCTION TheValue : Real;π END;ππ DataList = OBJECT (NodeList)π FUNCTION CurrentValue (Ptr : NodePtr) : Real;π PROCEDURE SetCurrentValue (Ptr : NodePtr; Value : Real);π END;ππVARπ Itr : NodePtr;π TestLink : DataList;ππ{------ Unique methods to create for your linked list type -----}ππCONSTRUCTOR DataValue.Init (A_Value : Real);πBEGINπ Value := A_Value;πEND;ππFUNCTION DataValue.TheValue : Real;πBEGINπ TheValue := Value;πEND;ππFUNCTION DataList.CurrentValue (Ptr : NodePtr) : Real;πBEGINπ CurrentValue := DataValuePtr (Ptr^.Retrieve)^.TheValue;πEND;ππPROCEDURE DataList.SetCurrentValue (Ptr : NodePtr; Value : Real);πBEGINπ DataValuePtr (Ptr^.Retrieve)^.Value := Value;πEND;πππBEGINπ TestLink.Init; {Create the list then add 5 values to it}ππ TestLink.Add (New (DataValuePtr, Init (1.0)));π TestLink.Add (New (DataValuePtr, Init (2.0)));π TestLink.Add (New (DataValuePtr, Init (3.0)));π TestLink.Add (New (DataValuePtr, Init (4.0)));π TestLink.Add (New (DataValuePtr, Init (5.0)));ππ TestLink.StartIterator (Itr); {Display the list on screen}π WHILE NOT TestLink.AtEndOfList (Itr) DO BEGINπ Write (TestLink.CurrentValue (Itr) : 5 : 1);π TestLink.NextValue (Itr);π END;π WriteLn;ππ TestLink.StartIterator (Itr); {Change some values in the list}π TestLink.SetCurrentValue (Itr, 0.0);π TestLink.NextValue (Itr);π TestLink.SetCurrentValue (Itr, -1.0);ππ TestLink.StartIterator (Itr); {Redisplay the list values}π WHILE NOT TestLink.AtEndOfList (Itr) DO BEGINπ Write (TestLink.CurrentValue (Itr) : 5 : 1);π TestLink.NextValue (Itr);π END;π WriteLn;π ReadLn;πEND.π 10 08-17-9308:39ALL SWAG SUPPORT TEAM Binary Tree - Linked ListIMPORT 73 ╙═╙¡ Unit BinTree;ππInterfaceππConst TOTAL_NODES = 100;ππType BTreeStr = String[40];π ShiftSet = (TiltL_Tilt, neutral, TiltR_Tilt);π BinData = Recordπ Key : BTreeStr;π End;π BinPtr = ^Bin_Tree_Rec;π Bin_Tree_Rec = Recordπ BTreeData : BinData;π Shift : ShiftSet;π TiltL, TiltR : BinPtr;π End;π BTreeRec = Array[1..TOTAL_NODES] of BinData;ππProcedure Ins_BinTreeπ (Var Rt : BinPtr;π Node : BinData);ππFunction Srch_BinTreeπ (Rt : BinPtr;π Node : BinData;π Index1 : Word) : Word;ππProcedure BSortArrayπ (Var Rt : BinPtr;π Var SortNode : BTreeRec;π Var Index : Word);ππProcedure Del_BinTreeπ (Var Rt : BinPtr;π Node : BinData;π Var DelFlag : Boolean);ππImplementationππProcedure Move_TiltR(Var Rt : BinPtr);ππ Varπ Ptr1, Ptr2 : BinPtr;ππ Beginπ Ptr1 := Rt^.TiltR;π If Ptr1^.Shift = TiltR_Tilt Then Beginπ Rt^.TiltR := Ptr1^.TiltL;π Ptr1^.TiltL := Rt;π Rt^.Shift := neutral;π Rt := Ptr1π Endπ Else Beginπ Ptr2 := Ptr1^.TiltL;π Ptr1^.TiltL := Ptr2^.TiltR;π Ptr2^.TiltR := Ptr1;π Rt^.TiltR := Ptr2^.TiltL;π Ptr2^.TiltL := Rt;π If Ptr2^.Shift = TiltL_Tiltπ Then Ptr1^.Shift := TiltR_Tiltπ Else Ptr1^.Shift := neutral;π If Ptr2^.Shift = TiltR_Tiltπ Then Rt^.Shift := TiltL_Tiltπ Else Rt^.Shift := neutral;π Rt := Ptr2π End;π Rt^.Shift := neutralπ End;ππProcedure Move_TiltL(Var Rt : BinPtr);ππ Varπ Ptr1, Ptr2 : BinPtr;ππ Beginπ Ptr1 := Rt^.TiltL;π If Ptr1^.Shift = TiltL_Tilt Then Beginπ Rt^.TiltL := Ptr1^.TiltR;π Ptr1^.TiltR := Rt;π Rt^.Shift := neutral;π Rt := Ptr1π Endπ Else Beginπ Ptr2 := Ptr1^.TiltR;π Ptr1^.TiltR := Ptr2^.TiltL;π Ptr2^.TiltL := Ptr1;π Rt^.TiltL := Ptr2^.TiltR;π Ptr2^.TiltR := Rt;π If Ptr2^.Shift = TiltR_Tiltπ Then Ptr1^.Shift := TiltL_Tiltπ Else Ptr1^.Shift := neutral;π If Ptr2^.Shift = TiltL_Tiltπ Then Rt^.Shift := TiltR_Tiltπ Else Rt^.Shift := neutral;π Rt := Ptr2;π End;π Rt^.Shift := neutralπ End;ππProcedure Ins_Bin(Var Rt : BinPtr;π Node : BinData;π Var InsOK : Boolean);ππ Beginπ If Rt = NIL Then Beginπ New(Rt);π With Rt^ Do Beginπ BTreeData := Node;π TiltL := NIL;π TiltR := NIL;π Shift := neutralπ End;π InsOK := TRUEπ Endπ Else If Node.Key <= Rt^.BTreeData.Key Then Beginπ Ins_Bin(Rt^.TiltL, Node, InsOK);π If InsOK Thenπ Case Rt^.Shift Ofπ TiltL_Tilt : Beginπ Move_TiltL(Rt);π InsOK := FALSEπ End;π neutral : Rt^.Shift := TiltL_Tilt;π TiltR_Tilt : Beginπ Rt^.Shift := neutral;π InsOK := FALSEπ End;π End;π Endπ Else Beginπ Ins_Bin(Rt^.TiltR, Node, InsOK);π If InsOK Thenπ Case Rt^.Shift Ofπ TiltL_Tilt : Beginπ Rt^.Shift := neutral;π InsOK := FALSEπ End;π neutral : Rt^.Shift := TiltR_Tilt;π TiltR_Tilt : Beginπ Move_TiltR(Rt);π InsOK := FALSEπ End;π End;π End;π End;ππProcedure Ins_BinTree(Var Rt : BinPtr;π Node : BinData);ππ Var Ins_ok : Boolean;ππ Beginπ Ins_ok := FALSE;π Ins_Bin(Rt, Node, Ins_ok)π End;ππFunction Srch_BinTree(Rt : BinPtr;π Node : BinData;π Index1 : Word)π : Word;ππ Varπ Index : Word;ππ Beginπ Index := 0;π While (Rt <> NIL) AND (Index < Index1) Doπ If Node.Key > Rt^.BTreeData.Key Then Rt := Rt^.TiltRπ Else if Node.Key < Rt^.BTreeData.Key Then Rt := Rt^.TiltLπ Else Beginπ Inc(Index);π Rt := Rt^.TiltLπ End;π Srch_BinTree := Indexπ End;ππProcedure Tvrs_Treeπ (Var Rt : BinPtr;π Var SortNode : BTreeRec;π Var Index : Word);ππ Beginπ If Rt <> NIL Then Beginπ Tvrs_Tree(Rt^.TiltL, SortNode, Index);π Inc(Index);π If Index <= TOTAL_NODES Thenπ SortNode[Index].Key := Rt^.BTreeData.Key;π Tvrs_Tree(Rt^.TiltR, SortNode, Index);π End;π End;ππProcedure BSortArrayπ (Var Rt : BinPtr;π Var SortNode : BTreeRec;π Var Index : Word);ππ Beginπ Index := 0;π Tvrs_Tree(Rt, SortNode, Index);π End;ππProcedure Shift_TiltRπ (Var Rt : BinPtr;π Var DelFlag : Boolean);ππ Varπ Ptr1, Ptr2 : BinPtr;π balnc2, balnc3 : ShiftSet;ππ Beginπ Case Rt^.Shift Ofπ TiltL_Tilt : Rt^.Shift := neutral;π neutral : Beginπ Rt^.Shift := TiltR_Tilt;π DelFlag := FALSEπ End;π TiltR_Tilt : Beginπ Ptr1 := Rt^.TiltR;π balnc2 := Ptr1^.Shift;π If NOT (balnc2 = TiltL_Tilt) Then Beginπ Rt^.TiltR := Ptr1^.TiltL;π Ptr1^.TiltL := Rt;π If balnc2 = neutral Then Beginπ Rt^.Shift := TiltR_Tilt;π Ptr1^.Shift := TiltL_Tilt;π DelFlag := FALSEπ Endπ Else Beginπ Rt^.Shift := neutral;π Ptr1^.Shift := neutral;π End;π Rt := Ptr1π Endπ Else Beginπ Ptr2 := Ptr1^.TiltL;π balnc3 := Ptr2^.Shift;π Ptr1^.TiltL := Ptr2^.TiltR;π Ptr2^.TiltR := Ptr1;π Rt^.TiltR := Ptr2^.TiltL;π Ptr2^.TiltL := Rt;π If balnc3 = TiltL_Tilt Thenπ Ptr1^.Shift := TiltR_Tiltπ Elseπ Ptr1^.Shift := neutral;π If balnc3 = TiltR_Tilt Thenπ Rt^.Shift := TiltL_Tiltπ Elseπ Rt^.Shift := neutral;π Rt := Ptr2;π Ptr2^.Shift := neutral;π End;π End;π End;π End;ππProcedure Shift_TiltLπ (Var Rt : BinPtr;π Var DelFlag : Boolean);ππ Varπ Ptr1, Ptr2 : BinPtr;π balnc2, balnc3 : ShiftSet;ππ Beginπ Case Rt^.Shift Ofπ TiltR_Tilt : Rt^.Shift := neutral;π neutral : Beginπ Rt^.Shift := TiltL_Tilt;π DelFlag := Falseπ End;π TiltL_Tilt : Beginπ Ptr1 := Rt^.TiltL;π balnc2 := Ptr1^.Shift;π If NOT (balnc2 = TiltR_Tilt) Then Beginπ Rt^.TiltL := Ptr1^.TiltR;π Ptr1^.TiltR := Rt;π If balnc2 = neutral Then Beginπ Rt^.Shift := TiltL_Tilt;π Ptr1^.Shift := TiltR_Tilt;π DelFlag := FALSEπ Endπ Else Beginπ Rt^.Shift := neutral;π Ptr1^.Shift := neutral;π End;π Rt := Ptr1π Endπ Else Beginπ Ptr2 := Ptr1^.TiltR;π balnc3 := Ptr2^.Shift;π Ptr1^.TiltR := Ptr2^.TiltL;π Ptr2^.TiltL := Ptr1;π Rt^.TiltL := Ptr2^.TiltR;π Ptr2^.TiltR := Rt;π If balnc3 = TiltR_Tilt Thenπ Ptr1^.Shift := TiltL_Tiltπ Elseπ Ptr1^.Shift := neutral;π If balnc3 = TiltL_Tilt Thenπ Rt^.Shift := TiltR_Tiltπ Elseπ Rt^.Shift := neutral;π Rt := Ptr2;π Ptr2^.Shift := neutral;π End;π End;π End;π End;ππProcedure Kill_Lo_Nodesπ (Var Rt,π Ptr : BinPtr;π Var DelFlag : Boolean);ππ Beginπ If Ptr^.TiltR = NIL Then Beginπ Rt^.BTreeData := Ptr^.BTreeData;π Ptr := Ptr^.TiltL;π DelFlag := TRUEπ Endπ Else Beginπ Kill_Lo_Nodes(Rt, Ptr^.TiltR, DelFlag);π If DelFlag Then Shift_TiltL(Ptr,DelFlag);π End;π End;ππProcedure Del_Bin(Var Rt : BinPtr;π Node : BinData;π Var DelFlag : Boolean);ππ Varπ Ptr : BinPtr;ππ Beginπ If Rt = NIL Thenπ DelFlag := Falseπ Elseπ If Node.Key < Rt^.BTreeData.Key Then Beginπ Del_Bin(Rt^.TiltL, Node, DelFlag);π If DelFlag Then Shift_TiltR(Rt, DelFlag);π Endπ Else Beginπ If Node.Key > Rt^.BTreeData.Key Then Beginπ Del_Bin(Rt^.TiltR, Node, DelFlag);π If DelFlag Then Shift_TiltL(Rt, DelFlag);π Endπ Else Beginπ Ptr := Rt;π If Rt^.TiltR = NIL Then Beginπ Rt := Rt^.TiltL;π DelFlag := TRUE;π Dispose(Ptr);π Endπ Else If Rt^.TiltL = NIL Then Beginπ Rt := Rt^.TiltR;π DelFlag := TRUE;π Dispose(Ptr);π Endπ Else Beginπ Kill_Lo_Nodes(Rt, Rt^.TiltL, DelFlag);π If DelFlag Then Shift_TiltR(Rt, DelFlag);π Dispose(Rt^.TiltL);π End;π End;π End;π End;ππProcedure Del_BinTreeπ (Var Rt : BinPtr;π Node : BinData;π Var DelFlag : Boolean);ππ Beginπ DelFlag := FALSE;π Del_Bin(Rt, Node, DelFlag)π End;πEnd. 11 08-27-9320:11ALL SWAG SUPPORT TEAM AVL Binary Trees IMPORT 52 ╙═ . {π> Does anyone have code(preferably TP) the implements AVL trees?π> I'm having trouble With the insertion part of it. I'm writing a smallπ> parts inventory Program For work(although I'm not employed as aπ> Programmer) and the AVL tree would be very fast For it.π}πππProgram avl;ππTypeπ nodeptr = ^node;π node = Recordπ key : Char;π bal : -1..+1; { bal = h(right) - h(left) }π left,π right : nodeptrπ end;ππ tree = nodeptr;ππVarπ t : tree;π h : Boolean; { insert & delete parameter }πππProcedure maketree(Var t : tree);πbeginπ t := nil;πend;ππFunction member(k : Char; t : tree) : Boolean;πbegin { member }π if t = nil thenπ member := Falseπ elseπ if k = t^.key thenπ member := Trueπ elseπ if k < t^.key thenπ member := member(k, t^.left)π elseπ member := member(k, t^.right);πend;ππProcedure ll(Var t : tree);πVarπ p : tree;πbeginπ p := t^.left;π t^.left := p^.right;π p^.right := t;π t := p;πend;ππProcedure rr(Var t : tree);πVarπ p : tree;πbeginπ p := t^.right;π t^.right := p^.left;π p^.left := t;π t := p;πendππProcedure lr(Var t : tree);πbeginπ rr(t^.left);π ll(t);πend;ππProcedure rl(Var t : tree);πbeginπ ll(t^.right);π rr(t);πend;ππProcedure insert(k : Char; Var t : tree; Var h : Boolean);ππ Procedure balanceleft(Var t : tree; Var h : Boolean);π beginπ Writeln('balance left');π Case t^.bal ofπ +1 :π beginπ t^.bal := 0;π h := False;π end;π 0 : t^.bal := -1;π -1 :π begin { rebalance }π if t^.left^.bal = -1 thenπ begin { single ll rotation }π Writeln('single ll rotation');π ll(t);π t^.right^.bal := 0;π endπ else { t^.left^.bal = +1 }π begin { double lr rotation }π Writeln('double lr rotation');π lr(t);π if t^.bal = -1 thenπ t^.right^.bal := +1π elseπ t^.right^.bal := 0;π if t^.bal = +1 thenπ t^.left^.bal := -1π elseπ t^.left^.bal := 0;π end;π t^.bal := 0;π h := False;π end;π end;π end;ππ Procedure balanceright(Var t : tree; Var h : Boolean);π beginπ Writeln('balance right');π Case t^.bal ofπ -1 :π beginπ t^.bal := 0;π h := False;π end;π 0 : t^.bal := +1;π +1 :π begin { rebalance }π if t^.right^.bal = +1 thenπ begin { single rr rotation }π Writeln('single rr rotation');π rr(t);π t^.left^.bal := 0π endπ else { t^.right^.bal = -1 }π begin { double rl rotation }π Writeln('double rl rotation');π rl(t);π if t^.bal = -1 thenπ t^.right^.bal := +1π elseπ t^.right^.bal := 0;π if t^.bal = +1 thenπ t^.left^.bal := -1π elseπ t^.left^.bal := 0;π end;π t^.bal := 0;π h := False;π end;π end;π end;ππbegin { insert }π if t = nil thenπ beginπ new(t);π t^.key := k;π t^.bal := 0;π t^.left := nil;π t^.right := nil;π h := True;π endπ elseπ if k < t^.key thenπ beginπ insert(k, t^.left, h);π if h thenπ balanceleft(t, h);π endπ elseπ if k > t^.key thenπ beginπ insert(k, t^.right, h);π if h thenπ balanceright(t, h);π end;πend;ππProcedure delete(k : Char; Var t : tree; Var h : Boolean);ππ Procedure balanceleft(Var t : tree; Var h : Boolean);π beginπ Writeln('balance left');π Case t^.bal ofπ -1 :π beginπ t^.bal := 0;π h := True;π end;π 0 :π beginπ t^.bal := +1;π h := False;π end;π +1 :π begin { rebalance }π if t^.right^.bal >= 0 thenπ beginπ Writeln('single rr rotation'); { single rr rotation }π if t^.right^.bal = 0 thenπ beginπ rr(t);π t^.bal := -1;π h := False;π endπ elseπ beginπ rr(t);π t^.left^.bal := 0;π t^.bal := 0;π h := True;π end;π endπ else { t^.right^.bal = -1 }π beginπ Writeln('double rl rotation');π rl(t);π t^.left^.bal := 0;π t^.right^.bal := 0;π h := True;π end;π end;π end;π end;ππ Procedure balanceright(Var t : tree; Var h : Boolean);π beginπ Writeln('balance right');π Case t^.bal ofπ +1 :π beginπ t^.bal := 0;π h := True;π end;π 0 :π beginπ t^.bal := -1;π h := False;π end;π -1 :π begin { rebalance }π if t^.left^.bal <= 0 thenπ begin { single ll rotation }π Writeln('single ll rotation');π if t^.left^.bal = 0 thenπ beginπ ll(t);π t^.bal := +1;π h := False;π endπ elseπ beginπ ll(t);π t^.left^.bal := 0;π t^.bal := 0;π h := True;π end;π endπ else { t^.left^.bal = +1 }π begin { double lr rotation }π Writeln('double lr rotation');π lr(t);π t^.left^.bal := 0;π t^.right^.bal := 0;π h := True;π end;π end;π end;π end;ππ Function deletemin(Var t : tree; Var h : Boolean) : Char;π begin { deletemin }π if t^.left = nil thenπ beginπ deletemin := t^.key;π t := t^.right;π h := True;π endπ elseπ beginπ deletemin := deletemin(t^.left, h);π if h thenπ balanceleft(t, h);π end;π end;ππbegin { delete }π if t <> nil thenπ beginπ if k < t^.key thenπ beginπ delete(k, t^.left, h);π if h thenπ balanceleft(t, h);π endπ elseπ if k > t^.key thenπ beginπ delete(k, t^.right, h);π if h thenπ balanceright(t, h);π endπ elseπ if (t^.left = nil) and (t^.right = nil) thenπ beginπ t := nil;π h := True;π endπ elseπ if t^.left = nil thenπ beginπ t := t^.right;π h := True;π endπ elseπ if t^.right = nil thenπ beginπ t := t^.left;π h := True;π endπ elseπ beginπ t^.key := deletemin(t^.right, h);π if h thenπ balanceright(t, h);π end;π end;πend;ππbeginπend.π 12 09-26-9308:50ALL GARRY J. VASS Linked Lists in EMS IMPORT 111 ╙═Çù {π PROTOTYPE PROCEDURES FOR CREATING AND ACCESSING SORTEDπ LINKED LISTS IN EXPANDED MEMORYππ GARRY J. VASS [72307,3311]ππThe procedures and functions given below present a prototypeπmethod for creating and accesing linked lists in expanded memory.πAlthough pointer variables are used in a way that appears toπconform to the TPascal pointer syntax, there are several majorπdifferences:ππ - there are none of the standard NEW, GETMEM,π MARK, RELEASE, DISPOSE, FREEMEM, and MAXAVAILπ calls made. These are bound to the program'sπ physical location in memory, and have noπ effect in expanded memory. Attempting toπ use these here, or to implement standardπ linked procedures by altering the HeapPtrπ standard variable is dangerous and highlyπ discouraged.π - pointer variables are set and queried byπ a simulation of TPascal's internal proceduresπ that is specially customized to the EMSπ page frame segment.π - the MEMAVAIL function is useless here. Theseπ procedures will support a list of up to 64K.ππThe general pseudo-code for creating a linked list in expandedπmemory is:ππ 1. Get a handle and allocate memory from the EMM.π 2. Get the page frame segment for the handle toπ mark the physical beginning of the list inπ expanded memory.π 3. Initialize the root pointer to the page frameπ segment.π 4. For each new record (or list member):ππ a. Calculate a new physical location for theπ record using a simulated normalizationπ procedure.π b. Set the appropriate values to theπ pointers using a simulated pointerπ assignment procedure.π c. Assure that the last logical recordπ contains a pointer value of NIL.ππAccessing the list is basically the same as the standard algorithms.ππThe procedures here assume that each list record (or member) is composedπof three elements:ππ - a pointer to the next logical record. If the member is theπ last logical record, this pointer is NIL.π - an index, or logical sort key. This value determines theπ logical position of the record in the list. These routinesπ and the demo use an integer type for index. The index,π however, can be of any type where ordinal comparisonsπ can be made, including pointers.π - an area for the actual data in each record. These routinesπ and the demo use a string of length 255, but this area canπ be of any type, including pointers to other lists.ππPlease note that these routines are exploratory and prototype. In no wayπare they intended to be definitive, accurate, efficient, or exemplary.ππAreas for further analysis are:ππ 1. A reliable analog to the MEMAVAIL function.π 2. Creating linked lists that cross handle boundaries.π 3. Creating linked lists that begin in heapspace andπ extend to expanded memory.π 4. A reliable method for assigning the standardπ variable, HeapPtr, to the base page.ππPlease let me know of your progress in these areas, or improvementsπto the routines below via the BORLAND SIG [72307,3311] or my PASCAL/πPROLOG SIG at the POLICE STATION BBS (201-963-3115).ππ}πPROGRAM LINKED_LISTS;πUses dos,crt;πCONSTπ ALLOCATE_MEMORY = $43;π EMS_SERVICES = $67;π FOREVER:BOOLEAN = FALSE;π GET_PAGE_FRAME = $41;π LOGICAL_PAGES = 5;π MAP_MEMORY = $44;π RELEASE_HANDLE = $45;πTYPEπ ANYSTRING = STRING[255];π LISTPTR = ^LISTREC;π LISTREC = RECORDπ NEXT_POINTER : LISTPTR;π INDEX_PART : INTEGER;π DATA_PART : ANYSTRING;π END;πVARπ ANYINTEGER : INTEGER;π ANYSTR : ANYSTRING;π HANDLE : INTEGER; { HANDLE ASSIGNED BY EMM }π LIST : LISTREC;π NEWOFFSET : INTEGER; { PHYSICAL OFFSET OF RECORD }π NEWSEGMENT : INTEGER; { PHYSICAL SEGMENT OF RECORD }π REGS1 : Registers;π ROOT : LISTPTR; { POINTER TO LIST ROOT }π SEGMENT : INTEGER; { PAGE FRAME SEGMENT }ππ{--------------------- GENERAL SUPPORT ROUTINES ----------------------}πFUNCTION HEXBYTE(N:INTEGER):ANYSTRING;πCONST H:ANYSTRING='0123456789ABCDEF';πBEGINπ HEXBYTE:=H[((LO(N)DIV 16)MOD 16)+1]+H[(LO(N) MOD 16)+1];πEND;ππFUNCTION HEXWORD(N:INTEGER):ANYSTRING;πBEGINπ HEXWORD:= HEXBYTE(HI(N))+HEXBYTE(LO(N));πEND;ππFUNCTION CARDINAL(I:INTEGER):REAL;πBEGINπ CARDINAL:=256.0*HI(I)+LO(I);πEND;ππPROCEDURE PAUSE;πVAR CH:CHAR;πBEGINπ WRITELN;WRITELN('-- PAUSING FOR KEYBOARD INPUT...');π READ(CH);π WRITELN;πEND;ππPROCEDURE DIE(M:ANYSTRING);πBEGINπ WRITELN('ERROR IN: ',M);π WRITELN('HALTING HERE, SUGGEST REBOOT');π HALT;πEND;πFUNCTION EXIST(FILENAME:ANYSTRING):BOOLEAN;VAR FILVAR:FILE;BEGIN ASSIGN(FILVAR,FILENAME);{$I-}πRESET(FILVAR);{$I+}EXIST := (IORESULT = 0);END;π{--------------------- END OF GENERAL SUPPORT ROUTINES ----------------}ππ{---------------------- EMS SUPPORT ROUTINES -------------------------}ππFUNCTION EMS_INSTALLED:BOOLEAN; { RETURNS TRUE IF EMS IS INSTALLED }πBEGIN { ASSURED DEVICE NAME OF EMMXXXX0 }π EMS_INSTALLED := EXIST('EMMXXXX0');{ BY LOTUS/INTEL/MS STANDARDS }πEND;ππFUNCTION NEWHANDLE(NUMBER_OF_LOGICAL_PAGES_NEEDED:INTEGER):INTEGER;πBEGINπ REGS1.AH := ALLOCATE_MEMORY;π REGS1.BX := NUMBER_OF_LOGICAL_PAGES_NEEDED;π INTR(EMS_SERVICES, REGS1);π IF REGS1.AH <> 0 THEN DIE('ALLOCATE MEMORY');π NEWHANDLE := REGS1.DX;πEND;ππPROCEDURE KILL_HANDLE(HANDLE_TO_KILL:INTEGER); { RELEASES EMS HANDLE. }πBEGIN { THIS MUST BE DONE IF }π REPEAT { OTHER APPLICATIONS ARE }π WRITELN('RELEASING EMS HANDLE'); { TO USE THE EM ARES. DUE}π REGS1.AH := RELEASE_HANDLE; { TO CONCURRENT PROCESSES,}π REGS1.DX := HANDLE_TO_KILL; { SEVERAL TRIES MAY BE }π INTR(EMS_SERVICES, REGS1); { NECESSARY. }π UNTIL REGS1.AH = 0;π WRITELN('HANDLE RELEASED');πEND;ππFUNCTION PAGE_FRAME_SEGMENT:INTEGER; { RETURNS PFS }πBEGINπ REGS1.AH := GET_PAGE_FRAME;π INTR(EMS_SERVICES, REGS1);π IF REGS1.AH <> 0 THEN DIE('GETTING PFS');π PAGE_FRAME_SEGMENT := REGS1.BX;πEND;ππPROCEDURE MAP_MEM(HANDLE_TO_MAP:INTEGER); {MAPS HANDLE TO PHYSICAL}πCONST PHYSICAL_PAGE = 0; {PAGES.}πBEGINπ REGS1.AH := MAP_MEMORY;π REGS1.AL := PHYSICAL_PAGE;π REGS1.BX := PHYSICAL_PAGE;π REGS1.DX := HANDLE_TO_MAP;π INTR(EMS_SERVICES, REGS1);π IF REGS1.AH <> 0 THEN DIE('MAPPING MEMORY');πEND;ππPROCEDURE GET_EMS_MEMORY(NUMBER_OF_16K_LOGICAL_PAGES:INTEGER);πVAR TH:INTEGER; { REQUESTS EM FROM EMM IN 16K INCREMENTS }πBEGINπ HANDLE := NEWHANDLE(NUMBER_OF_16K_LOGICAL_PAGES);π SEGMENT := PAGE_FRAME_SEGMENT;π MAP_MEM(HANDLE);πEND;π{----------------- END OF EMS SUPPORT ROUTINES -----------------------}ππ{----------------- CUSTOMIZED LINKED LIST SUPPORT ---------------------}πFUNCTION ABSOLUTE_ADDRESS(S, O:INTEGER):REAL; { RETURNS THE REAL }πBEGIN { ABSOLUTE ADDRESS }π ABSOLUTE_ADDRESS := (CARDINAL(S) * $10) { FOR SEGMENT "S" }π + CARDINAL(O); { AND OFFSET "O". }πEND;ππPROCEDURE NORMALIZE(VAR S, O:INTEGER); { SIMULATION OF TURBO'S INTERNAL }πVAR { NORMALIZATION ROUTINES FOR }π NEW_SEGMENT: INTEGER; { POINTER VARIABLES. }π NEW_OFFSET : INTEGER; { NORMALIZES SEGMENT "S" AND }πBEGIN { OFFSET "O" INTO LEGITAMATE }π NEW_SEGMENT := S; { POINTER VALUES. }π NEW_OFFSET := O;π REPEATπ CASE NEW_OFFSET OFπ $00..$0E : NEW_OFFSET := SUCC(NEW_OFFSET);π $0F..$FF : BEGINπ NEW_OFFSET := 0;π NEW_SEGMENT := SUCC(NEW_SEGMENT);π END;π END;π UNTIL (ABSOLUTE_ADDRESS(NEW_SEGMENT, NEW_OFFSET) >π ABSOLUTE_ADDRESS(S, O) + SIZEOF(LIST));π S := NEW_SEGMENT;π O := NEW_OFFSET;πEND;ππFUNCTION VALUEOF(P:LISTPTR):ANYSTRING; { RETURNS A STRING IN }π { SEGMENT:OFFSET FORMAT }π { WHICH CONTAINS VALUE }πBEGIN { OF A POINTER VARIABLE }π VALUEOF := HEXBYTE(MEM[SEG(P):OFS(P) + 3]) +π HEXBYTE(MEM[SEG(P):OFS(P) + 2]) +':'+π HEXBYTE(MEM[SEG(P):OFS(P) + 1]) +π HEXBYTE(MEM[SEG(P):OFS(P) + 0]);πEND;ππPROCEDURE SNAP(P:LISTPTR); { FOR THE RECORD BEING }πBEGIN { POINTED TO BY "P", THIS }π WRITELN(VALUEOF(P):10, { PRINTS THE SEGMENT/OFFSET }π VALUEOF(P^.NEXT_POINTER):20, { LOCATION, THE SEGMENT/ }π P^.INDEX_PART:5, { OFFSET OF THE RECORD PONTER, }π ' ',P^.DATA_PART); { RECORD INDEX, AND DATA. }πEND;ππPROCEDURE PROCESS_LIST; { GET AND PRINT MEMBERS OF A LIST }πVAR M1:LISTPTR; { SORTED IN INDEX ORDER. }πBEGINπ PAUSE;π M1 := ROOT;π WRITELN;π WRITELN('---------------- LINKED LIST ---------------------------------');π WRITELN('MEMBER LOCATION MEMBER CONTENTS');π WRITELN('IN MEMORY POINTER INDEX DATA ');π WRITELN('--------------- -----------------------------------------');π WRITELN;π REPEATπ SNAP(M1);π M1 := M1^.NEXT_POINTER;π UNTIL M1 = NIL;π WRITELN('------------ END OF LIST----------');πEND;ππPROCEDURE LOAD_MEMBER_HIGH (IND:INTEGER; DAT:ANYSTRING);πVAR M1:LISTPTR;π P:LISTPTR; { INSERTS A RECORD AT THE HIGH }πBEGIN { END OF THE LIST. }π M1 := ROOT;π REPEATπ IF M1^.NEXT_POINTER <> NIL THEN M1 := M1^.NEXT_POINTER;π UNTIL M1^.NEXT_POINTER = NIL;π NORMALIZE(NEWSEGMENT, NEWOFFSET);π M1^.NEXT_POINTER := PTR(NEWSEGMENT, NEWOFFSET);π P := M1^.NEXT_POINTER;π P^.INDEX_PART := IND;π P^.DATA_PART := DAT;π P^.NEXT_POINTER := NIL;πEND;ππPROCEDURE LOAD_MEMBER_MIDDLE (IND:INTEGER; DAT:ANYSTRING);πVAR M1:LISTPTR;π M2:LISTPTR;π P :LISTPTR;π T :LISTPTR;πBEGIN { INSERTS A MEMBER INTO THE MIDDLE }π M1 := ROOT; { OF A LIST. }π REPEATπ M2 := M1;π IF M1^.NEXT_POINTER <> NIL THEN M1 := M1^.NEXT_POINTER;π UNTIL (M1^.NEXT_POINTER = NIL) OR (M1^.INDEX_PART >= IND);π IF (M1^.NEXT_POINTER = NIL) ANDπ (M1^.INDEX_PART < IND) THENπ BEGINπ LOAD_MEMBER_HIGH (IND, DAT);π EXIT;π END;π T := M2^.NEXT_POINTER;π NORMALIZE(NEWSEGMENT, NEWOFFSET);π M2^.NEXT_POINTER := PTR(NEWSEGMENT, NEWOFFSET);π P := M2^.NEXT_POINTER;π P^.INDEX_PART := IND;π P^.DATA_PART := DAT;π P^.NEXT_POINTER := T;πEND;ππPROCEDURE LOAD_MEMBER (IND:INTEGER; DAT:ANYSTRING);πVAR M1:LISTPTR;πBEGINπ WRITELN('ADDING: ',DAT,' WITH AGE OF ',IND);π WRITELN('TURBO`S HEAP POINTER: ',VALUEOF(HEAPPTR),π ', MEMAVAIL = ',MEMAVAIL * 16.0:8:0);π WRITELN;π PAUSE;π WRITELN('... SEARCHING FOR ADD POINT ...');π IF ROOT^.INDEX_PART <= IND THEN { ENTRY POINT ROUTINE FOR }π BEGIN { ADDING NEW LIST MEMBERS }π LOAD_MEMBER_MIDDLE(IND, DAT); { ACTS ONLY IF NEW MEMBER }π EXIT; { SHOULD REPLACE CURRENT }π END; { ROOT. }π M1 := ROOT;π NORMALIZE(NEWSEGMENT, NEWOFFSET);π ROOT := PTR(NEWSEGMENT, NEWOFFSET);π ROOT^.INDEX_PART := IND;π ROOT^.DATA_PART := DAT;π ROOT^.NEXT_POINTER := M1;πEND;ππPROCEDURE INITIALIZE_ROOT_ENTRY(IND:INTEGER; DAT:ANYSTRING);πBEGINπ ROOT := PTR(NEWSEGMENT, NEWOFFSET); { INITIALIZES A LIST AND }π ROOT^.INDEX_PART := IND; { ADDS FIRST MEMBER AS }π ROOT^.DATA_PART := DAT; { "ROOT". }π ROOT^.NEXT_POINTER := NIL;πEND;ππBEGINπ TEXTCOLOR(15);π IF NOT EMS_INSTALLED THEN DIE('LOCATING EMS DRIVER');π CLRSCR;π WRITELN('DEMO OF LINKED LIST IN EXPANDED MEMORY...');π WRITELN('SETTING UP EMS PARAMETERS...');π GET_EMS_MEMORY(LOGICAL_PAGES);π WRITELN;π WRITELN('ASSIGNED HANDLE: ',HANDLE);π NEWSEGMENT := SEGMENT;π NEWOFFSET := 0;π WRITELN('EMS PARAMETERS SET. BASE PAGE IS: ',HEXWORD(SEGMENT));π WRITELN;π WRITELN('TURBO`S HEAP POINTER IS ',VALUEOF(HEAPPTR));π WRITELN('READY TO ADD RECORDS...');π PAUSE;ππ{ Demo: Create a linked list of names and ages with age as the index/sortπ key. Use random numbers for the ages so as to get a different sequenceπ each time the demo is run.}ππ INITIALIZE_ROOT_ENTRY(RANDOM(10) + 20, 'Anne Baxter (original root)');π LOAD_MEMBER(RANDOM(10) + 20, 'Rosie Mallory ');π LOAD_MEMBER(RANDOM(10) + 20, 'Sue Perkins ');π LOAD_MEMBER(RANDOM(10) + 20, 'Betty Williams ');π LOAD_MEMBER(RANDOM(10) + 20, 'Marge Holly ');π LOAD_MEMBER(RANDOM(10) + 20, 'Lisa Taylor ');π LOAD_MEMBER(RANDOM(10) + 20, 'Carmen Abigail ');π LOAD_MEMBER(RANDOM(10) + 20, 'Rhonda Perlman ');π PROCESS_LIST;π KILL_HANDLE(HANDLE);πEND.π 13 01-27-9412:12ALL WARREN PORTER Linked List Queues IMPORT 32 ╙═m' {π│ I'm trying to understand the rudiments of linked listsππ│ 4) What are common uses for linked lists? Is any one particular formπ│ (oneway, circular etc ) preferred or used over any other form?ππOne use is to maintain queues. New people, requests, or jobs come in atπthe end of the line (or break in with priority), but once the head ofπthe line has been serviced, there is no need to maintain its location inπthe queue. I wrote the following last semester:π---------------------------------------------------------------πPurpose:π Maintains a queue of jobs and priorities of those jobs in a linked list.π The user will be prompted for job number and priority and can list theπ queue, remove a job from the front of the queue (as if it ran), and stopπ the program. A count of jobs outstanding at the end will be displayed. }ππtypeπ PriRange = 0 .. 9;π JobPnt = ^JobNode;π Jobnode = RECORDπ Numb : integer;π Priority : PriRange;π Link : JobPntπ END;ππprocedure addrec(var Start : JobPnt; comprec : Jobnode);πvarπ curr,π next,π this : JobPnt;π found : boolean;πbeginπ new(this);π this^.Numb := comprec.Numb;π this^.Priority := comprec.Priority;π if Start = NIL thenπ beginπ Start := this; {Points to node just built}π Start^.Link := NIL; {Is end of list}π endπ else {Chain exists, find a place to insert it}π if comprec.Priority > Start^.Priority thenπ beginπ this^.Link := Start; {Prep for a new beg of chain}π Start := thisπ end {Condition for insert at beg of chain}π elseπ begin {Begin loop to insert after beg of chain}π found := false; {To initialize}π curr := start;π while not found doπ beginπ next := curr^.link;π if (next = NIL) or (comprec.Priority > next^.Priority) thenπ found := true;π if not found thenπ curr:= next {another iteration needed}π end;π {Have found this^ goes after curr^ and before next^}π this^.Link := next; {Chain to end (even if NIL)}π curr^.Link := this; {Insertion complete}π end;πend;ππprocedure remove(Var Start : JobPnt);πvarπ hold : JobPnt;πbeginπ if Start = NIL thenπ Writeln('Cannot remove from empty queue', chr(7))π elseπ beginπ hold := Start^.Link; {Save 1st node of new chain}π dispose(Start); {Delete org from chain}π Start := hold; {Reset to new next job}π end;πend;ππprocedure list(Start : JobPnt); {List all jobs in queue. "var" omitted}πbeginπ if Start = NIL thenπ Writeln('No jobs in queue')π elseπ beginπ Writeln('Job No Priority');π Writeln;π while Start <> NIL doπ beginπ Writeln(' ',Start^.Numb : 3, ' ', Start^.Priority);π Start:=Start^.Linkπ end;π Writeln;π Writeln('End of List');π end;πend;ππ{Main Procedure starts here}πvarπ cntr : integer;π build : JobNode;π work,π Start : JobPnt;π Achar : char;ππbeginπ Start := NIL; {Empty at first}π cntr := 0;π REPEATπ Write('Enter (S)top, (R)emove, (L)ist, or A jobnumb priority to');π Writeln(' add to queue');π Read(Achar);ππ CASE Achar ofπ 'A', 'a' :π beginπ Read(build.Numb);π REPEATπ Readln(build.Priority);π if (build.Priority < 0) or (build.priority > 9) thenπ Write(chr(7), 'Priority between 0 and 9, try again ');π UNTIL (build.Priority >= 0) and (build.Priority <= 9);π addrec(Start, build);π end;ππ 'R', 'r' :π beginπ Readln;π remove(Start);π end;ππ 'L', 'l' :π beginπ Readln;π list(Start);π end;ππ 'S', 's' : Readln; {Will wait until out of CASE loop}ππ elseπ beginπ Readln;π Writeln('Invalid option',chr(7))π end;π end;ππ UNTIL (Achar = 's') or (Achar = 'S');π work := start;π while work <> NIL doπ beginπ cntr := cntr + 1;π work := work^.linkπ end;π Writeln('Number of jobs remaining in queue: ', cntr);πend.π 14 02-03-9416:08ALL KEN BURROWS Linked List of Text IMPORT 24 ╙═══ {πFrom: KEN BURROWSπSubj: Linked List Problemπ---------------------------------------------------------------------------πHere is a short Linked List example. It loads a file, and lets you traverse theπlist in two directions. It's as simple as it gets. You may also want to lookπinto the TCollection objects associated with the Objects unit of Borlandsπversion 6 and 7.π}ππ{$A+,B-,D+,E-,F+,G-,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}π{$M 16384,0,655360}πProgram LinkedListOfText; {tested}πUses Dos,CRT;πTypeπ TextListPtr = ^TextList;π TextList = Recordπ line : string;π next,π prev : TextListPtr;π end;πConstπ first : TextListPtr = nil;π last : TextListPtr = nil;ππProcedure FreeTheList(p:TextListPtr);π var hold:TextListPtr;π beginπ while p <> Nil doπ beginπ hold := p;π p := p^.next;π dispose(hold);π end;π end;ππProcedure ViewForward(p:TextListPtr);π beginπ clrscr;π while p <> nil doπ beginπ writeln(p^.line);π p := p^.next;π end;π end;ππProcedure ViewReverse(p:TextListPtr);π beginπ clrscr;π while p <> nil doπ beginπ writeln(p^.line);π p := p^.prev;π end;π end;ππProcedure Doit(fname:string);π var f :Text;π s :string;π curr,π hold : TextListPtr;π stop : boolean;π beginπ assign(f,fname);π reset(f);π if ioresult <> 0 then exit;π curr := nil;π hold := nil;ππ while (not eof(f)) andπ (maxavail > SizeOf(TextList)) doπ begin {load the list forward and link the prev fields}π readln(f,s);π new(curr);π curr^.prev := hold;π curr^.next := nil;π curr^.line := s;π hold := curr;π end;π close(f);ππ while curr^.prev <> nil do {traverse the list backwards}π begin {and link the next fields}π hold := curr;π curr := curr^.prev;π curr^.next := hold;π end;ππ first := curr; {set the first and last records}π while curr^.next <> Nil do curr := curr^.next;π last := curr;ππ Repeat {test it}π clrscr;π writeln(' [F]orward view : ');π writeln(' [R]everse view : ');π writeln(' [S]top : ');π write('enter a command : ');π readln(s);π stop := (s = '') or (upcase(s[1]) = 'S');π if not stopπ then case upcase(s[1]) ofπ 'F' : ViewForward(first);π 'R' : ViewReverse(last);π end;π Until Stop;ππ FreeTheList(First);π end;ππvar m:longint;πBeginπ m := memavail;π if paramcount > 0π then doit(paramstr(1))π else writeln('you need to supply a filename');π if m <> memavailπ then writeln('memory error of ',m-memavail,' bytes');πEnd.π 15 05-25-9408:21ALL ALEXANDER STAUBO Buffer Streams SWAG9405 45 ╙═°≡ π{πJB> AS>Use buffered streams. That way you can access fairly many records onπJB> AS>disk without noticable speed degradation.πJB> ^^^^^^^^^^^^^^^^^^^^^^^^^^^πJB> Do you mean from RAM?? Whoah! How do you go about using bufferedπJB> streams?ππActually, you should write a local "cache" for your records. Ie.,πyour implement an array of records, say 1..50, or, 1..MaxCacheSize,πwhere MaxCacheSize is a defined constant. Then you have a couple ofπgeneralized procedures for putting/getting records; now, the point is,πwhenever the program asks for a record -that is in the cache-, thatπrecord is read directly from RAM. If the record is -not- in theπcache, the record is read, and, if there is space in the cache, theπrecord is inserted into the cache.ππLet's try a Pascal implementation.π}ππ constπ MaxCacheSize = 50; (* cache can hold 50 records *)ππ typeπ (* this is the cache item *)π PCacheItem = ^TCacheItem;π TCacheItem =π recordπ Offset : Longint; (* file offset of cache record *)π Rec : TRecord; (* use your own record type here *)π end;ππ varπ Cache : array[1..MaxCacheSize] of PCacheItem;π CacheSize : Word;ππ procedure InitCache;π {-Resets cache}π beginπ CacheSize:=0;π end;ππ function FindCache (Offset : Longint) : PCacheItem;π {-Returns cache item for Offset if found, otherwise nil}π varπ W : Word;π beginπ for W:=1 to CacheSize doπ if Cache[W]^.Offset = Offset thenπ beginπ FindCache:=Cache[W];π Exit;π end;π FindCache:=nil;π end;ππ varπ F : file of TRecord; (* file in question *)ππ procedure PutRecord (Offset : Longint; var Rec : TRecord);π {-Put record into cache and file}π varπ P : PCacheItem;π beginπ Write(F, Rec);ππ (* if exists in RAM (cache), update it *)π P:=FindCache(Offset);π if P <> nil thenπ P^.Rec:=Recπ elseπ beginπ (* put into cache *)π Inc(CacheSize);π New(Cache[CacheSize]);π Cache[CacheSize]^.Offset:=Offset;π Cache[CacheSize]^.Rec:=Rec;π end;π end;ππ procedure GetRecord (Offset : Longint; var Rec : TRecord);π {-Get record from cached file}π varπ P : PCacheItem;π beginπ (* if exists in RAM (cache), get it *)π P:=FindCache(Offset);π if P <> nil thenπ Rec:=P^.Recπ else if CacheSize < MaxCacheSize thenπ beginπ (* read record from file *)π Read(F, Rec);ππ (* put into cache *)π Inc(CacheSize);π New(Cache[CacheSize]);π Cache[CacheSize]^.Offset:=Offset;π Cache[CacheSize]^.Rec:=Rec;π end;π end;ππTo use the routines:ππ Assign(F, 'MYFILE.DAT');π Reset(F);π GetRecord(FilePos(F), MyRec);π GetRecord(FilePos(F), MyRec);π GetRecord(FilePos(F), MyRec);π PutRecord(FilePos(F), MyRec);π Close(F);ππOr something like that, anyway.ππNow, there is a simpler way; "simpler" in this case means "some guyπhas already spent hours writing it just for you". The concept isπcalled streams. Now, I don't know how "novice" a programmer you are,πbut knowledge of streams requires knowledge of OOP. I suggest youπread about OOP right away.ππStreams work in a very simple way. You have a basic, "abstract"πobject, which provides some simple I/O tools. A stream is a type ofπ(abstract) file, an input/output mechanism, that you may manipulate;πmost often it's on a hierarchical level, ie., the high-levelπprocedures call low-level procedures, just like DOS. Think of streamsπas the Pascal type "file", except now the stream is a shell forπanything.ππThe shell implements a -standard- interface for any kind ofπinformation area. You have file streams, buffered streams (streamsπthat caches areas of the file in memory to optimize accessπefficiency), EMS streams (yes, you can have a "virtual file" that liesπin EMS memory and may be used just like a file), and so on. Theπstandardization implies that you may write more flexible programs.ππA tiny example:ππ varπ S : TBufStream;π T : TRecord;π Str : string;π beginπ S.Init('MYFILE.DAT', stOpen, 2048);π (* | | |π file name file mode buffer sizeπ *)π S.Read(T, SizeOf(T));π S.Write(T, SizeOf(T));π Str:=S.ReadStr^;ππ S.Done;π end;ππThe corresponding boring-old-Dos example'd be:ππ varπ F : file;π T : TRecord;π Str : string;π beginπ (* note: no buffering -> slower! *)π Assign(F, 'MYFILE.DAT');π Reset(F, 1);ππ BlockRead(F, T, SizeOf(T));π BlockWrite(F, T, SizeOf(T));π Read(F, Str[0]);π BlockRead(F, Str[1], Ord(Str[0]));ππ Close(F);π end;ππIn the end, streams -are- simpler, too. And they are extremely fast;πa friend of mine is writing a mail reader and is using object streamsπfor the message/conference/etc. databases. Now, personally I useπindexed, light-speed B-tree databases. And his work -just fine-.π 16 05-26-9411:06ALL BILL ZECH Linked List Routine IMPORT 65 ╙═≤ π{ Links Unit - Turbo Pascal 5.5π Patterned after the list processing facility in Simula class SIMSET.π Simula fans will note the same naming conventions as Simula-67.ππ Written by Bill Zech @CIS:[73547,1034]), May 16, 1989.ππ The Links unit defines objects and methods useful for implementingπ list (set) membership in your own objects.ππ Any object which inherits object <Link> will acquire the attributesπ needed to maintain that object in a doubly-linked list. Because theπ Linkage object only has one set of forward and backward pointers, aπ given object may belong to only one list at any given moment. Thisπ is sufficient for many purposes. For example, a task control blockπ might belong in either a ready list, a suspended list, or a swappedπ list, but all are mutually exclusive.ππ A list is defined as a head node and zero or more objects linkedπ to the head node. A head node with no other members is an emptyπ list. Procedures and functions are provided to add members to theπ end of the list, insert new members in position relative to anπ existing member, determine the first member, last member, sizeπ (cardinality) of the list, and to remove members from the list.ππ Because your object inherits all these attributes, your programπ need not concern itself with allocating or maintaining pointersπ or other stuff. All the actual linkage mechanisms will beπ transparent to your object.ππ *Note*π The following discussion assumes you have defined your objectsπ as static variables instead of pointers to objects. For mostπ programs, dynamic objects manipulated with pointers will beπ more useful. Some methods require pointers as arguments.π Example program TLIST.PAS uses pointer type variables.ππ Define your object as required, inheriting object Link:ππ typeπ myObjType = object(Link)π xxx.....xxxxπ end;ππ To establish a new list, declare a variable for the head nodeπ as a type Head:ππ varπ Queue1 :Head;π Queue2 :Head;ππ Define your object variables:ππ varπ X : myObjType;π Y : myObjType;π Z : myObjType;π P :^myObjType;ππ Make sure the objects have been Init'ed as required for dataπ initialization, VMT setup, etc.ππ Queue1.Init;π Queue2.Init;π X.Init;π Y.Init;π Z.Init;ππ You can add your objects to a list with <Into>:π (Note the use of the @ operator to make QueueX a pointer to theπ object.)ππ beginπ X.Into(@Queue1);π Y.Into(@Queue2);ππ You can insert at a specific place with <Precede> or <Follow>:ππ Z.Precede(@Y);π Z.Follow(@Y);ππ Remove an object with <Out>:ππ Y.Out;ππ Then add it to another list:ππ Y.Into(@Queue1);ππ Note that <Into>, <Precede> and <Follow> all have a built-inπ call to Out, so to move an object from one list to another canπ be had with a single operation:ππ Z.Into(@Queue1);ππ You can determine the first and last elements with <First> and <Last>:π (Note the functions return pointers to objects.)ππ P := Queue1.First;π P := Queue1.Last;ππ The succcessor or predecessor of a given member can be found withπ fucntions <Suc> and <Pred>:ππ P := X.Pred;π P := Y.Suc;π P := P^.Suc;ππ The number of elements in a list is found with <Cardinal>:ππ N := Queue1.Cardinal;ππ <Empty> returns TRUE is the list has no members:ππ if Queue1.Empty then ...ππ You can remove all members from a list with <Clear>:ππ Queue1.Clear;ππ GENERAL NOTES:ππ The TP 5.5 type compatibility rules allow a pointer to aπ descendant be assigned to an ancestor pointer, but not vice-versa.π So although it is perfectly legal to assign a pointer toπ type myObjType to a pointer to type Linkage, it won't letπ us do it the opposite.ππ We would like to be able to assign returned values fromπ Suc, Pred, First, and Last to pointers of type myObjType,π and the least fussy way is to define these pointer typesπ internal to this unit as untyped pointers. This works fineπ because all we are really doing is passing around pointersπ to Self, anyway. The only down-side to this I have noticedπ is you can't do: P^.Suc^.Pred because the returned pointerπ type cannot be dereferenced without a type cast.π}ππunit Links;ππinterfaceππtypeππ pLinkage = ^Linkage;π pLink = ^Link;π pHead = ^Head;ππ Linkage = objectπ prede :pLinkage;π succ :pLinkage;π function Suc :pointer;π function Pred :pointer;π constructor Init;π end;ππ Link = object(Linkage)π procedure Out;π procedure Into(s :pHead);π procedure Follow (x :pLinkage);π procedure Precede(x :pLinkage);π end;ππ Head = object(Linkage)π function First :pointer;π function Last :pointer;π function Empty :boolean;π function Cardinal :integer;π procedure Clear;π constructor Init;π end;ππππimplementationππconstructor Linkage.Init;πbeginπ succ := NIL;π prede := NIL;πend;ππfunction Linkage.Suc :pointer;πbeginπ if TypeOf(succ^) = TypeOf(Head) thenπ Suc := NILπ else Suc := succ;πend;ππfunction Linkage.Pred :pointer;πbeginπ if TypeOf(prede^) = TypeOf(Head) thenπ Pred := NILπ else Pred := prede;πend;ππprocedure Link.Out;πbeginπ if succ <> NIL thenπ beginπ succ^.prede := prede;π prede^.succ := succ;π succ := NIL;π prede := NIL;π end;πend;ππprocedure Link.Follow(x :pLinkage);πbeginπ Out;π if x <> NIL thenπ beginπ if x^.succ <> NIL thenπ beginπ prede := x;π succ := x^.succ;π x^.succ := @Self;π succ^.prede := @Self;π end;π end;πend;πππprocedure Link.Precede(x :pLinkage);πbeginπ Out;π if x <> NIL thenπ beginπ if x^.succ <> NIL thenπ beginπ succ := x;π prede := x^.prede;π x^.prede := @Self;π prede^.succ := @Self;π end;π end;πend;ππprocedure Link.Into(s :pHead);πbeginπ Out;π if s <> NIL thenπ beginπ succ := s;π prede := s^.prede;π s^.prede := @Self;π prede^.succ := @Self;π end;πend;πππfunction Head.First :pointer;πbeginπ First := suc;πend;ππfunction Head.Last :pointer;πbeginπ Last := Pred;πend;ππfunction Head.Empty :boolean;πbeginπ Empty := succ = prede;πend;ππfunction Head.Cardinal :integer;πvarπ i :integer;π p :pLinkage;πbeginπ i := 0;π p := succ;π while p <> @Self doπ beginπ i := i + 1;π p := p^.succ;π end;π Cardinal := i;πend;ππprocedure Head.Clear;πvarπ x : pLink;πbeginπ x := First;π while x <> NIL doπ beginπ x^.Out;π x := First;π end;πend;ππconstructor Head.Init;πbeginπ succ := @Self;π prede := @Self;πend;ππend.ππ{------------------------ DEMO PROGRAM --------------------- }ππprogram tlist;ππuses Links;ππtypeπ NameType = string[10];π person = object(link)π name :NameType;π constructor init(nameArg :NameType);π end;π Pperson = ^person;ππconstructor person.init(nameArg :NameType);πbeginπ name := nameArg;π link.init;πend;ππvarπ queue : Phead;π man : Pperson;π man2 : Pperson;π n : integer;π tf : boolean;ππbeginπ new(queue,Init);π tf := queue^.Empty;π new(man,Init('Bill'));π man^.Into(queue);π new(man,Init('Tom'));π man^.Into(queue);π new(man,Init('Jerry'));π man^.Into(queue);ππ man := queue^.First;π writeln('First man in queue is ',man^.name);π man := queue^.Last;π writeln('Last man in queue is ',man^.name);ππ n := queue^.Cardinal;π writeln('Length of queue is ',n);π if not queue^.Empty then writeln('EMPTY reports queue NOT empty');ππ new(man2,Init('Hugo'));π man2^.Precede(man);ππ new(man2,Init('Alfonso'));π man2^.Follow(man);π { should now be: Bill Tom Hugo Jerry Alfonso }π writeln('After PRECEDE and FOLLOW calls, list should be:');π writeln(' {Bill, Tom, Hugo, Jerry, Alfonso}');π writeln('Actual list is:');ππ man := queue^.First;π while man <> NIL doπ beginπ write(man^.name,' ');π man := man^.Suc;π end;π writeln;ππ man := queue^.Last;π writeln('The same list backwards is:');π while man <> NIL doπ beginπ write(man^.name,' ');π man := man^.Pred;π end;π writeln;ππ n := queue^.Cardinal;π writeln('Queue size should be 5 now, is: ', n);ππ queue^.Clear;π writeln('After clear operation,');π n := queue^.Cardinal;π writeln(' Queue size is ',n);π tf := queue^.Empty;π if tf then writeln(' and EMTPY reports queue is empty.');π writeln;π writeln('Done with test.');πend.ππ 17 08-24-9413:32ALL KEN BURROWS Duplicate File/String SWAG9408 !╖û 16 ╙═ {π MG> Trying to figure out the fastest wayπ MG> to find and delete duplicate strings,π MG> which are actually file names in anπ MG> ASCII file.ππUsing the strings and objects unit, pstringcollections can be used to sort andπtest for dupes quite easilly.π}ππUses Objects,Strings,Dos;ππConstπ inFile : String = '';π OutFile : String = '';π DupFile : String = '';ππTypeπ NewPCol = Object(TStringCollection)π function compare(key1,key2:pointer):integer; virtual;π end;π PSColl = ^NewPCol;ππFunction NewPCol.Compare(key1,key2:pointer):integer;π Beginπ Compare := StrIComp(key1,key2);π End;ππProcedure Doit;π Var NewLst,π DupLst : PSColl;π s : string;π ps : pstring;π f : text;π i : integer;π Procedure WriteEm(pst:Pstring); far;π beginπ writeln(f,pst^);π end;π Beginπ New(NewLst,init(5,5));π New(DupLst,init(5,5));π DupLst^.Duplicates := true;π assign(f,InFile); reset(f);π While not Eof(f) doπ Beginπ readln(f,s);π if s <> ''π then beginπ ps := newstr(s);π i := NewLst^.Count;π NewLst^.insert(ps);π if i = NewLst^.Count then DupLst^.insert(ps);π end;π End;π close(f);π if NewLst^.count > 0π then beginπ assign(f,OutFile); rewrite(f);π NewLst^.forEach(@WriteEm);π close(f);π end;π if DupLst^.Count > 0π then beginπ assign(f,DupFile); rewrite(f);π DupLst^.forEach(@WriteEm);π close(f);π end;π dispose(DupLst,done);π dispose(NewLst,Done);π End;ππBeginπ if paramcount < 2 then halt;π InFile := paramstr(1);π OutFile := paramstr(2);π DupFile := OutFile;π Dec(DupFile[0],3);π DupFile := DupFile + 'DUP';π if DupFile = OutFile then halt;π Doit;πEnd.ππ 18 08-24-9413:44ALL SWAG SUPPORT TEAM Example of LINKED RecordsSWAG9408 εε╒ 35 ╙═ program LinkLst2;ππusesπ Crt;ππconstπ FileName = 'LinkExp.dta';ππtypeπ PMyNode = ^TMyNode;π TMyNode = recordπ Name : String;π Flight: integer;π Day : String;π Next : PMyNode; {Used to link each field}π end;ππprocedure CreateNew(var Item: PMyNode);πbeginπ New(Item);π Item^.Next := nil;π Item^.Name := '';π Item^.Flight := 0;π Item^.Day := '';πend;ππprocedure GetData(var Item: PMyNode);πbeginπ ClrScr;π repeatπ GotoXY(1, 1);π Write('Enter Name: ');π Read(Item^.Name);π until (Item^.Name <> '');π GotoXY(1, 2);π Write('Enter Flight number: ');π ReadLn(Item^.Flight);π GotoXY(1, 3);π Write('Enter Day: ');π ReadLn(Item^.Day);πend;ππprocedure DoFirst(var First, Current: PMyNode);πbeginπ CreateNew(Current);π GetData(Current);π First := Current;πend;ππprocedure Add(var Prev, Current: PMyNode);πbeginπ Prev := Current;π CreateNew(Current);π GetData(Current);π Prev^.Next := Current;πend;ππprocedure DeleteNode(var Head, Node, Current: PMyNode);πvarπ Temp: PMyNode;πbeginπ Temp := Head;π while Temp^.Next <> Node doπ Temp := Temp^.Next;π if Temp^.Next^.Next <> nil thenπ Temp^.Next := Temp^.Next^.Nextπ else beginπ Temp^.Next := nil;π Current := Temp;π end;π Dispose(Node);πend;ππfunction Find(Head: PMyNode; S: String): PMyNode;πvarπ Temp: PMyNode;πbeginπ Temp := nil;π while Head^.Next <> nil do beginπ if Head^.Name = S then beginπ Temp := Head;π break;π end;π Head := Head^.Next;π end;π if Head^.Name = S then Temp := Head;π Find := Temp;πend;ππprocedure DoDelete(var Head, Current: PMyNode);πvarπ S: String;π Temp: PMyNode;πbeginπ ClrScr;π Write('Enter name from record to delete: ');π ReadLn(S);π Temp := Find(Head, S);π if Temp <> nil thenπ DeleteNode(Head, Temp, Current);πend;ππprocedure ShowRec(Item: PMyNode; i: Integer);πbeginπ GotoXY(1, i); Write('Name: ', Item^.Name);π GotoXY(25, i); Write('Flight: ', Item^.Flight);π GotoXY(45, i); Write('Day: ', Item^.Day);πend;ππprocedure Show(Head: PMyNode);πvarπ i: Integer;πbeginπ i := 1;π ClrScr;π while Head^.Next <> nil do beginπ Head := Head^.Next;π ShowRec(Head, i);π Inc(i);π end;π WriteLn;π WriteLn('==========================================================');π WriteLn(i, ' records shown');π ReadLn;πend;ππprocedure FreeAll(var Head: PMyNode);πvarπ Temp: PMyNode;πbeginπ while Head^.Next <> nil do beginπ Temp := Head^.Next;π Dispose(Head);π Head := Temp;π end;π Dispose(Head);πend;ππprocedure CreateNewFile(Head: PMyNode);πvarπ F: File of TMyNode;πbeginπ Assign(F, FileName);π ReWrite(F);π while Head^.Next <> nil do beginπ Write(F, Head^);π Head := Head^.Next;π end;π Write(F, Head^);π Close(F);πend;ππprocedure ReadFile(var First, Prev, Current: PMyNode);πvarπ F: File of TMyNode;πbeginπ Assign(F, FileName);π Reset(F);π CreateNew(Current);π Read(F, Current^);π First := Current;π while not Eof(F) do beginπ Prev := Current;π CreateNew(Current);π Read(F, Current^);π Prev^.Next := Current;π end;π Close(F);πend;ππprocedure Main(var First, Prev, Current: PMyNode);πvarπ F : Text;πbeginπ {$I-}π Assign (f, 'HW2FILE.TXT');π Reset(f);π {$I+}π if (IOResult <> 0) then beginπ WriteLn('error Reading File');π Halt;π end;π CreateNew(Current);π ReadLn(F, Current^.Name);π ReadLn(F, Current^.Flight);π ReadLn(F, Current^.Day);π First := Current;π while not Eof(F) do beginπ Prev := Current;π CreateNew(Current);π ReadLn(F, Current^.Name);π ReadLn(F, Current^.Flight);π ReadLn(F, Current^.Day);π Prev^.Next := Current;π end;π Close(F);π Show(First);π CreateNewFile(First);πend;ππfunction WriteMenu: Char;πvarπ Ch: Char;πbeginπ ClrScr;π GotoXY(1, 1);π WriteLn('A) Add');π WriteLn('D) Delete');π WriteLn('S) Show');π WriteLn('W) Write File');π WriteLn('X) Exit');π repeatπ Ch := UpCase(ReadKey);π until Ch in ['A', 'D', 'S', 'W', 'X'];π WriteMenu := Ch;πend;ππvarπ Ch: Char;π First,π Prev,π Current: PMyNode;ππbeginπ ClrScr;π { Main(First, Prev, Current); Use this option to read text file }π ReadFile(First, Prev, Current);π repeatπ Ch := WriteMenu;π case Ch ofπ 'A': Add(Prev, Current);π 'D': DoDelete(First, Current);π 'S': Show(First);π 'W': CreateNewFile(First);π end;π until Ch = 'X';πend.πend. { main program}π 19 08-24-9413:45ALL SWAG SUPPORT TEAM Linked List Routine SWAG9408 UJ╒ 12 ╙═ typeπ PDataRec = ^TDataRec;π TDataRec = recordπ Name: String;π Next: PDataRec;π end;ππconstπ DataRecList: PDataRec = nil;π CurRec :PDataRec = nil;ππprocedure AddRec(AName: String);πvar Temp: PDataRec;πbeginπ New(CurRec);π CurRec^.Name := AName;π CurRec^.Next := nil;π Temp := DataRecList;π if Temp = nil thenπ DataRecList := CurRecπ elseπ beginπ while Temp^.Next <> nil do Temp := Temp^.Next;π Temp^.Next := CurRec;π end;πend;ππprocedure PrevRec;πvar Temp: PDataRec;πbeginπ Temp := DataRecList;π if Temp <> CurRec thenπ while Temp^.Next <> CurRec do Temp := Temp^.Next;π CurRec := Temp;πend;ππprocedure NextRec;πbeginπ if CurRec^.Next <> nil then CurRec := CurRec^.Next;πend;ππprocedure List;πvar Temp: PDataRec;πbeginπ Temp := DataRecList;π while Temp <> nil doπ beginπ Write(Temp^.Name);π if Temp = CurRec thenπ Writeln(' <<Current Record>>')π elseπ Writeln;π Temp := Temp^.Next;π end;πend;ππbeginπ AddRec('Tom'); AddRec('Dick'); AddRec('Harry'); AddRec('Fred');π Writeln('Original List');π List;π Writeln;π Readln;ππ PrevRec; PrevRec;π Writeln('After Two PrevRec Calls');π List;π Writeln;π Readln;ππ NextRec;π Writeln('After One NextRec Call');π List;π Writeln;π Readln;ππ Writeln('End of Program.');πend. 20 08-24-9413:49ALL GUY MCLOUGHLIN Double Linked Lists SWAG9408 ╒@pÑ 39 ╙═ πprogram Demo_Doubly_Linked_List_Sort;ππconstπ co_MaxNode = 1000;ππtypeπ T_St15 = string[15];ππ T_PoNode = ^T_Node;ππ T_Node = recordπ Data : T_St15;π Next,π Prev : T_PoNodeπ end;ππ T_PoArNodes = ^T_ArNodePtrs;π T_ArNodePtrs = array[1..succ(co_MaxNode)] of T_PoNode;πππ function RandomString : {output}π T_St15;π varπ by_Index : byte;π st_Temp : T_St15;π beginπ st_Temp[0] := chr(succ(random(15)));π for by_Index := 1 to length(st_Temp) doπ st_Temp[by_Index] := chr(random(26) + 65);π RandomString := st_Tempπ end;ππ procedure AddNode({update}π varπ po_Node : T_PoNode);π beginπ if (maxavail > sizeof(T_Node)) thenπ beginπ new(po_Node^.Next);π po_Node^.Next^.Next := nil;π po_Node^.Next^.Prev := po_Node;π po_Node^.Next^.Data := RandomStringπ endπ end;ππ procedure DisplayList({input}π po_Node : T_PoNode);π varπ po_Temp : T_PoNode;π beginπ po_Temp := po_Node;π repeatπ write(po_Temp^.Data:20);π po_Temp := po_Temp^.Nextπ until (po_Temp^.Next = nil);π write(po_Temp^.Data:20)π end;ππ procedure ShellSortNodes ({update}π varπ ar_Nodes : T_ArNodePtrs;π {input }π wo_NodeTotal : word);π varπ Temp : T_PoNode;π Index1,π Index2,π Index3 : word;π beginπ Index3 := 1;π repeatπ Index3 := succ(3 * Index3)π until (Index3 > wo_NodeTotal);π repeatπ Index3 := (Index3 div 3);π for Index1 := succ(Index3) to wo_NodeTotal doπ beginπ Temp := ar_Nodes[Index1];π Index2 := Index1;π while (ar_Nodes[(Index2 - Index3)]^.Data > Temp^.Data) doπ beginπ ar_Nodes[Index2] := ar_Nodes[(Index2 - Index3)];π Index2 := (Index2 - Index3);π if (Index2 <= Index3) thenπ breakπ end;π ar_Nodes[Index2] := Tempπ endπ until (Index3 = 1)π end; (* ShellSortNodes. *)ππ procedure RebuildList({input }π varπ ar_Nodes : T_ArNodePtrs;π {update}π varπ po_Head : T_PoNode);π varπ wo_Index : word;π po_Current : T_PoNode;π beginπ wo_Index := 1;π po_Head := ar_Nodes[wo_Index];π po_Head^.Prev := nil;π po_Head^.Next := ar_Nodes[succ(wo_Index)];π po_Current := po_Head;π repeatπ inc(wo_Index);π po_Current := po_Current^.Next;π po_Current^.Next := ar_Nodes[succ(wo_Index)];π po_Current^.Prev := ar_Nodes[pred(wo_Index)]π until (ar_Nodes[succ(wo_Index)] = nil)π end;ππvarπ wo_Index : word;ππ po_Heap : pointer;ππ po_Head,π po_Current : T_PoNode;ππ po_NodeArray : T_PoArNodes;ππBEGINπ (* Initialize pseudo-random number generator. *)π randomize;ππ (* Mark initial HEAP state. *)π mark(po_Heap);ππ (* Initialize list head node. *)π new(po_Head);π with po_Head^ doπ beginπ Next := nil;π Prev := nil;π Data := RandomStringπ end;ππ (* Create doubly linked list of random strings. *)π po_Current := po_Head;π for wo_Index := 1 to co_MaxNode doπ beginπ AddNode(po_Current);π if (wo_Index < co_MaxNode) thenπ po_Current := po_Current^.Nextπ end;ππ writeln('Total Nodes = ', wo_Index);π readln;ππ DisplayList(po_Head);π writeln;π writeln;ππ (* Allocate array of node pointers on the HEAP. *)π if (maxavail > sizeof(T_ArNodePtrs)) thenπ new(po_NodeArray);ππ (* Set them all to NIL. *)π fillchar(po_NodeArray^, sizeof(po_NodeArray^), 0);ππ (* Assign pointer in array to nodes. *)π wo_Index := 0;π po_Current := po_Head;π repeatπ inc(wo_Index);π po_NodeArray^[wo_Index] := po_Current;π po_Current := po_Current^.Nextπ until (po_Current^.Next = nil);ππ (* ShellSort the array of nodes. *)π ShellSortNodes(po_NodeArray^, wo_Index);ππ (* Re-build the doubly linked-list from array of nodes. *)π RebuildList(po_NodeArray^, po_Head);ππ (* Deallocate array of nodes. *)π dispose(po_NodeArray);ππ writeln;π writeln;π DisplayList(po_Head);ππ (* Release HEAP memory used. *)π release(po_Heap)ππEND.ππ 21 08-24-9413:49ALL MARK GAUTHIER OOP Linked Lists SWAG9408 ;¿y 70 ╙═ Unit MgLinked;ππinterfaceππconstππ { Error list. }π Succes = $00;π Need_Mem = $01;π Point_To_Nil = $02;ππtypeππ DoubleLstPtr = ^DoubleLst;π DoubleLst = recordπ Serial : longint;π Size : word;π Addresse : pointer;π Next : DoubleLstPtr;π Previous : DoubleLstPtr;π end;πππ PDoubleLst = ^ODoubleLst;π ODoubleLst = objectππ privateπ LastCodeErr : word; {-- Last error. --}ππ publicπ TotalObj : longint; {-- Total obj allocate. --}π CurentObj : DoubleLstPtr; {-- Curent obj number. --}ππ constructor Init(var Install:boolean; Serial:longint; Size:word;πData:pointer);π {-- Initialise all variables, new curent. ---}ππ destructor Done;ππ {--- get and clear the last err. ---}π function LastError:word;ππ {--- Seek to end and add an object. ---}π procedure Add(Size:word; Data:pointer);ππ {--- Change the size of data of a object. 0 = change curent. ---}π procedure ChangeSize(Serial:longint; NewSize : word);ππ {--- Insert an object before the curent obj. 0 = insert curent pos ---}π procedure Insert(Serial:longint; Size:word; Data:pointer);ππ {--- Delete an object from the list. 0 = delete curent. ---}π procedure Delete(Serial:longint);ππ {--- Pointe on next or end, etc. ---}π procedure SeekFirst;π procedure SeekLast;π procedure SeekNext;π procedure SeekPrevious;π procedure SeekNum(Serial:longint);ππ {--- Move data from obj to user buffer ---}π {--- 0 = use curent object. ---}π function MoveObjToPtr(Serial:longint; p:pointer):word;ππ {--- Move user buffer to obj data. obj data take ObjSize bytes ---}π {--- 0 = use curent object. ---}π function MovePtrToObj(Serial:longint; p:pointer):word;ππ end;ππimplementationππ(****************************************************************************)ππ procedure move(Src,Dst:pointer; Size:word);assembler;π asmπ lds si,Srcπ les di,Dstπ mov cx,Sizeπ cldπ rep movsbπ end;πππ(****************************************************************************)ππconstructor ODoubleLst.Init(var Install:boolean; Serial:longint; Size:word;πData:pointer);π{-- Initialise all variables, new curent. ---}πbeginπ Install := false;π if Serial = 0 then exit;π New(CurentObj);π if CurentObj = nil then exit;π GetMem(CurentObj^.Addresse, Size);π if CurentObj^.Addresse = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ CurentObj^.Next := nil;π CurentObj^.Previous := nil;π CurentObj^.Size := Size;π CurentObj^.Serial := Serial;π move(Data, CurentObj^.Addresse, Size);ππ TotalObj := 1;ππ Install := true;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππdestructor ODoubleLst.Done;π{-- Initialise all variables, new curent. ---}πbeginπ repeat delete(0);π until (LastError <> Succes) or (TotalObj <= 0);πend;ππ(****************************************************************************)ππfunction ODoubleLst.LastError:word;π{--- get and clear the last err. ---}πbeginπ LastError := LastCodeErr;π LastCodeErr := 0;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Add(Size:word; Data:pointer);π{--- Seek to end and add an object. ---}πbeginπ repeat SeekNext until LastError <> Succes; { SeekEnd }ππ New(CurentObj^.Next);π if CurentObj^.Next = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ GetMem(CurentObj^.Next^.Addresse, Size);π if CurentObj^.Next^.Addresse = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ CurentObj^.Next^.Size := Size;ππ { Store information data. }π move(Data, CurentObj^.Next^.Addresse, Size);ππ { Increment the total number of reccords. }π inc(TotalObj);ππ CurentObj^.Next^.Next := nil;π CurentObj^.Next^.Previous := CurentObj;ππ LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.ChangeSize(Serial:longint; NewSize : word);π{--- Change the size of an object. ---}πvar p:pointer;πbeginπ getmem(p,NewSize);π if p = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;π SeekNum(Serial);π move(CurentObj^.Addresse, p, NewSize);π freemem(CurentObj^.Addresse, CurentObj^.Size);π CurentObj^.Size := NewSize;π CurentObj^.Addresse := p;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Insert(Serial:longint; Size:word; Data:pointer);π{--- Insert an object before the curent obj. ---}πVar n:DoubleLstPtr;πbeginπ new(n);π if n = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;π SeekNum(Serial);π getmem(n^.Addresse, Size);π if n^.Addresse = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;ππ n^.Size := Size;π move(Data, n^.Addresse, Size);ππ n^.Previous := CurentObj^.Previous;π n^.Next := CurentObj;ππ CurentObj^.Previous^.Next := n;π CurentObj^.Previous := n;ππ inc(TotalObj);πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Delete(Serial:longint);π{--- Delete an object from the list. ---}πbeginπ SeekNum(Serial);π if CurentObj^.Addresse <> nil thenπ beginπ FreeMem(CurentObj^.Addresse,CurentObj^.Size);π CurentObj^.Addresse := nil;π end;ππ CurentObj^.Next^.Previous := CurentObj^.Previous;π CurentObj^.Previous^.Next := CurentObj^.Next;ππ if CurentObj <> nil then Dispose(CurentObj);π CurentObj := CurentObj^.Previous;ππ dec(TotalObj);πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekLast;πbeginπ repeat SeekNext until LastError <> Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekFirst;πbeginπ repeat SeekPrevious until LastError <> Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekNext;πbeginπ if CurentObj^.Next = nil thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π CurentObj := CurentObj^.Next;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekPrevious;πbeginπ if CurentObj^.Previous = nil thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π CurentObj := CurentObj^.Previous;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekNum(Serial:longint);πbeginπ if Serial = 0 then exit;π SeekFirst;π repeatππ SeekNext;ππ if CurentObj^.Serial = Serial thenπ beginπ LastCodeErr := Succes;π break;π end;ππ if LastError <> Succes thenπ beginπ LastCodeErr := Point_To_Nil;π break;π endπ else continue;ππ until false;ππend;ππ(****************************************************************************)ππfunction ODoubleLst.MoveObjToPtr(Serial:longint; p:pointer):word;π{--- Move data from obj to user buffer ---}πbeginπ SeekNum(Serial);π if (CurentObj^.Addresse = nil) or (p = nil) thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π move(CurentObj^.Addresse, p, CurentObj^.Size);π LastCodeErr := Succes;π MoveObjToPtr := CurentObj^.Size;πend;πππ(****************************************************************************)ππfunction ODoubleLst.MovePtrToObj(Serial:longint; p:pointer):word;π{--- Move user buffer to obj data. obj data take ObjSize bytes ---}πbeginπ SeekNum(Serial);π if (CurentObj^.Addresse = nil) or (p = nil) thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π move(p, CurentObj^.Addresse, CurentObj^.Size);π LastCodeErr := Succes;π MovePtrToObj := CurentObj^.Size;πend;πππend.π 22 08-24-9413:50ALL MARIUS ELLEN Pointers SWAG9408 K┤+█ 13 ╙═ {πDVE>> What I want to do is to make it point to the next byte in memory,πDVE>> sort of "apointer:=[byte ptr] apointer + 1"πDVE>> Apointer:=ptr(seg(apointer^),Ofs(apointer^) + 1);ππAGB> That won't work if the pointer is equal to 0FFFFh (Segment must beπAGB> adjusted!). A shorter (and faster?) method of coding this (wrong) way :πAGB> Inc(LongInt(APointer));ππOeps, this doesn't work either, especially in the case $ffff ! (unwantedπparagraph increase and in protected mode a RunTime Error 216 "Generalπprotection fault")ππFor non segm. overrides this should work fine: Aptr:=pchar(Aptr)+1;πand if youre planning segments overrides than you should use this:π}ππfunction GetDosPtr(Point:Pointer;Offs:Longint):pointer;πassembler;{offs in [$0..$fffff}πasmπ mov dx,point.word[2]π mov cx,offs.word[2]π mov bx,offs.word[0]π add bx,point.word[0]π adc cx,0π mov ax,bxπ and ax,0fhπ shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π add dx,bxπend;ππ{And for protected mode: }ππfunction GetPtr(BASE:Pointer;Offs:Longint):Pbyte;πassembler;πasmπ MOV AX,word ptr [OFFS+2]π MOV BX,word ptr [OFFS+0]π ADD BX,word ptr [BASE+0]π ADC AX,0π MUL SelectorIncπ ADD AX,word ptr [BASE+2]π MOV DX,AXπ MOV AX,BXπend;π 23 08-24-9413:58ALL MARK GAUTHIER Match Strings in Array SWAG9408 1}₧M 44 ╙═ π{* Stack Research string for turbo pascal unit *}π{* Public Domain, 21/07/94 by Mark Gauthier. *}π{* Fidonet 1:242/818.5, FM 101:190/805.5 *}ππUnit Search;ππ{ What for?, it use stack function to search for a matching stringπ in an array. }ππInterfaceππConstππ MaxString : Word = 4096;π MaxStack : Word = 500;ππVarπ StrAddr : Array[1..4096] of Pointer;π { Addresse for all strings. }ππ TotalStr : Word;π { Curent strings number }ππ StrFreq : Array[1..4096] of Word;π { Search frequence for each string }ππ procedure ClearAllStack;π { Clear stack. You must call this procedure to tell unitπ you will change the searchstring. }ππ procedure AddString (S:String);π { Add a string in array, only if totalstr if < maxstring. }ππ function SearchString (S:String) : boolean;π { Search for a string, if stack is not clear previous search asπ been made. Example: you search for 'ABC' and this functionπ return true. If you search for 'ABCD' then this functionπ will go in stack and get all the old addr for 'ABC' and seeπ if 'D' is the next letter for the check strings.ππ * This unit is usefull to build compression unit.π }ππimplementationππVarπ SearchStr : Pointer;π LastFound : Word;π CurentStack : Byte;π StackPos : Array[1..2] of Word;π StackData : Array[1..2,1..500] of Word;ππ{*===================================================================*}ππ{ Return true is stack is empty }πfunction StackIsEmpty:boolean;πbeginπ StackIsEmpty := false;π if StackPos[CurentStack] = 0 then StackIsEmpty := true;πend;ππ{*===================================================================*}ππ{ Pop an element from stack }πfunction MgPop:Word;πbeginπ MgPop := 0;π If Not StackIsEmpty thenπ beginπ MgPop := StackData[CurentStack, StackPos[CurentStack]];π Dec(StackPos[CurentStack]);π end;πend;ππ{*===================================================================*}ππ{ Push an element on stack }πprocedure MgPush(Number:word);πvar x:byte;πbeginπ if CurentStack = 1 then x := 2 else x := 1;π If StackPos[x] < MaxStack thenπ beginπ Inc(StackPos[x]);π StackData[x, StackPos[x]] := Number;π end;πend;ππ{*===================================================================*}ππ{ Clear the curent stack }πprocedure ClearStack;πbeginπ StackPos[CurentStack] := 0;πend;ππ{*===================================================================*}ππ{ Inverse pop and push stack }πprocedure InverseStack;πbeginπ ClearStack;π If CurentStack = 1 then CurentStack := 2 else CurentStack := 1;πend;ππ{*===================================================================*}ππ{ Compare SearchStr(global var) and DATA(parameter) }π{$F+}πfunction Compare(Data:Pointer):boolean;assembler;πasmπ push bpπ mov bp,spππ push dsππ lds si,SearchStrπ lodsbπ mov cl,alπ mov ch,0ππ les di,[Bp+8]π inc diππ mov al,0π cldπ repe cmpsbπ jne @NotMatchπ mov al,1ππ@NotMatch:ππ pop dsπ pop bpπend;π{$F-}ππ{*===================================================================*}ππ{ Search procedure execute this procedure if stack is not empty. }πfunction SearchWhitPop:boolean;πVar Start : Word;πbeginπ SearchWhitPop := false;π While not StackIsEmpty doπ beginπ Start := MgPop;π if Compare(StrAddr[Start]) thenπ beginπ LastFound := Start;π SearchWhitPop := true;π MgPush(Start);π Inc(StrFreq[Start]);π end;π end;π InverseStack;πend;ππ{*===================================================================*}ππ{ Search procedure execute this procedure if stack is empty. }πfunction CompleteSearchPush:boolean;πvar i : word;πbeginπ CompleteSearchPush := false;π For i := 1 to TotalStr doπ beginπ if Compare(StrAddr[i]) thenπ beginπ LastFound := i;π CompleteSearchPush := true;π MgPush(i);π Inc(StrFreq[i]);π end;π end;π InverseStack;πend;ππ{*===================================================================*}ππ{ Public Search routine }πfunction SearchString(S:String):boolean;πbeginπ SearchStr := Addr(S);π If StackIsEmptyπ then SearchString := CompleteSearchPushπ else SearchString := SearchWhitPop;πend;ππ{*===================================================================*}ππ{ Add a string in heap }πprocedure AddString(S:String);πbeginπ Inc(TotalStr);π GetMem(StrAddr[TotalStr], Length(S));π Move(S,StrAddr[TotalStr]^, Length(S)+1);πend;ππ{*===================================================================*}ππ{ Clear pop and push stack }πprocedure ClearAllStack;πbeginπ InverseStack;π ClearStack;πend;ππ{*===================================================================*}ππ{ Unit Initialisation }πvar i : word;πBeginπ TotalStr := 0;π CurentStack := 0;π StackPos[1] := 0;π StackPos[2] := 0;π for i := 1 to 4096 do StrFreq[i] := 0;πEnd.π 24 08-24-9413:59ALL SWAG SUPPORT TEAM Nth array item in BASM SWAG9408 Å$▒≡ 5 ╙═ {πCC> I want to know how to retrieve the n(th) element from theπCC> table in BASM.ππSolution:π}ππ program _getvalue;ππ const table:array[0..9] of integer=π (1001,1002,1003,1004,1005,1006,1007,1008,1009,1010);ππ function getvalue(nth:word):integer; assembler;π asmπ mov si,nth { get index }π add si,si { 'multiply' by two (word-sized) }π mov ax,word ptr table[si] { put table[index] in ax -> function-result }π end;ππ beginπ writeln(getvalue(7));π end.π 25 08-24-9414:00ALL MATT BOUSEK Avl Tree Tally SWAG9408 ┐╚_ 59 ╙═ (*πHere is TALLY.PAS, a program that Matt Bousek <MBOUSEK@intel9.intel.com> wroteπto do a word frequency analysis on a text file. It uses an AVL tree. Itπshould compile under TP 6.0 or BP 7.0π*)πprogram word_freq(input,output);ππtypeπ short_str = string[32];ππ{************AVLtree routines*********}πtypeπ balance_set = (left_tilt,neutral,right_tilt);π memptr = ^memrec;π memrec = recordπ balance : balance_set;π left,right : memptr;π count : longint;π key : short_str;π end;ππ {**************************************}π procedure rotate_right(var root:memptr);π var ptr2,ptr3 : memptr;π beginπ ptr2:=root^.right;π if ptr2^.balance=right_tilt then beginπ root^.right:=ptr2^.left;π ptr2^.left:=root;π root^.balance:=neutral;π root:=ptr2;π end else beginπ ptr3:=ptr2^.left;π ptr2^.left:=ptr3^.right;π ptr3^.right:=ptr2;π root^.right:=ptr3^.left;π ptr3^.left:=root;π if ptr3^.balance=left_tiltπ then ptr2^.balance:=right_tiltπ else ptr2^.balance:=neutral;π if ptr3^.balance=right_tiltπ then root^.balance:=left_tiltπ else root^.balance:=neutral;π root:=ptr3;π end;π root^.balance:=neutral;π end;ππ {*************************************}π procedure rotate_left(var root:memptr);π var ptr2,ptr3 : memptr;π beginπ ptr2:=root^.left;π if ptr2^.balance=left_tilt then beginπ root^.left:=ptr2^.right;π ptr2^.right:=root;π root^.balance:=neutral;π root:=ptr2;π end else beginπ ptr3:=ptr2^.right;π ptr2^.right:=ptr3^.left;π ptr3^.left:=ptr2;π root^.left:=ptr3^.right;π ptr3^.right:=root;π if ptr3^.balance=right_tiltπ then ptr2^.balance:=left_tiltπ else ptr2^.balance:=neutral;π if ptr3^.balance=left_tiltπ then root^.balance:=right_tiltπ else root^.balance:=neutral;π root:=ptr3;π end;π root^.balance:=neutral;π end;ππ {*****************************************************************}π procedure insert_mem(var root:memptr; x:short_str; var ok:boolean);π beginπ if root=nil then beginπ new(root);π with root^ do beginπ key:=x;π left:=nil;π right:=nil;π balance:=neutral;π count:=1;π end;π ok:=true;π end else beginπ if x=root^.key then beginπ ok:=false;π inc(root^.count);π end else beginπ if x<root^.key then beginπ insert_mem(root^.left,x,ok);π if ok then case root^.balance ofπ left_tilt : beginπ rotate_left(root);π ok:=false;π end;π neutral : root^.balance:=left_tilt;π right_tilt : beginπ root^.balance:=neutral;π ok:=false;π end;π end;π end else beginπ insert_mem(root^.right,x,ok);π if ok then case root^.balance ofπ left_tilt : beginπ root^.balance:=neutral;π ok:=false;π end;π neutral : root^.balance:=right_tilt;π right_tilt : beginπ rotate_right(root);π ok:=false;π end;π end;π end;π end;π end;π end;ππ {*****************************************************}π procedure insert_memtree(var root:memptr; x:short_str);π var ok:boolean;π beginπ ok:=false;π insert_mem(root,x,ok);π end;ππ {*********************************}π procedure dump_mem(var root:memptr);π beginπ if root<>nil then beginπ dump_mem(root^.left);π writeln(root^.count:5,' ',root^.key);π dump_mem(root^.right);π end;π end;πππ{MAIN***************************************************************}π{*** This program was written by Matt Bousek sometime in 1992. ***}π{*** The act of this posting over Internet makes the code public ***}π{*** domain, but it would be nice to keep this header. ***}π{*** The basic AVL routines came from a book called "Turbo Algo- ***}π{*** rythms", Sorry, I don't have the book here and I can't ***}π{*** remember the authors or publisher. Enjoy. And remember, ***}π{*** there is no free lunch... ***}ππconstπ wchars:set of char=['''','a'..'z'];ππvarπ i,j : word;π aword : short_str;π subject : text;π wstart,wend : word;π inword : boolean;π linecount : longint;π wordcount : longint;π buffer : array[1..10240] of char;π line : string;π filename : string;π tree : memptr;ππBEGINπ tree:=nil;ππ filename:=paramstr(1);π if filename='' then filename:='tally.pas';π assign(subject,filename);π settextbuf(subject,buffer);π reset(subject);ππ wordcount:=0;π linecount:=0;π while not eof(subject) do beginπ inc(linecount);π readln(subject,line);π wstart:=0; wend:=0;π for i:=1 to byte(line[0]) do beginπ if line[i] in ['A'..'Z'] then line[i]:=chr(ord(line[i])+32);π inword:=(line[i] in wchars);π if inword and (wstart=0) then wstart:=i;π if inword and (wstart>0) then wend:=i;π if not(inword) or (i=byte(line[0])) then beginπ if wend>wstart then beginπ aword:=copy(line,wstart,wend+1-wstart);π j:=byte(aword[0]);π if (aword[j]='''') and (j>2) then begin {lose trailing '}π aword:=copy(aword,1,j-1);π dec(wend);π dec(j);π end;π if (aword[1]='''') and (j>2) then begin {lose leading '}π aword:=copy(aword,2,j-1);π inc(wstart);π dec(j);π end;π if (j>2) and (aword[j-1]='''') and (aword[j]='s') thenπbegin {lose trailing 's}π aword:=copy(aword,1,j-2);π dec(wend,2);π dec(j,2);π end;π if (j>2) then beginπ inc(wordcount);π insert_memtree(tree,aword);π end;π end; { **if wend>wstart** }π wstart:=0; wend:=0;π end; { **if not(inword)** }π end; { **for byte(line[0])** }π end; { **while not eof** }ππdump_mem(tree);πwriteln(linecount,' lines, ',wordcount,' words.');πEND.π 26 08-25-9409:10ALL LEE BARKER Sorting Linked Lists SWAG9408 ╡à· 11 ╙═ {π│ I'm looking for a routine to swap two nodes in a doubleπ│ linked list or a complete sort.ππThere has been a thread on the TP conf area in CIS on quickπsorting a (double) linked list. To swap two nodes, remove one,πthen add it in where desired. Quick sample-π}ππtypeπ s5 = string[5];π ntp = ^nodetype;π nodetype = recordπ prv,nxt : ntp;π data : s5;π end;πconstπ nbr : array[0..9] of string[5] = ('ZERO','ONE','TWO',π 'THREE','FOUR','FIVE','SIX','SEVEN','EIGHT','NINE');πvarπ node,root : ntp;π i : integer;ππprocedure swap (var n1,n2 : ntp);π var n : ntp;π beginπ n := n1;π n1 := n2;π n2 := n;π end;ππprocedure addnode (var n1,n2 : ntp);π beginπ swap(n1^.nxt,n2^.prv^.nxt);π swap(n1^.prv,n2^.prv);π end;ππprocedure getnode(i:integer);π var n : ntp;π beginπ getmem(n,sizeof(nodetype));π n^.nxt := n;π n^.prv := n;π n^.data := nbr[i];π if root=nilπ then root := nπ else addnode(n,root);π end;ππbeginπ root := nil;π for i := 0 to 9 doπ beginπ getnode(i);π node := root;π writeln;π writeln('The linked now is-');π repeatπ writeln(node^.data);π node := node^.nxt;π until node = root;π end;πend.π 27 08-25-9409:11ALL DEAVON EDWARDS Stacks SWAG9408 τ "█ 76 ╙═ {πFrom: Deavon@sound.demon.co.uk (Deavon Edwards)ππI am having some problem with this program. I would like to modified it toπdo the following....π i). To simulate the operation of a queue (Last In First Out).π ii) To use a linked list instead of arrays(simulating a stack and queue).πIf anyone out there can help it would be greatly appreciated.ππ This program will simulate the operation of a stack and a queue with aπ 10 items maximum. It will give the user the opportunity to insert andπ delete items from the data structures, display the data on screen,π it on a printer, and save and load the data from a diskπ}ππPROGRAM StackSimulation(input, output);ππUSES CRT,DOS,PRINTER;ππVARπ Stack : ARRAY [1..10] OF STRING[20];π StackFull : BOOLEAN;π StackEmpty : BOOLEAN;π Pointer : INTEGER;π Choice : CHAR;ππ {*******************************************************************}ππPROCEDURE PressAKey;πBEGINππ WRITELN;π WRITELN;π WRITELN (' ************************************');π WRITELN (' *** PRESS RETURN TO CONTINUE ***');π WRITELN (' ************************************');π READLN;π CLRSCR;πEND;π {*******************************************************************}πPROCEDURE Jump_a_Line(Jump: INTEGER);πVARπ Skip : INTEGER;ππBEGINπ FOR Skip := 1 TO Jump DOπ WRITELN;πEND;π {*******************************************************************}ππProcedure Introduction; {Display an introduction message to user}π BEGINπ CLRSCR;π gotoxy (1,10);π Textcolor(Cyan);π writeln(' ********************************************************');π writeln(' ********************************************************');π writeln(' * *');π writeln(' * WELCOME TO STACK & QUEUE SIMULATION PROGRAM *');π writeln(' * *');π writeln(' ********************************************************');π writeln(' ********************************************************');π Jump_a_line(3);π DELAY (1000);π end;ππ {*******************************************************************}ππPROCEDURE Initialise (VAR StackFull, StackEmpty : BOOLEAN);ππBEGINπ CLRSCR;π gotoxy (1,10);π Jump_a_line(2);π WRITELN (' ******************************************************');π WRITELN (' THE STACK IS INITIALISING...........PLEASE WAIT.......');π WRITELN (' ******************************************************');π Jump_a_line(3);π SOUND (240);π DELAY (1000);π CLRSCR;π NOSOUND;π Pointer := 0;π StackFull := FALSE;π StackEmpty := TRUE;πEND;ππ {*******************************************************************}ππPROCEDURE Add (VAR StackFull, StackEmpty : BOOLEAN);πBEGINπ IF StackFull THENπ BEGINπ gotoxy (1,10);π Jump_a_line(2);π WRITELN ('************************************************************');π WRITELN ('** SORRY, THE STACK IS FULL, NO MORE DATA CAN BE ENTERED ***');π WRITELN ('************************************************************');π Jump_a_line(3);π PressAKey;π ENDπ ELSEπ BEGINπ INC (Pointer);π Jump_a_line(3);π WRITE ('PLEASE ENTER THE ITEM TO BE ADDED TO THE STACK :=> ');π READLN (Stack [Pointer]);π CLRSCR;π IF StackEmpty THEN StackEmpty := FALSE;π IF Pointer = 10 THEN StackFull := TRUE;π END;πEND;ππ {*******************************************************************}ππPROCEDURE Take (VAR StackFull, StackEmpty : BOOLEAN);πBEGINπ IF StackEmpty THENπ BEGINπ gotoxy (1,10);π Jump_a_line(3);π WRITELN (' *******************************************************');π WRITELN (' *** THE STACK IS EMPTY, NO MORE DATA CAN BE REMOVED ***');π WRITELN (' *******************************************************');π Jump_a_line(3);π PressAKey;π ENDπ ELSEπ BEGINπ gotoxy (1,10);π Jump_a_line(3);π WRITE ('THE FOLLOWING ITEM HAVE BEEN REMOVE FROM THE STACK :=> ');π WRITELN (Stack [Pointer]);π DEC (Pointer);π IF Pointer = 0 THEN StackEmpty := TRUE;π IF StackFull THEN StackFull := FALSE;π Jump_a_line(3);π PressAKey;π END;πEND;ππ {*******************************************************************}ππPROCEDURE Display_to_Screen (StackEmpty : BOOLEAN);πVARπ Counter : INTEGER;πBEGINπ CLRSCR;π GOTOXY (1,10);π IF StackEmpty THENπ WRITELN (' THE STACK IS CURRENTLY EMPTY ');π Jump_a_Line (3);π FOR Counter := 1 TO Pointer DOπ WRITELN (Counter:2 ,' ', Stack [Counter]);π Jump_a_Line(2);π PressAKey;πEND;ππ {*******************************************************************}πPROCEDURE Print_to_Printer (StackEmpty : BOOLEAN);πVARπ Counter : INTEGER;πBEGINπ CLRSCR;π GOTOXY (1,10);π {$I-}π WRITELN (lst,#0);π IF IORESULT <> 0 THENπ WRITELN (' >>>>>> PRINTING ERROR.......PRINTER OFF LINE <<<<<< ')π ELSEπ BEGINπ IF StackEmpty THENπ WRITELN ('THE STACK IS CURRENTLY EMPTY, THERE IS NO DATA TO BE PRINTED.')π ELSEπ WRITELN (' THE CONTENTS OF THE STACK IS PRINTING........');π FOR Counter := Pointer DOWNTO 1 DOπ WRITELN (Lst,Counter:2 ,' ', Stack [Counter]);π END;π {$I+}π PressAKey;πEND;πππ {****************************************************}ππPROCEDURE Save_to_File;ππVARπ Write_to_File : TEXT;π Output_to_File : STRING[20];π Read_File : BOOLEAN;π Counter : INTEGER;ππBEGINπ CLRSCR;π Jump_a_Line(3);π WRITE('PLEASE ENTER THE NAME YOU WISH TO CALLED THE FILE :=> ');π READLN(Output_to_File);π ASSIGN(Write_to_File,Output_to_File);π REWRITE(Write_to_File);π FOR Counter := 1 TO Pointer DOπ BEGINπ Writeln(Write_to_File,Stack[Counter]);π Writeln('SAVING... ',Counter:2,' ... ',Stack[Counter]);π END;π CLOSE(Write_to_File);π PressAKey;πEnd;ππ {**************************************************}ππPROCEDURE Open_A_File (StackEmpty : BOOLEAN);ππVARπ Read_File : TEXT;π Input_to_File : STRING[20];ππ BEGINπ CLRSCR;π Jump_a_Line(3);π WRITE ('PLEASE ENTER THE NAME OF THE FILE YOU WHICH TO OPENED :=> ');π READLN(Input_to_File);π ASSIGN(Read_File,Input_to_File);π {$I-}π RESET(Read_File);π IF IOResult = 0 THENπ BEGINπ Jump_a_Line(2);π Pointer := 0;π WHILE NOT EOF(Read_File) DOπ BEGINπ INC (Pointer);π READLN(Read_File,Stack [Pointer]);π WRITELN(Pointer:2,' : ',Stack[Pointer]);π END;π CLOSE(Read_File);π StackEmpty := FALSE;π ENDπ ELSEπ CLRSCR;π Jump_a_Line(2);π WRITELN (' ***********************************');π WRITELN (' *** FILE NAME DOES NOT EXIT ***');π WRITELN (' ***********************************');π {$I+}π PressAKey;πEND;ππ {****************************************************}ππPROCEDURE Menu;ππ BEGINπ gotoxy (1,10);π Textcolor(White);π WRITELN (' **************************************************');π WRITELN (' **************************************************');π WRITELN (' **** A : Add to Stack *****');π WRITELN (' **** T : Take from Stack *****');π WRITELN (' **** D : Display Stack List to Screen *****');π WRITELN (' **** P : Print Stack List *****');π WRITELN (' **** I : Initialise Stack List *****');π WRITELN (' **** S : Save Stack to disk *****');π WRITELN (' **** L : Load Stack from disk *****');π WRITELN (' **** Q : Quit program *****');π WRITELN (' **************************************************');π WRITELN (' **************************************************');π WRITELN;π WRITELN;π WRITELN (' PLEASE ENTER AN OPTION >> ');π Choice := READKEY;ππ END;ππPROCEDURE QuitProgram;ππBEGINπ gotoxy (1,10);π WRITELN (' ***********************************');π WRITELN (' """""""""""""""""""""""""""""""""""');π WRITELN (' [[[[[ GOODBYE!!!!!! ]]]]] ');π WRITELN (' """""""""""""""""""""""""""""""""""');π WRITELN (' ***********************************');π WRITELN;π WRITELN;πEND;ππ {*******************************************************************}π {*******************************************************************}ππBEGINπ Introduction;π Initialise (StackFull, StackEmpty);π REPEATπ Menu;π CLRSCR;π CASE Choice OFπ 'A', 'a' : Add (StackFull, StackEmpty);π 'T', 't' : Take (StackFull, StackEmpty);π 'D', 'd' : Display_to_Screen (StackEmpty);π 'P', 'p' : Print_to_Printer (StackEmpty);π 'I', 'i' : Initialise (StackFull, StackEmpty);π 'S', 's' : Save_to_File;π 'L', 'l' : Open_a_File(StackEmpty);π 'Q', 'q' : QuitProgramπ ELSEπ BEGINπ gotoxy (1,10);π WRITELN (' **************************');π WRITELN (' ** Invalid key pressed **');π WRITELN (' **************************');π WRITELN;π PressAKey;π END;π END;π UNTIL (Choice = 'Q') OR (Choice = 'q');πEND.π 28 08-26-9408:32ALL SWAG SUPPORT TEAM Binary Tree Example SWAG9408
┐╫· 44 ╙═ PROGRAM BinaryTreeSample ( INPUT, OUTPUT );ππUSES Crt;ππTYPE NodePtr = ^Node;ππ Node = RECORDπ Left,π Parent,π Right : WORD;π KeyWord : POINTER; { Will hold in STRING format }π END; { Where 1st byte is length }ππ Comparison = (Less, Greater, Equal);πππVAR NewWord : STRING; { Holds word typed in }π StartMem : LONGINT; { Holds starting memory }π Counter, { Used for FOR Loop }π LastNode : WORD; { Holds last node stored }π BTree : ARRAY[1..16000] OF NodePtr; { Entire Binary Tree }ππππFUNCTION PtrStr ( Ptr : POINTER ) : STRING; { Ptr --> String conversion }ππVAR Str : STRING;ππBEGINπ Move( Ptr^, Str, Mem[Seg(Ptr^):Ofs(Ptr^)]+1 ); { +1 to copy count byte }π PtrStr := Str;πEND;πππPROCEDURE Destroy ( VAR P : POINTER );πBEGINπ FreeMem (P,Mem[Seg(P^):Ofs(P^)]+1); { Dispose ptr to free mem }πEND;πππFUNCTION Compare( Ptr1, { Compares two ptrs like }π Ptr2 : POINTER ) : Comparison; { strings, returning: <, }π { >, or = }πVAR Str1,π Str2 : STRING;π Result : Comparison;ππBEGINπ Move( Ptr1^, Str1, Mem[Seg(Ptr1^):Ofs(Ptr1^)]+1 );π Move( Ptr2^, Str2, Mem[Seg(Ptr2^):Ofs(Ptr2^)]+1 );π IF Str1=Str2 THENπ Result := Equalπ ELSEπ IF Str1>Str2 THENπ Result := Greaterπ ELSEπ Result := Less;π Compare := Result;πEND;πππPROCEDURE Str_To_Pointer ( Str : STRING; { Converts Str to Ptr }π VAR Ptr : POINTER );ππBEGINπ GetMem(Ptr,Ord(Str[0])+1);π Move (Str,Ptr^,Ord(Str[0])+1);πEND;πππPROCEDURE PlaceWord ( Str : STRING ); { Sort through binary tree, and if }π { the word does not exist, add the }πVAR NewNode : Node; { node to the binary tree }π Index : WORD;π Found,π SearchFinished : BOOLEAN;π Comp : Comparison;ππBEGINπ SearchFinished := (LastNode=0);π Found := FALSE;π Index := 1;π WITH NewNode DO { Constructs initial full node }π BEGINπ Left := 0; { Don't know yet }π Right := 0; { " " " }π Parent := 0; { " " " }π Str_To_Pointer ( Str, KeyWord ); { This should store the word in ^ }π END;π IF SearchFinished THENπ BEGINπ Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[LastNode]^ := NewNode; { Store new node now }π END;π WHILE NOT (SearchFinished OR Found) DOπ BEGINπ Comp := Compare(NewNode.Keyword,BTree[Index]^.KeyWord);π IF Comp=EQUAL THENπ Found := TRUEπ ELSEπ IF Comp=Less THENπ BEGINπ IF BTree[Index]^.Left = 0 THEN { IF Last branch then }π BEGIN { .. lets make a new one }π Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[Index]^.Left := LastNode; { Point left to next node }π NewNode.Parent := Index; { Set parent to index }π BTree[LastNode]^ := NewNode; { Store new node now }π SearchFinished := TRUE { All finished! }π ENDπ ELSEπ Index := BTree[Index]^.Leftπ ENDπ ELSE { Must be greater then }π BEGINπ IF BTree[Index]^.Right = 0 THEN { IF Last branch then.. }π BEGIN { .. lets make a new one }π Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[Index]^.Right := LastNode; { Point left to next node }π NewNode.Parent := Index; { Set parent to index }π BTree[LastNode]^ := NewNode; { Store new node now }π SearchFinished := TRUE { All finished! }π ENDπ ELSEπ Index := BTree[Index]^.Rightπ END;π END;πEND;ππPROCEDURE Init;πBEGINπ LastNode := 0;πEND;πππPROCEDURE DisposeAll;ππVAR Counter : WORD;ππBEGINπ FOR Counter := 1 TO LastNode DOπ BEGINπ Destroy(BTree[Counter]^.KeyWord);π Dispose(BTree[Counter]);π ENDπEND;πππBEGINπ ClrScr;π StartMem := MemAvail;π Init;π REPEATπ Write ('Insert new word ["stop" to finish] : ');π Readln (NewWord);π IF NewWord <> 'stop' THENπ PlaceWord ( NewWord );π UNTIL NewWord='stop';π Writeln;π Writeln (' Node Left Parent Right Word');π Writeln ('-----------------------------------------------');π FOR Counter := 1 TO LastNode DOπ WITH BTree[Counter]^ DOπ Writeln (Counter:5,Left:8,Parent:11,Right:10,' ',PtrStr(KeyWord));π Writeln;π Writeln ('Initial memory availible : ',StartMem);π Writeln ('Memory availible before dispose : ',MemAvail);π DisposeAll;π Writeln ('Memory availible after clean-up : ',MemAvail);π Readln;πEND.π
