IMD 1.18: 15/07/2013 8:39:40 turbo pascal tutor sample programs disk  ’’’ €DŅ’öööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööö’’’@`€   Ą ą @`€š’Ąą! #@%`'€) +Ą-ą/1 3@5`7€9 ;Ą=ą?A C@E`G€I KĄMąOQ S@U`W€Y [Ą]ą_a c@e`g€i kĄmąoq s@u`w€yš’{Ą}ą ƒ@…`‡€‰ ‹Ąą ‘ “@ •` —€ ™  ›Ą ą Ÿ ” £@ „` §€ ©  «Ą ’ļ Æš’± ³@ µ` ·€ ¹  »Ą ½ą æ Į Ć@ Å` Ē€ É  ĖĄ Ķą Ļ Ń Ó@ Õ` ך’’Æ ŪĄ Żą ßį ć@å`ē€é ėĄķąļń ó@õ`÷€ł ūĄżą’!Aa ” Į į!Aa”Įį’/#A%a')”+ń’-ń’/ń’1ń’3ń’5ń’7ń’9”;Į=į?A!CAEaGI”KĮMįOQ!SAUaWY”[Į]į_a!cAeagi”kĮmįoq!sAuawy”{Į}į!ƒA…a‡‰”‹Įį‘!“A•ń’—™”›Įį’ööööööööööööööööööööööööö’’’@`€   Ą ą @`€š’Ąą! #@%`'€) +Ą-ą/1 3@5`7€9 ;Ą=ą?A C@E`G€I KĄMąOQ S@U`W€Y [Ą]ą_a c@e`g€i kĄmąoq s@u`w€yš’{Ą}ą ƒ@…`‡€‰ ‹Ąą ‘ “@ •` —€ ™  ›Ą ą Ÿ ” £@ „` §€ ©  «Ą ’ļ Æš’± ³@ µ` ·€ ¹  »Ą ½ą æ Į Ć@ Å` Ē€ É  ĖĄ Ķą Ļ Ń Ó@ Õ` ך’’Æ ŪĄ Żą ßį ć@å`ē€é ėĄķąļń ó@õ`÷€ł ūĄżą’!Aa ” Į į!Aa”Įį’/#A%a')”+ń’-ń’/ń’1ń’3ń’5ń’7ń’9”;Į=į?A!CAEaGI”KĮMįOQ!SAUaWY”[Į]į_a!cAeagi”kĮmįoq!sAuawy”{Į}į!ƒA…a‡‰”‹Įį‘!“A•ń’—™”›Įį’öööööööööööööööööööööööööFILEMGR PAS€.FILEMGR INCæANIMALS PASz€eANIMALS DTA­€TYPIST PAS°€OTYPIST DTAŲ€LISTT PASŁLISTT DOC!€DEFAULT LTP,EPSON80 LTP.EPSON100LTP0OKI82 LTP2OKI92 LTP4OKI93 LTP6MANUAL PAS8»TBOMOUSEPAS–€öööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööö öööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööööö{$C-,I-} { Turn off Ctrl-C checking, trap I/O errors } program FileManager; { -------------------------------------------------------------------- FILEMGR.PAS - Example program Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. -------------------------------------------------------------------- SYSTEM REQUIREMENTS Turbo Pascal : Version 3.0 for MS-DOS Hardware : Any computer that runs MS-DOS Turbo Pascal 3.0 Operating systems: MS-DOS 2.0 or later Memory : about 30K This program demonstrates how to perform many basic DOS functions: FILES: directory list, copy, type, delete, rename DIRECTORIES: list directory, change to a directory, make, remove MISC: changed logged drive, get date, get time Some of these routines are built-in to Turbo Pascal, others are performed by making DOS calls. This program uses the following Turbo Pascal features and commands extensively: Video output commands (GotoXY) Data structures & types (char, byte, integer, real, boolean, array, string, record, user-defined scalars, set) Extensions (typed constants, MsDos) -------------------------------------------------------------------------- } const Version = '1.00'; SubDirectory = 16; { The attribute of a subdirectory } DirRows = 8; DirCols = 5; type CharSet = set of char; AnyString = string[80]; Registers = record { Used in MsDos and Intr calls } case byte of 1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : integer); 2 : (AL, AH, BL, BH, CL, CH, DL, DH : byte); end; ColorType = (HiColor, LoColor); OpType = (DirOp, CopyOp, EraseOp, RenameOp, TypeOp, LogOp, MakeOp, ZapOp, EscapeOp); { The different operations possible } SelectType = (All, FileOnly, DirOnly, None); { The type of entry to display }  { or select } PromptType = array[DirOp..ZapOp] of record { A record holding the prompts } Prompt1, Prompt2 : string[24]; { and search/select types for } Search, Select : SelectType; { each option } end; Boxes = (NoBox, YesBox); { Boxes drawn around windows } WindowRec = record Col, Row : byte; { Window dimensions } Height, Width : byte; Color : ColorType; { Default color of window } Box : Boxes; { Which box to draw around the window? } end; const FullScreenWindow : WindowRec = (Col : 1; { The windo ws used in } Row : 1; { this program } Height : 25; Width : 80; Color : LoColor;  Box : NoBox); MenuWindow : WindowRec = (Col : 1; Row : 2; Height : 7; Width : 35; Color : HiColor; Box : YesBox); DirWindow : WindowRec = (Col : 1; { For listing directories } Row : 14; Height : 10; Width : 80; Color : HiColor;  Box : YesBox); CurrDirWindow : WindowRec = (Col : 1; { For displaying logged directory }  Row : 1; Height : 2; Width : 80;  Color : HiColor; Box : NoBox); PromptWindow : WindowRec = (Col : 1; { Where user is prompted for input } Row : 9; { of file names, etc. }  Height : 5; Width : 80; Color : HiColor;  Box : NoBox); TypeWindow : WindowRec = (Col : 1; { For displaying the contents of a file }  Row : 10; Height : 15; Width : 80; Color : HiColor; Box : YesBox); MessageWindow : WindowRec = (Col : 1; { For error messages } Row : 24; Height : 2; Width : 80; Color : HiColor; Box : NoBox); LogOnWindow : WindowRec = (Col : 1; { For displaying log on screen } Row : 1; Height : 6; Width : 35; Color : HiColor; Box : YesBox); DateTimeWindow : WindowRec = (Col : 66; { For displaying date/time } Row : 1;  Height : 4; Width : 14; Color : HiColor; Box : NoBox); { Typed constant holding information about each operation: } Prompt : PromptType = ((Prompt1 : 'Dir mask: '; { DirOp } Prompt2 : '';  Search : All; Select : None), (Prompt1 : 'File to copy: '; { CopyOp } Prompt2 : 'Copy to: '; Search : All; Select : FileOnly), (Prompt1 : 'File to erase: '; { EraseOp } Prompt2 : '';  Search : All; Select : FileOnly), (Prompt1 : 'File  to rename: '; { RenameOp } Prompt2 : 'Rename to: '; Search : All;  Select : FileOnly), (Prompt1 : 'File to type: '; { TypeOp }  Prompt2 : ''; Search : All; Select : FileOnly),  (Prompt1 : 'Change drive/directory: '; { LogOp } Prompt2 : '';  Search : DirOnly; Select : DirOnly), (Prompt1 : 'Make new directory: '; { MakeOp } Prompt2 : ''; Search : None; Select : None), (Prompt1 : 'Remove directory: '; { ZapOp } Prompt2 : '';  Search : DirOnly; Select : DirOnly)); { Define some important keystrokes: } NULL = #0; Bell = #7; BS = #8; LF = #10; CR = #13;  ESC = #27; HomeKey = ^A; EndKey = ^F; { cursor control keys } UpKey = ^E;  DownKey = ^X; PgUpKey = ^R; PgDnKey = ^C; LeftKey = ^S; InsKey = ^V; RightKey = ^D;  DelKey = ^G; var CurrOp : OpType; { The current option being executed } CurrWindow : WindowRec; { Information on the current window } DTA : array[1..43] of byte; { The variable needed for the DOS disk transfer area } OldDate : string[12]; { The last date read } OldTime : string[8]; { The last time read } WhereX, WhereY : byte; { Keep track of the current cursor location } {$I FILEMGR.INC} { ======================= PROGRAM EXECUTION ROUTINES ======================== } procedure Abort {(Msg : AnyString)} ; { Aborts the program and prints a message } begin MakeWindow(FullScreenWindow); ClrScr; if Msg <> '' then Writeln(Msg); Halt; end; { Abort } procedure ShowLogOnMsg; { Prints initial log-on message that will display for 1.5 seconds or until a key is pressed. } var Ch : char; Counter : byte; begin MakeWindow(LogOnWindow); PrintXY('TURBO TUTOR FILE MANAGER', HiColor, 3, 2); PrintXY(Version, HiColor, 30, 2); PrintXY('MS-DOS', HiColor, 28, 3); PrintXY('Copyright (C) 1986 BORLAND Inc.', HiColor, 3, 5); Counter := 1; repeat  { delay 1.5 seconds or until a key is pressed } Delay(100); Counter := Succ(Counter); until (Counter > 15) or KeyPressed; while KeyPressed do { Empty the keyboard buffer } Read(Kbd, Ch); EraseWindow(LogOnWindow); end; { ShowLogOnMsg } procedure InitScreen; { Performs screen initialization, initializes the date and time, and checks  to see what type of monitor is being used } begin ClrScr; WhereX := 1; WhereY := 1; OldDate := ''; OldTime := ''; ShowLogOnMsg; PrintCurrentDir; { show logged drive & directory } PrintMenu;   { show main menu } UpdateTime; { show date & time } end; { InitScreen } procedure ExecuteOp(Op : OpType); { Control routine that executes the option requested via the menu routine. Some operations need two file names (copy, rename), others need only one (dir, delete, etc.) } var File1, File2 : AnyString; { scratch file names } begin { ExecuteOp } { GET INPUT FILE NAMES: } with Prompt[Op] do begin File1 := GetDirFileName(Prompt1, 1, Op); { get first file name } if File1 = ESC then  { hit ESC? } Exit; if Prompt[Op].Prompt2 <> '' then begin File2 := GetFileName(Prompt[Op].Prompt2, 3); { get second file name } if (File2 = ESC) or (File2 = '') then { hit ESC or RETURN? }  Exit; end; end; { with } { PERFORM REQUESTED OPERATION: } { Corresponding DOS commands } case Op of  { -------------------------- } DirOp : ; { GetFileName handles dir } CopyOp : CopyFile(File1, File2); { copy } TypeOp : TypeFile(File1); { type } EraseOp : EraseFile(File1); { del OR erase } RenameOp : RenameFile(File1, File2); { ren OR rename } MakeOp : MakeDir(File1);  { md OR mkdir } ZapOp : ZapDir(File1); { rd OR rmdir } LogOp : LogDir(File1); { cd OR chdir OR a: } end; { case } end; { ExecuteOp } { ============================ PROGRAM BODY ============================ }  begin { FileManager } InitScreen; { get video mode, cursor type, etc.} SetWindow(PromptWindow); { set up window for user input } GetMenuOption(CurrOp); { get user input } while CurrOp <> EscapeOp do begin ExecuteOp(CurrOp); { perform the requested operation } EraseWindow(PromptWindow);  { erase the input window } SetWindow(PromptWindow); { set up window for user input } GetMenuOption(CurrOp); { get user input again } end; Abort(''); { exit program: restore cursor } end. { FileManager } ååå{ ------------------------------------------------------------ FILEMGR.INC - Include module for FILEMGR.PAS Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. ------------------------------------------------------------ }  { ===================== GENERAL CONVERSION ROUTINES ==================== } function IntToString(Num, Width : integer) : AnyString; { Changes an integer into a string } var TempString : AnyString; begin Str(Num:Width, TempString); IntToString : = TempString; end; { IntToString } function IntToPadString(Num, Width : integer) : AnyString; { Changes an integer into a string and pads it with a zero on the left if it is less than 10 } begin if Num < 10 then IntToPadString := '0' + IntToString(Num, Width) else IntToPadString := IntToString(Num, Width); end; { IntToString } function RealToString(Num : real; Width, Places : integer) : AnyString; { Changes a real number into a string } var TempString : AnyString; begin Str(Num:Width:Places, TempString); RealToString := TempString; end; { RealToString } { ==================== GENERAL PURPOSE STRING ROUTINES ====================== } function FixString(FString : AnyString; Len : byte) : AnyString; { Makes a string a specified length. If the string is too long, the extra characters will be truncated. If the string is too short, the string will be padded with spaces. } var StringLen : byte absolute FString; { Make a variable for FString's length byte } begin if StringLen > Len then Delete(FString, Succ(Len), StringLen - Len)  { Delete end of string if it is too long } else while StringLen < Len do { Pad FString with spaces on the right } FString := FString + ' '; FixString := FString; end; { FixString } function UpperCase(S : AnyString) : AnyString; { Convert a string to all upper case letters } var I : integer; begin { Note that we intentionally modify a } for I := 1 to Length(S) do { VALUE parameter, and then return that } S[I] := UpCase(S[I]); { modified value via the function value. } UpperCase := S; end; { UpperCase } function CenterString(S : AnyString) : AnyString; { Centers a string by finding the difference between the string length and a full line, and adding half of that difference (in spaces) to the start of the string. } var Counter : byte; begin for Counter := 1 to (80 - Length(S)) DIV 2 do S := ' ' + S; CenterString := S; end; { CenterString } { ========================= DATE AND TIME ROUTINES ========================== } function GetDate : AnyString; { Gets date from DOS and returns it as a string } const Months : array[1..12] of string[3] = ('JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN', 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'); var Reg : Registers; { Registers used for BIOS and DOS function calls } begin with Reg do begin AH := $2A; MsDos(Reg); GetDate := Months[DH] + ' ' + { month }  IntToString(DL, 1) + ', ' + { day } IntToString(CX, 1); { year } end; { with } end; { GetDate } function GetTime : AnyString; { Get time from DOS and return it as a string } var Reg : Registers;  { Registers used for BIOS and DOS function calls } begin with Reg do begin AH := $2C; { Get time function from MS-DOS } MsDos(Reg); GetTime := FixString(IntToPadString(CH, 1) + ':' + { hour }  IntToPadString(CL, 1) + ':' + { min } IntToPadString(DH, 1), 8); { sec  } end; { with } end; { GetTime } { ======================== SCREEN HANDLING ROUTINES ========================= } procedure SetColor(NewColor : ColorType); { Sets the foreground and background colors } begin if NewColor = HiColor then HighVideo else LowVideo; end; { SetColor } procedure GotoWinXY(X, Y : byte); { Executes a GotoXY inside the current window } begin with CurrWindow do GotoXY(Pred(Col + X), Pred(Row + Y)); WhereX := X; WhereY := Y; end; { GotoWinXY } procedure ClearScreen; { Clears the current window } var Counter : byte; S : AnyString;  { A string of blanks } begin with CurrWindow do begin S := ''; S := FixString(S, Width); { Pad S to the width of the current window } for Counter := 1 to Pred(Height) do begin GotoWinXY(1, Counter);  { Clear all but last line } Write(S); end; GotoWinXY(1, Height); if (Pred(Height + Row) = 25) and (Pred(Width + Col) = 80) then Delete(S, Length(S), 1); { Prevent scroll on last line of screen } Write(S); GotoWinXY(1, 1); end; { with } end; { ClearScreen } procedure SetWindow(Win : WindowRec); { Changes the current window to a particular window, moves the cursor into the window, and "remembers" the current window in the variable CurrWindow. } begin with Win do SetColor(Color); CurrWindow := Win; GotoWinXY(1, 1); end; { SetWindow } procedure Print(S : AnyString; PColor : ColorType); { Prints a string in the specified color } begin SetColor(PColor); Write(S); WhereX := WhereX + Length(S); end; { Print } procedure PrintXY(S : AnyString; PColor : ColorType; Col, Row : byte); { Prints a string in the specified color at the specified position } begin GotoWinXY(Col, Row); Print(S, PColor); end; { PrintXY } procedure DrawBox(Win : WindowRec); { Draws a colored box around a particular window } type BoxRec = record  UL, UR, LL, LR, Horiz, Vert : char; end; const Boxes : BoxRec = (UL : '+'; UR : '+'; LL : '+'; LR : '+'; Horiz : '-'; Vert : '|'); var Counter : byte; begin with Win do begin SetWindow(FullScreenWindow); GotoWinXY(Col, Row); Print(Boxes.UL, Color); { Draw the box } for Counter := 1 to (Width - 2) do  Print(Boxes.Horiz, Color); Print(Boxes.UR, Color); for Counter := 1 to (Height - 2) do begin GotoWinXY(Col, Row + Counter); Print(Boxes.Vert, Color); GotoWinXY(Pred(Col + Width), WhereY); Print(Boxes.Vert, Color); end; GotoWinXY(Col, Pred(Row + Height)); Print(Boxes.LL, Color); for Counter := 1 to (Width - 2) do  Print(Boxes.Horiz, Color); Print(Boxes.LR, Color); end; { with } SetWindow(Win); end; { DrawBox } procedure ClearWindow(Win : WindowRec); { Clears a particular window, leaving its box intact, and sets the window as the current window }  var TempWindow : WindowRec; begin { Create a new window inside the old window } if Win.Box = YesBox then begin TempWindow.Col := Succ(Win.Col); TempWindow.Row := Succ(Win.Row); TempWindow.Height := Win.Hei ght - 2; TempWindow.Width := Win.Width - 2; TempWindow.Color := LoColor; TempWindow.Box := NoBox; end else  TempWindow := Win; SetWindow(TempWindow); ClearScreen; { Clear the new window } SetWindow(Win); end; { ClearWindow } procedure MakeWindow(Win : WindowRec); { Puts up a new window - will draw a box around the window if the window is defined to have one. } begin with Win do begin SetWindow(Win); if Box <> NoBox then DrawBox(Win); end; { with } end; { MakeWindow } procedure EraseWindow(Win : WindowRec); { Erases a window from the screen } begin with Win do begin SetWindow(Win); SetColor(LoColor); ClearScreen; end; { with } end; { EraseWindow } procedure PrintMenuStringXY(Pstring : AnyString; Col, Row : byte); { Prints a command string for the main menu; highlights any capital letters in the string. } var Counter : byte; begin GotoWinXY(Col, Row); for Counter := 1 to Length(Pstring) do begin if PString[Counter] in ['A'..'Z'] then Print(PString[Counter], HiColor)  else Print(PString[Counter], LoColor); end; end; { PrintMenuStringXY } procedure PrintHelp(Key, Explanation : AnyString); { Prints out help keys } begin Print(Key, HiColor); Print(Explanation, LoColor); end; { PrintHelp } procedure PrintMenu; { Prints the menu of choices on the screen } begin MakeWindow(MenuWindow); PrintMenuStringXY('Directory', 3, 2); { Left column } PrintMenuStringXY('Copy', 3, 3); PrintMenuStringXY('Erase', 3, 4); PrintMenuStringXY('Rename', 3, 5); PrintMenuStringXY('Type', 20, 2); { Right column } PrintMenuStringXY('Log directory', 20, 3); PrintMenuStringXY('Make directory', 20, 4); PrintMenuStringXY('Zap directory', 20, 5); PrintMenuStringXY('ESCape', 12, 6); { Centered in menu } end; { PrintMenu } procedure PrintDate; { Prints the date on the screen } var SaveX, SaveY : byte; OldWindow : WindowRec; begin OldWindow := CurrWindow; { save value of current window }  SaveX := WhereX; SaveY := WhereY; OldDate := GetDate; SetWindow(DateTimeWindow); PrintXY(FixString('', DateTimeWindow.Width - 2), { erase old date } LoColor, 1, 1); PrintXY(OldDate, LoColor, { right justify date } DateTimeWindow.Width - Length(OldDate), 1); SetWindow(OldWindow);  { restore old window } GotoWinXY(SaveX, SaveY); end; { PrintDate } procedure UpDateTime; forward; { Check to see if the time needs to be changed - if so, print it } procedure PrintTime; { Prints the time on the screen } var SaveX, SaveY : byte; OldWindow : WindowRec; begin OldWindow := CurrWindow; { save value of old window } SaveX := WhereX; SaveY := WhereY; SetWindow(DateTimeWindow); PrintXY(OldTime, HiColor, 6, 2); SetWindow(OldWindow);  { restore old window } GotoWinXY(SaveX, SaveY); end; { PrintTime } procedure PrintCurrentDir; { Prints the name of the current directory at the top of the screen } var S : AnyString; begin GetDir(0, S); SetWindow(CurrDirWin dow); PrintXY(FixString(S, 66), HiColor, 1, 1); end; { PrintCurrentDir } { ============================== INPUT ROUTINES ============================= } procedure Abort(Msg : AnyString); forward; { Aborts the program and prints a message } function GetKey : char; { Read a character, convert function/arrow keys to upper ASCII - convert all letters to upper case. Note that function keys and arrow keys generate 2 scan codes - a null character followed by a lower ASCII character. Turbo converts the null to ESC; this routine simply turns the high bit of the second character on by adding 128 to its ASCII value.  An identifier for each special key is declared at the beginning of the program (F1, F2, etc.). While waiting for a key to be pressed, the time is updated. } var Ch : char; begin repeat UpdateTime; { Update the time until a key is pressed } until KeyPressed; Read(Kbd, Ch); if (Ch = ESC) and KeyPressed then { Check for extended character } begin Read(Kbd, Ch); Ch := Chr(Ord(Ch) + 128); { Turn on high bit } end; GetKey := UpCase(Ch); { Convert to upper case } end; { GetKey } function GetLegalKey(LegalSet : CharSet) : char; { Keeps reading characters from the keyboard until the character entered is in the specified set of legal characters. } var Ch : char; begin repeat Ch := GetKey; until Ch in LegalSet; GetLegalKey := Ch; end; { GetLegalKey } function Confirm(Msg : AnyString) : char; { Displays a question or warning and returns a 'Y' or 'N' answer  from the user. } var Ch : char; begin PrintXY(Msg + ' (Y/N)? ', HiColor, 1, 5); Ch := GetLegalKey(['Y', 'N']); if Ch = 'Y' then Print('Yes', LoColor) else Print('No', LoColor); Confirm := Ch; end; { Confirm } function GetString(Len : byte) : AnyString; { Reads in a string from the keyboard } procedure EraseInput(Len, FirstCol, FirstRow : byte); { Erases the input string on the screen } begin PrintXY(FixString('', Len), LoColor, FirstCol, FirstRow);  { Erase the string } end; { EraseInput } function ProcessInput(MaxLen, FirstCol, FirstRow : byte; var InputString : AnyString) : char; { Reads in and returns one keystroke, and modifies the input string } var Inp : char; CurrLen : byte absolute InputString; begin Inp := GetLegalKey([#32..#126, BS, CR, ^A, ^U, ^X, ESC]); SetColor(LoColor); case Inp of #32..#126 : if CurrLen < MaxLen then { Add new character to string } begin InputString := InputString + Inp; Write(Inp); WhereX := Succ(WhereX); end; BS : if CurrLen > 0 then { Backspace one character } begin Write(BS + ' ' + BS); Delete(InputString, CurrLen, 1); WhereX := Pred(WhereX); end; ^A, ^U, ^X : begin  { Blank out the input string } EraseInput(CurrLen, FirstCol, FirstRow); InputString := '';  GotoWinXY(FirstCol, FirstRow); end; ESC : begin EraseInput(CurrLen, FirstCol, FirstRow); InputString :  = ESC; { Stop input } end; end; { case } ProcessInput := Inp; end; { ProcessInput } var Strng : AnyString; FirstX, FirstY : byte; Ch : char; begin { GetString } Strng := ''; FirstX := WhereX; { Save the location of the cursor before any input } FirstY := WhereY; repeat Ch := ProcessInput(Len, FirstX, FirstY, Strng); until Ch in [ESC, CR]; GetString := UpperCase(Strng); end; { GetString } procedure GetMenuOption(var Op : OpType); { Reads an option from the keyboard - converts the input to an option type } var Ch : char; begin GotoWinXY(1, 1); Ch := GetLegalKey(['D', 'C', 'E', 'R', 'T', 'L', 'M', 'Z', ESC]); case Ch of 'D': Op := DirOp; 'C': Op := CopyOp; 'E': Op := EraseOp; 'R': Op := RenameOp; { Converts characters to the scalar operation type } 'T': Op := TypeOp; 'L': Op := LogOp; 'M': Op := MakeOp; 'Z': Op := ZapOp; ESC: Op := EscapeOp; end; { case }  end; { GetMenuOption } { ========================= GENERAL PURPOSE ROUTINES ======================== } procedure Beep; { Sound the "bell" - use ^G } begin Write(^G); end; { Beep } procedure UpdateTime; { Gets the time from DOS - if this time is different than the old time, update the time (using the global variable OldTime). } var NewTime : AnyString; begin NewTime := GetTime; if NewTime <> OldTime then begin OldTime := NewTime; PrintTime; if GetDate <> OldDate then PrintDate; end; end; { UpdateTime } procedure Message(Msg : AnyString); { Prints a message at the bottom of the screen - it saves the values of the old window, blanks out the message line, writes the message, waits for the ESC key to be pressed, erases the error message, and then restores the old window. } var OldWindow : WindowRec; Ch : char; begin OldWindow := CurrWindow; SetWindow(MessageWindow); GotoWinXY(1, 2); { Blank error message line with correct color } SetColor(HiColor); ClrEol; PrintXY(FixString(CenterString(Msg + '. Press ESC to continue.'), 79),  HiColor, 1, 2); Ch := GetLegalKey([ESC]); { Wait for ESC to be pressed } SetColor(LoColor);  { Clear error message line } GotoWinXY(1, 2); ClrEol; SetWindow(OldWindow); end; { Message } function IOError(FileName : AnyString; Op : OpType) : boolean; { Checks IOResult and prints an error message if an error occurred.  Uses the variable Op in order to "know" which operation was just attempted. } var Msg : AnyString; Result : integer; begin Result := IOResult; if Result <> 0 then begin FileName := '"' + FileName + '"'; { Put file name in quotes } case Result of $01 : case Op of CopyOp, TypeOp, EraseOp, LogOp : Msg := 'Cannot find ' + FileName; RenameOp : Msg := 'The file ' + FileName + ' already exists'; MakeOp  : Msg := 'Cannot create the directory ' + FileName; ZapOp : Msg := 'Cannot remove ' + FileName;  end; { case } $F0 : Msg := 'Cannot copy ' + FileName + '--DISK FULL'; else Msg := 'IO error #' + IntToSt  ring(Result, 1); end; { case } Beep; Message(Msg); IOError := True; end else IOError := False; end; { IOError } { ================== FILE AND DIRECTORY HANDLING ROUTINES =================== The steps to take in reading a disk directory are as follows: 1. Set up the disk transfer area (DTA). The DTA is used by the DOS directory reading routines to store information about the file just read. The DTA needs to be 43 bytes long. 2. Read the first entry in the directory. Use DOS function $4E to read the first directory entry. The first piece of information that you need to provide is the name of the file(s) to search for. This name can include global characters, which allow you to search for more than one file. Global characters are '?', which will search for a file with any character at the '?' position, and '*', which is the same as having all '?''s to represent a file name or an extension. For example, '*.*' will search for all files, and '???.PAS' will search for all files with a file name of three characters and an extension of '.PAS'. The other infromation that you need to provide is the attribute to search on, which lets you search for special files (such as hidden or system files). The information returned in the DTA includes the filename, the file's attribute, the date and the time that the file was last modified, and the file's size. 3. Read the second and succeeding entries in the directory. Use DOS function $4F to read the next directory entry. This function returns the same file information in the DTA that the previous function did. } function FileExists(FileName : AnyString) : boolean; { Checks to see if a file exists by attempting to open it. If the file does exist, it is closed to avoid using up a DOS file handle. } var F : file; begin Assign(F, FileName); Reset(F); If IOResult = 0 then { If the file exists... } begin Close(F); { Close file to avoid using up a file handle } FileExists := True; end else FileExists := False; end; { FileExists } procedure SetDTA; { Sets the DOS Disk Transfer Area to the location of the global variable DTA } var Reg : Registers; { Registers used for BIOS and DOS function calls } begin with Reg do begin AH := $1A; { Uses DOS function $1A to set the DTA } DS := Seg(DTA); DX := Ofs(DTA); end; { with } MsDos(Reg); end; { SetDTA } function ReadFile(Reg : Registers; var Attribute : byte) : AnyString; { Reads a file name and attribute from the disk } var P : byte; FileName : AnyString; begin MsDos (Reg); { Calls DOS to get the file information } if Reg.AX = 0 then { The AX register will return a non-zero number if } begin { there are no more files to read } FileName[0] := #13;  { Extract the file name from the DTA } Move (DTA[31], FileName[1], 13); P := Pos (#0, FileName); Delete (FileName, P, 14 - P); Attribute := DTA[22]; { Extract the file attribute } ReadFile := FileName;   end else begin Attribute := 0; ReadFile := ''; end; end; { ReadFile } function FirstFile (SearchFile : AnyString; var Attribute : byte) : AnyString; { Reads the first file in a directory } const AllFiles = 16; var Reg : Registers; { Registers used for BIOS and DOS function calls } begin SetDTA; SearchFile := SearchFile + #0; { Put #0 at the end of SearchFile to make it an ASCIIZ string } with Reg do begin AH := $4E; CX := AllFiles; { Read all file types in the directory } DS := Seg(SearchFile); DX := Ofs(SearchFile[1]); { Set DX to point to the first character of SearchFile - if we just used the offset of  SearchFile instead of SearchFile[1], the routine would not work, since DOS would think the length byte of the string is  SearchFile's first character. } end; { with } FirstFile := ReadFile(Reg, Attribute); end; { FirstFile }  function NextFile(var Attribute : byte) : AnyString; { Reads the second and subsequent files in a directory } var Reg : Registers; { Registers used for BIOS and DOS function calls } begin Reg.AH := $4F; NextFile := ReadFile(Reg, Attribute); end; { NextFile } { =========================== FILE COPY ROUTINES ============================ } procedure CopyFile(Source, Dest : AnyString); { Copies a file to another file } type CopyRecType = record SourceName, DestName : AnyString; { The names of the files to copy } FSource, FDest : file; { The file variables used to copy the files }  Buffer : ^byte; { A pointer to the copy buffer - note that the buffer can be up to 64K bytes in size, even though the pointer is pointing to a byte } BufferSize : integer; { The actual buffer size used by GetMem } RealBufferSize : real; { The buffer size in a printable form  } OK : boolean; { Keeps track of whether the previous step in the } end; { copying was successful or not } procedure CloseFile(FileName : AnyString; var F : file); { Closes a file and checks for errors } begin Close(F); if IOError(FileName, CopyOp) then ; end; { CloseSource } procedure OpenFiles(var CpRec : CopyRecType); { Opens the file to be copied and the file to be copied to } begin with CpRec do begin OK := False;  { OK is false if one or both files are not opened } Assign(FSource, SourceName); { Open source file } Reset(FSource, 1); if IOError(SourceName, CopyOp) then { The source file must be present } Exit; if FileExists(DestName) then { If the destination file exists, find out } begin { if the user really wants to delete it } if Confirm('Destroy ' + DestName) <> 'Y' then begin CloseFile(SourceName, FSource); Exit; end; end; Assign(FDest, DestName); { Open destination file, erasing it if it ex  ists } Rewrite(FDest, 1); if IOError(DestName, CopyOp) then begin Exit; CloseFile(SourceName, FSource); end; OK := True; { OK is true if both files are opened } end; { with } end; { SetUpFiles } procedure GetCopyBuffer(var CpRec : CopyRecType); { Allocates a buffer to copy the files - OK is true if the buffer was allocated, false otherwise. } begin with CpRec do begin OK := False; { The buffer will not have been allocated if the function is exited } if (MaxAvail < 0) or ((MaxAvail * 16.0) > 65535.0) then begin RealBufferSize := 65535.0; BufferSize := $FFFF; end else begin  RealBufferSize := MaxAvail * 16.0; BufferSize := Trunc(RealBufferSize); end; if BufferSize = 0 then begin Message('No memory available for buffer'); Exit; end; GetMem(Buffer, BufferSize); { Allocate space on the heap for the buffer - refer to chapter 15 in the Turbo Pascal  manual for more information } OK := True; { The buffer was allocated } end; { with } end; { GetCopyBuffer } procedure FileReadWrite(var CpRec : CopyRecType); { Does the reads and writes to and from the files - OK is true if the file was copied correctly, false otherwise } var Blocks : integer; begin with CpRec do begin OK := False; { Read/Write is unsuccessful if procedure is exited } repeat BlockRead(FSource, Buffer^, BufferSize, Blocks); { Read from the source file, recording how many blocks were read } If IOError(Source, CopyOp) then { Stop copying if there was } begin { a read error  } CloseFile(SourceName, FSource); CloseFile(DestName, FDest); Erase(FDest); Exit;  end; BlockWrite(FDest, Buffer^, Blocks); { Write the number of blocks that were just read to the destination file } if IOError(Dest, CopyOp) then { Stop copying if there was a write error } begin CloseFile(SourceName, FSource); CloseFile(DestName, FDest); Erase(FDest); Exit; end; until Blocks = 0;  { Stop copying when all blocks have been read } OK := True; { Read/Write was successful } end; { with } end; { FileReadWrite } var CopyRec : CopyRecType; begin { CopyFile } with CopyRec do begin SourceName := Source; DestName := Dest; OpenFiles(CopyRec); if not OK then Exit; GetCopyBuffer(CopyRec); if OK then { Only copy if the buffer has been allocated } begin PrintXY('Copying ' + RealToString(LongFileSize(FSource), 1, 0) + ' bytes (buffer = ' + RealToString(RealBufferSize, 1, 0) +  ' bytes)', HiColor, 1, 5); FileReadWrite(CopyRec); FreeMem(Buffer, BufferSize); { release copy buffer } if not OK then Exit; end; CloseFile(Source, FSource); CloseFile(Dest, FDest);   end; end; { CopyFile } { ========================== FILE TYPING ROUTINES =========================== } procedure TypeFile(FileName : AnyString); { Prints out a file on the screen } var F : text; procedure PrintTypeHelpKeys; { Prints out the help keys in the function bar style at the bottom of the screen. } begin SetWindow(MessageWindow); SetColor(HiColor);  GotoWinXY(1, 2); ClrEol; { Clears out any old message } GotoWinXY(26, 2); if EOF(F) then PrintHelp('Any Key', '-exit [ END OF FILE ]') { Print different message at end of file } else begin PrintHelp('SPACE', '-next screen '); PrintHelp('ESC', '-exit'); end; SetWindow(TypeWindow); end; { PrintTypeHelpKeys } procedure TypeScreen(var Ch : char); { Types out a screenful of the file } var  S : AnyString; Lines : byte; begin Lines := 0; repeat if not EOF(F) then Readln(F, S) else S := ''; S := FixString(S, 78); { Make sure that the string is 78 chars long } Lines := Succ(Lines); PrintXY(S, HiColor, 2, Succ(Lines)); until Lines = (TypeWindow.Height - 2); if EOF(F) then { Print revised help keys } PrintTypeHelpKeys; Ch := GetKey; end; { TypeScreen } var Ch : char; begin { TypeFile } Assign(F, FileName); Reset(F); if IOError(FileName, TypeOp) then Exit; MakeWindow(TypeWindow); Ch := ' '; PrintTypeHelpKeys; while (not EOF(F)) and (Ch <> ESC) do TypeScreen(Ch); Close(F); if IOError(FileName, TypeOp) then ; EraseWindow(TypeWindow); EraseWindow(MessageWindow); end; { TypeFile } { ================ MISCELLANEOUS FILE AND DIRECTORY ROUTINES ================ } procedure EraseFile(FileName : AnyString); { Erases a file } var F : file; begin if not FileExists(FileName) then Message('Cannot find "' + FileName + '"') else begin { Ask user if they really want to erase the file } if Confirm('Destroy ' + FileName) <> 'Y' then Exit; Assign(F, FileName); Erase(F); if IOError(FileName, EraseOp) then ; { IOError handles the error } end; end; { EraseFile } procedure RenameFile(Source, Dest : AnyString); { Renames a file } var F : file; begin if not FileExists(Source) then Message('Cannot find "' + Source + '"') else begin Assign(F, Source); Rename(F, Dest); if IOError(Dest, RenameOp) then ; end; end; { RenameFile } procedure MakeDir(NewDir : AnyString); { Creates a new directory } begin MkDir(NewDir); if IOError(NewDir, MakeOp) then ; end; { MakeDir } procedure ZapDir(DirName : AnyString); { Removes a directory } begin RmDir(DirName); if IOError(DirName, ZapOp) then ; end; { ZapDir } procedure LogDir(Path : AnyString); { Changes the current directory } begin ChDir(Path); if not IOError(Path, LogOp) then PrintCurrentDir; end; { LogDir } { ======================= DIRECTORY DISPLAY ROUTINES ======================== } type DirRecord = record { Holds 1 entry in the file directory } Name : string[12]; Attr : byte; end; DirPage = array[1..DirCols, 1..DirRows] of DirRecord;   { An array that holds file names and attributes } function DirWindowMgr(Op : OpType;  PathName, Mask : AnyString; SaveX, SaveY : byte) : AnyString; { Returns a file name that the user selects from the screen, which has a list of the files in a selected directory printed on it. Basically, the user uses the cursor keys to move through the file names until they select the correct one, at which point they press CR. If a directory is selected and the current option expects a file name, the files in the directory just selected will be displayed on the screen and the user will now get to select one of those files.} type DirectoryData = record CurrEntry : byte; { The number of the file on the screen that is being highlighted }  TotalFiles : byte; { The number of files read into the current directory page  } CurrPage : integer; { The current directory page } FileData : DirPage; { The file name and attribute info } MoreFiles : boolean; { True if not at the end of the  directory } end; var DirData : DirectoryData; procedure PrintEntry(Col, Row : byte; DPage : DirectoryData; PColor : ColorType); { Prints a file name on the screen } begin with DPage.FileData[Col, Row] do begin PrintXY(Name, PColor, (14 * Pred(Col)) + 6, Succ(Row)); Print(FixString('', 14 - Length(Name)), LoColor); end; { with } end; { PrintEntry } function CalcCol(Entry : byte) : byte; { Calculates the current column based on a particular entry } begin CalcCol := Succ(Pred(Entry) MOD DirCols); end; { CalcCol } function CalcRow(Entry : byte) : byte; { Calculates the current row based on a particular entry } begin CalcRow := Pred(Entry + DirCols) DIV DirCols; end; { CalcRow } procedure HighLight(NewEntry : byte;  var DPage : DirectoryData); { Highlights a particular entry, and changes the value of CurrEntry } begin with DPage do begin GotoWinXY((Pred(CalcCol(NewEntry)) * 14) + 6, Succ(CalcRow(NewEntry))); CurrEntry := NewEntry;  end; { with } end; { HighLight } procedure DisplayDirPage(var DPage : DirectoryData); { Prints a page full of files on the screen } var ColCounter, RowCounter : byte; begin SetWindow(DirWindow); with DPage do begin for RowCounter := 1 to DirRows do begin for ColCounter := 1 to DirCols do begin with FileData[ColCounter, RowCounter] do begin if Attr = SubDirectory then PrintEntry(ColCounter, RowCounter, DPage, HiColor)  else PrintEntry(ColCounter, RowCounter, DPage, LoColor); end; { with } end; end; CurrEntry := 1; { Start at first entry } HighLight(CurrEntry, DPage); end; { with } end; { DisplayDirPage } procedure PrintDirHelpKeys; { Prints out the help keys at the bottom of the screen using the function  bar style. } begin SetWindow(MessageWindow); SetColor(HiColor); GotoWinXY(1, 1); ClrEol; GotoWinXY(3, 1); PrintHelp('^E', '-'); PrintHelp('^X', '-move to next item '); PrintHelp('^R', '-prev page '); PrintHelp('^C', '-next page '); PrintHelp('Return', '-select '); PrintHelp('ESC', '-quit'); SetWindow(DirWindow); end; { PrintDirHelpKeys }  procedure ReadDirPage(var DPage : DirectoryData; NewPage : byte); { Reads files into a particular directory page } procedure ReadNextDirPage(var DPage : DirectoryData); { Reads the next page of files, making sure that the files have the correct attributes } function LegalFile(FileName : AnyString; Attrib : byte) : boolean; { Checks to see if a particular file should be read into the directory listing } begin LegalFile := (((Prompt[Op].Search = All) or ((Prompt[Op].Search = FileOnly) and (Attrib <> SubDirectory)) or ((Prompt[Op].Search = DirOnly) and  (Attrib = SubDirectory))) and (FileName <> '.')) or (FileName = ''); end; { LegalFile } const CurrFile : DirRecord = (Name : ''; Attr : 0); { Holds information about the file just read } var FirstFileRead : boolean; begin { ReadNextDirPage } FirstFileRead := False; with DPage do begin TotalFiles := 0; repeat with FileData[CalcCol(Succ(TotalFiles)), CalcRow(Succ(TotalFiles))] do begin repeat if (CurrPage = 1) and (TotalFiles = 0) and not FirstFileRead then begin { Read first file if no files have been read yet } CurrFile.Name := FirstFile(PathName + Mask, CurrFile.Attr); FirstFileRead := True; end; Name := CurrFile.Name; Attr := CurrFile.Attr; CurrFile.Name := NextFile(CurrFile.Attr); until LegalFile(Name, Attr); { Accept only the correct files } if Name <> '' then TotalFiles := Succ(TotalFiles); end; { with } until (TotalFiles = (DirRows * DirCols)) or (CurrFile.Name = ''); MoreFiles := CurrFile.Name <> ''; { Check to see if more files exist than can fit on one screen } end; { with } end; { ReadNextDirPage } var Counter : byte; begin { ReadDirPage } with DPage do begin FillChar(FileData, SizeOf(FileData), 0); if NewPage < CurrPage then { Read directory up to current page } begin  CurrPage := 1; for Counter := 1 to Pred(NewPage) do begin ReadNextDirPage(DPage); CurrPage := Succ(CurrPage); end; end; CurrPage := NewPage; ReadNextDirPage(DPage); { Read current directory page } DisplayDirPage(DPage); end; { with } end; { ReadDirPage } function MoveThroughDir(var DPage : DirectoryData) : AnyString; { Moves around in the directory based on the character entered - returns the name of the file that was selected } procedure ProcessLeft; { Processes the left arrow key } begin with DPage do begin if CurrEntry = 1 then { Highlight last entry } HighLight(TotalFiles, DPage) else HighLight(Pred(Cur rEntry), DPage); { Highlight previous entry } end; { with } end; { ProcessLeft } procedure ProcessRight; { Processes the right arrow key } begin with DPage do begin if CurrEntry = TotalFiles then { Highlight first entry } HighLight(1, DPage) else HighLight(Succ(CurrEntry), DPage); { Highlight successive entry } end; { with } end; { ProcessRight } procedure ProcessUp; { Processes the up arrow key } var Place : integer; begin with DPage do begin if CurrEntry <= DirCols then { Entry is in top row } begin if CurrEntry = 1 then { Move to last entry } Place := DirRows * DirCols else Place := (Pred(DirRows) * DirCols) + Pred(CurrEntry); { Move to bottom line in previous column } while Place > TotalFiles do Place := Place - DirCols; { Move up until at a filename } if Place = 0 then Place := TotalFiles; HighLight(Place, DPage); end else HighLight(CurrEntry - DirCols, DPage);  { Move up 1 line } end; { with } end; { ProcessUp } procedure ProcessDown; { Processes the down arrow key } var Place : integer; begin with DPage do begin if (CurrEntry + DirCols) > TotalFiles then { Entry is in bottom row } begin if (CurrEntry MOD DirCols = 0) then { Move to first entry } Place := 1 else  Place := (Pred(CurrEntry) MOD DirCols) + 2; { Move to top of next column } if Place > TotalFiles then Place := 1; HighLight(Place, DPage); end else HighLight(CurrEntry + DirCols, DPage); end; { with } end; { ProcessDown } function ProcessCR(var Ch : char) : AnyString; { Processes a carriage return - returns a filename if one was selected } begin with DPage do begin with FileData[CalcCol(CurrEntry), CalcRow(CurrEntry)] do begin if (Attr <> SubDirectory) and (Op = DirOp) then begin Beep;  Message('You can only select a directory here'); Ch := ' '; { No file was selected }  ProcessCR := ''; HighLight(CurrEntry, DPage); end else if ((Attr = SubDirectory) and (Prompt[Op].Select = DirOnly)) or (Attr <> SubDirectory) then ProcessCR := PathName + Name { A directory was selected and is expected by the current option } else begin { Read and display the files in the selected directory } ChDir(Name); GetDir(0, PathName); if PathName[Length(PathName)] <> '\' then  PathName := PathName + '\'; Mask := '*.*'; SetWindow(PromptWindow); PrintXY(FixString(PathName + Mask, 80 - SaveX), LoColor, SaveX, SaveY); ReadDirPage(DPage, 1); { Read first page of new directory } Ch := ' '; { No file was selected } ProcessCR := ''; end;  end; { with } end; { with } end; { ProcessCR } var Ch : char; begin { MoveThroughDir } with DPage do begin rep eat Ch := GetKey; if TotalFiles > 0 then begin case Ch of LeftKey : ProcessLeft; RightKey : ProcessRight; UpKey : ProcessUp; DownKey : ProcessDown; PgUpKey : if CurrPage > 1 then  ReadDirPage(DPage, Pred(CurrPage)); PgDnKey : if MoreFiles then ReadDirPage(DPage, Succ(CurrPage)); HomeKey : HighLight(1, DPage); { go to first in list } EndKey : HighLight(TotalFiles, DPage); { go to last in list } ESC : MoveThroughDir := ESC; CR : MoveThroughDir := ProcessCR(Ch); end; { case } end else MoveThroughDir := ESC; until Ch in [ESC, CR]; end; { with } end; { MoveThroughDir } var DirectoryPage : DirectoryData; begin { DirWindowMgr } MakeWindow(DirWindow); DirectoryPage.CurrPage := 1; { Start at first page of directory } ReadDirPage(DirectoryPage, 1); if DirectoryPage.TotalFiles = 0 then PrintXY('No file(s)', HiColor, 35, 5); PrintDirHelpKeys; HighLight(1, DirectoryPage); DirWindowMgr := MoveThroughDir(DirectoryPage); EraseWindow(DirWindow); EraseWindow(MessageWindow); end; { DirWindowMgr } { ======================= FILE NAME READING ROUTINES ======================== } function GetFileName(PromptMsg : AnyString;  InputLine : byte) : AnyString; { Read a file name that will be used in executing options - returns true if a filename was read } begin GetFileName := ESC; if PromptMsg <> '' then begin PrintXY(PromptMsg, HiColor, 1, InputLine);  GetFileName := GetString(55); end; end; { GetFileName } function GetDirFileName(PromptMsg : AnyString;  InputLine : byte; Op : OpType) : AnyString; { Read a file name - get the name from the directory if a filename is not entered - returns true if a filename was read } function AddToPathName(Path : AnyString) : AnyString; { Adds a backslash on to the end of a path name } begin if (Path <> '') and { Path has no backslash at the end } (Path[Length(Path)] <> '\') then Path := Path + '\'; { Add backslash } AddToPathName := Path; end; { AddToPathName } function CleanPathName(Path : AnyString) : AnyString; { Returns a path name that has its last backslash removed } begin if (Path[Length(Path)] = '\') and { Last char of path is backslash } (Path <> '\') and { Path is not a root directory } not ((Length(Path) = 3) and (Copy(Path, 2, 2) = ':\')) then Delete(Path, Length(Path), 1); { Delete backslash } CleanPathName := Path; end; { CleanPathName } procedure ExtractFilePath(var Path, FileName : AnyString; Op : OpType); { Given a string with file name that may be preceded by a path, this routine splits the string and puts the path part into Path and the file name part into FileName. } var Place : byte; begin if (Op = LogOp) and (Length(Path) = 1) and (Path[1] in ['A'..'Z']) then Path := Path + ':'; { Treat a single letter as a drive specifier } Place := Length(Path); while (Place > 0) and not (Path[Pla ce] in [':', '\']) do { backup to last char } Place := Pred(Place);  if Place = 0 then { only a name, no path specified } begin FileName := Path; Path := '';  end else begin { split name from path } FileName := Copy(Path, Succ(Place), Length(Path) - Place);  { take back half } Path[0] := Chr(Place); { take front half } end; if Path[Length(Path)] = ':' then { Add path name if just a drive } GetDir(Succ(Ord(Path[1]) - Ord('A')), Path); { was specified } Path := AddToPathName(Path); end; { ExtractFilePath } procedure CheckDirGlobal(var Path, FileName : AnyString; Op : OpType); { Determines from Path, FileName, and current option whether the program  will search an entire directory or not } var Attrib : byte; TempName : AnyString; begin if (Pos('*', FileName) <> 0) or (Pos('?', FileName) <> 0) then Exit; { Global filename - no changes needed } if FileName = '' then begin if Path = '' then { Null entry - search all of current directory } begin FileName := '*.*'; Exit; end else { Just a path name was specified } Path := CleanPathName(Path); end; TempName := FirstFile(Path + FileName, Attrib); if Attrib = SubDirectory then { Find out if specified file is subdirectory } begin Path := AddToPathName(Path) + AddToPathName(FileName);{ Correct path name } if Op in [LogOp, ZapOp] then FileName := '' { Only a path is needed for LogOp and ZapOp } else FileName := '*.*'; { Search entire specified directory } end else if (FileName = '') and not (Op in [LogOp, ZapOp]) then FileName := '*.*'; { Search entire specified directory } Path := AddToPathName(Path);  { Put backslash at end of path name } end; { CheckDirGlobal } procedure ReadNameFromDir(var FileName : AnyString;  OldDir : AnyString; SaveY : byte;  Op : OpType); { Gets a file name from the directory } var Path : AnyString; begin Path := FileName; ExtractFilePath(Path, FileName, Op); { Split into Path and FileName } CheckDirGlobal(Path, FileName, Op); { Add "*.*" (if needed) to FileName } GetDir(0, OldDir); { Save current directory name } ChDir(CleanPathName(Path));  { Change directory to specified directory } if not IOError(AddToPathName(Path), LogOp) then { If directory exists... }  begin GetDir(0, Path); { Find current path name } if FileName <> '' then  { Put backslash at end of path name to } Path := AddToPathName(Path); { make it look correct. }  PrintXY(FixString(Path + FileName, 55), LoColor, Succ(Length(Prompt[Op].Prompt1)), SaveY); { Print out file name } if FileName = '' then { If just a path name is needed, make it } Path := CleanPathName(Path); { look  correct. } if (Pos('*', FileName) <> 0) or (Pos('?', FileName) <> 0) or (Op = DirOp) then begin { Do a search using global filename characters } FileName := DirWindowMgr(Op, Path, FileName, Succ(Length(Prompt[Op].Prompt1)), SaveY); ChDir(OldDir); { Change back to starting directory } if FileName = ESC then Exit; SetWindow(PromptWindow); if Prompt[Op].Select <> None then PrintXY(FixString(FileName, 55), LoColor, { Print out file name } Succ(Length(Prompt[Op].Prompt1)), SaveY); end else begin ChDir(OldDir); { Change back to starting directory } FileName := Path + FileName; { Return full path and file name } end; end else  { Illegal path was entered } FileName := ESC; end; { ReadNameFromDir } var FileName : AnyString; SaveY : byte; SaveDir : AnyString; begin { GetDirFileName } GetDirFileName := ESC; SaveY := WhereY; FileName := GetFileName(Prompt[Op].Prompt1, 1); if (FileName = '') and (Prompt[Op].Search = None) then FileName := ESC;  { Exit if nothing was entered } if FileName = ESC then Exit; if Prompt[Op].Search <> None then ReadNameFromDir(FileName, SaveDir, SaveY, Op); GetDirFileName := FileName; end; { GetDirFileName } { ------------------------------------------------------------ FILEMGR.INC - End of include module for FILEMGR.PAS ------------------------------------------------------------ } åå{$C-,V-} { Turn off Ctrl-C, var parameter checking } program Animals; { -------------------------------------------------------------------- ANIMALS.PAS - Example program Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. -------------------------------------------------------------------- SYSTEM REQUIREMENTS Turbo Pascal : Version 3.0 Hardware : Any computer that runs Turbo Pascal 3.0 Operating systems: PC/MS-DOS 2.0 or later CP/M-80 2.2 or later CP/M-86 1.1 or later Memory : about 25K DESCRIPTION This program is a simple example of artificial intelligence. It is an animal guessing game, where the user thinks of an animal and the program does the "guessing." If the program does not know the the animal, it asks for a description and thus "learns" from the user. EFFICIENCY If the early questions are carefully structured, the program can achieve remarkable efficiency. This program can be easily adapted for use in other applications. It should also be noted that the program will lose badly if the user lies or is ignorant about the animal in questi on (i.e. that horses are single-toed, hoofed herbivores). PROGRAM OVERVIEW Each animal and its brief description are stored in a record (AnimalRec). The record also contains two pointers that are used to build a binary tree. Beginning with the first animal in the tree (the root), the descriptive statement is phrased in the form of a yes or no question (It is a bird?). If the answer is no, then the guessing procedure (GuessAnimal) is called recursively and passed the value of the NO pointer. If the answer is yes, then the program "guesses" the animal associated with the question:  It's cold blooded w/scaly skin (snake) YES NO  / \ Likes water It' a bird (frog) (sparrow) YES NO YES NO / \ / \ Sharp teeth Pushups Flightless Flies ... ... ... ... If the program guesses your animal, it brags for a moment and then offers you a chance to play again (function WantToGuess). If the program does not know your animal (it gets to a dead end), it will ask you for the animal's name and a descriptive sentence, add these to its tree and then start over. This aspect of the program is actually quite short. In addition to behaving as described above, this program saves its data to disk in a text file (ANIMALS.DTA) and loads the tree automatically the next time the program is run. It also features some modest cartooning (an owl that blinks its eyes) to make it more fun to play. ------------------------------------------------------------------------- } const DataFile = 'ANIMALS.DTA'; { disk file to store tree } MaxRows = 24; { max rows per screen } ESC = #27; { several keystrokes' ASCII codes: } CR = #13; NULL = #0; BS = #8; DEL = #127; type MaxString = string[80]; { general purpose string type } NameStr = string[25]; { animal's name } QuestionStr = string[40];  { animal's description } AnimalPtr = ^AnimalRec; AnimalRec = record Name : NameStr;  Question : QuestionStr; Yes, No : AnimalPtr; end; StringRec = record  { used to load tree fro disk } Name : NameStr; Question : QuestionStr;  StringP : string[3]; { NIL or END } end; ScoreRec = record Added,  { number of new animals learned } Guessed, { number of correct guesses }  Total : integer; { total animals known } end; BubbleRec = record  X, Y, { box's dimensions } Height, Width : byte; Vert, Horiz, { box's wall characters } UpLeft, UpRight, { corner characters } L owLeft, LowRight, BubbleChar : char; { bubbles to come from Owl's head } LinesToClear : byte; { number of lines to erase } end; const BlinkOwl = True; OwlX = 55; OwlY = 13; OwlBubble : BubbleRec = (X : 1; Y : 1; { box's dimensions } Height : 11;  { OwlY - 2 } Width : 56; { Succ(OwlX) } Vert : '|'; { box's wall characters } Horiz : '_'; UpLeft : '/'; { corner characters } UpRight : '\'; LowLeft : '\'; LowRight : '/';  BubbleChar : 'o'; LinesToClear : 0); { number of lines to erase } var Root : AnimalPtr; Rec : StringRec; F : text; Score : ScoreRec; procedure Abort(Msg : MaxString); { Abort the program, display an error message. } begin GotoXY(1, MaxRows); HighVideo; Write(Msg, '. Program aborted'); Halt; end; { Abort } procedure CreateNode(var P : AnimalPtr; Beast : NameStr; Query : QuestionStr;  var Count : integer); { either Score.Added or score.Total } { Allocate a new record from the heap; halt the program if there is not enough memory. } begin if Abs(MaxAvail) < SizeOf(P^) then Abort('Out of memory'); Count := Succ(Count); New(P); with P^ do begin Name := Beast; Question := Query; Yes := nil; No := nil; end; end; { CreateNode } procedure FillTree(var Root : AnimalPtr); { This procedure checks for the data file called DataFile. If the file exists, it gets the first animal from the file and then calls LoadTree to build and load the tree of known animals. If the file does not exist, it creates a tree with one animal. } procedure GetRec(var Rec : StringRec); { Reads a "record" from the disk file. } begin with Rec do begin Readln(F, Name); StringP := Name; { assume it's a NIL stmt } if Name = 'NIL' then Exit; { Name & question will be ignored } Readln(F, Question); StringP := ''; end; { with } end; { GetRec } procedure LoadTree(var Rec : StringRec; var Animal : AnimalPtr); { Loads the tree from a disk file at program start up. } begin if Rec.StringP = 'END' then Exit; { EOF } if Rec.StringP <> 'NIL' then begin CreateNode(Animal, Rec.Name, Rec.Question, Score.Total); GetRec(Rec); LoadTree(Rec, Animal^.Yes); LoadTree(Rec, Animal^.No); end else GetRec(Rec); end; { LoadTree } function OpenFile(var F : text; FileName : MaxString) : boolean; { TRUE if can successfully open FILENAME, else FALSE } begin Assign(F, FileName); {$I-} Reset(F); {$I+} OpenFile := IOresult = 0; end; { OpenFile } begin { FillTree } FillChar(Score, SizeOf(Score), #0);  { init score variables } if OpenFile(F, DataFile) then { found the disk file } begin Writeln('Loading from disk...'); GetRec(Rec); LoadTree(Rec, Root); end else { empty tree: create r oot entry } CreateNode(Root, 'snake', 'It''s cold blooded w/scaly skin', Score.Total); ClrScr; end; { FillTree } procedure SaveTree(var Root : AnimalPtr); { This procedure saves the tree (pointed to by "Root") to a disk file. Note that file was "opened" by FillTree at program start up. } procedure DumpTree(Animal : AnimalPtr); { Recursive procedure that dumps the tree to a text file. The global file variable "f" is already "opened" by FillTree and SaveTree. DumpTree uses a pre-order traversal of the tree. } begin if Animal <> nil then begin Writeln(F, Animal^.Name); Writeln(F, Animal^.Question); DumpTree(Animal^.Yes); DumpTree(Animal^.No); end else Writeln(F, 'NIL'); { indicates a nil pointer in the text file } end; { DumpTree } begin { SaveTree } GotoXY(1, MaxRows); if Score.Added <> 0 then { any changes made to the tree? } begin Write('Saving animals...'); Rewrite(F); DumpTree(Root); Writeln(F, 'END'); { indicates END of tree data in text file } Close(F); end; Write(#13, 'Happy hootin''...'); { go to column #1, display msg } end; { SaveTree } function AorAn(S : MaxString) : MaxString; { This function is given a string; if the string begins with a vowel, it returns the article "a", a space and the original word, otherwise it returns the article "an", a space and the original word. } const Vowels : set of char = ['A', 'E', 'I', 'O', 'U']; begin if UpCase(S[1]) in Vowels then AorAn := 'an ' + S else AorAn := 'a ' + S; end; { AorAn } { ================= Cartoon routines =============================== } procedure DrawBubble(Bubble : BubbleRec); { Draws a bubble-shaped window. On horizontal lines, draws a space every other character to make the box "softer" and more like a bubble. } var B : byte; begin LowVideo; with Bubble do begin GotoXY(Succ(X), Y); { upper left corner } for B := 1 to Width - 2 do { top border } if Odd(B) then Write(' ') else Write(Horiz); GotoXY(X, Y + Pred(Height));  { lower left corner } Write(LowLeft); for B := 1 to Width - 2 do { bottom border } if Odd(B) then  Write(' ') else Write(Horiz); Write(LowRight); { lower right corner } for B := 1 to Height - 2 do { bottom border } begin GotoXY(X, Y + B); { left border } Write(Vert);  GotoXY(X + Pred(Width), Y + B);{ right border } Write(Vert); end; { for } GotoXY(X, Succ(Y)); { upper left corner } Write(UpLeft); GotoXY(X + Pred(Width), Succ(Y)); { upper left corner } Write(UpRight);  GotoXY(X + Width, Y + Height); Write(BubbleChar); GotoXY(Succ(X + Width), Succ(Y + Height)); Write(BubbleChar);  end; { with } end; { DrawBubble } procedure ClrBubble(var Bubble : BubbleRec); { Clears the "bubble" window of text. } var B : byte; begin LowVideo; with Bubble do begin for B := 1 to Pred(LinesToClear) do { only erase dirty lines } begin GotoXY(Succ(X), Y + B); { dirty line, inside bubble border } Write(' ':Width - 2); { eras e bubble } end; LinesToClear := 0; end; { with } end; { ClrBubble } type Tasks = (EntireOwl, EyesOpen, EyesClosed); procedure DrawOwl(Task : Tasks; X, Y : byte); { A cartooning routine that draws an owl. It can be used to "blink" the eyes by calling it with various TASK parameters. } var I : integer; begin HighVideo; case Task of EntireOwl : begin ClrScr; for I := 0 to 8 do begin GotoXY(X, Y + I); case I of 0 : Writeln(' /\,,,/\'); 1 : Writeln('  {(o) (o)}'); 2 : Writeln(' | V |'); 3 : Writeln(' //|||||||\\');  4 : Writeln('////|||||||||\\\\'); 5 : Writeln('/// ||||||| \\\');  6 : Writeln('// ||/ \|| \\'); 7 : Writeln(' ," ,'); 8 : Writeln('======^^=^^=============='); end; { case } end; { for } end; EyesOpen : begin GotoXY(X + 6, Succ(Y)); Write('o) (o'); end; EyesClosed: begin GotoXY(X + 6, Succ(Y)); Write('-) (-'); end; end; { case } end; { DrawOwl } procedure BlinkEyes(CurX, CurY : byte); { A cartooning routine to blink the owl's eyes. It is called by the GetCh routine; it blinks the owl's eyes until a key is typed, then it makes sure the owl's eyes are "open" and then exits. It is passed the current x,y cursor coordinates, blinks the eys, and then returns to the prev. cursor position upon exit. } const OpenDuration = 200; { keep eyes open 200/hundredths of a second } ClosedDuration = 120; { keep eyes closed 120/hundredths of a second } var BlinkCount : integer; begin BlinkCount := 0; repeat BlinkCount := Succ(BlinkCount); Delay(10); if BlinkCount mod OpenDuration = 0 then begin if KeyPressed then Exit; DrawOwl(EyesClosed, OwlX, OwlY); GotoXY(CurX, CurY); { return to former cursor position } repeat BlinkCount := Succ(BlinkCount); Delay(10); until KeyPressed or (BlinkCount mod ClosedDuration = 0); DrawOwl(EyesOpen, OwlX, OwlY); GotoXY(CurX, CurY); { return to former cursor position } BlinkCount := 0;  end; until KeyPressed; end; { BlinkEyes } { ============== beginning of editing routines ============== } type CharSet = set of char; procedure GetCh(X, Y : byte; { x,y coordinates } var Ch : char; { character to read } LegalSet : CharSet; { legal input characters } BlinkOwl : boolean); { whether to blink the owl's eyes } { Read a character from the keyboard. Keep reading characters until: o a ^C is typed (abort the program) o a legal character is typed (specified by LegalSet parameter) In addition, if we are blinking the owl's eyes, call the cartooning routine BlinkEyes. } begin repeat if BlinkOwl then BlinkEyes(X, Y); Read(Kbd, Ch);  if (Ch = #27) and KeyPressed then begin Read(Kbd, Ch); Ch := Chr(Ord(Ch) or $80); { turn on high bit } end; if Ch in [^C] then Abort('** INTERRUPTED'); until UpCase(Ch) in LegalSet; end; { GetCh } const TermSet : CharSet = [ESC, CR]; { set of terminating chars. } function GetString(var St : MaxString; { string to edit } MaxLen : byte; { max length of str } X, Y : byte { starting row,col } ) : char; { returns terminating char } { GetString edits a string. It is given a string variable (St), the maximum allowable length of the string (MaxLen), and the x,y coor- dinates of the first character in the string. It uses GetCh to get characters from the keyboard and the global set constant TermSet to determine when to stop editing the string. It returns the terminating character as the function value. Input characters are highlighted (HighVideo), a stream of periods ('.') shows the user how many input characters are allowed. } procedure AddChar(Ch : char; var S : MaxString); { Add a character to the end of the string. } begin HighVideo; Write(Ch); { display new char } LowVideo; S := S + Ch; { add to string } end; { AddChar } procedure DelChar(var S : MaxString); { Delete a character from the end of the string. } begin GotoXY(Pred(X + Length(S)), Y); { to last char } LowVideo;  Write('.'); { overwrite it } Delete(S, Length(S), 1); { remove last char } GotoXY(X + Length(S), Y); { to end of string } end; { DelChar } var Ch : char; B : byte; begin { GetString } GotoXY(X, Y);  { use periods to show maximum len } LowVideo; for B := 1 to MaxLen do { fill out display field with periods } Write('.'); GotoXY(X, Y); HighVideo; Write(St); GetString := Null; { Assume no terminating action taken } repeat GetCh(X + Length(St), Y, Ch, [#0..#255], BlinkOwl); { to end of string } if not (Ch in TermSet) then begin case Ch of ' '..#127 : if Length(St) < MaxLen then { still room for more }  AddChar(Ch, St); BS, DEL : if Length(St) > 0 then DelChar(St); ^X,^U,^A : while Length(St) > 0 do { erase string } DelChar(St); else; { case else: ignore other characters } end; { case } end; until Ch in TermSet; GetString := Ch; end; { GetString } { ===================== end of editing routines ===================== } procedure GuessAnimal(var Animal : AnimalPtr;  var Ch : char); { returns answer } { Recursive routine that "guesses" the user's animal. It is given a pointer to an "Animal." It asks the user the question associated with this "animal" (done by ThisQuestion); if the user answers yes to the question, it "guesses" the animal's name (done by ThisAnimal); if the animal was "guessed" correctly, the procedure boasts about its accomplishment, the unwinds the stack and returns to the calling routine. If i t did not guess the animal, it calls itself and passes the appropriate pointer associate with each animal (a YES description follows the YES path, a NO to description follows the NO path...). } function ThisQuestion(Animal : AnimalPtr;  var Ch : char { returns the answer } ) : boolean; { Ask the user a question using the description associated with this animal; return TRUE if the user YES, otherwise return FALSE; return the answer in the char variable parameter. } const Qx = 3; { x coordinate of where question will be asked } Qy = 3; { y coordinate of where question will be asked } begin { ThisQuestion } ClrBubble(OwlBubble); GotoXY(Qx, Qy); HighVideo;  Write(Animal^.Question, '? '); { Ask the question } LowVideo; Write('[Y,N] '); HighVideo; GetCh(Qx + Length(Animal^.Question) + 8, Qy, { x,y coordinates } Ch,  { read this char } ['Y', 'N', #27], { set of answers } BlinkOwl);  { do cartooning } OwlBubble.LinesToClear := Qy; { set flag: dirtied the window } ThisQuestion := UpCase(Ch) = 'Y'; end; { ThisQuestion } function ThisAnimal(Animal : AnimalPtr; var Ch : char { returns the answer } ) : boolean; { Guess the animal's name using the animal associated with this record: return TRUE if the user YES, otherwise return FALSE; return the answer in the char variable parameter. } const Ax = 3; { x coordinate of where question will be asked } Ay = 4; { y coordinate of where question will be asked } var S : MaxString; begin GotoXY(Ax, Ay); HighVideo; S := 'Is it ' + AorAn(Animal^.Name) + '? '; { the question to ask } Write(S); LowVideo; Write('[Y,N] '); HighVideo; GetCh(Ax + Length(S) + 6, Ay,  { x,y coordinates } Ch, { char to read } ['Y','N',#27],  { legal answers } BlinkOwl); { do cartooning } OwlBubble.LinesToClear := Ay; { set flag: dirtied the window } ThisAnimal := UpCase(Ch) = 'Y'; end; { ThisAnimal } procedure AddAnimal(var Animal : AnimalPtr; var Ch : char); { returns value } { This routine adds another animal to the tree. It asks the user for the animal's name; it asks for a brief description of the animal (which it will later read as if it was a question). It then adds the animal to the tree. The terminating character from the editing routine is returned in the char parameter. } const Ax = 3; { x coordinate of where animal name is entered } Ay = 6; { y coordinate of where animal name is entered } Qx = 3; { x coordinate of where description is entered } Qy = 9; { y coordinate of where description is entered } var Ques : QuestionStr;  { description entered } Beast : NameStr; { name entered } begin GotoXY( Ax, Ay); HighVideo; with OwlBubble do LinesToClear := Pred(Height); { set flag: we dirtied the bubble } Write('Ok, ok, I give up. What''s your animal''s name:'); Beast := ''; Ch := GetString(Beast, Pred(SizeOf(Beast)), Ax, Succ(Ay)); { get name } if Ch = ESC then Exit; { ESC: Don't add } GotoXY(Qx, Qy); Write('What''s ', AorAn(Beast), ' like:'); Ques := ''; Ch := GetString(Ques, Pred(SizeOf(Ques)), Qx, Succ(Qy)); { get descrip. }  if (Ques <> '') and { legal name & description? Add to tree } (Beast <> '') and (Ch <> ESC) then CreateNode(Animal, Beast, Ques, Score.Added); end; { AddAnimal } procedure Boast; { Boast after having guessed the animal correctly. } begin Write('Yes'); with OwlBubble do GotoXY(X + 2, Y + Height - 2); { last row } HighVideo; Write('-- AHA! I knew it was ', AorAn(Animal^.Name), '!'); Score.Guessed := Succ(Score.Guessed); Delay(2200); with OwlBubble do LinesToClear := Pred(Height); { we dirtied the bubble } end; { Boast } begin { GuessAnimal } if Ch = ESC then  Exit; { return to main menu } if Animal <> nil then { more animals to guess } begin if ThisQuestion(Animal, Ch) then begin Write('Yes'); if ThisAnimal(Animal, Ch) then  Boast { confirm our guess } else GuessAnimal(Animal^.Yes, Ch) { right description, wrong animal } end { if } { follow YES path } else GuessAnimal(Animal^.No, Ch) { wrong description, wrong animal } end { if } { follow NO path  } else { No more animals on this path: add the animal } begin Write('No'); AddAnimal(Animal, Ch); end; { else } end; { GuessAnimal } function WantToGuess(var Ch : char) : boolean; { Display scoring information, check whether user wants to play another round. } var Col, Line : byte; procedure GoLine(X : byte; var Y : byte); { Go to line Y, increment Y } begin GotoXY(X, Y); Y := Succ(Y); end; { GoLine } procedure ShowBubbleMsg; { Fills the bubble window with text that explains the game. } begin with OwlBubble do begin Write('':Pred((Width - 18 - Col) div 2), 'THINK OF AN ANIMAL'); LowVideo; Line := Succ(Line); GoLine(Col, Line); with Score do begin case Total + Added of 1 : Write('I only know one animal, but I can guess or learn'); else  Write('I know ', Total + Added, ' different animals and can guess'); end; { case } end; { with } end; { with } GoLine(Col, Line); Write('the ones you think of. Think of an animal'); GoLine(Col, Line); Write('if you want to play. '); HighVideo; end; { ShowBubbleMsg } begin { WantToGuess } LowVideo;  { show scoring info } GotoXY(67, Pred(MaxRows)); Write('Guessed', Score.Guessed:6); GotoXY(67, MaxRows);  Write('Added ', Score.Added:6); with OwlBubble do begin Line := Y + 2; Col := X + 3; GoLine(Col, Line);  HighVideo; ShowBubbleMsg; { paint "menu" } GotoXY(Col, Succ(Line)); Write('Ready? '); GetCh(Col + 7, Succ(Line), { x,y coordinates } Ch,  { char to read } ['Y','N', #27], { legal answers } not BlinkOwl);  { don't blink eyes } if UpCase(Ch) <> 'Y' then Write('No'); LinesToClear := Pred(Height); { set flag: we dirtied the bubble } end; WantToGuess := UpCase(Ch) = 'Y'; end; { WantToGuess } var Ch : char; { used by entry routines: returns terminating char } Quit : boolean; { loop control variable } begin { program body } FillTree(Root); { load from disk or build if new } DrawOwl(EntireOwl, OwlX, OwlY); { paint screen } DrawBubble(OwlBubble); repeat Quit := not WantToGuess(Ch);  if not Quit then begin GuessAnimal(Root, Ch); { guess the animal } ClrBubble(OwlBubble) { clear the window } end; until Quit; SaveTree(Root); { save animal data to disk } end. åsnake It's cold blooded w/scaly skin frog It likes the water alligator Has a long snout and sharp teeth NIL NIL lizard Has 4 legs and can do pushups NIL NIL sparrow It's a bird ostrich It is a flightless bird penguin Likes the water, loves to eat fish NIL NIL pelican Likes to fill its pouch with fish NIL owl Hunts at night, wise, & guesses animals NIL NIL  goldfish It's a fish salmon Lives in saltwater, spawns in rivers NIL shark Has a large appetite & very sharp teeth NIL NIL cow Warm blooded & its babies are born alive dolphin Lives in the ocean whale Largest animal on Earth NIL NIL mouse It's a rodent gopher Burrows underground NIL NIL horse Has hooves, munches only plants giraffe Has a rather long neck  NIL NIL dog Has 4 legs, likes to munch meat house cat It's in the cat family tiger Big cat with orange fur & black stripes NIL NIL bear Has lots of fur and sharp claws & teeth NIL NIL gorilla It's a primate (likes to swing in trees) human creature Very clever, dangerous & likes Pascal NIL NIL fly Has an exoskeleton (insect family) dragonfly Has wings and can fly (as an adult) mosquito Humms while it drinks your blood NIL NIL ant Very strong and likes picnics NIL worm Wiggly, squiggly and wet NIL NIL NIL NIL END å{$C-,V-} program TurboTypist; { -------------------------------------------------------------------- TYPIST.PAS - Example program Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. ------------------------------------- ------------------------------- SYSTEM REQUIREMENTS Turbo Pascal : Version 3.0 Hardware : Any computer that runs Turbo Pascal 3.0 Operating systems: PC/MS-DOS 2.0 or later CP/M-80 2.2 or later  CP/M-86 1.1 or later Memory : about 17K DESCRIPTION This program is a typing game. Create a text file with the Turbo Pascal editor. Enter as many words as you wish, placing one word or phrase on each line. Run the program and type each word as the program displays it. A file called TYPIST.DTA is provided.  PROGRAM OVERVIEW Please refer to Chapter 19 of the Tutor manual. -------------------------------------------------------------------- } const Speed : integer = 1; { increment car's column position by this amount.  See procedure GetSpeed } KeysPerCycle = 5; { max # keystrokes user can type before GetStr edit  routine will exit and let PlayOneRound move the car. Larger numbers slow the car, smaller ones speeds it } PauseConst = 1; { Number of 1/10's of a sec. delay per "loop" } WordLength = 50; { maximum line length } CarLength = 7; { column length of car } TruckLength = 24; { column length of truck } RoadLength = 80;  { there are 80 columns on my screen } RoadRow = 12; { the road goes on line 10 } TypingRow = 17; { Row where words are typed } TargetRow = 5; { Row where target words appear } MaxRows = 24; { max # rows on screen } NULL = #0; { Null character } BS = #8; { Backspace key } CR = #13; { Carriage Return } ESC = #27; { Escape key } DEL = #127; { Delete key } type MaxString = string[WordLength]; { max length of target words } CarType = array[1..2] of string[CarLength]; CharSet = set of char; DirectionType = (Forwardd, { "forward" is a reserved word } Backward); { both are used by Drive to determine direction } ScoreRec = record Title : string[8]; { heading to accompany score }  Row : byte; { which row to display score } Count : integer; end; const PrettyCar : CarType = ('_]~\__', { Typed constants } '-o--o-'''  ); EmptyCar : CarType = (' ', ' ' ); BrokenCar : CarType = (' _,}{', ' -o-oo ' ); Words : ScoreRec = (  Title : 'Word #'; Row : 19; Count : 0); Crashes : ScoreRec = ( Title : 'Crashes'; Row : 23; Count : 0); Mistakes : ScoreRec = ( Title : 'Mistakes'; Row : 21; Count : 0); const TermSet : CharSet = [^C, ESC, CR]; { set of terminating chars. Used by GetString } { =================== Beginning of misc. routines ==== =============== } procedure AbortCheck(Ch : char); begin if Ch in [ESC, ^C] then begin GotoXY(1, MaxRows); HighVideo; Write('** INTERRUPTED **'); Halt; end; end; { Abort } function GetKey : char; { Reads a character from the keyboard } var Ch : char; begin Read(Kbd, Ch); if (Ch = ESC) and KeyPressed then begin Read(Kbd, Ch); Ch := Chr(Ord(Ch) + 128); end; GetKey := Ch; end; { GetKey } procedure Pause(var Tenths : integer); { An interruptable, machine-independent (almost) delay routine. It delays for a specified amound of time (measured approx. in tenths of a second) or until any key is typed. } var T : integer; begin T := Tenths; repeat T := Pred(T); Delay(100);  until (T <= 0) or (KeyPressed and (T <= Tenths div 1)); Tenths := T; { return # time remaining on count down } end; { Pause } function GetString(X, Y : byte; { starting row,col } var St : MaxString;  { string to edit } MaxLen : byte; { max length of st } KeyQuota : byte; { used to limit # chars } DelayTime : integer; { limits time spent editing } TermSet : CharSet  { exit if one of these is typed } ) : char; { returns terminating char } { A string editing routine with some special time control features. GetString is passed editing parameters (x,y coordinates for cursor placement, string to edit and the maximum length of the string). In addition, 2 other parameters, KeyQuota and TermSet, are passed to the routine and determine when the function exits: o GetString will exit when a character is typed that is contained  in the set TermSet. o GetString will exit when KeyQuota (a byte ) keystrokes have been typed. This allows the cartooning routines to run smoothly -- even if the user holds down a key continuously. For the same reason, GetString will also exit when too much time has been spent editing the string. Time is incremented in a local variable called DelayTime. DelayTime is initialized to PauseCount (declared & initialized by PlayOneRound) and is decremented until it reaches zero. At that point, GetString returns to the calling routine. When GetString was terminated by a character contained in the set, TermSet, it returns the terminating character as the function value; otherwise, it returns a NULL value to the calling routine. } procedure AddCh(Ch : char; var St : MaxString); { Adds a character to the string being edited, displays the char. } begin HighVideo; Write(Ch); { display new char } LowVideo; St := St + Ch;  { add to string } end; { AddCh } procedure DelCh(var St : MaxString); { Deletes last character from the string being edited, update display. } begin GotoXY(Pred(X + Length(St)), Y); { to last char } Write(' ');  { overwrite it } Delete(St, Length(St), 1); { remove last char } GotoXY(X + Length(St), Y); { to end of st } end; { DelCh } var Ch : char; begin GetString := NULL; { Assume no terminating action taken } repeat  if KeyPressed then begin Ch := GetKey; { read a character } KeyQuota := Pred(KeyQuota); { reduce keystrokes left } if not (Ch in TermSet) then begin GotoXY(X + Length(St), Y); { go to end of string } case Ch of ' '..#127 : if Length(St) < MaxLen then { still room for more } AddCh(Ch, St); BS, DEL : if Length(St) > 0 then { string not empty } DelCh(St); ^X,^U,^A : while Length(St) > 0 do { erase entire string } DelCh(St); else; { case else: ignore other characters } end; { case } end else GetString := Ch; end { if KeyPressed } else Pause(DelayTime); until (KeyQuota = 0) or { used our quota of keystrokes } (Ch in TermSet) or { evaluate string/char } (DelayTime <= 0); { we've been here long enough } end; { GetString } type String80 = string[80]; function CenterStr(S : String80) : byte; { A nice library routine that is used to center a string. The function computes the starting column. Returns first col to write string in order to center it } begin CenterStr := (RoadLength - Length(s)) div 2; end; { CenterStr } { =================== Beginning of file routines ================== } function GetWord(var F : text; var Word : MaxString) : boolean; { A routine to read vocabulary words from a disk file. } begin Word := ''; while not Eof(F) and (Word = '') do Readln(F, Word); GetWord := Word <> ''; end; { GetWord } type FileString = string[66]; { DOS maximum = 66; CP/M = 12 } var TargetWord : MaxString; { the current word to be typed } WordFile : text; { the file that contains all target words } FileName : FileString; { the name of WordFile }  procedure OpenFile(var F : text; var Name : FileString); { Displays the logon screen; gets the name of the text file to use and "opens" it; lets the user adjust the speed of the car. } const Title = 'T U R B O T Y P I S T'; Prompt : string[10] = 'File name:'; var Opened : boolean; Ch : char; procedure LogOnScreen; var B : byte; { scratch } begin { LogOnScreen } ClrScr; LowVideo; GotoXY(1, MaxRows - 6); Writeln; Writeln('This program is a typing game. Create a text file with the', ' Turbo Pascal'); Writeln('editor. Enter as many words as you wish, placing one word',  ' or phrase on'); Writeln('each line. Run the program & type each word as the program', ' displays it.'); for B := 1 to 72 do Write('='); Writeln; Writeln('Copyright (c) 1986 by Borland International, INC.'); end; { LogOnScreen } procedure GetSpeed; { Let's the user specify the speed of the car; converts to an integer value and updates the global typed constant "speed." } procedure MenuDisplay(S : MaxString); { Displays a menu item, highlights the first character of the word } begin HighVideo; Write(' ', Copy(S, 1, 1)); LowVideo; Writeln(Copy(S, 2, Length(S))); end; { M enuDisplay } var Ch : char; begin LowVideo; Writeln('Set the speed:'); Writeln; MenuDisplay('Reasonable'); MenuDisplay('Fast'); MenuDisplay('Turbo!'); repeat Ch := UpCase(GetKey); AbortCheck(Ch); until Ch in ['R', 'F', 'T']; case Ch of 'R' : Speed := 1; { reasonable } 'F' : Speed := 2; { fast } 'T' : Speed := 3;  { Turbo! } end; { case } end; { GetSpeed } begin { OpenFile } LogOnScreen; GotoXY(1, 5); Write(Title);  GotoXY(1, 8); Write(Prompt, ' '); HighVideo; if Name <> '' then Write(Name); repeat repeat  { get file name } Ch := GetString( 1 + SizeOf(Prompt),8, { row, col }  Name, { string to edit } WordLength, { maximum length } 1, { max keystrokes allowable } PauseConst,  { max time allowable } TermSet); { set of terminating chars } until Ch in TermSet;  AbortCheck(Ch); { STOP the program } Assign(F, Name); {$I-} Reset(F); {$I+}  Opened := IOresult = 0; if not Opened then Write(^G); until Opened; Writeln; Writeln; GetSpeed;  { allow user to change speed } ClrScr; GotoXY(CenterStr(Title), 3); Write(Title); end; { OpenFile } { =================== Beginning of cartoon routines ================== } procedure DrawCar(Car : CarType; X, Y : integer); { A cartooning routine to draw a car. } begin GotoXY(X, Y - 2); Write(Car[1]); GotoXY(X, Y - 1); Write(Car[2]); end; { DrawCar } procedure Drive(var Col : integer; Speed : integer; Direction : DirectionType); { A cartooning routine to move a car. Increment the car's column counter -- depending on whether we are going backwards or forwards. } begin case Direction of Forwardd : Col := Col + Speed; Backward : begin  Col := Col - Speed; if Col < 1 then Col := 1; { adjust if off screen's edge } end; end; { case } end; { Drive } procedure DrawTruck(Col, Road : integer); { A cartooning routine to draw a truck (uses a different technique than DrawCar). } const TruckHeight = 5; { truck is 5 rows high } var Line : byte; begin for Line := 0 to Pred(TruckHeight) do begin GotoXY(Col, Road - TruckHeight + Line); case Line of 0 : Write(' ________________'); 1 : Write('| | __'); 2 : Write('| TURBO TRUCKING || |_'); 3 : Write('|________________||____|'); 4 : Write(' OO OO O'); end; { case } end; { for } end; { DrawTruck } procedure Backup(var Col : integer); { A cartooning routine to move the car backwards. } begin while Col > 1 do { backup to column 0 } begin DrawCar(EmptyCar, Col, RoadRow); Drive(Col, 2 * Speed, Backward); { backup twice normal speed } DrawCar(PrettyCar, Col, RoadRow); end; end; { Backup } procedure DisplayTarget(Word : MaxString; var Col  : integer; Row : integer); { A display routine that displays the word we are trying to type. } begin Col := CenterStr('"' + Word + '"'); GotoXY(Col, Row); HighVideo; Write('"'); { surround word in quotes to show leading spaces }  LowVideo; Write(Word); HighVideo; Write('"'); LowVideo; Col := Succ(Col); { adjust by one because of quote } end; { DisplayTarget } procedure DisplayScore(Score : ScoreRec; ShowTitle : boolean); { A routine to display the score. } begin with Score do begin if ShowTitle then { display title also } begin GotoXY(RoadLength - Length(Title), Pred(Row)); { row above score } Write(Title); end; { if } GotoXY(RoadLength - 7, Row); Write(Count:7); end; { with } end; { DisplayScore } { ====================== End of cartoon routines ==================== } procedure PlayOneRound(var TargetWord : MaxString); { Sets up and plays one round of the typing game, beginning with the first word in the word file and stopping when done with the last or interrupted by characters defined by AbortCheck. } var Ch : char; { scratch character variable } CollisionPt : byte; { the column where the car & truck collide } CarX : integer; { the car's current column } Collision : boolean; { true if an Collision occurred } WordEntered : MaxString; { the string filled in by the typist } TypingCol : integer; { column 1 of WordEntered } PauseTime : integer; { used to slow/speed the "loop" } Odometer : integer; { total # of miles driven this round } procedure ShowMileage(Odometer : integer); { A routine that displays the odometer reading for this round. It converts the odometer to a string, fills it with leading zeros and then displays below the roadway. } var S : string[5]; B : byte; begin Str(Odometer:5, S); for B := 1 to Length(S) do if S[B] = ' ' then S[B] := '0'; GotoXY(1, Succ(RoadRow)); Write(S); end; { ShowMileage } procedure CarInit; { An initialization routine called by PlayOneRound: - draws the truck, car and roadway - initializes and shows the scoring information - shows the first word to be typed  } var I : byte; begin LowVideo; DrawTruck(Succ(RoadLength - TruckLength), RoadRow); { put truck @ far right } GotoXY(1, RoadRow); for I := 1 to RoadLength - TruckLength + 5 do Write('='); CarX := 1; { start car in column 1 } HighVideo; DrawCar(PrettyCar, CarX, RoadRow); LowVideo; CollisionPt := RoadLength - Pred(TruckLength) - Pred(CarLength); WordEntered := ''; { display scoring info } Odometer := 0; ShowMileage(Odometer); Words.Count := 1;  DisplayScore(Words, True); { show title on first time } Mistakes.Count := 0; DisplayScore(Mistakes, True); { show title on first time } Crashes.Count := 0; DisplayScore(Crashes, True); { show title on first time } { special case: display first word in list on first time } DisplayTarget(TargetWord, TypingCol, TargetRow); end; { CarInit } procedure CrashTheCar; begin Crashes.Count := Succ(Crashes.Count); { update score } DisplayScore(Crashes, False); !  { don't show title } DrawCar(EmptyCar, CarX, RoadRow); CarX := CollisionPt; { move car exactly to collision pt } HighVideo; DrawCar(BrokenCar, CarX, RoadRow); LowVideo; PauseTime := PauseConst * 2; { after crash, delay 2 * norml count } Pause(PauseTime); Backup(CarX); PauseTime := PauseConst; Pause(PauseTime); end; { CrashTheCar } procedure ProcessWord; { Checks whether user typed in correct word. Updates score and cartoon appropriately. } begin { ProcessWord } if TargetWord = WordEntered then { typed correctly! } begin if GetWord(WordFile, TargetWord) then { get next word } begin GotoXY(1, TargetRow); { erase old word } ClrEol; DisplayTarget(TargetWord, TypingCol, TargetRow); Backup(CarX); Words.Count := Succ(Words.Count); { update score }  DisplayScore(Words, False); { don't show title } GotoXY(1, TypingRow); { clear old word }  ClrEol; WordEntered := ''; end; { if } end { if } else { typed CR, incorrectly typed } begin Mistakes.Count := Succ(Mistakes.Count); { update score } DisplayScore(Mistakes, False); { don't show title } if WordEntered = '' then begin PauseTime := PauseConst; Pause(PauseTime); end; end; { else } end; { ProcessWord } begin { PlayOneRound } CarInit; { initialize all the variables } repeat PauseTime := PauseConst; DrawCar(EmptyCar, CarX, RoadRow); GotoXY(TypingCol + Length(WordEntered), TypingRow); { go near text } Drive(CarX, Speed, Forwardd); Odometer := Odometer + Speed; ShowMileage(Odometer);  Collision := (CarX + Speed) >= CollisionPt; { collision? } if Collision then CrashTheCar else  { no collision, paint the car, get keystrokes } begin HighVideo; DrawCar(PrettyCar, CarX, RoadRow);  LowVideo; GotoXY(TypingCol + Length(WordEntered), TypingRow); { go near text } Ch := GetString(TypingCol, TypingRow, { row, col } WordEntered, { string to edit } Length(TargetWord), { maximum length } KeysPerCycle, { max keystrokes allowable }  PauseConst, { max time allowable } TermSet); { set of terminating chars }  AbortCheck(Ch); { STOP the program } if Ch in TermSet then ProcessWord; end; { else no collision } until (TargetWord = ''); { no more words } Close(WordFile); end; { PlayOneRound } begin { program body } FileName := ParamStr(1); { get filename from command line, if there } if FileName = '' then FileName := 'TYPIST.DTA'; repeat OpenFile(WordFile, FileName); { HALTS the program if ^C or ESC typed } if GetWord(WordFile, TargetWord) then { make sure the file isn't empty } PlayOneRound(TargetWord) else begin GotoXY(1, Pred(MaxRows)); Writeln('I can''t find a single word in that file.'); end; GotoXY(1, MaxRows)" ; HighVideo; Write('Try again? '); until UpCase(GetKey) <> 'Y'; Writeln('No'); end. åabsolute and array begin case const DIV do downto else end external file forward for function goto inline if in label MOD nil not overlay of or packed procedure program record repeat set SHL SHR string then type to until var while with XOR å(* -------------------------------------------------------------------- LISTT.PAS - Turbo Pascal Program Lister Version 2.00D Turbo Pascal Tutor 2.0 Copyright (c) 1984,85,86 by Borland International, INC. -------------------------------------------------------------------- Documentation for this program can be found in the file LISTT.DOC. Several parameter files for a few common printers have also been included. These are the files with the extension of ".LTP". -------------------------------------------------------------------- This program is designed to work with all versions of Turbo Pascal. However, some parts of the program must be changed between versions. The symbol {!} has been used at each place where a change is necessary. Of course, each Tutor disk comes with these changes already made. This file has been modified for MS/PC-DOS. -------------------------------------------------------------------- *) {$C-,U-,R-}  (* CP/M-86 and MS-DOS *) {!} (* {$C-,U-,R-,A-} CP/M-80 *) {!} Program ListTurbo; Const CopyrightMessage: Array [1..74] Of Char= 'ListT version 2.00D Copyright (C) 1984,85,86 BORLAND International, Inc.'^M^J; Type FileName=String[20]; String3=String[3]; String10=String[10];  Buffer=String[200]; ParseStates=(PreKey,KeyWord,Comment,Comment2,Quoted); Const ParameterSetSize=502; { This is the size of the parameter set that will be saved in a parameter file. It is the number  of bytes enclosed between the variables PageLength and IncludeDrive. THIS VALUE MUST BE CORRECT!! } Type ParameterSet=Array [1..ParameterSetSize] Of Byte; ParameterRecord=Array [1..1000] Of Byte; Const NoList: Boolean=False; PageStarted: Boolean=False; InInclude: Boolean=False; CommandLineStartup: Boolean=False; ParseState: ParseStates=PreKey; YesNo: Array [False..True] Of String[3]=('No','Yes'); Var  PageLength: Integer; {---------------------------------} LineWidth: Integer; { If anything in this section is } HiLite: String10; { changed, the constant } LoLite: String10;  { ParameterSetSize MUST also be } InitString: String10; { changed to agree with the } ExitS# tring: String10; { number of bytes here! } LineNumbers: Boolean; {  } UpKeys: Boolean; { } PageForIncludes: Boolean; {  } Indent: Integer; { } Heading: Buffer; { } Footing: Buffer; {  } CurrentPageNumber: Integer; { } CurrentLineNumber: Integer; {  } SavedInFileName: FileName; { } SavedOutFileName: FileName; { } IncludeDrive: Char; {---------------------------------}  Parms: ParameterSet Absolute PageLength; (* For MS-DOS and CP/M-86 *) (* Parms: ParameterSet Absolute IncludeDrive; For CP/M-80 only! *) {!} ParmFile: File Of ParameterRecord; ParmFileName: FileName; InFileName: FileName; OutFileName: FileName; TimeString: String10; DateString: String10; CurrentInFileName: String[60]; InFile: Text; OutFile: Text; Ok: Boolean; OutIsDevice: Boolean; Blanks: Buffer; Ch: Char; I: Integer; LinesLeft: Integer; Procedure ErrorMessage(Message: Buffer); Var Ch: Char; Begin WriteLn(Message); While KeyPressed Do Read(Kbd,Ch); { Flush input buffer } Write('Hit any key to continue or to abort: '); Read(Kbd,Ch); WriteLn; If Ch=^[ Then Halt; End; Function CommandLineArgument(N: Integer): FileName; Const Buffered: Boolean=False; CommandLineBuffer: String[127]=''; Var CommandLine: String[127] Absolute CSeg:$0080; (* MS-DOS *) {!} (* CommandLine: String[127] Absolute DSeg:$0080; CP/M-86  CommandLine: String[127] Absolute $0080; CP/M-80 *) CLA: FileName; I,J: Integer; Begin  If Not Buffered Then CommandLineBuffer:=CommandLine; Buffered:=True; J:=1; For I:=1 To N Do Begin  CLA:=''; While (J<=Length(CommandLineBuffer)) And (CommandLineBuffer[J]=' ') Do J:=J+1; While (J<=Length(CommandLineBuffer)) And (CommandLineBuffer[J]<>' ') Do Begin CLA:=CLA+CommandLineBuffer[J]; J:=J+1; End; End; CommandLineArgument:=CLA; End; Procedure InitParms; Procedure ZeroFill(Var S: String10); Var I: Integer; Begin For I:=1 To Length(S) Do If S[I]=' ' Then S[I]:='0'; End; Var Hour,Min,AM_PM,Month,Day,Year: String[2]; I: Integer; Regs: Record Case Integer Of (* MS-DOS only *) {!} 1: (AX,BX,CX,DX,BP,DI,SI,DS,ES,Flags: Integer);  2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte); End; (* Nothing for CP/M-80 or CP/M-86 *)  {!} Begin { InitParms } PageLength:=66; { PageLength must be greater } $  LineWidth:=79; { than 6; all others may take } HiLite:=''; { on any reasonable value...  } LoLite:=''; { LineWidth is 79 to prevent } InitString:=''; { line wrap on some printers. } ExitString:=''; LineNumbers:=False; UpKeys:=False; PageForIncludes:=False; Indent:=0; Heading:='Listing of %F, page %# at %T %D'; Footing:='%F page %#'; CurrentPageNumber:=1; CurrentLineNumber:=1; Blanks:=''; For I:=1 To 200 Do Blanks:=Blanks+' '; With Regs Do  (* MS-DOS *) {!} Begin (* Comment entire section out for CP/M-80 or 86 *) {!} AH:=$2C; Flags:=0; MsDos(Regs); AM_PM:='am'; If CH>11 Then Begin CH:=CH-12; AM_PM:='pm'; End; If CH=0 Then CH:=12; Str(CH:2,Hour); Str(CL:2,Min);  TimeString:=Hour+':'+Min+AM_PM; ZeroFill(TimeString); AH:=$2A; Flags:=0; MsDos(Regs);  Str((CX Mod 100):2,Year); Str(DL:2,Day); Str(DH:2,Month); DateString:=Month+'/'+Day+'/'+Year;  ZeroFill(DateString); {!} End; { With Regs } (* End of commented-out area for CP/M-80 or 86 *) (* TimeString:=''; {!} DateString:=''; *) (* Comment these 2 lines out for MS-DOS *) {!} End; { InitParms } Procedure FixString(Var St: FileName); Var I: Integer; Begin While (St[1]=' ') And (Length(St)>0) Do Delete(St,1,1); If Pos(' ',St)<>0 Then St[0]:=Chr(Pos(' ',St)-1); For I:=1 To Length(St) Do St[I]:=UpCase(St[I]); End; Procedure FixFileName(Var FN: FileName; Ext: String3); Begin FixString(FN); If Pos('.',FN)=0 Then FN:=FN+'.'+Ext; End; Function PercentExpand(Ing: Buffer): Buffer; Var PE: Buffer; I,CPN: Integer; PN: String[6]; Center: (Left,Middle,Right); Begin Center:=Middle; PE:=''; I:=1; While (I<=Length(Ing)) Do Begin If Ing[I]<>'%' Then PE:=PE+Ing[I] Else If I=Length(Ing) Then PE:=PE+'%' Else  Begin Case UpCase(Ing[I+1]) Of '#': Begin PN:=''; CPN:=CurrentPageNumber; Repeat PN:=Chr(Ord('0')+(CPN Mod 10))+PN; CPN:=CPN Div 10; Until CPN=0; PE:=PE+PN; End; 'T': PE:=PE+TimeString; 'D': PE:=PE+DateString; 'F': PE:=PE+CurrentInFileName; '<': Center:=Left;  '>': Center:=Right; '[': Begin Center:=Right; If Odd(CurrentPageNumber) Then Center:=Left; End; ']': Begin Center:=Left; If Odd(CurrentPageNumber) Then Center:=Right; End; Else PE:=PE+Ing[I+1]; End; { Case Ing[I% +1] } I:=I+1; End; { Else Ing[I]='%' } I:=I+1; End; { While } If Length(PE)>LineWidth Then PE[0]:=Chr(LineWidth); If Center=Middle Then PE:=Copy(Blanks,1,(LineWidth-Length(PE)) Div 2)+PE Else If Center=Right Then PE:=Copy(Blanks,1,LineWidth-Length(PE))+PE; PercentExpand:=PE; End; { PercentExpand } Procedure WLine(S: Buffer); Begin If KeyPressed Then Begin Repeat Read(Kbd,Ch) Until Not KeyPressed; Write(^M,'Terminate (Y/N)? '); Read(Kbd,Ch); If UpCase(Ch)='Y' Then Begin WriteLn('Y'); Write(OutFile,ExitString); Close(OutFile); Halt;  End Else Write(^M,' ',^M); End; { If KeyPressed } If Not PageStarted Then Begin WriteLn(OutFile); WriteLn(OutFile,PercentExpand(Heading)); WriteLn(OutFile); PageStarted:=True; End; Write(OutFile,Copy(Blanks,1,Indent)); If LineNumbers Then Begin Write(OutFile,CurrentLineNumber:5); If InInclude Then Write(OutFile,'> ') Else Write(OutFile,': '); End Else If InInclude Then Write(OutFile,'> '); WriteLn(OutFile,S); If (OutFileName<>'CON:') And (CurrentLineNumber Mod 16=0) Then Write(^M,'Line ',CurrentLineNumber); LinesLeft:=LinesLeft-1; If LinesLeft=0 Then Begin WriteLn(OutFile); WriteLn(OutFile,PercentExpand(Footing)); WriteLn(OutFile); LinesLeft:=PageLength-6; CurrentPageNumber:=CurrentPageNumber+1; PageStarted:=False; End; End; { WLine }  Procedure NewPage; Var SaveLineNumbers: Boolean; Begin SaveLineNumbers:=LineNumbers; LineNumbers:=False; Repeat WLine(''); Until Not PageStarted; LineNumbers:=SaveLineNumbers; End;  Procedure ListIt(Var InF: Text); Var Line, Remainder: Buffer; WasCmd: Boolean; Procedure UpKeyWords; Const NKeyWords=45; MaxKeyLen=9; MaxKeyLenPlus1=10; KeyWords: Array [1..NKeyWords] Of String[MaxKeyLen]= ('ABSOLUTE','AND','ARRAY','BEGIN','CASE','CONST','DIV','DO', 'DOWNTO','ELSE','END','EXTERNAL','FILE','FOR','FORWARD','FUNCTION', 'GOTO','IF','IN','INLINE','LABEL','MOD','NIL','NOT','OF','OR',  'OVERLAY','PACKED','PROCEDURE','PROGRAM','RECORD','REPEAT','SET', 'SHL','SHR','STRING','THEN','TO','TYPE','UNTIL','VAR','WHILE', 'WITH','XOR',''); Var First, LL, LK, I, J: Integer; PossibleKey: String[MaxKeyLenPlus1]; Min, Max, Guess: Integer; Found: Boolean; Line1: Buffer; Begin  I:=1; LL:=Length(Line)+1; If UpKeys Then Begin Line[Length(Line)+1]:=Chr(254);  Line[0]:=Succ(Line[0]); While I<=LL Do Begin Case ParseState Of PreKey: Case Line[I] Of 'A'..'Z','a'..'z','_': Begin ParseState:=KeyWord; &  First:=I; LK:=1; End; '{': ParseState:=Comment; '(': If (Line[I+1]='*') And (I+1Quoted Then ParseState:=Comment; '(': If (ParseState<>Quoted) And (Copy(Line1,I,2)='(*') Then  ParseState:=Comment2; '}': If ParseState=Comment Then ParseState:=PreKey; '*': If (ParseState=Comment2) And (Copy(Line1,I,2)='*)') Then ParseState:=PreKey; '''': If ParseState=Quoted Then ParseState:=PreKey Else If ParseState=PreKey Then ParseState:=Quoted; End; '  I:=I+1; End; { While ILineWidth Then Begin Remainder:=Copy(Line,LineWidth-Extra+1,200); Line:=Copy(Line,1,LineWidth-Extra); End  Else Remainder:=''; End; Procedure ProcessDirectives; Var Cmd: String3; IncludeName: FileName; IncludeFile: Text; Where, Temp, OffSet: Integer; RightPart: Buffer; Delimiter: String[2]; WasEmpty: Boolean; Procedure CheckDirective(Where, Len: Integer); Function CmdStr: Buffer; Var S: Buffer; { 2.00D addition } Begin S:=Copy(Line,Where+3,Len-3); if (Length(S) > 2) and (Copy(S, 1, 2) = '^[') then CmdStr:=#27+Copy(S, 3, Length(S)-2) { 2.00D addition } else CmdStr:=S; End; Function CmdVal(OldVal: Integer): Integer; Var I,Temp,Code: Integer; CV: FileName; Begin CV:=CmdStr; FixString(CV); Val(CV,Temp,Code); If Code=0 Then CmdVal:=Temp Else Begin CmdVal:=OldVal; WasCmd:=False; End; End;  Begin { CheckDirective } WasCmd:=False; If Line[Where]='.' Then Begin Cmd:=Copy(Line,Where+1,2); For I:=1 To 2 Do Cmd[I]:=Upcase(Cmd[I]); WasCmd:=True; If Cmd='PL' Then Begin If PageStarted Then NewPage; PageLength:=CmdVal(PageLength); If PageLength<7 Then PageLength:=7; LinesLeft:=PageLength-6; End Else If Cmd='PA' Then NewPage Else If Cmd='CP' Then Begin If LinesLeft':') And (IncludeDrive<>' ') Then IncludeName:=IncludeDrive+':'+IncludeName; If InInclude Then  Line:='-- Illegal nested include of file '+IncludeName+' --' Else Begin Assign(IncludeFile,IncludeName); {$I-} Reset(IncludeFile); {$I+} Ok:=(IOResult=0); If Not Ok Then Line:='-- Include file '+IncludeName+' not found --' Else Begin If PageForIncludes And PageStarted Then NewPage; CurrentInFileName:=InFileName+'-include file '+IncludeName;  WLine(Line); WasCmd:=True; InInclude:=True; CurrentLineNumber:=CurrentLineNumber+1; ListIt(IncludeFile); CurrentLineNumber:=CurrentLineNumber-1;  InInclude:=False; If PageForIncludes And PageStarted Then NewPage; CurrentInFileName:=InFileName; Close(IncludeFile); End; { Else include file was found } End; { Else not currently in include } End; { If include directive } If WasCmd Then Delete(Line,Where-Length(Delimiter),Len+2*Length(Delimiter)); End; { CheckDirective } Begin { ProcessDirectives } WasEmpty:=(Line=''); Where:=1; Repeat Delimiter:=' '; RightPart:=Copy(Line,Where,200); OffSet:=201-Where; Temp:=Pos('{',RightPart); If (Temp<>0) And (Temp0) And (Temp0) And (Temp'%' Then Write(S[I]) Else If S[I+1]='@' Then Begin WriteLn; I:=I+1; End Else If S[I+1]='!' Then Begin HighVideo; { If your screen doesn't have high/low video, } Write(S[I+2]); { replace these 3 lines with: } LowVideo; { Write(S[I+2],')');  } I:=I+2; End Else Write('%'); I:=I+1; End; { While I<=Length(S) } End; { Say } Function AskString(Prompt: Buffer; Param: Buffer): Buffer; Var I: Integer; Skip: Boolean; AS: Buffer; Ch: Char; Begin AS:=Param; WriteLn; Say(Prompt); I:=0; Repeat Skip:=False; Read(Kbd,Ch); Case Ch Of ^H,^S,#127: Begin Skip:=True; If I>0 Then Begin Write(^H,' ',^H); If Ord(AS[I])<32 Then Write(^H,' ',^H); I:=I-1; End; End; ^A,^X: Begin  Skip:=True; While I>0 Do Begin Write(^H,' ',^H); If Ord(AS[I])<32 Then Write(^H' '^H); I:=I-1; End; End; ^D: If Length(AS)>I Then Ch:=AS[I+1] Else Skip:=True; ^F,^R: Begin Skip:=True;  While Length(AS)>I Do Begin I:=I+1; If Ord(AS[I])>31 Then Write(AS[I])  Else Write('^',Chr(Ord(AS[I])+64)); End; End; ^P: Read(Kbd,Ch); ^M: Skip:=True; End; { Case Ch } If Not Skip Then Begin If Ord(Ch)>31 Then Write(Ch)  Else Write('^',Chr(Ord(Ch)+64)); I:=I+1; AS[I]:=Ch; If I>Length(AS) Then AS[0]:=Chr(I); End; Until Skip And (Ch=^M); AS[0]:=Chr(I); AskString:=AS; End; { AskString } Procedure AskInt(Prompt: Buffer; Var Param: Integer); Var Temp: Buffer; P,Legal: Integer; Begin Str(Param,Temp); Temp:=AskString(Prompt,Temp); Val(Temp,P,Legal); If Legal=0 Then Param:=P; End; Procedure Title; Begin ClrScr; HighVideo; WriteLn(CopyrightMessage); { 2.00D change } LowVideo; End; Procedure HardwareMenu; Var Command: Char; ReDraw: Boolean; Begin ReDraw:=True; Repeat If ReDraw Then Begin Title; Say('%@Hardware parameters:%@%@%!Page length: '); WriteLn(PageLength); Say('Line %!Width: '); WriteLn(LineWidth); Say('* %@%!Hilite string: "'+HiLite+'"%@'); Say('%!Lolite string: "'+LoLite+'"%@%@'); Say('%!Initialization string: "'+InitString+'"%@'); Say('%!Exit string: "'+ExitString+'"%@%@'); Say('%!Drive for include files: '+IncludeDrive); If IncludeDrive<>' ' Then Write(':'); Say('%@%@%!Quit%@%@>'); End; { If ReDraw }  Read(Kbd,Command); ReDraw:=True; Case Upcase(Command) Of 'P': AskInt('New page length: ',PageLength); 'W': AskInt('New line width: ',LineWidth); 'H': HiLite:=AskString('New hilite string: ',HiLite);  'L': LoLite:=AskString('New lolite string: ',LoLite); 'I': InitString:=AskString('New printer initialization string: ', InitString); 'E': ExitString:=AskString('New printer exit string: ', ExitString); 'D': Begin Say('%@New drive for include files: '); Read(Kbd,IncludeDrive); If IncludeDrive In ['A'..'Z','a'..'z'] Then  IncludeDrive:=Upcase(IncludeDrive) Else IncludeDrive:=' '; End; Else ReDraw:=False; End; { Case Command } Until Upcase(Command)='Q'; End; { HardwareMenu } Procedure FormatMenu;  Var Command: Char; ReDraw: Boolean; TempBuf: Buffer; Begin ReDraw:=True; Repeat  If ReDraw Then Begin Title; Say('%@Formatting parameters:%@%@Print line %!Numbers: '+  YesNo[LineNumbers]); Say('%@Hilite %!Reserved words: '+YesNo[UpKeys]); Say('%@%!Start a new page for each include file: '+ YesNo[PageForIncludes]); Say('%@%@%!Indent lines by: '); WriteLn(Indent); Say('%@%!Heading: "'+Heading+'"%@'); TempBuf:=PercentExpand(Heading); Say(' Example: "'+TempBuf+'"%@'); Say('%!Footing: "'+Footing+'"%@'); TempBuf:=PercentExpand(Footing); Say(' Example: "'+TempBuf+'"%@'); Say('%@Starting %!Page number: '); WriteLn(CurrentPageNumber);  Say('Starting %!Line number: '); WriteLn(CurrentLineNumber); Say('%@%!Quit%@%@>'); End; { If ReDraw } Read(Kbd,Command); ReDraw:=True; Case Upcase(Command) Of 'N': LineNumbers:=Not LineNumbers; 'R': UpKeys:=Not UpKeys; 'S': PageForIncludes:=Not PageForIncludes; 'I': AskInt('New indent: ',Indent); 'H': Heading:=AskString('New heading: ',Heading); 'F': Footing:=AskString('New footing: ',Footing); 'P': AskInt('Starting page number: ',CurrentPageNumber); 'L': AskInt('Starting line number: ',CurrentLineNumber); Else ReDraw:=False; End; Until Upcase(Command)='Q'; End; { FormatMenu }  Procedure LoadParms; Var PP: Record Case Integer Of 1: (P1000: ParameterRecord); 2: (Parmz: ParameterSet); End; Begin Assign(ParmFile,ParmFileName); {$I-} Reset(ParmFile); {$I+} +  If IOResult<>0 Then ErrorMessage('Parameter file not found') Else Begin Read(ParmFile,PP.P1000);  Parms:=PP.Parmz; Close(ParmFile); If InFileName='' Then InFileName:=SavedInFileName; If (OutFileName='') Or (OutFileName='P') Or (OutFileName='S') Then OutFileName:=SavedOutFileName; End; { Else parameter file was found } End; { LoadParms } Procedure MainMenu; Var Command: Char; ReDraw: Boolean; PP: Record Case Integer Of 1: (P1000: ParameterRecord); 2: (Parmz: ParameterSet); End; Begin If OutFileName='.LIS' Then OutFileName:='P'; CurrentInFileName:=InFileName; ReDraw:=True; Repeat If ReDraw Then Begin Title; Say('%@Main menu%@%@%!Input file: ');  Write(InFileName); Say('%@%!Output file: '); If OutFileName='S' Then Write('The screen') Else If OutFileName='P' Then Write('The printer') Else Write(OutFileName); Say('%@%@%!Load parameter file%@'); Say('%!Save parameter file%@%@'); Say('%!Hardware parameters%@'); Say('%!Formatting parameters%@%@'); Say('%!Time: '); WriteLn(TimeString); Say('%!Date: '); WriteLn(DateString); Say('%@%!Reset line and page numbers%@%@%!Quit%@%!Go%@%@>'); End; { If ReDraw } Read(Kbd,Command); Command:=Upcase(Command); ReDraw:=True; Case Command Of 'I': Begin InFileName:=AskString('Input file name: ',InFileName); If InFileName<>'' Then FixFileName(InFileName,'PAS');  CurrentInFileName:=InFileName; If (IncludeDrive=' ') And (InFileName[2]=':') Then  IncludeDrive:=InFileName[1]; End; 'O': Begin OutFileName:=AskString('Output file name (or S=the screen or P=the printer): ',OutFileName); FixString(OutFileName); If (OutFileName<>'P') And (OutFileName<>'S') Then FixFileName(OutFileName,'LIS'); End;  'T': TimeString:=AskString('Current time: ',TimeString); 'D': DateString:=AskString('Current date: ',DateString);  'L': Begin ParmFileName:=AskString('Parameter file name: ',ParmFileName); FixFileName(ParmFileName,'LTP'); WriteLn(^M,'Parameter file name: ',ParmFileName); LoadParms;  Delay(500); End; 'S': Begin ParmFileName:=AskString('Parameter file name: ',ParmFileName); FixFileName(ParmFileName,'LTP'); WriteLn(^M,'Parameter file name: ',ParmFileName); Assign(ParmFile,ParmFileName); {$I-} Reset(ParmFile); {$I+} Command:='Y'; If IOResult=0 Then Begin Close(ParmFile);  Write('Overwrite (DESTROY) old ',ParmFileName,'? '); ReadLn(Command); Command:=Upcase(, Command); End; If Command='Y' Then Begin Assign(ParmFile,ParmFileName); {$I-} Rewrite(ParmFile); {$I+} If IOResult=0 Then  Begin SavedInFileName:=InFileName; SavedOutFileName:=OutFileName;  FillChar(PP.P1000,1000,0); PP.Parmz:=Parms; Write(ParmFile,PP.P1000);  Close(ParmFile); End { If IOResult=0 } Else ErrorMessage(ParmFileName+' could not be opened.'); End { If Command='Y' } Else Command:=' '; End;  'H': HardwareMenu; 'F': FormatMenu; 'R': Begin CurrentLineNumber:=1;  CurrentPageNumber:=1; End; 'G': If (InFileName='') Or (OutFileName='') Then ErrorMessage('Both input and output filenames must be specified!'); Else ReDraw:=False; End; { Case Command } Until (Command='Q') Or (Command='G'); WriteLn; If Command='Q' Then Halt; End; { MainMenu } Begin { ListTurbo } InFileName:=CommandLineArgument(1); OutFileName:=CommandLineArgument(2); ParmFileName:=CommandLineArgument(3); If InFileName[1]='&' Then Begin CurrentInFileName:=InFileName; { Temporary } InFileName:=OutFileName; OutFileName:=ParmFileName; ParmFileName:=Copy(CurrentInFileName,2,20); End Else If OutFileName[1]='&' Then Begin CurrentInFileName:=OutFileName; { Temporary } OutFileName:=ParmFileName; ParmFileName:=Copy(CurrentInFileName,2,20); End; If ParmFileName[1]='&' Then Delete(ParmFileName,1,1); FixFileName(InFileName,'PAS'); If InFileName='.PAS' Then InFileName:=''; IncludeDrive:=' '; If InFileName[2]=':' Then IncludeDrive:=InFileName[1]; FixString(OutFileName); If (OutFileName<>'S') And (OutFileName<>'P') Then FixFileName(OutFileName,'LIS'); If OutFileName='.LIS' Then OutFileName:=''; FixFileName(ParmFileName,'LTP'); InitParms; If ParmFileName<>'.LTP' Then LoadParms; If OutFileName='' Then OutFileName:='P'; If InFileName='' Then MainMenu Else CommandLineStartup:=True; Repeat Assign(InFile,InFileName); {$I-} Reset(InFile); {$I+} Ok:=(IOResult=0); If Not Ok Then ErrorMessage('File '+InFileName+' does not exist!') Else Begin OutIsDevice:=False; If (OutFileName='S') Or (OutFileName='P') Then Begin OutIsDevice:=True; If OutFileName='S' Then OutFileName:='CON:' Else OutFileName:='LST:'; End; Assign(OutFile,OutFileName); {$I-} Reset(OutFile); Ok:=(IOResult<>0) Or OutIsDevice; Close(OutFile); {$I+} If Not Ok Then Begin Write('File ',OutFileName,' exists. Replace (DESTROY) it (Y/N)? '); ReadLn(Ch);  If UpCase(Ch)='Y' Then Ok:=True; End; If Ok Then Begin Assign(OutFile,OutFileNa- me); {$I-} Rewrite(OutFile); {$I+} Ok:=(IOResult=0); If Not Ok Then ErrorMessage('File '+OutFileName+' could not be created.') Else Begin If OutFileName='LST:' Then Begin  Write('Position printer at top of form and hit return: '); ReadLn; End; Write(OutFile,InitString); LinesLeft:=PageLength-6; CurrentInFileName:=InFileName; ListIt(InFile); If PageStarted Then NewPage; Write(OutFile,ExitString); Close(OutFile);  End; { Else output file was succesfully created } End; { If Ok } End; { Else input file was found }  If OutFileName='LST:' Then OutFileName:='P' Else If OutFileName='CON:' Then OutFileName:='S'; If Not CommandLineStartup Then MainMenu; Until CommandLineStartup; End. { ListTurbo } -------------------------------------------------------------------- LISTT.DOC - Documentation for Turbo Pascal Program Lister  Turbo Pascal Tutor 2.0 Copyright (c) 1984,85,86 by Borland International, INC. -------------------------------------------------------------------- ListT is the replacement for the former Turbo Pascal Program Lister 'TLIST'. We have attempted to make it as flexible and easy to use as possible, but if you want to make improvements, the source code has been included.  There are two ways to start ListT. If you start it by just typing ListT, you will be given a menu that allows you to set various ListT parameters. You must specify at least an input file and an output file. You can also load and save parameter files. All inputs may be edited using a subset of the standard WordStar control characters. You can also start ListT with parameters on the command line. The first parameter is the input file, the second is the output file, and the third is the parameter file. If no parameter file is specified, the defaults are used. If no output file is specified, output is sent to the printer. To specify a parameter file with no input or output file names, use the form &. Examples: A>LISTT test s parms -- list TEST.PAS to the screen using PARMS.LTP A>LISTT test.inc -- list TEST.INC to the printer using defaults A>LISTT &parms -- read in PARMS.LTP and use the input and output files specified in it  Your program files may contain dot-commands that change the values of ListT parameters. These are specified by placing comments of the form {.xx} in the program text. The commands are: {.PLnn} Set the page length to nn lines per page and start a new page. The default is 66. {.POnn} Indent by nn characters. The default is 0. This should only be  used if the printer prints off the left edge of the paper. {.LWnn} Set the printer's line width to nn. The default is 79, as some printers will start a new line after receiving the 80 characters on a line. This leaves a blank line on the page and makes ListT lose track of where the next page starts. {.PA} Start a new . page. {.CPnn} Start a new page if there are less than nn lines left on this page. {.HEtext} Set the page heading to "text". Special % sequences are provided (see below). The default is "Listing of %F, page %# at %T %D" {.FOtext} Set the page footing to "text". The default is "%F page %#" {.HItext} Set the hilight string to "text". The default is nothing. {.LOtext} Set the lolight string to "text". The default is nothing. If both of these are set, and keyword hilight mode is on, keywords will be hilighted with these sequences. You could specify, for instance, the sequences that cause your printer to turn underlining on and off. {.PRtext} Print "text". This may be used to turn on special printing modes, such as 132 column compressed mode on 80 column (11") printers. {.L-} Don't list the following lines. {.L+} Start listing again. This is the default. {.U+} Start hilighting keywords. Keywords will be converted to upper case if no hi/lolight strings are specified. {.U-} Stop hilighting keywords.  This is the default. {.N+} Start numbering lines on the listing. {.N-} Stop numbering lines. This is the default.  {.P+} Start a new page for each include file {.P-} Don't start a new page for each include file {$Ifile} Include file "file" in listing (like the compiler) Unrecognized or illegal dot-commands will be printed, but legal ones will not show up in the listing, though they will still be counted for line numbers. Dot-commands should be closed, i.e. if you want to make a comment about the dot-command, use something like {.PA} { Start a new page }. Include files may not be nested and other text on a line which has an include directive on it may not print correctly. The heading and footing may contain one of the following characters preceded by a '%' to indicate certain special strings: # = the current page number T = the current system time (read from the system clock on MS/PC-DOS, D = the current system date entered manually on CP/M-80/86) F = the name of the file being listed (and the current include file name) < = left-justify this heading/footing  > = right-justify this heading/footing [ = left-justify on odd pages, right-justify on even pages ] = right-justify on odd pages, left-justify on even pages any other character = that character (for example, "%%" becomes "%") Thus {.he%<Page #%# of "%F" at %T, %D} could produce the heading of Page #17 of "PROGRAM.PAS" at 03:27pm, 10/03/84 If neither %< nor %> is specified, the heading or footing is centered. Summary of default settings of directives: Page length {.PL66} Indent {.PO0} Line width {.LW79} Header {.HEListing of %F, page %# at %T %D} Footer  {.FO%F page %#} Hilite string {.HI} Lolite string {.LO} List on/off {.L+} Keyword hilite {.U-} Line numbers {.N-} Page for includes {.P-} -------------------------------------------------------------------- å/ BO< > ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą Bƒ- -  ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą Bƒ- -  ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą BƒC D  ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %0 F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą BƒC D  ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą BƒC D  ListiListing of %F, page %# at %T %D$Š&_‰‡wžvč½t č üŠ_X¢vˆ&_*ĢčWžÉułĆčėUŠNōƒķ ÉuéĘčįQU‹Nü‹nžčŗQ ķuo€>#rMč}čIč-€># s €>#u čŌRčė`€>#uŠ&)žĢ°±č9øž čėF€># %F page %# %F page %#)čŒ”)čįø˜'čšė čtčqč¼č“€>2tčCč„YžÉtč9éh’]ƒķŠFMöF€tłžČuõYžÉtčé@’č&]‹Fš Ąt č‘‹Fņč}‹Fųé“÷n t ‹Föčpø$(čƀ>#t€>#r €>#wč†6€># s€>#u€>żuč.PAS.P.PASčĀP.LIS čVčP.LIS¬čą { -------------------------------------------------------------------- MANUAL.PAS - Example programs from the manual Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. -------------------------------------------------------------------- This file contains source code for every complete example in the Turbo Tutor. In addition, we have included other routines of interest from the manual to save you some typing. To run any of the examples in this file: 1.1  Load Turbo Pascal and specify MANUAL.PAS as your work file. 2. Mark a block that contains the program you wish to run (to mark a block, press F7 at the beginning of the first line of the program, then move the cursor below the last line of the program and press F8). 3. Write the block to a temporary test file, TEST.PAS, by typing ^K^W. 4. Exit the editor (^K^D), type "W" and specify TEST as your work file. 5. Type "R" to run the program, "E" to edit it. For more information on manipulating blocks of text, please refer to your Turbo Pascal Reference Manual. } ================================== CHAPTER 6 =================================== program MyName; begin ClrScr; Writeln('Hello world, my name is _________________') end. ================================== CHAPTER 7 =================================== program calculate; begin Writeln( 4 * 6 / 2 + 3 ); end. ------------------------------------------------------------------------------- program Simple; { This is the Program Heading.} { A simple Pascal program to display the sum of two numbers. DATE: 17 June 1986 AUTHOR: put your name here } { This is the beginning of the Declaration Part of the program, where our identifiers are declared. } const YourName = 'Friend'; { This is a string constant used in the greeting message. Change to contain your name if you'd like. } var A,B,C : integer; { This is the beginning of the Statement Part of the program. It contains statements -- the parts of a Pascal program that tell the computer what to do. } begin { Main body of program Simple } { Start by greeting the user. As in our very first program, we use a Writeln ("Write Line") statement to write a line to the terminal. } Writeln('Hello, ', YourName, '.'); { Note that the Writeln statement can take a LIST  of things to write on a line, as well as just one thing. In the statement above, we wrote three things: the constant string 'Hello, ', the value of the constant identifier YourName (another string), and a period (a character constant). } { We now write a string to the terminal asking the user for an integer. A message like this one, which requests a response of some kind, is often called a "prompt." } Writeln('Please type an integer, followed by a return.'); Readln(A); { Wait for the user to type a number, then place that number in the variable A. "Readln," which is read as "Read Line," tells the computer to wait for the carriage return key to be pressed before assuming that the number is complete. } { Repeat the two steps above for a second number: } Writeln('Now please type another integer, followed ', 'by a carriage return.'); { Prompt for another number } Readln(B); { Read the number and place it in the variable B. } C := A + B; { Add A and B and place the result in the variable C. } Writeln('The sum of the two integers is: ', C) { Write a line containing a message and the value of the variable C. }  { Putting an identifier (here, C) in the list of things that a Writeln statement is to write causes its VALUE to b2 e written, rather than its name. If we wanted to just print the letter C, we would enclose it in single quotes as we did with the period in the first Writeln statement. } end. { of program Simple } ================================== CHAPTER 9 =================================== program truncate; const a = 123456789012345.0; begin Writeln(a); end. ================================== CHAPTER 10 ================================== program Day_Of_Week_Example; type Days = (Monday,Tuesday,Wednesday,Thursday, Friday,Saturday,Sunday); var DayOfWeek : Days; begin DayOfWeek := Thursday; { ... } if DayOfWeek = Saturday then Writeln('It''s Saturday. Why are you at work?'); { ... } end. ================================== CHAPTER 11 ================================== program WaitForkey; { Program to wait for a key to be struck on the keyboard } {$R+,C-} { Range-checking on; Ctrl-C breaks off } begin Write('Waiting for a keystroke');  { Announce that we're waiting } while not KeyPressed do { Write dots continuously until a key is hit. } Write('.'); { KeyPressed is a Turbo Pascal function } { that returns TRUE only after a key has been struck. } end. ------------------------------------------------------------------------------- program GuessingGame; {$R+}  { Turn range checking on } const Answer = 3; { For the purposes of this demonstration, let's make the required answer 3 always. } var Guess : integer; begin Writeln('In this program, you will guess an integer ',  'from 1 to 10.'); repeat Writeln('You have not guessed the number yet.'); Write('Type an integer from 1 to 10 as your guess: '); Readln(Guess); until Guess = Answer; end. ------------------------------------------------------------------------------- {$C-} program Whoops; var i : integer; begin i := 1; repeat if (i MOD 3) = 0 then  { If this is true, i is evenly divisible by 3 } begin Writeln(i); {Write i out} i := Succ(i); {Increment i by 1} end until (i = 20) or KeyPressed; { we'll also quit if a key is pressed... } end. ================================== CHAPTER 12 ================================== program Sample; const Ten = 10; var NewNumber, Index : integer;  procedure GetNumber; { Get a number from the user and store } { it in the global variable NewNumber } const Minimum = 0; Maximum = 25; type Response = Minimum..Maximum; { type for a legal response } var Temporary : Response;  { temporary place for user's integer } begin { Statement Part of procedure GetNumber } Writeln('Please enter an integer from ', Minimum, ' to ', Maximum, ': '); Readln(Temporary); while (Temporary < Minimum) or (Temporary > Maximum) do  begin Writeln('The integer you have entered is not between 0 and 25, '); Writeln('inclusive. Please try again.');  Readln(Temporary); end; NewNumber := Temporary; end; { procedure GetNumber } begin { Statement Part of program Sample - the code has been changed from that in the book to make it a little more useful } for Index := 1 to Ten do 3 begin GetNumber; case NewNumber of 0: Writeln('You have selected option 0'); { ... } { You can add your own routines here } 25: Writeln('This is option 25: '); end; { case } end; end. { of program Sample } ------------------------------------------------------------------------------- program A; const { These are the "global" identifiers of program A.} J = 1; {They are visible everywhere within the program,} K = 2; {unless hidden by local symbols with the same name.} var R, S : integer; procedure B; const L = K; { L is defined to be 2 (NOT 3!) } K = 3; { K is now defined locally to be 3, "hiding" the K defined in A } begin { Statement Part of procedure B } { Within the Statement Part of procedure B, the following identifiers are visible: identifier | defined in ---------- + ---------- B, J, R, S | A K, L | B The local constant L derives its value from the  GLOBAL constant K, not the local one, since the global identifier was not yet "hidden" when L was defined. Note that there is no identifier A visible. Turbo Pascal, unlike most other compilers, ignores the program heading entirely,  including the program name. } end; { procedure B } var T, U: integer; { These identifiers are not visible  within procedure B! } procedure C; var V : integer; procedure D; { local to procedure C } var R, T : integer; { These declarations "hide" the R and T declared in A } begin { Statement Part of procedure D } { Within the Statement Part of procedure D, the following identifiers are visible: identifier | defined in ---------------- + ---------- B, C, J, K, S, U | A D, V | C R, T | D Note that the constant K is seen as having the value 2 here, since the local K (with a value of 3) defined in B is visible only there. } end; var B : integer; { This declaration "hides" procedure B within the Statement Part of procedure C. However, procedure B is still callable from procedure D, and this integer is  not visible to D. } begin { Statement Part of procedure C } { Within the Statement Part of procedure C, the following identifiers are visible: identifier | defined in -------------------- + ---------- C, J, K, R, S, T, U | A B, D, V | C } end; { procedure C } begin { program A } { Within the Statement Part of program A, the following identifiers are visible: identifier | defined in ---------------------- + ---------- B, C, J, K, R, S, T, U | A } end. { program A } ------------------------------------------------------------------------------- program Scope2; var A : integer; procedure SetA; var A : integer; begin { Statement Part of procedure SetA } A := 4 end; { procedure SetA } begin { Statement Part of program Scope2 } A := 3; SetA;  Writeln(A) end. { program Scope2 } ------------------------------------------------------------------------------- proce4 dure GetNumber (var NewNumber : integer); { Get a number from the user and return it in the variable parameter NewNumber. } const Minimum = 0; Maximum = 25; type Response = Minimum..Maximum; { A type for a legal response } var Temporary : Response; { A temporary place for the user's integer } begin { Statement Part of procedure GetNumber } Writeln('Please enter an integer from ', Minimum, ' to ', Maximum, ': '); Readln(Temporary); while (Temporary < Minimum) or (Temporary > Maximum) do begin Writeln('The integer you have entered is not ', 'between 0 and 25,');  Writeln('inclusive. Please try again.'); Readln(Temporary); end; NewNumber := Temporary; end; { procedure GetNumber } ------------------------------------------------------------------------------- procedure ISqrt(Value : integer; var Root : integer); var OddSeq, Square : integer; begin { procedure ISqrt } OddSeq := -1; Square := 0; repeat OddSeq := OddSeq + 2; Square := Square + OddSeq until Value < Square; Root := Succ(OddSeq DIV 2); if Value <= Square - Root then Root := Pred(Root) end; { procedure ISqrt } ------------------------------------------------------------------------------- function ISqrt(Value : integer) : integer; var OddSeq,Square,Root : integer; begin { Statement Part of function ISqrt } OddSeq := -1; Square := 0; repeat OddSeq := OddSeq + 2; Square := Square + OddSeq until Value < Square; Root := Succ(OddSeq DIV 2); if Value <= Square - Root then Root := Pred(Root) ISqrt := Root { The value is returned by assigning to the function name as if it were a variable } end; { function ISqrt } ------------------------------------------------------------------------------- function Factorial(N : byte) : Real; begin { function Factorial } if N <= 1 then Factorial := 1 { If N <= 1, no recursion occurs. } else Factorial := N * Factorial(N - 1) { Here is the statement that causes the recursion! } end; ------------------------------------------------------------------------------- program Example; var Alpha : integer; procedure Test1(var A : integer); begin { procedure Test1 } A := A-1; if A > 0 then Test2(A) Writeln(A); end; { procedure Test1 } procedure Test2(var A : integer); begin { procedure Test2 } A := A DIV 2; if A > 0 then Test1(A) Writeln(A); end; { procedure Test2 } begin { Statement Part of program Example } Alpha := 15; Test1(Alpha) end. { program Example } ------------------------------------------------------------------------------- function RunningTotal : Real; var Subtotal, NewNumber : Real; begin  Subtotal := 0.0; repeat Write ('Enter a number to be added to the total: '); Readln (NewNumber); if NewNumber <> -1.0 then { Only add if number is not -1 } Subtotal := Subtotal + NewNumber; until NewNumber = -1.0; { Exit the loop if number is -1 } RunningTotal := Subtotal; end; ------------------------------------------------------------------------------- function RunningTotal : Real; var Subtotal, NewNumber : Real; begin Subtotal := 0.0; repeat 5  Write ('Enter a number to be added to the total: '); Readln (NewNumber); if NewNumber = -1.0 then begin RunningTotal := Subtotal; { Set the function result and exit } Exit; { right here! } end until false; { Since we exit the loop from the middle, we'll never want the "until" to be satisfied } end;  ================================== CHAPTER 14 ================================== program LengthTest; type SmallStr = string[15]; var Test : SmallStr; procedure ShowLength(St : SmallStr); { Write out a string and its length } begin Writeln('The Length of "',St,'" is ',Length(St)) end; { procedure ShowLength } begin Test := 'hello, there'; ShowLength(Test); Test := 'hi'; ShowLength(Test); Test := ''; { This is null string--it has a length of 0.} ShowLength(Test) end. { program LengthTest } ------------------------------------------------------------------------------- procedure GetWord(var Line, Word : BigStr); { Get the next word from the string Line } const Space = ' '; var Len : integer; begin  while Pos(Space,Line) = 1 do { remove leading blanks } Delete(Line,1,1); Len := Pos(Space,Line) - 1; { look for blank } if Len = 0 then begin { no blanks left } Word := Line; { get word might be null string if none left } Line := '' { now make line the null string } end else begin  { get word and delete from line } Word := Copy(Line,1,Len); { get all but blank } Delete(Line,1,Len + 1)  { delete word plus blank } end end; { procedure GetWord } ------------------------------------------------------------------------------- procedure Replace(var Line : BigStr; Token,Sub : TokStr); { Look for Token in Line and replace with Sub } var Index,Len : integer; begin repeat Index := Pos(Token,Line); if Index > 0 then begin Delete(Line,Index,Length(Token)); Insert(Sub,Line,Index) end until Index = 0 end; { procedure Replace } ------------------------------------------------------------------------------- program PrintASCII; {Print the characters for all the ASCII codes, 0 to 255.} var i : integer; begin for i := 0 to 255 do Writeln(i, ' --> ', Chr(i)); end. ------------------------------------------------------------------------------- program MisMatch; var Token : string[15]; Len : integer; begin Token := 'this string'; Len := Token[0]; { The compiler will indicate an error here.} Writeln('The Length of Token is ',Len) end. ------------------------------------------------------------------------------- type Maxstring = string[255]; procedure UpperCase(var Str : Maxstring); var Index : integer; begin for Index := 1 to Length(Str[0]) do Str[Index] := UpCase(Str[Index]) end; { procedure UpperCase} ================================== CHAPTER 16 ================================== program charTest; {$V-} { to avoid any problems passing strings } type CharSet = set of char; Prompt = string[80]; var Cmd : char; procedure Getchar(var Ch : char; Msg : Prom6 pt; OKSet : CharSet); { Write a message, then get a character from the user. Ignore any character that is not in the set OKSet. } begin Write(Msg); repeat Read(KBD,Ch); { read the character from the keyboard, but do not echo it } Ch := UpCase(Ch) { force Ch to be upper case } until Ch in OKSet; Writeln(Ch) end; { procedure GetChar } begin { Statement Part of program charTest } repeat Getchar(Cmd,'CharTest> S)peak, C)ount, Q)uit: ', ['S','C','Q']); case Cmd of 'S' : Writeln('Woof! Woof!'); 'C' : Writeln('1, 2, 3, 4, 5, 6, 7, 8, 9, 10') end until Cmd = 'Q' end. { program charTest } ------------------------------------------------------------------------------- program EqualityTest; var Set1 : set of char; Set2 : set of 'a'..'x'; begin Set2 := ['a', 'b', 'g'..'w']; Set1 := Set2; Writeln(Set1 = Set2); end.  ================================== CHAPTER 17 ================================== type CheckNumType = 1..1000; MonthType = (January, February, March, April, May, June, July, August, September, October, November, December);  DayType = 1..31; YearType = 1980..2000; PayeeType = string[40]; CheckPointer = ^Check; { This definition is allowed to precede the definition of the type Check. } Check = record CheckNumber : CheckNumType; Amt : real; Month : MonthType; Day : DayType;  Year : YearType; Payee : PayeeType; NextCheck : CheckPointer; end; function FindCheck (Num: CheckNumType; FirstCheck : CheckPointer) : CheckPointer; { Given Num, the number of a check, and FirstCheck, a pointer to the first of a linked list of checks, return a pointer to the first check found on that list with the given number. If no check with that number is found, return nil. } begin { FindCheck } FindCheck := nil; { Start by assuming failure. } while FirstCheck <> nil do { Stop if end of list } if FirstCheck^.CheckNum = Num then { Check found? }  begin FindCheck := FirstCheck; { If so, set the function } Exit { result and exit from the } { routine right away } end else FirstCheck := FirstCheck^.NextCheck; { Number doesn't match; point to next check, if any. Note that since FirstCheck is not a var parameter, we only change our local copy. } end; { FindCheck } ------------------------------------------------------------------------------- program WriteFree; { Write the amount of available heap space. The result is given in bytes for a CP/M system, and in paragraphs (blocks of 16 bytes) for a 16-bit system. } var TrueFree : Real; begin TrueFree := MaxAvail; { convert to real value } if TrueFree < 0.0 then TrueFree := TrueFree + 65536.0; Writeln('Space available: ',TrueFree:7:0) end. ================================== CHAPTER 18 ================================== program FormatDemo; begin Writeln(7 Pi); { The predefined constant } Writeln(Pi:8); { Pi = 3.1415926535 } Writeln(-Pi:8); Writeln(Pi:12); Writeln(Pi:16); Writeln(Pi:20); Writeln(Pi:8:0); Writeln(Pi:8:4); Writeln(Pi:12:10) end. ------------------------------------------------------------------------------- program FileTest; var MyFile : text; { The text file we'll use } Line : string[255]; { A string to hold a line we read from the file } LineCounter : integer; { A counter for the lines we read } I : integer; { A counter for writing numbers to the file } begin { program FileTest } Assign(MyFile, 'MYFILE.TXT'); { The Assign procedure associates a file ^ ^ variable inside your program with a | | file on the disk in the outside world. A file variable | The names can be completely different; A Pascal string giving the name of the disk file, however, must the name of a file on be legal for the operating system you the disk are using.  } Rewrite(MyFile); { The Rewrite procedure "opens" a file ^  that you intend to write to. If there | was already a file on the disk having  A file variable the name given in the Assign statement, it is destroyed.  } Writeln(MyFile, 'Hello, World!'); { Write some text to the file } Writeln(MyFile, 'This is my first file!'); for I := 1 to 10 do { Write some integers to the file } Writeln(MyFile, i:2); Writeln(MyFile, '---end of file---'); { Write one more line of text } Reset(MyFile); { The Reset procedure "opens" a file that ^ you intend to read from. Note that since |  the name associated with MyFile is still A file variable the same, we don't need to call Assign again. If the file was already open, Reset closes it and re-opens it for reading. } LineCounter := 0; { We'll count the lines and display a line number with each one. } while not EOF(MyFile) do { The built-in function Eof returns True } begin { if the end of a file has been reached. } LineCounter := LineCounter + 1; { Count the next line } Readln(MyFile, Line);  { Read it into the variable Line } Writeln('Line ', LineCounter:2, ' ---> ', Line); { Write it to  the screen } end; Close(MyFile); { The Close procedure "closes" a file ^  after you have finished using it. When | you close a text file you have just A file variable written, Close will put a ^Z (end-of-file mark) on 8 the end of the file. You must always close your files after using them,  or other programs may not be able to read or write them.  } end. ------------------------------------------------------------------------------- type CheckNumType = 1..10000; MonthType = (January, February, March, April, May, June, July, August, September, October, November, December); DayType = 1..31; YearType = 1980..2000; PayeeType = string[40]; Check = record CheckNum : CheckNumType; Amt : Real; Month : MonthType; Day : DayType; Year : YearType; Payee : PayeeType; end;  var CheckFile : file of Check; { Keep check info in a file } ThisCheck : Check; { A variable to hold a record read from the file } procedure MakeCheckFile; var CheckNumber : CheckNumType; MonthNumber : 1..12; begin Assign(CheckFile, 'CHKBOOK.DAT'); { Associate a name with the file } Rewrite(CheckFile);  { Open it as a new file } CheckNumber := 1; { Start with check #1 } with ThisCheck do repeat { Start our input loop here } Writeln('Enter information for check #', CheckNumber, ': '); Write('Amount (< 0 to Exit): ');  { Get amount of check } Readln(Amt); if Amt < 0 then { User is done if amt is negative } begin  Close(CheckFile); { Always close the file!!! } Exit; { This is the one way to exit from the procedure } end; Write('Month (1-12): '); { Get month by number, then convert } Readln(MonthNumber); Month := MonthType(MonthNumber - 1); { When the name of a scalar type is used as if it were a function, and applied to a value of another scalar type, the result is a value of the first type with the same ordinal value. Here, we convert  1 -> January (ordinal value 0), 2 -> February, etc. This conversion process is called "type conversion."  } Write('Day (1-31): '); Readln(Day); Write('Year (1980 - 2000): '); Readln(Year);  Write('Payee (40 characters max): '); Buflen := 40; { Buflen is a predeclared variable in Turbo Pascal that determines the maximum number of characters that will be accepted from the user the next time information is input from the terminal. It is reset to the default of 127 after every read. By using Buflen, we make sure the user cannot type more characters than we can handle! } Readln(Payee); Write(CheckFile, ThisCheck); { Got all the information--write it out } CheckNumber := Succ(CheckNumber); until false; { We'll always exit from the middle of the loop } end; ------------------------------------------------------------------------------- {$C- } procedure CheckCommand; var Cmd : char; begin if KeyPressed then begin Read(KBD,Cmd); { read key w/out echo } Cmd := UpCase(Cmd); { force to upper case } case Cmd of { ... } { handle commands } else W9 rite(Chr(7)); { beep at illegal cmd } end { case } end { ifs } end; { procedure CheckCommand } ------------------------------------------------------------------------------- program MyProgram; { ... } var IOErr : boolean; { ... } type Prompt = string[80]; { ... } procedure Error(Msg : Prompt); { Write error Msg out on line 24 and wait for a key } var Ch : char; begin GoToXY(1,24); ClrEOL; Write(^G,Msg, 'Hit any key to continue') Read(KBD,Ch) end; { procedure Error } procedure IOCheck; { Check for I/O error; print message if needed } var IOCode : integer; begin IOCode := IOresult; IOErr := (IOCode <> 0); if IOErr then begin case IOCode of $01 : Error('File does not exist'); $02 : Error('File not open for Input'); $03 : Error('File not open for Output'); $04 : Error('File not open'); $10 : Error('Error in numeric format'); $20 : Error('Operation not allowed on logical device'); $21 : Error('Not allowed in direct mode'); $22 : Error('Assign to standard files not allowed'); $90 : Error('Record Length mismatch'); $91 : Error('Seek beyond end-of-file'); $99 : Error('Unexpected end-of-file'); $F0 : Error('Disk Write error'); $F1 : Error('Directory is full'); $F2 : Error('File size overflow'); $F3 : Error('Too many open files'); $FF : Error('File disappeared') else Error('Unknown I/O error: '); Write(IOCode:3)  end { case } end end; { procedure IOCheck } ================================== CHAPTER 20 ================================== program LinkedLists; type NodePtr = ^Node; Node = record Data : integer; Next : NodePtr  end; var Header : NodePtr; { ... } begin { main body of program LinkedList } New(Header); with Header^ do begin Data := 0; Next := nil end; { ... } end. { of program LinkedList } ------------------------------------------------------------------------------- type NodePtr = ^Node; Node = record Data : integer; Next : NodePtr end; var StackPtr : NodePtr; { Header for stack } StackEmpty : boolean; { flag for empty stack } procedure CreateStack; begin New(StackPtr); with StackPtr^ do begin Next := nil; Data := 0; end; StackEmpty := true; end; { of proc CreateStack } procedure Pop(var Val : integer); var NPtr : NodePtr; begin if not StackEmpty then begin NPtr := StackPtr^.Next; StackPtr^.Next := NPtr^.Next; Val := NPtr^.Data Dispose(NPtr); StackEmpty := (StackPtr^.Next = nil); end; end; { of proc Pop } procedure Push(Val : integer); var NPtr : NodePtr; begin StackEmpty := false; New(NPtr); NPtr^.Data := Val; NPtr^.Next := StackPtr^.Next; StackPtr^.Next := NPtr; end;  { of proc Push } procedure DeleteStack; var TVal : integer; begin while not StackEmpty do Pop(TVal); Dispose(StackPtr); end; { of proc DeleteStack } ------------------------------------------------------------------------------- type NodePtr = ^Node; Node = record Data : integer; Last,Next: NodePtr end; var Header : NodePtr; :  { Header for stack } QueueEmpty : boolean; { flag for empty stack } procedure CreateQueue; begin New(Header); with Header^ do begin Next := Header; Last := Header; Data := 0; end; QueueEmpty := true; end; { of proc CreateQueue } procedure GetVal(var Val : integer); var NPtr : NodePtr; begin if not QueueEmpty then begin NPtr := Header^.Next; Header^.Next := NPtr^.Next; Header^.Next^.Last := Header; Val := NPtr^.Data; Dispose(NPtr); QueueEmpty := (Header^.Next = Header); end end; { of proc Pop } procedure PutVal(Val : integer); var NPtr : NodePtr; begin QueueEmpty := false; New(NPtr); with NPtr^ do begin Data := Val; Next := Header; Last := Header^.Last; end; Header^.Last := NPtr; NPtr^.Last^.Next := NPtr; end; { of proc PutVal } procedure DeleteQueue; var TVal : integer; begin while not QueueEmpty do GetVal(TVal); Dispose(Header); end; { of proc DeleteQueue } ------------------------------------------------------------------------------- const Front = true; Rear = false; type NodePtr = ^Node; Node = record Data : integer; Last,Next: NodePtr end; var Header : NodePtr; { Header for stack } DequeEmpty : boolean; { flag for empty stack } procedure CreateDeque; begin New(Header); with Header^ do begin Next := Header; Last := Header; Data := 0 end; DequeEmpty := true; end; { of proc CreateDeque } procedure InsertNode(var NPtr,TPtr : NodePtr); begin NPtr^.Next := TPtr^.Next; NPtr^.Last := TPtr; TPtr^.Next := NPtr; NPtr^.Next^.Last := NPtr; end; { of proc InsertNode } procedure RemoveNode(var NPtr,TPtr : NodePtr); var TPtr : NodePtr; begin NPtr := TPtr; NPtr^.Next^.Last := NPtr^.Last; NPtr^.Last^.Next := NPtr^.Next; end; { of proc RemoveNode } procedure GetValue(var Val : integer; theFront : boolean); var NPtr : NodePtr; begin  if not DequeEmpty then begin if theFront then RemoveNode(NPtr,Header^.Next) else RemoveNode(NPtr,Header^.Last);  Val := NPtr^.Data; Dispose(NPtr); DequeEmpty = (Header^.Next = Header); end; end; { of proc Pop } procedure PutVal(Val : integer; theFront : boolean); var NPtr : NodePtr; begin DequeEmpty := false; New(NPtr); NPtr^.Data := Val; if theFront then InsertNode(NPtr,Header) else InsertNode(NPtr,Header^.Last); end; { of proc PutVal } procedure DeleteDeque; var TVal : integer; begin while not DequeEmpty do GetVal(TVal,Front); Dispose(Header); end; { of proc DeleteDeque } ================================== CHAPTER 21 ================================== type NodePtr  = ^Node; Node = record Data : integer; Left,Right : NodePtr end; function FoundInTree(var TPtr,Parent : NodePtr; Val : integer) : boolean; var Found : boolean; begin TPtr := Root; Parent := nil; Found := false; while (TPtr <> nil) and not Found do with TPtr^ do begin if Data = Val  then Found := True else begin Parent := TPtr; if Data > Val then TPtr := Left else TP; tr := Right; end; end; FoundInTree := Found; end; { of func FoundInTree } ------------------------------------------------------------------------------- procedure AddToTree(Val : integer); var TPtr,Parent,NPtr : NodePtr; Done  : boolean; begin if not FoundInTree(TPtr,Parent,Val) then begin if GetNode(NPtr) then begin  NPtr^.Data := Val; if Root = nil then Root := NPtr else with Parent^ do if Data > Val then Left := NPtr else Right := NPtr; end; end; end; { of proc AddToTree } ------------------------------------------------------------------------------- procedure WriteData(Data : integer; var Row,Col : byte); begin GoToXY(Col,Row); Write(Data:9); Row := Row + 1; end; { of proc WriteData } procedure PreOrder(Node : NodePtr; var Row,Col : byte);  begin if Node <> nil then with Node^ do begin WriteData(Data,Row,Col); PreOrder(Left,Row,Col); PreOrder(Right,Row,Col); end; end; { of proc PreOrder } procedure InOrder(Node : NodePtr; var Row,Col : byte); begin if Node <> nil then with Node^ do begin InOrder(Left,Row,Col); WriteData(Data,Row,Col); InOrder(Right,Row,Col); end end; { of proc InOrder } procedure PostOrder(Node : NodePtr; var Row,Col : byte); begin if Node <> nil then with Node^ do begin PostOrder(Left,Row,Col); PostOrder(Right,Row,Col); WriteData(Data,Row,Col); end; end; { of proc PostOrder } -------------------------------------------------------------------------------  procedure PruneTree(var TPtr : NodePtr); begin if TPtr <> nil then with TPtr^ do begin PruneTree(Left); PruneTree(Right); if (Left = nil) and (Right = nil) then begin Dispose(TPtr); TPtr := nil; end; end; end; { of proc PruneTree } ------------------------------------------------------------------------------- Node = record  Next,Last : NodePtr; case Header : boolean of false : ( Val : integer; X,Y  : ARange); true : ( XVal : integer; Up,Down : NodePtr) end; function NodeFound(TX,TY : integer; var TPtr : NodePtr) : boolean; var Found : boolean; begin TPtr := theHead^.Up; Found := false; while (TPtr^.XVal < TX) and (TPtr <> theHead) do TPtr := TPtr^.Up; if TPtr^.XVal = TX then begin TPtr := TPtr^.Next; while (TPtr^.Y < TY) and not TPtr^.Header do TPtr := TPtr^.Next; Found := (TPtr^.Y = TY);  end; NodeFound := Found; end; { of func NodeFound } ------------------------------------------------------------------------------- var Header : array[ARange] of NodePtr; function NodeFound(TX,TY : integer; var TPtr : NodePtr) : boolean; var Done : boolean; begin TPtr := Header[TX]; NodeFound := false; if TPtr <> nil then begin Done := false; repeat if (TPtr^.Y >= TY) then Done := True else TPtr := TPtr^.Next until Done or (TPtr = nil); if Done then NodeFound := (TPtr^.Y = TY); end; end; { of func NodeFound } ==========================< ======== CHAPTER 22 ================================== procedure InsertSort(ListMax : integer); { purpose: sort list using insertion algorithm } var Indx,Jndx,Val : integer; begin for Indx := 2 to ListMax do begin Val := List[Indx]; Jndx := Indx; while List[Jndx-1] > Val do begin List[Jndx] := List[Jndx-1]; Jndx := Jndx - 1 end; List[Jndx] := Val end end; { of proc InsertSort } ------------------------------------------------------------------------------- procedure ShellSort; { purpose: sort list using shell algorithm } label ExitLoop; var Indx,Jndx,Val,Inc : integer; begin Inc := 1; repeat Inc := 3*Inc + 1 until Inc > ListMax; repeat Inc := Inc DIV 3; for Indx := Inc+1 to ListMax do begin Val := List[Indx]; Jndx := Indx; while List[Jndx-Inc] > Val do begin List[Jndx] := List[Jndx-Inc]; Jndx := Jndx - Inc; if Jndx <= Inc then goto ExitLoop end; ExitLoop: List[Jndx] := Val end until Inc = 1 end; { of proc ShellSort } ------------------------------------------------------------------------------- function Partition(Left,Right : integer) : integer; { partition list into two sublists } var Val,Indx,Jndx,Temp : integer; begin Val := List[Right]; Indx := Left - 1; Jndx := Right; repeat repeat Indx := Indx + 1 until List[Indx] >= Val; repeat Jndx := Jndx - 1 until List[Jndx] <= Val; Temp := List[Indx];  List[Indx] := List[Jndx]; List[Jndx] := Temp until Jndx <= Indx; List[Jndx] := List[Indx]; List[Indx] := List[Right]; List[Right] := Temp; Partition := Indx end; { of func Partition } procedure QuickSort(Left,Right : integer); { recursive implementation of Quicksort } var Indx : integer; begin { main body of proc QuickSort } if Left <= Right then begin Indx := Partition(Left,Right); QuickSort(Left,Indx-1); QuickSort(Indx+1,Right) end end; { of proc QuickSort } ------------------------------------------------------------------------------- procedure QuickSort; { non-recursive implementation of Quicksort } var Left,Right,Indx : integer; Done : boolean; begin Left := 1; Right := ListMax; ClearStack; Done := false; repeat if Left <= Right then begin Indx := Partition(Left,Right);  if (Indx-Left) > (Right-Indx) then begin Push(Left); Push(Indx-1); Left := Indx + 1 end else begin Push(Indx+1); Push(Right); Right := Indx -1 end; end else if not StackEmpty then begin  Pop(Right); Pop(Left) end else Done := True until Done end; { of proc QuickSort } ------------------------------------------------------------------------------- function Found(Val : integer; var Indx : integer) : boolean; var Flag : boolean; begin Flag := false; Indx := 1; while not Flag and (Indx <= ListMax) do if List[Indx] = Val  then Flag := True else Indx := Indx + 1; Found := Flag end; { of func Found } ------------------------------------------------------------------------------- function Found(Val : integer; var Indx : integer) : boolean; var Done =  : boolean; begin Found := false; Done := false; Indx := 1; while not Done and (Indx <= ListMax) do if List[Indx] = Val then begin Done := true; Found := True end else if List[Indx] > Val then Done := True  else Indx := Indx + 1 end; { of func Found } ------------------------------------------------------------------------------- function BFound(Val : integer; var Indx : integer) : boolean; var Left,Right : integer; begin Left := 1; Right := ListMax; repeat Indx := (Left+Right) SHR 1; { = div 2 } if Value < List[Indx] then Right := Indx - 1  else Left := Indx + 1 until (Value = List[Indx]) or (Left > Right); BFound := (Left <= Right) end; { of func BFound } ================================== CHAPTER 23 ================================== type FileStr : string[80]; { ... } procedure ChainTo(FileName : FileStr; var IOCode : integer); var CFile : file; begin Assign(CFile,FileName); {$I-}  Chain(CFile); {$I+} IOCode := IOResult end; { of proc ChainTo } ================================== CHAPTER 24 ================================== program TCDemo; procedure Recurse; const A : integer = 0; var B : integer; begin B := A; A := Succ(A); { We can assign to A as if it were an integer variable } if A < 10 then Recurse; Writeln (A:3, B:3); end; { Recurse } begin { TCDemo } Recurse; end. { TCDemo } ------------------------------------------------------------------------------- program CounterDemo; var I : integer; procedure Counter; const Count : integer = 0; begin Writeln (Count); Count := Succ(Count); end; begin { CounterDemo } for I := 1 to 10 do Counter; end. { CounterDemo } ================================== CHAPTER 25 ================================== program Spaghetti; label One, Two, Three, Four; var A : integer; begin A := 0; One: if A > 3 then goto Three; Two: A := A + 5; goto Four; Three: A := A + 3; goto Two; Four: if A MOD 3 <> 0 then goto One; Writeln(A); end. ================================== CHAPTER 26 ================================== procedure TrimTrailing(var AnyString); var Len : byte absolute AnyString; { The variable Len overlays the length byte of AnyString } St : string[255] absolute AnyString; { The variable St overlays all of AnyString, and perhaps other things. This is OK, since only the  length byte is changed. } begin { TrimTrailing } while (Len > 0) and (St[Len] = ' ') do { If St ends with ' ' }  Len := Pred(Len); { Decrement its length } end; { TrimTrailing } ------------------------------------------------------------------------------- procedure SwapVars(var Var1, Var2; Size : integer); type BigArray = array [1..MaxInt] of byte; var V1 : BigArray absolute Var1; { Treat Var1 and Var2 like large } V2 : BigArray absolute Var2; { arrays of bytes for this move } Count : integer; { Count of bytes moved } Tmp : byte;  { Temporary place to keep byte } begin { SwapVars } for Count := 1 to Size do begin { for } Tmp := V1[> Count]; { Save original byte from V1 } V1[Count] := V2[Count]; { Move value to V1 from V2 }  V2[Count] := Tmp; { Move to V2 from original V1 } end;{ for } end; { SwapVars } ================================== CHAPTER 28 ================================== procedure VInLine(var Value : integer); { A simple use of inline code. Note that some constants have been defined and used, while other values are left as literal hexadecimal constants. This is done just for illustration. The following routine example divides an integer by 2 and discards the remainder. } const CLC = $F8; INC_DI = $47; begin inline ($C4/$BE/VALUE/ { LES DI,VALUE[BP] } CLC/ { CLC } $26/$D0/$1D) { RCR ES:WORD PTR [DI] } end; { VInLine } ------------------------------------------------------------------------------- program InterruptHandler; { ... } const DataSave : integer = 0; { a typed constant that will hold the value of DS. It is located in the code segment so it is accessible by the ISR. Please note: Variables that are NOT global to the program or local to the interrupt service routine (ISR) may NOT be accessed by the ISR. } { ... } {$K-} { IMPORTANT: Always turn off stack checking before an ISR } procedure TurboISR; begin { ISR Entry code:  The interrupt service routine must save the contents of all registers that may be used in the compiled code of  the body of the ISR } inline($50/ { PUSH AX }  $53/ { PUSH BX } $51/ { PUSH CX }  $52/ { PUSH DX } $57/ { PUSH DI }  $56/ { PUSH SI } $13/ { PUSH DS }  $06/ { PUSH ES } $FB/ { STI Enable other interrupts }  { The following instructions are only necessary if the ISR needs to access global variables } $2E/ $A1/ DataSave/ { MOV AX,CS:[DataSave] this instruction moves the value of DS for this Turbo program accessed by a typed constant (since a code segment variable  is always accessible) } $8E/$D8); { MOV DS,AX Now DS has the segment value  for this program } { ... Pascal source body of the ISR ... } { ISR Exit code: The previous contents of the register are restored as well as the restore of the SP and BP that were automatically pushed by Turbo at the start of the procedure. } inline($07/ { POP ES } $1F/ { POP DS } $5E/ { POP SI } $5F/ { POP DI } $5A/ { PO? P DX } $59/ { POP CX } $5B/ { POP BX } $58/ { POP AX } $8B/$ED/ { MOV SP,BP } $5D/ { POP BP } $CF); { IRET }{ Return to the interrupted program } end; {$K+} { Okay to restore stack checking after an ISR } { ... other declarations... } begin { Main } DataSave := DSeg; { Stores the value of DS into DataSave, which will make the value accessible to the interrupt service routine } { ... other statements ... } end. åå{ -------------------------------------------------------------------- TBOMOUSE.PAS - Library of Microsoft mouse routines Turbo Pascal Tutor 2.0 Copyright (c) 1986 by Borland International, INC. -------------------------------------------------------------------- This file contains a library of useful routines for using the Microsoft Mouse from within a Turbo Pascal program. } type RegisterSet = record AX, BX, CX, DX, BP, DI, SI, DS, ES, Flags: integer;  end; const MouseInt = $33; function MouseInstalled : boolean; { Reset mouse and see if mouse is installed - this function will return true if the mouse is installed, false otherwise. } var Reg : RegisterSet; begin with Reg do  begin AX := 0; Intr(MouseInt, Reg); MouseInstalled := boolean(AX); end; { with } end; procedure ShowCursor; { Displays the mouse cursor on the screen } var Reg : RegisterSet; begin Reg.AX := 1; Intr(MouseInt, Reg); end; procedure HideCursor; { Hides the mouse cursor } var Reg : RegisterSet; begin Reg.AX := 2; Intr(MouseInt, Reg); end;  procedure GetMouse(var X, Y, Button : integer); { Finds the mouse position and button status } var Reg : RegisterSet; begin with Reg do begin AX := 3; Intr(MouseInt, Reg); Button := BX; X := CX; Y := DX; end; { with } end; procedure SetMouse(X, Y : integer); { Moves the cursor to the specified X and Y position } var Reg : RegisterSet; begin with Reg do begin AX := 4; CX := X; DX := Y; Intr(MouseInt, Reg); end; end; procedure GetButtonPress(Button : integer; var ButtonStatus, Count : integer; var LastX, LastY : Integer); var Reg : RegisterSet; { For a selected button, this procedure finds the button status, the count of button presses since the last call to this function, and the X and Y positions of the cursor at the last press of the button. } begin with Reg do begin AX := 5; BX := Button; Intr(MouseInt, Reg); ButtonStatus := AX; Count := BX; LastX := CX; LastY := DX; end; { with } end; procedure GetButtonRelease(Button : integer; var ButtonStatus, Count : integer@ ; var LastX, LastY : integer); { For a selected button, this procedure finds the button status, the count of  button releases since the last call to this function, and the X and Y positions of the cursor at the last release of the button. } var Reg : RegisterSet; begin with Reg do begin AX := 6; BX := Button; Intr(MouseInt, Reg);  ButtonStatus := AX; Count := BX; LastX := CX; LastY := DX; end; { with } end; procedure SetMinMaxX(Min, Max : integer); { Sets the minimum and maximum horizontal cursor positions on the screen } var Reg : RegisterSet; begin with Reg do begin AX := 7; CX := Min; DX := Max; Intr(MouseInt, Reg); end; { with } end; procedure SetMinMaxY(Min, Max : integer); { Sets the minimum and maximum vertical cursor positions on the screen } var Reg : RegisterSet;  begin with Reg do begin AX := 8; CX := Min; DX := Max; Intr(MouseInt, Reg); end; end; procedure SetTextCursor(CursorType, AttrScanStart, AttrScanEnd : integer); { Selects the software or hardware text cursor. If the software text cursor is selected, the character attributes of the cursor when in text mode are defined. If the hardware text cursor is selected, the first and last scan lines of the cursor are defined. } var Reg : RegisterSet; begin with Reg do begin AX := 10; BX := CursorType; CX := AttrScanStart; DX := AttrScanEnd; Intr(MouseInt, Reg); end; { with } end; procedure GetMickeyCount(var X, Y : integer); { Finds the horizontal and vertical mickey count since the last call to this function. } var Reg : RegisterSet; begin with Reg do begin AX := 11; Intr(MouseInt, Reg); X := CX; Y := DX; end; { with } end; procedure SetMickeyRatio(Rx, Ry : integer); { Sets the mickey to pixel ratio } var Reg : RegisterSet; begin with Reg do begin AX := 15; CX := Rx; DX := Ry; Intr(MouseInt, Reg); end; { with } end; åååååååååA ååååååååååååååååååååååååååB ååååååååååååååååååååååååååC ååååååååååååååååååååååååååD ååååååååååååååååååååååååååE ååååååååååååååååååååååååååF ååååååååååååååååååååååååååG ååååååååååååååååååååååååååH ååååååååååååååååååååååååååI ååååååååååååååååååååååååååJ ååååååååååååååååååååååååååK ååååååååååååååååååååååååååL åååååååååååååååååååååååååå