IMD 1.16: 29/05/2007 12:23:32 FOGCPM.028 --FOGCPM028SLIST PAS^ SLIST1 INC4SLIST2 INC+SLIST3 INC, !SYSCONSTCON"SYSTYPE TYP#SYSVAR VAR$CENTER FNC %&CPM PRC"'()*+CRT PRC,-DISKFILEFNC.HEXTOCHRFNC /0LCRJUST FNC 12LST PRC3MANYCHARFNC4REPLACE FNC 56SAYBOOL FNC7SQUEEZE FNC 89SYSINIT PRC :;TRIM FNC <=WAIT PRC>FOGSTORECOM]?@ABCDEFGHIJFOGSTOREDOC0KLMNOPFOGSTOREPAS+QRSTUVMONEY2 COMvWXYZ[\]^_`abcdeMONEY2 DOCfghMONEY2 PAS\ijklmnopqrstSORTS COM`uvwxyz{|}~SORTS DOCSORTS PASqPICTURE DOC0PICTURE PAS GETPIC FNCESAYPIC FNCE-02-00 86 -CPM028 DOCThis is the disk name. {.L+ } program SList; (*************************************************) (* SLIST Version 1.00A - CP/M, Z80 *) (* *) (* (C) Copyright 1985, Herb Bowie. *) (* All commercial rights reserved. This *) (* program is licensed for non-commercial use. *) (* *) (* Have you payed for this program yet? If not, *) (* and you find it useful, then may I suggest *) (* that you make a small donation to its author? *) (* Something like $10 would be wonderful. You *) (* may send it to: *) (* *) (* Herb Bowie *) (* P.O. Box 4724 *) (* Culver City, CA 90231-4724 *) (* *) (*************************************************) (* NAME Slist.Pas AUTHOR Herb Bowie. FUNCTION Prints Turbo Pascal source code, and/or documentation. *) type {$I A:SysType.Typ } const {$I A:SysConst.Con } PIi = 1; PTi = 2; HEi = 3; FOi = 4; SXi = 5; FFi = 6; BEi = 7; CMi = 8; CCi = 9; SQi = 10; ICi = 11; PLi = 12; LLi = 13; POi = 14; MTi = 15; HMi = 16; MBi = 17; FMi = 18; MaxCodes = 24; ReservedWords = 148; CRTRows : integer = 24; CRTColumns : integer = 52; First : boolean = true; FilePic : string [14] = 'F:FFFFFFFF.FFF'; InName : string [14] = 'A:.PAS'; ErrorMsg : string [80] = ''; IdStartChars : set of char = ['A'..'Z', '_']; IdChars : set of char = ['0'..'9', 'A'..'Z', '_']; type String2 = string [2]; String10 = string [10]; String14 = string [14]; String23 = string [23]; String128 = string [128]; CodeIndexType = 1..MaxCodes; RsvWordIndexType = 1..ReservedWords; var {$I A:SysVar.Var } CtrlFile : text; ListFile : text; InFile : text; IncFile : text; SXFile : text; RsvFile : text; InRec : string [135]; WorkLine : string [192]; Word : string [128]; OutLine : string [192]; TempLine : string [192]; LastName : string [14]; IncName : string [14]; SXName : string [14]; SXString : string [133]; PageStr : string [5]; CommentValue : string [128]; NextChar : char; CurrChar : char; LastChar : char; WorkBool : char; SXDrive : char; SXOption : char; LastLine : integer; BCount : integer; KCount : integer; PageCt : integer; LineCt : integer; NextSeqCt : integer; SeqCt : integer; SeqCtWritten : integer; InLng : integer; DataLng : integer; PrefixLng : integer; CI : integer; LastCI : integer; CurrCI : integer; NextCI : integer; I, J : integer; IncStart : integer; RsvIndex : integer; CRTLine : integer; AnotherFile : boolean; SXOpen : boolean; LineToPrint : boolean; PrintingLines : boolean; FormatOnLine : boolean; OldLineDone : boolean; IncOn : boolean; PageBegun : boolean; RsvLoaded : boolean; CodeWork : String [2]; CodeNumber : integer; CodeNum : CodeIndexType; CodeIndex : CodeIndexType; Code : array [CodeIndexType] of String2; CodeType : array [CodeIndexType] of char; CodeDesc : array [CodeIndexType] of String23; CodeMaxLng : array [CodeIndexType] of integer; CodeInt : array [CodeIndexType] of integer; CodeStr : array [1..4] of String128; CodeBool : array [CodeIndexType] of boolean; RsvPtr : array [1..26] of integer; ReservedWord : array [RsvWordIndexType] of String10; {$I A:Center.Fnc } {$I A:CPM.Prc } {$I A:CRT.Prc } {$I A:DiskFile.Fnc } {$I A:HexToChr.Fnc } {$I A:LCRJust.Fnc } {$I A:LST.Prc } {$I A:ManyChar.Fnc } {$I A:Replace.Fnc } {$I A:Squeeze.Fnc } {$I A:SysInit.Prc } {$I A:SayBool.Fnc } {$I A:Trim.Fnc } {$I A:Wait.Prc } {$I A:GetPic.Fnc } {$I A:SayPic.Fnc } procedure WriteMsg; (* Writes message at bottom of screen *) begin gotoxy (1, CRTRows); clreol; if ErrorMsg <> '' then begin CRTBeep; write (Center (ErrorMsg, CRTColumns)); end; end; procedure Clean; (* Clears screen and positions cursor *) begin clrscr; writeln ('SLIST Turbo Pascal Source Lister ', InName); WriteMsg; gotoxy (1, 3); end; procedure WriteSeqCt; begin gotoxy (3, CRTLine); write (NextSeqCt:5); SeqCtWritten := NextSeqCt; end; procedure WriteFileLine (FileName: String14); begin if CRTLine > 5 then WriteSeqCt; if (CRTLine < (CRTRows - 2)) then CRTLine := CRTLine + 1 else begin gotoxy (1, 5); delline; end; WriteSeqCt; write (' ', FileName); end; {$I B:SLIST1.INC } {$I B:SLIST2.INC } {$I B:SLIST3.INC } procedure SXRef; type DataItemType = record Seq : integer; Word : string [64]; end; var DataItem : DataItemType; SortResult: integer; ItemSize : integer; SortInCt : integer; SortOutCt : integer; LastSortCt: integer; ValCode : integer; WordLength: integer; {$I B:Sort.Box } procedure Inp; begin reset (SXFile); SortInCt := 0; LastSortCt := 0; gotoxy (1, 8); write (' Records released to Sort'); while not eof (SXFile) do begin readln (SXFile, SXString); val (squeeze (copy (SXString, 1, 5), Blank),  DataItem.Seq, ValCode); if ValCode > 0 then DataItem.Seq := 0; WordLength := length (SXString) - 6; if WordLength > 64 then WordLength := 64; DataItem.Word := copy (SXString, 7, WordLength); SortRelease (DataItem); SortInCt := succ (SortInCt); if SortInCt > (LastSortCt + 9) then begin gotoxy (1, 8); write (SortInCt: 5); LastSortCt := SortInCt; end; end; gotoxy (1, 8); write (SortInCt:5); close (SXFile); gotoxy (1, 10); writeln ('Sorting file now...'); end; function Less; var Rec1 : DataItemType absolute X; Rec2 : DataItemType absolute Y; begin Less := ((Rec1.Word < Rec2.Word) or ((Rec1.Word = Rec2.Word) and (Rec1.Seq < Rec2.Seq))); end; procedure OutP; var SaveCodeBoolCMi : boolean; SaveCodeBoolBEi : boolean; SaveCodeBoolSQi : boolean; LastWord : string [64]; SeqStr : string [6]; procedure PutSXLine; begin if length (OutLine) > 0 then begin OutLine := ManyChar (blank, CodeInt [POi]) + OutLine; PutLine; end; end; begin EndPage; SaveCodeBoolCMi := CodeBool [CMi]; SaveCodeBoolBEi := CodeBool [BEi]; SaveCodeBoolSQi := CodeBool [SQi]; CodeBool [CMi] := false; CodeBool [BEi] := false; CodeBool [SQi] := false; Compute; LineCt := 99; LastWord := ''; OutLine := ''; SortOutCt := 0; LastSortCt := 0; gotoxy (1, 12); write (' Records returned from Sort'); while not SortEOS do begin SortReturn (DataItem); if DataItem.Word <> LastWord then begin PutSXLine; OutLine := DataItem.Word; while ((length (OutLine) < 32) or (((length (OutLine) - 32) mod 6) > 0)) do OutLine := OutLine + '.'; LastWord := DataItem.Word; end; if length (OutLine) = 0 then OutLine := ManyChar (Blank, 32); str (DataItem.Seq:6, SeqStr); OutLine := OutLine + SeqStr; if (length (OutLine) + 6) > DataLng then begin PutSXLine; OutLine := ''; end; SortOutCt := succ (SortOutCt); if SortOutCt > (LastSortCt + 9) then begin gotoxy (1, 12); write (SortOutCt:5); LastSortCt := SortOutCt; end; end; gotoxy (1, 12); write (SortOutCt:5); PutSXLine; CodeBool [CMi] := SaveCodeBoolCMi; CodeBool [BEi] := SaveCodeBoolBEi; CodeBool [SQi] := SaveCodeBoolSQi; end; begin Clean; writeln ('Insert a sort work disk in the SLIST drive,'); writeln ('if extra sort work space is needed.'); writeln; Wait; writeln; NewDisks;  ItemSize := SizeOf (DataItem); SortResult := TurboSort (ItemSize); writeln; writeln; if SortResult = 0 then erase (SXFile) else begin writeln ('*** Unsuccessful Sort: ', SortResult, ' ***'); Wait; writeln; end; writeln ('Remove sort work disk now, and replace SLIST disk,'); writeln ('if sort work disk inserted earlier.'); writeln; Wait; NewDisks; end; begin SysInit; LoadCodes; RsvLoaded := false; repeat GetInFile; if AnotherFile then begin GetOptions; Compute; assign (ListFile, 'LST:'); reset (ListFile); assign (SXFile, SXName); SXOpen := false; LineCt := 99; PageCt := 0; SeqCt := 0; NextSeqCt := 0; KCount := 0; BCount := 0; PrintingLines := true; LineToPrint := false; PageBegun := false; Clean; writeln ('Make Sure Printer Is Ready.'); Wait; CsrUp (2);  clreol; writeln; clreol; gotoxy (1, 3); writeln ('Printing...'); write (ListFile, HexToChr (CodeStr [PIi])); LSTLngth (CodeInt [LLi]); if SXOption <> 'R' then begin assign (InFile, InName); if SXOption in ['A', 'U'] then begin rewrite (SXFile); SXOpen := true; if ((SXOption = 'U') and (not RsvLoaded)) then begin assign (RsvFile, 'A:SLISTRSV.DAT'); reset (RsvFile); for RsvIndex := 1 to ReservedWords do begin readln (RsvFile, ReservedWord [RsvIndex]); if ((RsvIndex = 1) or (ReservedWord [RsvIndex] [1] <> ReservedWord [RsvIndex - 1] [1])) then RsvPtr [ord (ReservedWord [RsvIndex] [1]) - 64] := RsvIndex; end; close (RsvFile); RsvLoaded := true; end; end; reset (InFile); IncOn := false; CRTLine := 4; WriteFileLine (InName); CurrChar := Blank; NextChar := Blank; OldLineDone := true; GetChar; GetChar; while CurrChar <> EndFile do ProcWord; PrintLine; WriteSeqCt; end; if SXOpen then begin close (SXFile); SXOpen := false; end; if SXOption in ['A', 'R', 'U'] then SXRef; EndPage; write (ListFile, HexToChr (CodeStr [PTi])); end; (* if AnotherFile *) until not AnotherFile; clrscr; writeln ('Thanks for using Singular Software!'); end. rvedWord [RsvIndex - 1] [1])) then RsvPtr [ord (ReservedWord [RsvIndex] [1]) - 64] := RsvIndex; end; close (RsvFile); RsvLoaded := true; end; end; reprocedure WriteCode; begin CRTLine := CodeIndex + 2; gotoxy (1, CRTLine); clreol; write (Code [CodeIndex]); gotoxy (3, CRTLine); write (' - ', CodeDesc [CodeIndex]); gotoxy (29, CRTLine); write (' = '); case CodeType [CodeIndex] of 'B': writeln (SayBool (CodeBool [CodeIndex])); 'I': writeln (CodeInt [CodeIndex]:3); 'S': writeln (CodeStr [CodeIndex]); end; end; procedure LoadCodes; begin assign (CtrlFile, 'SLISTCTL.DAT'); reset (CtrlFile); CodeIndex := 0; while not eof(CtrlFile) do begin CodeIndex := succ (CodeIndex); readln (CtrlFile, Code [CodeIndex]); readln (CtrlFile, CodeDesc [CodeIndex]); readln (CtrlFile, CodeType [CodeIndex]); readln (CtrlFile, CodeMaxLng [CodeIndex]); case CodeType [CodeIndex] of 'B': begin readln (CtrlFile, WorkBool); if WorkBool = 'Y' then CodeBool [CodeIndex] := true else CodeBool [CodeIndex] := false; end; 'I': begin readln (CtrlFile, CodeInt [CodeIndex]); CodeStr [CodeIndex] := ''; end; 'S': begin CodeInt [CodeIndex] := 0; readln (CtrlFile, CodeStr [CodeIndex]); end; end; (* Case *) end; (* While *) close (CtrlFile); CodeNum := CodeIndex; end; (* Procedure *) procedure CopyRight; begin writeln ('*************************************************'); writeln ('* SLIST Version 1.00A - CP/M, Z80 *'); writeln ('* *'); writeln ('* (C) Copyright 1985, Herb Bowie. *'); writeln ('* All commercial rights reserved. This *'); writeln ('* program is licensed for non-commercial use. *'); writeln ('* *'); writeln ('* Have you payed for this program yet? If not, *'); writeln ('* and you find it useful, then may I suggest *'); writeln ('* that you make a small donation to its author? *'); writeln ('* Something like $10 would be wonderful. You *'); writeln ('* may send it to: *'); writeln ('* Herb Bowie *'); writeln ('* P.O. Box 4724 *'); writeln ('* Culver City, CA 90231-4724 *'); writeln ('*************************************************'); end; (* GET-IN-FILE Proc: When program is first run will check for a file name passed by CP/M, and will try to open that file. If no name is passed, will ask operator for a file name to open. Proc will tell operator if file doesn't exist, and will allow multiple retrys. On 2nd and later executions, proc will not check for CP/M passed file name. In all cases, proc will assume a file type of .PAS if file type is not specified. PROGRAM EXIT from this proc when a null string is entered in response to a file name request. *) procedure GetInFile; (* Gets input file name *) var Parm : string[14] absolute $81; (* Passed file name, if any *) ParmLth : byte absolute $80; (* CP/M passed length of parm *) Existing: boolean; procedure GetInName; begin LastName := InName; if (ParmLth in [1..14]) and First then begin InName := Copy (Parm,1,ParmLth - 1); if pos (':', InName) = 0 then InName := 'A:' + InName; if pos ('.', InName) = 0 then InName := InName + '.PAS'; end else begin Clean; writeln; writeln; CopyRight; CsrUp (18); write ('Enter File Name or RETURN to Exit: '); InName := SayPic (InName, FilePic); write (InName); CsrLeft (14); InName := Squeeze (GetPic (InName, FilePic), Blank); end; First := false; AnotherFile := not (LastName = InName); end; begin repeat GetInName; if AnotherFile then begin Existing := DiskFile (InName); if Existing then ErrorMsg := '' else ErrorMsg := '*** FILE DOES NOT EXIST ***'; end; until (not AnotherFile) or Existing; end; (* GetOptions procedure gives user a chance to modify the default run options. *) procedure GetOptions; var C : char; WorkValue: string [80]; WorkPic : string [80]; MaxLng : integer; R : integer; begin Clean; for CodeIndex := 1 to CodeNum do WriteCode; writeln; repeat WriteMsg; gotoxy (1, CodeNum + 4); clreol; gotoxy (1, CodeNum + 5); clreol; gotoxy (1, CodeNum + 4); write ('Enter Code to modify, or blank to end: '); CodeWork := GetPic (' ', '!!'); writeln; ErrorMsg := ''; if CodeWork <> ' ' then begin CodeIndex := 1; while (CodeIndex <= CodeNum) and (Code [CodeIndex] <> CodeWork) do CodeIndex := succ (CodeIndex); if CodeIndex > CodeNum then ErrorMsg := '*** INVALID SELECTION ***' else begin MaxLng := CodeMaxLng [CodeIndex]; case CodeType [CodeIndex] of 'B': CodeBool [CodeIndex] := not CodeBool [CodeIndex]; 'I': begin str (CodeInt [CodeIndex]:5, WorkValue); WorkPic := ManyChar ('9', MaxLng); WorkValue := SayPic (WorkValue, WorkPic); write ('Enter new value: ', WorkValue); CsrLeft (MaxLng); WorkValue := GetPic (WorkValue, WorkPic); val (WorkValue, CodeInt [CodeIndex], R); end; 'S': begin if MaxLng > 5 then WorkPic := ManyChar ('X', MaxLng)  else WorkPic := ManyChar ('!', MaxLng); WorkValue := SayPic (CodeStr [CodeIndex], WorkPic); write ('Enter new value: ', WorkValue); CsrLeft (MaxLng); CodeStr [CodeIndex] := GetPic (WorkValue, WorkPic); end; end; (* of case *) WriteCode; end; (* valid work code *) end; (*non-blank work code *) until CodeWork = ' '; end;  str (CodeInt [CodeIndex]:5, WorkValue); WorkPic := ManyChar ('9', MaxLng); WorkValue := SayPic (WorkValue, WorkPic); write ('Enter new value: ', WorkValue); CsrLeft (MaxLng); WorkValue := GetPic (WorkValue, WorkPic); val (WorkValue, CodeInt [CodeIndex], R); end; 'S': begin if MaxLng > 5 then WorkPic := ManyChar ('X', MaxLng)  procedure Compute; begin LastLine := CodeInt [PLi] - CodeInt [MBi]; if CodeInt [PLi] = 0 then LastLine := 0; DataLng := CodeInt [LLi] - CodeInt [POi]; if CodeBool [CMi] then DataLng := DataLng - 2; if CodeBool [BEi] then DataLng := DataLng - 3; if CodeBool [SQi] then DataLng := DataLng - 6; PrefixLng := CodeInt [LLi] - DataLng; if length (CodeStr [SXi]) < 1 then SXOption := 'N' else SXOption := CodeStr [SXi] [1]; if length (CodeStr [SXi]) < 2 then SXDrive := 'A' else SXDrive := CodeStr [SXi] [2]; SXName := SXDrive + ':SXREF.DAT'; end; procedure SkipLine (X: integer); (* Puts X blank lines to output file *) begin while X > 0 do begin writeln (ListFile); X := pred (X); end; end; procedure StartPage; begin PageCt := succ (PageCt); LineCt := 1; SkipLine (CodeInt [MTi] - 1 - CodeInt [HMi]); WorkLine := Replace (CodeStr [HEi], '@', InName); str (PageCt, PageStr); WorkLine := Replace (WorkLine, '#', PageStr); WorkLine := Trim (WorkLine); WorkLine := LCRJust (WorkLine, DataLng); write (ListFile, ManyChar (Blank, CodeInt [POi])); if CodeBool [CMi] then write (ListFile, 'C '); if CodeBool [BEi] then write (ListFile, 'BE '); if CodeBool [SQi] then write (ListFile, ' SEQ '); writeln (ListFile, WorkLine); SkipLine (CodeInt [HMi]); LineCt := CodeInt [MTi]; PageBegun := true; end; procedure EndPage; begin if PageBegun then begin SkipLine (CodeInt [PLi] - LineCt - CodeInt [MBi] + CodeInt [FMi]); WorkLine := Replace (CodeStr [FOi], '@', InName); WorkLine := Replace (WorkLine, '#', PageStr); WorkLine := LCRJust (WorkLine, DataLng); write (ListFile, ManyChar (Blank, CodeInt [POi])); if CodeBool [CMi] then write (ListFile, ' '); if CodeBool [BEi] then write (ListFile, '  '); if CodeBool [SQi] then write (ListFile, ' '); writeln (ListFile, WorkLine); LineCt := succ (LineCt); if CodeBool [FFi] then write (ListFile, FF) else SkipLine (CodeInt [PLi] - LineCt); PageBegun := false; end; end; procedure PutLine; begin if (LastLine > 0) and (LineCt >= LastLine) then begin EndPage; StartPage; end; LineCt := succ (LineCt); writeln (ListFile, OutLine); end; procedure PrintLine; var WorkStr : string [6]; begin if (LineToPrint and PrintingLines and ((CodeBool [CCi]) or (not FormatOnLine))) then begin TempLine := ManyChar (Blank, CodeInt [POi]); if CodeBool [CMi] then begin if KCount > 0 then WorkStr := '*' else WorkStr := Blank; TempLine := TempLine + WorkStr + Blank; end; if CodeBool [BEi] then begin str (BCount:2, WorkStr); TempLine := TempLine + WorkStr + Blank; end; if CodeBool [SQi] then begin str (SeqCt:5, WorkStr); TempLine := TempLine + WorkStr; if IncOn then TempLine := TempLine + '+' else TempLine := TempLine + blank; end; TempLine := TempLine + InRec; J := PrefixLng + 1; while ((J <= length (TempLine)) and (TempLine [J] = Blank)) do J := succ (J); if J > length (TempLine) then J := PrefixLng + 1; J := succ (J); while length (TempLine) > CodeInt [LLi] do begin I := CodeInt [LLi]; while ((I > PrefixLng) and (TempLine [I] <> Blank)) do I := pred (I); if I = PrefixLng then I := CodeInt [LLi]; OutLine := copy (TempLine, 1, I); PutLine; delete (TempLine, 1, I); TempLine := ManyChar (Blank, J) + TempLine; end; OutLine := TempLine; PutLine; end; LineToPrint := false; end; procedure GetLine; begin PrintLine; FormatOnLine := false; if IncOn then if eof (IncFile) then begin IncOn := false; close (IncFile); WriteFileLine (InName); end else begin readln (IncFile, InRec); LineToPrint := true; end; if not IncOn then begin if eof (InFile) then begin InRec := EndFile; end else begin readln (InFile, InRec); LineToPrint := true; end; end; NextSeqCt := succ (NextSeqCt); if (NextSeqCt > (SeqCtWritten + 10)) then WriteSeqCt; InLng := length (InRec); CI := 1; end; procedure GetChar; begin LastChar := CurrChar; CurrChar := NextChar; LastCI := CurrCI; CurrCI := NextCI; SeqCt := NextSeqCt; if OldLineDone then begin GetLine; OldLineDone := false; end; NextCI := CI; if CI > InLng then begin if CurrChar = EndFile then NextChar := EndFile else NextChar := Blank; OldLineDone := true; end else begin NextChar := upcase (InRec [CI]); CI := succ (CI); end; end; hen begin if eof (InFile) then begin InRec := EndFile; end else begin readln (InFile, InRec); LineToPrint := true; end; end; NextSeqCt := succ (NextSeqCt); if (NextSeqCt > (SeqCtWritten + 10)) then WriteSeqCt; InLng := length (InRec); CI := 1; end; procedure GetChar; begin LastChar := CurrChar; CurrChar := NextChar; LastCI := CurrCI; CurrCI := NextCI; SeqCt := NextSeqCt; if OldLineDone then begin GetLine; OldLineDone := false; end; NextCI := Cprocedure SkipBlanks; begin while CurrChar = Blank do GetChar; end; procedure GetCommentValue; begin SkipBlanks; CommentValue := ''; while KCount > 0 do begin if CurrChar = '}' then KCount := 0 else if ((CurrChar = '*') and (NextChar = ')')) then begin KCount := 0; GetChar; end else begin if length (CommentValue) < 128 then CommentValue := CommentValue + CurrChar; GetChar; end; end; end; procedure ProcDirective; begin GetChar; if ((CurrChar = 'I') and (not (NextChar in ['+', '-'])) and (IncStart >= CodeInt [ICi])) then begin GetChar; GetCommentValue; IncName := Squeeze (CommentValue, Blank); if (pos (':', IncName) = 0) then IncName := 'A:' + IncName; if (pos ('.', IncName) = 0) then IncName := IncName + '.PAS'; WriteFileLine (IncName); if DiskFile (IncName) then begin PrintLine; IncOn := true; assign (IncFile, IncName); reset (IncFile); end else begin write (' *** FILE NOT FOUND ***'); WriteFileLine (InName); end; end else GetCommentValue; end; procedure GetCodeNumber; var X, Y, Z: integer; begin X := 1; while ((X <= length (CommentValue)) and (not (CommentValue [X] in ['0'..'9']))) do X := succ (X); Y := X; while ((Y <= length (CommentValue)) and (CommentValue [Y] in ['0'..'9'])) do X := succ (X); if Y = X then CodeNumber := 0 else val (copy (CommentValue, X, Y - X), CodeNumber, Z); end; procedure ProcFormat; begin FormatOnLine := true; GetChar; CodeWork := ''; if CurrChar in ['A'..'Z'] then begin CodeWork := CurrChar; GetChar; if CurrChar in ['A'..'Z', '+', '-'] then begin C odeWork := CodeWork + CurrChar; GetChar; end; end; GetCommentValue; if CodeWork = 'PA' then LineCt := LastLine + 1 else if CodeWork = 'CP' then begin GetCodeNumber; if (LineCt + CodeNumber) >= LastLine then LineCt := LastLine + 1; end else if CodeWork = 'L-' then PrintingLines := false else if CodeWork = 'L+' then PrintingLines := true else begin CodeIndex := 1; while ((CodeIndex <= CodeNum) and (Code [CodeIndex] <> CodeWork)) do CodeIndex := succ (CodeIndex); if CodeIndex <= CodeNum then begin case CodeType [CodeIndex] of 'B': begin if length (CommentValue) = 0 then CodeBool [CodeIndex] := not CodeBool [CodeIndex] else if CommentValue [1] in ['T', 'Y', '+'] then CodeBool [CodeIndex] := true else  if CommentValue [1] in ['F', 'N', '-'] then CodeBool [CodeIndex] := false else CodeBool [CodeIndex] := not CodeBool [CodeIndex]; end; 'I': begin GetCodeNumber; CodeInt [CodeIndex] := CodeNumber; end; 'S': CodeStr [CodeIndex] := CommentValue; end; (* of case CodeType *) end; (* of CodeIndex <= CodeNum *) end; (* of if CodeWork else *) Compute; end; procedure ProcComment; begin KCount := 1; if CurrChar = '*' then IncStart := LastCI else IncStart := CurrCI; GetChar; case CurrChar of '$': ProcDirective; '.': ProcFormat; else GetCommentValue; end; GetChar; end; procedure ProcStrLit; begin repeat GetChar; if ((CurrChar = Quote) and (NextChar = Quote)) then begin GetChar; GetChar; end until CurrChar = Quote; GetChar; end; procedure GetWord; begin Word := CurrChar; GetChar; if Word [1] in IdStartChars then begin while CurrChar in IdChars do begin Word := Word + CurrChar; GetChar; end; end; end; procedure ProcWord; begin SkipBlanks; if CurrChar = '(' then GetChar; if (((LastChar = '(') and (CurrChar = '*')) or (CurrChar = '{')) then ProcComment else if CurrChar = Quote then begin ProcStrLit; end else if CurrChar <> EndFile then begin GetWord; if ((SXOpen) and (Word [1] in IDStartChars)) then begin if ((SXOption = 'A') or (Word [1] = '_') or (length (Word) > 10)) then writeln (SXFile, SeqCt:5, ',', Word) else begin RsvIndex := RsvPtr [ord (Word [1]) - 64]; while ((RsvIndex <= 144) and (Word > ReservedWord [RsvIndex])) do RsvIndex := succ (RsvIndex); if Word <> ReservedWord [RsvIndex] then writeln (SXFile, SeqCt:5, ',', Word); end; end; if ((Word = 'BEGIN') or (Word = 'CASE')) then BCount := succ (BCount) else if Word = 'END' then if BCount > 0 then BCount := pred (BCount); end; end;  if CurrChar = Quote then begin ProcStrLit; end else if CurrChar <> EndFile then begin GetWord; if ((SXOpen) and (Word [1] in IDStartChars)) then begin if ((SXOption = 'A') or (Word [1] = '_') or (length (Word) > 10)) then writeln (SXFile, SeqCt:5, ',', Word) else begin RsvIndex := RsvPtr [ord (Word [1]) - 64]; while ((RsvIndex <= 144) and (Word > (* SYSCONST.CON *) (* Global Constant Definitions *) Blank = ' '; Quote = ''''; Tab = #09; FF = #12; NewLine = #13; EndFile = #26;  (* SYSTYPE.TYP *) (* Global type definitions. *) String5 = string [5]; String255 = string [255]; StringMax = string [255]; (* SYSVAR.VAR *) (* Global Constant Definitions to be initialized *) (* by SYSINIT.PRC. *) (* CRT Variables *) CRTBeepStr : string [2]; CRTDimStr : string [2]; CRTBrightStr : string [2]; CRTGraphStr : string [2]; CRTNoUndStr : string [2]; CRTTextStr : string [2]; CRTUnderStr : string [2]; CsrLeftStr : string [2]; CsrRightStr : string [2]; CsrUpStr : string [2]; CsrDownStr : string [2]; (* Printer Variables *) LSTMaxLngths : integer; LSTLineLength : array [1..5] of integer; LSTLLStr : array [1..5] of String5; (* Center.Fnc *) (* Output: A string data item containing the *) (* contents of the input string, but *) (* with all non-blank data centered *) (* within the specified length. *) (* Input 1: A string field to have characters *) (* centered within it. *) (* Input 2: An integer value indicating the *) (* total desired length of the output*) (* string, including leading and *) (* trailing spaces. *) function Center (InStr: String255; OutLng: integer): String255; var A, B, C: integer; begin A := 1; while (A <= length (InStr)) and (InStr [A] = ' ') do A := succ (A); B := length (InStr); while (B > 0) and (InStr [B] = ' ') do B := pred (B); C := ((OutLng - B + A - 1) div 2) + 1; while A < C do begin insert (' ', InStr, 1); A := succ (A); end; while A > C do begin delete (InStr, 1, 1); A := pred (A); end; while length (InStr) < OutLng do InStr := InStr + ' '; while length (InStr) > OutLng do delete (InStr, length (InStr), 1); Center := InStr; end; nput 2: An integer value indicating the *) (* total desired length of the output*) (* string, including leading and *) (* trailing spaces. *) function Center (InStr: String255; OutLng: integer): String255; var A, B, C: integer; begin A := 1; while (A <= length (InStr)) and (InStr [A] = ' ') do A := succ (A); B := length (InStr); while (B > 0) and (InStr [B] = ' ') do B := pred (B); C := ((OutLng - B + A - 1) div 2) + 1; while A < C do be(* CPM.Prc *) (* Collection of operating system-dependent CP/M *) (* functions and procedures. *) (* NewDisks Procedure *) (* Function: Prepare operating system for disk *) (* change. *) procedure NewDisks; begin bdos (13); end; (* CurrDisk Function *) (* Output: Char containing current disk drive. *) function CurrDisk: char; begin CurrDisk := chr (bdoshl (25) + 65); end; (* SelDisk Procedure *) (* Function: Selects new disk drive for *) (* subsequent operations. *) (* Input 1: A character containing the desired *) (* drive letter. *) procedure SelDisk (DriveChar: char); begin bdos (14, ((ord (DriveChar) mod 32) - 1)); end; (* Dir Function *) (* Output: Str ing containing file name. If *) (* file name is null, then all file *) (* names have been returned. *) (* Input 1: String containing mask to be used *) (* to select file names. Asterisks *) (* and a period may be used, as well *) (* as question marks. *) (* Input 2: Boolean variable which should be *) (* set to true the first time through.*) (* It will be changed to false by this*) (* function. *) function Dir ( DirMask : String14; var FirstTime: boolean) : String14; const FCBL = $5C; FCB = $80; SchFirst = 17; SchNext = 18; SetDMA = 26; var PeriodPos : integer; ExtPos : integer; AstPos : integer; I : integer; DMAPntr : integer; DMABuf : array [1..130] of byte; SaveDisk : char; WorkName : string [12]; begin if FirstTime then begin if DirMask [2] = ':' then begin SaveDisk := CurrDisk; if SaveDisk <> DirMask [1] then SelDisk (DirMask [1]); delete (DirMask, 1, 2); end else SaveDisk := '0'; AstPos := pos ('*', DirMask); PeriodPos := pos ('.', DirMask); if PeriodPos > 0 then ExtPos := PeriodPos + 1 else if AstPos in [1..8] then ExtPos := AstPos + 1 else ExtPos := 9; if ((AstPos > 0) and (AstPos < ExtPos)) then begin repeat insert ('?', DirMask, AstPos); AstPos := succ (AstPos); until AstPos = 9; delete (DirMask, AstPos, 1); end; if PeriodPos > 0 then begin PeriodPos := pos ('.', DirMask); while PeriodPos < 9 do begin insert (' ', DirMask, PeriodPos); PeriodPos := succ (PeriodPos);  end; delete (DirMask, PeriodPos, 1); end; AstPos := pos ('*', DirMask); if AstPos > 0 then begin repeat insert ('?', DirMask, AstPos); AstPos := succ (AstPos); until AstPos > 11; delete (DirMask, AstPos, 1); end; mem [FCBL] := 0; for I := 1 to length (DirMask) do mem [FCBL + I] := ord (DirMask [I]); for I := (length (DirMask) + 1) to 11 do mem [FCBL + I] := ord (' '); for I := 12 to 36 do mem [FCBL + I] := 0; bdos (SetDMA, addr (DMABuf [1])); DMAPntr := bdos (SchFirst, FCBL); end else DMAPntr := bdos (SchNext, FCBL); if DMAPntr < 255 then begin DMABuf [(DMAPntr * 32) + 1] := 11; WorkName := ' '; move (DMABuf [(DMAPntr * 32) + 1], WorkName, 12); insert ('.', WorkName, 9); end else begin bdos (SetDMA, FCB); WorkName := ''; if (SaveDisk <> '0') and (SaveDisk <> CurrDisk) then SelDisk (SaveDisk); end; Dir := WorkName; FirstTime := false; end; s > 11; delete (DirMask, AstPos, 1); end; mem [FCBL] := 0; for I := 1 to length (DirMask) do mem [FCBL + I] := ord (DirMask [I]); for I := (length (DirMask) + 1) to 11 do mem [FCBL + I] := ord (' '); for I := 12 to 36 do mem [FCBL + I] := 0; bdos (SetDMA, addr (DMABuf [1])); DMAPntr := bdos (SchFirst, FCBL); end else DMAPntr := bdos (SchNext, FCBL); if DMAPntr < 255 then begin DMABuf [(DMAPntr * 32) + 1] := 11; WorkName := ' '; move (DMABuf [(DMAPntr * 32) + 1], WorkName, 12); insert ('.', WorkName, 9); end else begin bdos (SetDMA, FCB); WorkName := ''; if (SaveDisk <> (* Cursor.Prc *) (* Collection of video control procedures for the *) (* Osborne 1. *) (* CRTBeep Procedure *) (* Function: Beep at user *) procedure CRTBeep; begin write (CRTBeepStr); end; (* CRTGraph Procedure *) (* Function: Begin graphics mode on terminal *) procedure CRTGraph; begin write (CRTGraphStr) end; (* CRTNoUnd Procedure *) (* Function: End underlining on screen *) procedure CRTNoUnd; begin write (CRTNoUndStr) end; (* CRTText Procedure *) (* Function: End graphics mode, and begin text *) procedure CRTText; begin write (CRTTextStr) end; (* CRTUnder Procedure *) (* Function: Begin underlining on screen *) procedure CRTUnder; begin write (CRTUnderStr) end;   (* CsrLeft Procedure *) (* Function: Move cursor left specified spaces *) procedure CsrLeft (Times: integer); var Count: integer; begin for count := 1 to Times do write (CsrLeftStr) end; (* CsrRight Procedure *) (* Function: Move cursor right specified spaces*) procedure CsrRight (Times: integer); var Count: integer; begin for count := 1 to Times do write (CsrRightStr) end; (* CsrUp Procedure *) (* Function: Move cursor up specified rows *) procedure CsrUp (Times: integer); var Count: integer; begin for count := 1 to Times do write (CsrUpStr) end; (* CsrDown Procedure *) (* Function: Move cursor down specified rows *) procedure CsrDown (Times: integer); var Count: integer; begin for count := 1 to Times do write (CsrDownStr) end; (* DiskFile.Fnc *) (* Output: Boolean True if the passed file *) (* name exists, otherwise boolean *) (* False. *) (* Input 1: String value containing file name.*) function DiskFile (FileName: String255): boolean; var WorkFile: file; begin assign (WorkFile, FileName); (*$I-*) (* Turn off error checking *) reset (WorkFile); (*$I+*) (* Turn error checking back on *) DiskFile := (IOResult = 0) end;  (* HexToChr.Fnc *) (* Output: A string data item containing the *) (* contents of the input string, but *) (* converted from hex paired notation*) (* to a character string. *) (* Input 1: A string field in hex paired *) (* notation. *) function HexToChr (InStr: String255) : String255; var A, B, C: integer; function HexToInt (InChar: char) : integer; begin if InChar in ['0'..'9'] then HexToInt := ord (InChar) - 48 else HexToInt := (ord (InChar) mod 32) + 9; end; begin A := 1; while A <= length (InStr) do begin B := HexToInt (InStr [A]); C := 1; if A < length (InStr) then begin B := (B * 16) + HexToInt (InStr [A + 1]); C := succ (C); end; delete (InStr, A, C); insert (chr (B), InStr, A); A := succ (A); end; HexToChr := InStr; end; ntents of the input string, but *) (* converted from hex paired notation*) (* to a character string. *) (* Input 1: A string field in hex paired *) (* notation. *) function HexToChr (InStr: String255) : String255; var A, B, C: integer; function HexToInt (InChar: char) : integer; begin if InChar in ['0'..'9'] then HexToInt := ord (InChar) - 48 else HexToInt := (ord (InChar) mod 32) + 9; end; begin A := 1; while A <= length (InStr) do begin B := HexToInt (InStr [A]); C := 1; if A < length (InStr) then begin B := (B * 16) + HexToInt (InStr [A + 1]); C := succ (C); end; delete (InStr, A, C); insert(* LCRJust.Fnc *) (* Output: A string data item containing the *) (* data contained in parm 1, but with*) (* back-slashes ("\") removed, and *) (* with the data preceding the first *) (* backslash left-justified, the data*) (* between the first and second *) (* centered, and the data after the *) (* second justified. *) (* Input 1: A string field to be formatted. *) (* Input 2: An integer value indicating the *) (* total desired length of the output*) (* string. *) function LCRJust (InStr : String255; OutLng: integer) : String255; var A, B, C: integer; begin A := 1; while (A <= length (InStr)) and (InStr [A] <> '\') do A := succ (A); if A <= length (InStr) then begin delete (I nStr, A, 1); B := A; while (B <= length (InStr)) and (InStr [B] <> '\') do B := succ (B); if B <= length (InStr) then delete (InStr, B, 1); C := (((OutLng - B + A) div 2) + 1); while A < C do begin insert (' ', InStr, A); A := succ (A); B := succ (B); end; while length (InStr) < OutLng do insert (' ', InStr, B); while (A > 1) and (length (InStr) > OutLng) do begin A := pred (A); delete (InStr, A, 1); end; end; LCRJust := InStr; end; tput*) (* string. *) function LCRJust (InStr : String255; OutLng: integer) : String255; var A, B, C: integer; begin A := 1; while (A <= length (InStr)) and (InStr [A] <> '\') do A := succ (A); if A <= length (InStr) then begin delete (I(* LST.Prc *) (* Collection of printer control procedures. *) (* LSTLngth Procedure *) (* Function: Set printer to desired line length*) procedure LSTLngth (LineLength: integer); var A: integer; begin A := 1; while (A <= LSTMaxLngths) and (LineLength > LSTLineLength [A]) do A := succ (A); if A <= LSTMaxLngths then write (LST, LSTLLStr [A]); end; (* Page.Prc *) (* Function: Writes a form feed to the lst file*) (* in order to skip to the top of a *) (* new page. *) procedure Page; begin write (lst, FF) end; (* ManyChar.Fnc *) (* Output: String containing a specified *) (* character repeated a specified *) (* number of times. *) (* Input 1: Character to be repeated. *) (* Input 2: Number of times to repeat char. *) function ManyChar (Fill: char; Chars: integer): String255; var WorkString: String255; begin WorkString := ''; while (length (WorkString) < Chars) do WorkString := concat (WorkString, Fill); ManyChar := WorkString end;  (* Replace.Fnc *) (* Output: A string with all occurrences of *) (* the search string replaced with *) (* the replacement string. Note that*) (* the search string must not occur *) (* in the replacement string, or an *) (* error will occur. *) (* Input 1: The input string, to have the *) (* replacement applied to it. *) (* Input 2: The search string to be replaced. *) (* Input 3: The replacement string. *) function Replace (InStr : String255; SearchStr : String255; ReplaceStr: String255) : String255; var A: integer; begin A := pos (SearchStr, InStr); while A > 0 do begin delete (InStr, A, length (SearchStr)); insert (ReplaceStr, InStr, A); A := pos (SearchStr, InStr); end; Replace := InStr;  end; e search string replaced with *) (* the replacement string. Note that*) (* the search string must not occur *) (* in the replacement string, or an *) (* error will occur. *) (* Input 1: The input string, to have the *) (* replacement applied to it. *) (* Input 2: The search string to be replaced. *) (* Input 3: The replacement string. *) function Replace (InStr : String255; SearchStr : String255; ReplaceStr: String255) : String255; var A: integer; begin A := pos (SearchStr, InStr); while A > 0 do begin delete (InStr, A, length (SearchStr)); insert (ReplaceStr, InStr, A); A := pos (SearchStr, InStr); end; Replace := InStr; (* SayBool.Fnc *) (* Output: A single character representing *) (* the input boolean value. *) (* Input 1: Boolean value to be displayed. *) function SayBool (InBool: boolean): char; begin if InBool then SayBool := 'Y' else SayBool := 'N'; end; REPLACE FNC 56SAYBOOL $$$ (* Squeeze.Fnc *) (* Output: A string data item containing the *) (* contents of the input string, but *) (* with all specified characters *) (* removed from the string. *) (* Input 1: A string field to have characters *) (* squeezed from it. *) (* Input 2: A string containing all the *) (* characters to be squeezed from the*) (* string. *) function Squeeze (InStr: String255; SqStr: String255): String255; var A, B: integer; begin A := 1; while A <= length (InStr) do begin while (A <= length (InStr)) and (pos (InStr [A], SqStr) = 0) do A := succ (A); B := A; while (B <= length (InStr)) and (pos (InStr [B], SqStr) > 0) do B := succ (B); if A <= length (InStr) then delete (InStr, A, B - A); end; (* while A <= length *) Squeeze := InStr; end; tents of the input string, but *) (* with all specified characters *) (* removed from the string. *) (* Input 1: A string field to have characters *) (* squeezed from it. *) (* Input 2: A string containing all the *) (* characters to be squeezed from the*) (* string. *) function Squeeze (InStr: String255; SqStr: String255): String255; var A, B: integer; begin A := 1; while A <= length (InStr) do begin while (A <= length (InStr)) and (pos (InStr [A], SqStr) = 0) do A := succ (A); B := A; while (B <= length (InStr)) and (pos (InStr [B], SqStr) > 0) do B := succ (B); if A <= length (InStr) then (* SysInit.Prc *) (* This procedure will initialize the variables *) (* defined in SysVar.Var, which can be included *) (* in a Turbo Pascal program. The initializing *) (* data will be read from file SYSTEM.DAT. *) procedure SysInit; var SysFile : text; SysName : string [14]; WorkStr : String5; WorkInt : integer; LSTLLIndex : integer; function HexStr: String5; begin WorkStr := ''; while (not eoln (SysFile)) do begin read (SysFile, WorkInt); WorkStr := WorkStr + chr(WorkInt); end; if not eof (SysFile) then readln (SysFile); HexStr := WorkStr; end; begin SysName := 'a:System.Dat'; assign (SysFile, SysName); reset (SysFile); CRTBeepStr := HexStr; CRTDimStr := HexStr; CRTBrightStr := HexStr; CRTGraphStr := HexStr; CRTNoUndStr := HexStr; CRTTextStr := HexStr; CRTUnderStr := HexStr; CsrLeftStr := HexStr; CsrRightStr := HexStr; CsrUpStr := HexStr; CsrDownStr := HexStr; readln (SysFile, LSTMaxLngths); for LSTLLIndex := 1 to LSTMaxLngths do begin read (SysFile, LSTLineLength [LSTLLIndex]); LSTLLStr [LSTLLIndex] := HexStr; end; for LSTLLIndex := (LSTMaxLngths + 1) to 5 do begin LSTLineLength [LSTLLIndex] := 0; LSTLLStr [LSTLLIndex] := ''; end; close (SysFile); end; (not eoln (SysFile)) do begin read (SysFile, WorkInt); WorkStr := WorkStr + chr(WorkInt); end; if not eof (SysFile) then readln (SysFile); HexStr := WorkStr; end; begin SysName := 'a:System.Dat'; assign (SysFile, SysName); reset (SysFile); CRTBeepStr := HexStr; CRTDimStr := HexStr; CRTBrightStr := HexStr; CRTGraphStr := HexStr; CRTNoUndStr := HexStr; CRTTextStr := HexStr; CRTUnderStr := H (* Trim.Fnc *) (* Output: A string data item containing the *) (* contents of the input string, but *) (* with spaces and/or nulls removed *) (* from the trailing *) (* positions of the string. *) (* Input 1: A string field to be trimmed on *) (* the right side. *) function Trim (Instr: String255): String255; var A, B: integer; BlankChar: boolean; begin if length (Instr) > 0 then begin BlankChar := true; B := length (Instr); while ((B >= 1) and BlankChar) do begin if ((Instr [B] = ' ') or (Instr [B] = chr (0))) then B := pred (B) else BlankChar := false end; if B = 0 then Trim := '' else Trim := copy (Instr, 1, B) end else (* length(InStr) = 0 *) Trim := '' end; ntents of the input string, but *) (* with spaces and/or nulls removed *) (* from the trailing *) (* positions of the string. *) (* Input 1: A string field to be trimmed on *) (* the right side. *) function Trim (Instr: String255): String255; var A, B: integer; BlankChar: boolean; begin if length (Instr) > 0 then begin BlankChar := true; B := length (Instr); while ((B >= 1) and BlankChar) do begin if ((Instr [B] = ' ') or (Instr [B] = chr (0))) then B := pred (B) else BlankChar := false end; if B = 0 then Trim := '' else Trim := copy (Instr, 1, B) end else (* length(InStr) = 0 *) Trim := '' end(* Wait.Prc *) (* Function: Writes message to console and *) (* then waits until user presses any *) (* key. *) procedure Wait; begin writeln ('Press any key to continue...'); while not keypressed do; end; HEXTOCHRFNC /0LCRJUST FNC 12LST PRC3MANYCHARFNC4REPLACE FNC 56SAYBOOL FNC7SQUEEZE FNC 89SYSINIT PRC :;TRIM FNC <=WAIT $$$ͫCopyright (C) 1984 BORLAND IncA MORROW MT-70utivetedP= ERT()~7#~=% o&ͦoͦܐԩͣ}!!"8~#(}:$= +*!Z!*B!!:(=2!Z: <2!!!:O::O:!*B! !45(!.+/ 0y0( d!kZ!{Z͈͈o&  :(y ͠|( *"x2y( >28!?"9!!>2 :D]SXN]D [ (!e}̈́A8Q0G: x@!\w# (   yV. V!h6# (*(.(!8}(*(̈́w#>?> w#a{ |͒}͛Ɛ'@'7||}>"C"6# ""͐ͩ*B"[R5*"^#V#^#V#N#FO/o&9O/o&9!9(> (G!9 w#E͊w}8uRB0 >R@RR!+ͨ z R!+ͨ z <!+ͨ z <!+ͨ z <!#ͨ z <!+ͨ z T]KB!z> S>))0 = |JJDMgo>jB0 7?= H\<z5+)+<z {0Gɯgo||H}||/g}/o#}o&K[xAJSJDM!b"!6J"DM'ͬͬdͬ ͬ} wͦWͧ _}8(8J`9{T]=o`9y w >uJ u` }>(; xQ }} ˸T}ٕ(0D=C ,= ( [ 0%D , 7 ͏ ?(8u x O - ; 8˸x X ,-xG}; }م 9; .>#n0[ D = - nx P ,-(-˸G,-; }ٕ? 9.>͏ 8u ?= u+-(>O 0u O 8͏ ?x P , 78ƀ8ƀ8ox٨!دoGOW_gɷɷ|لg{ً_zيWyىOxوG|ٔg{ٛ_zٚWyٙOx٘Gxٸyٹzٺ{ٻ|ټx٨ xx(ͼ ?}ٽÏ }ց; <(; 7D = |٤g{٣_z٢Wy١Ox٠GD u J }x>uu}ƀ/ƀo; -J }0W-J W,}l˸ͨ 8 ; ` x( -ͨ 8J -ͨ 8,J }l8;*!` ! >u` ` u--- J ,,,-xGg?+2n*8t z~,->uxua}.; OJ , ; !U >,k- o&0%,` }g; }؉}颋.:}8c~I$I~L*kٷx˸; }0G,͙<},-(-J ! >0 a` o8 Oþ >um.`1pF,t6|!wS<.z}[|%FXc~ur1}Oٯx(<˸ͨ 8; !~Jͨ 0O!><ͨ 8 =  7 <` O ; 7 0 W-J OT0 j oD,:j !I}袋.}8c~I$I~L!>u` ` 77 ` = O nf^VNF!DLT\I!!53!r1!\!> x #-= o˸xO(- }(x>8(C ,C `iM!>u|; |J>| )=|(DMbo˸ͦ88ͦx(0 8> Mx(>-Ͳ{(ay(Ͱͦ \z(>.Ͳ (Ͱ ~ͦ{>EͲ>+|(|Dg>-Ͳ|/ 0:p# ~# +>0w#,-  60#J˸}րogM| .(C = ~> x0w#xG%P %P ZJDM%P = _~65i+~hìx-Sx9?+{Η@}|C C gZJDM0D ,7}o˸  #yO!@9i&   # w# /w# w#!9! E9!!9~(+F͊!"9!(#>2*Ͳ"|>" :( ͆ *6#w*6#6 !\$![ (̈́( #:~CONTRMKBDLSTAUXUSR>2$*#~ Ͷ$*:> >w###6  #6++p>2S-$Ͷ:*6###ww#w$w#w: ##N#F*B> w#w#[s#r>2S$Ͷ$*6 #-Nw#Fwq#p#6#w#w#w* :( ͒: *^ F* < >26"~͟*-w#ww#͟"~ <@*Ͳ!\  <ʮ!\$> >2*|>! * \$\<(!: [1Á\!(f"> 2:!<"F( #~#6e>!["N>!~8>O6*"w (=(&("( :(N 8y(~#x+% (6*#~[*#~ *~(h#"b=  8 J= B== ͯ}8= ͵}/ͭ !*###~-_~(4Q6*>2>*##w:>*##~*#~(E[ ( ( ( !][ ( ( ((w#(6!]~-#8~>7  [>OkͼMs #rkͼpX á[ [ (( #w(q*#~[ (  *##~6͜O$*#~(08ʦ=ʦ==ʩ=ʬò+###~-_q46͡> *:4^q}Ò*|(M|( M6-#͐ͦ[R8 (G> ͒C~͒#*ͦC!h !lTRUEFALSEͦ!9^#(~#(G~͒#> ͒> Ò "F![(#RR0*4#4> RR *4 #4(>>2$*V(/˖:(#~+ x y2!͵( =( X:(R*:(###~-_-͌X> :("͟"*^˞*V˖0 SRѷR8A* N#F#s#r$ 0})jS\*###w* N#FB ͟r+s> !T]>)j)0 0= UR!#U*^#V#N#F#^#V>">!2DM"~x(L* :O(o:" C}=( ?*-N#Fp+qq#p! * F+N+++V+^Bq#p>>> SRѷR* s#r$ s#r"S"! N#FB(^x * 6#[<(H*! Kq#p##K[! *! 4 #4! x *$ *>w""{_!"*nf}(HR0nf" ^VMDnfutqp*s#r*s#r"* 5KB!>u~#fo{_"*R0RnfR0KqputsrNF( ^VNF^V*SutKqp R*R(~w~wnf ut"6# * *!""*NFy(* "*B0Cnf* [R*"*RS[s#r^#VS>O"w2x2!"" @*>2"!"""!\Ͳ*: !~6go(\R*s#r_2x( s x(T]DMR0 -a%}̈́o*!~6o&͠|ͣ}%^C User break1:% I/O% Run-time% error ͒%, PC=[R"͍% Program aborted*1!͍!3/Ͳ/!͡!!|(\u !͡!"}2!*5zT "*&Rb*#4 R͐bŔ; -------> TYPE TO CONTINUE <-------b!+_bR!b! ! Ŕ1-----> NOT A VALID INPUT, PLEASE TRY AGAIN <-----͐bR!bŔOKAY...........SO LONG͐b!~͡!2!+)))TWENTIES!W!! !+)!s#r!2!+)))TENS !!! !+)!s#r!2!+)))FIVES !!! !+)!s#r!2!+)))ONES !!! !+)!ds#r!2!+)))HALVES !+"! !+)!2s#r!2!+)))QUARTERS!`"! !+)!s#r!2!+)))DIMES !"! !+)! s#r!2!+)))NICKLES !"! !+)!s#r!2! +)))PENNIES !"! ! +)!s#rŔAMOUNT TENDERED? b!+_b!!~ͼ !͡R͐bŔ CHANGE IS !! !@͐bR͐b!!p= #͸E#!H! ͙"!! 5zv$"*! *+)^#V"*! *+)^#V"*!͛Em$!2*+)))R!q́: *!͐b*##U "!͡! ͡}2!*s*&1R(%!! ͸!!ͥ}oE$!*s%%!! ! ͳ !͡-&2R©%!!͸!!Hͥ}oEy%!*sæ%!! ! ͳ !͡-&3R*&!!͸!!pͥ}oE%!*s'&!! ! ͳ !͡-&ͳ !=!O R͐b! !! Ŕ DAILY TOTALS͐b!=!O R͐bR͐bR͐b! !! ŔSOLD TAX TOTAL͐bR͐bŔSOFTWARE..................... !!!@bR!! !@!!ͳ ! !@͐bŔBOOKS AND TAPES.............. !!!@bR!! !@!!ͳ ! !@͐bŔMISC. MERCHANDISE............ !!!@bR!! !@!!ͳ ! !@͐b!!ͳ !ͳ !͡R͐bŔTOTAL........................ !!!@bR!! !@!!ͳ ! !@͐bR͐bR͐bR͐bU !!͡R!b!=!O R͐b! !! Ŕ CASH REGISTER͐b!=!O R͐bR͐bR͐b! ! Ŕ1 = SOFTWARE ($5.00 TO $150.00)͐bR͐b! ! Ŕ%2 = BOOKS AND TAPES ($2.00 TO $25.00)͐bR͐b! ! Ŕ&3 = MISC. MERCHANDISE ($.50 TO $15.00)͐bR͐b!_!O R͐bŔ b!+_b*&Q!1a!2a!3aE,Ŕ QUANTITY? b!+_bŔPRICE? b!+_b*&!!!z$*&}oEz+ͳ ç+!!! ͳ !͡R͐bŔ b!+_b*R͐bR!bŔ SUBTOTAL = !!!@͐b!!͡Ŕ SALESTAX = !!!@͐b! !  !-! R͐b!!ͳ !͡Ŕ TOTAL = !!!@͐b!9!R!͐b!=!O R͐b! ! ŔTHE FOG COMPUTER STORE͐b!=!O R͐bR͐bR͐bŔYOUR SELECTIONS͐b!-! R͐bR͐bŔ1 CASH REGISTER͐bŔ2 DAILY TOTALS͐bŔ3 QUIT PROGRAM͐bR͐bR͐b!_!O R͐bŔ(PLEASE MAKE YOUR SELECTION 1,2 OR 3 --> b!+_b*&Q!1a!2a!3a}oEʐ.ͳ *&Q!1a!2a!3aE%.R!͐b*&1R.3).2R..&.3R. !*&!3NE,!!͡!!͡!!͡,R!͐b*&1R13).2R2.&.3R3 !*&!3N!! ͳ !͡R͐bŔ b!+_b*R͐bR!bŔ SUBTOTAL = !!!@͐b!!͡Ŕ SALESTAX = !!!@͐b! !  !-! R͐b!!ͳ !͡Ŕ TOTAL = !!!@͐b!9!R! b Ro Forsythe Thi articl an th accompanyin progra ar th resul o reques mad o FO RCP/ #1 Someon starte discussio abou Turb Pasca ( can' imagin who whic resulte i reques fo regula colum i th FOGHORN answere the tha don' hav th expertis t writ regula column bu figure i go th bal rolling mayb som o th rea expert woul contribut t th caus an w coul ge a leas twelv Pasca article year. Th accompanyin progra listin i fo a imaginar compute suppl stor calle FOG An resemblanc t an othe compute organizatio o th sam nam i purel coincidental Wha follow i m effor t explai th progra logic an brie discussio o th hig point o Pasca and i particular Turb Pascal Befor yo g on perhap shoul attac disclaimer d no preten t b a exper Pasca programme an thi progra ma hav bug whic didn' discover Mayb th nex Pasca articl coul discus improvement t thi on (i anyon i stuc fo topic). Th bigges advantag o languag lik Pasca i tha i force th programme t develo structure programmin habits Pasca progra i actuall severa smalle program calle procedure and/o functions Man o thes procedure an function ar simila i severa program tha yo write I i simpl tas t buil yoursel toolches o frequentl use modules an inser the i whateve ne progra yo ma b running Thi als allow yo t tes progra befor i i full written on modul a time I th progra listin tha accompanie thi article th actua progra itsel consist o onl th tw step betwee BEGI an END a th en o th progra listing Othe tha that th progra i actuall serie o module eac callin anothe unti th fina outpu i reached. I yo examin th program yo wil fin tha th firs ste i th progra titl followe b a optiona comment Th Pasca equivalen o MBASIC' RE i th parenthesi an asterisk. Th nex ste i t declar an globa variables Thes ar variable tha ca b use fro th mai progra o an modules Pasca make n assumption a t th attribute o variable Eac mus b defined suc a REAL INTEGER BOOLEAN o CHAR REA pertain t rea number an cover th wides range Integer ar whol number wit rang o -3276 throug 32768 BOOLEA i logica argument TRU o FALSE CHA represent character. Nex i ou progra i th functio SALESTAX Thi functio i goo on fo you toolchest i yo inten t writ man program whic cal fo th salesta t b computed I thi program th rat i define a constan wit valu o 0.06 Thi allow yo t easil updat th progra i th rat shoul change Fo example i thi progra wer bein writte fo busines i th Sa Francisc Ba area the th rat woul b change t 0.065 B usin functio i thi manner n matte ho larg th progra grow to i i seldo difficul t update. Th nex modul i procedur calle WRITECHR Thi procedur i use t pain th scree displa fo aestheti reason only Again i i don thi wa t allo fo eas modifications an les repetitio o th sam code Nex come procedur PAUSE A th nam implies thi modul wil b calle anytim th progra need t tel th operato something an the paus th progra executio unti th operato say tha the ar read t proceed Th lin READLN(CH cause th progra t wai unti i get som characte inpu fro th operator. Procedur TERMINAT simpl display  messag t tel th operato tha th progra i quitting. Th nex procedur i calle CHANGE I wil comput th chang du t customer Computatio o th denomination o th chang wil occu onl i th amoun o th chang doe no excee 327.68 Thi i du t th intege valu range. Th procedur CHECKNAD i a erro tra t chec fo predefine minimu an maximu value i th mai program I orde t kee ou sale cler fro ringin u bo o compute pape a $2000 w hav establishe valu rang fo eac category. Procedur DAYTOTA wil comput th Dail Totals b categor fo ou compute suppl store an i calle b th mai menu. Procedur REGISTE i th cas registe portio o ou business I i calle fro th mai menu an wil displa secon men o choices chec fo vali input the transfe value t th othe procedure an function i need t comput  th fina output. Th las procedur i th progra i calle MAINMENU I wil displa men o choices chec fo vali input the pas contro procedur REGISTER DAYTOTA o TERMINATE. I yo don' hav Turb Pasca an don' quit kno i Pasca i th directio yo wan t go tr usin JR Pasca first JR Pasca i i th FO library s th pric i right Thi progra wil compil wit JR Pasca o Turbo JR i reall n compariso t Turbo bu i wil giv yo a ide o th flexibilit o th Pasca language I yo lik JR eve little the spen th $49.9 fo Turb an fal i love Wit Turb yo ca generat tru CO file tha wil ru outsid o Turbo Th compilin spee i awesom an th erro catchin outstanding. Thank t Stev Turner SYSO o FO #20 fo checkin ou m code An t Joe Sebe woul lik t say "OK too th challenge no it' you turn."ou m code An tPROGRAM FOGSTORE; (* By Ron Forsythe *) VAR OPONE,OPTWO,OPTHREE: REAL; FUNCTION SALESTAX(AMOUNT: REAL): REAL; CONST RATE = 0.06; BEGIN SALESTAX := AMOUNT * RATE; END;(* SALESTAX *) PROCEDURE WRITECHR(CHRIN : CHAR; NUM :INTEGER); VAR CTR : INTEGER; BEGIN FOR CTR := 1 TO NUM DO WRITE(CHRIN); END;(* WRITECHR *) PROCEDURE PAUSE; VAR CH : CHAR; BEGIN WRITELN; WRITE(' -------> TYPE TO CONTINUE <-------'); READLN(CH); END; (* PAUSE *) PROCEDURE ERROR; BEGIN WRITE(CHR(7)); WRITECHR(' ',14); WRITELN('-----> NOT A VALID INPUT, PLEASE TRY AGAIN <-----'); END;(* ERROR *) PROCEDURE TERMINATE; BEGIN WRITE(CHR(26)); WRITELN('OKAY...........SO LONG'); END; (* TERMINATE *) PROCEDURE CHANGE(TOTAL: REAL); TYPE DENOMINATION = ARRAY[1..8] OF CHAR; VAR NAMES: ARRAY[1..9] OF DENOMINATION; VALUES: ARRAY[1..9] OF INTEGER; AMOUNT: REAL; COUNT,CHANGE, I: INTEGER; BEGIN NAMES[1] := 'TWENTIES'; VALUES[1] := 2000; NAMES[2] := 'TENS '; VALUES[2] := 1000; NAMES[3] := 'FIVES '; VALUES[3] := 500; NAMES[4] := 'ONES '; VALUES[4] := 100; NAMES[5] := 'HALVES '; VALUES[5] := 50; NAMES[6] := 'QUARTERS'; VALUES[6] := 25; NAMES[7] := 'DIMES '; VALUES[7] := 10; NAMES[8] := 'NICKLES '; VALUES[8] := 5; NAMES[9] := 'PENNIES '; VALUES[9] := 1; WRITE('AMOUNT TENDERED? '); READLN(AMOUNT); AMOUNT := AMOUNT - TOTAL; WRITELN;WRITELN('CHANGE IS ',AMOUNT:10:2); WRITELN; IF AMOUNT < 327.68 THEN CHANGE := ROUND(100.0 * AMOUNT); FOR I := 1 TO 9 DO BEGIN COUNT := CHANGE DIV VALUES[I]; CHANGE := CHANGE MOD VALUES[I]; IF COUNT > 0 THEN WRITELN(NAMES[I],': ',COUNT); END; PAUSE; END;(* PROCEDURE CHANGE *) PROCEDURE CHECKNADD(OPTION: CHAR; QUAN,PRICE: REAL;VAR OK:BOOLEAN); BEGIN OK := TRUE; CASE OPTION OF '1' : IF (PRICE < 5.00) OR (PRICE > 150.00) THEN OK := FALSE ELSE OPONE := OPONE + (QUAN * PRICE); '2' : IF (PRICE < 2.00) OR (PRICE > 25.00) THEN OK := FALSE ELSE OPTWO := OPTWO + (QUAN * PRICE); '3' : IF (PRICE < 0.50) OR (PRICE > 15.0) THEN OK := FALSE ELSE OPTHREE := OPTHREE + (QUAN * PRICE); ELSE ERROR END; (* CASE *) END; (* CHECKNADD *) PROCEDURE DAYTOTAL; VAR TOTAL: REAL; BEGIN WRITECHR('=',79);WRITELN; WRITECHR(' ',33);WRITELN('DAILY TOTALS'); WRITECHR('=',79); WRITELN;WRITELN;WRITELN; WRITECHR(' ',33);WRITELN('SOLD TAX TOTAL'); WRITELN; WRITE('SOFTWARE..................... ',OPONE:8:2); WRITELN(SALESTAX(OPONE):10:2,(OPONE + SALESTAX(OPONE)):10:2); WRITE('BOOKS AND TAPES.............. ',OPTWO:8:2); WRITELN(SALESTAX(OPTWO):10:2,(OPTWO + SALESTAX(OPTWO)):10:2); WRITE('MISC. MERCHANDISE............ ',OPTHREE:8:2); WRITELN(SALESTAX(OPTHREE):10:2,(OPTHREE + SALESTAX(OPTHREE)):10:2); TOTAL := OPONE + OPTWO + OPTHREE; WRITELN; WRITE('TOTAL........................ ',TOTAL:8:2); WRITELN(SALESTAX(TOTAL):10:2,(TOTAL + SALESTAX(TOTAL)):10:2); WRITELN;WRITELN;WRITELN; PAUSE; END; (* DAYTOTAL *) PROCEDURE REGISTER; VAR OPTION: CHAR; OK: BOOLEAN; PRICE,QUAN,SUBTOTAL,TAX,TOTAL: REAL; BEGIN SUBTOTAL := 0; WRITE(CHR(26)); WRITECHR('=',79); WRITELN; WRITECHR(' ',33); WRITELN('CASH REGISTER'); WRITECHR('=',79); WRITELN; WRITELN; WRITELN; WRITECHR(' ',15); WRITELN('1 = SOFTWARE ($5.00 TO $150.00)'); WRITELN; WRITECHR(' ',15); WRITELN('2 = BOOKS AND TAPES ($2.00 TO $25.00)'); WRITELN; WRITECHR(' ',15); WRITELN('3 = MISC. MERCHANDISE ($.50 TO $15.00)'); WRITELN; WRITECHR('_',79); WRITELN; WRITE('ENTER YOUR CHOICE - 1,2,3 OR ANY OTHER KEY FOR SUBTOTAL --> '); READLN(OPTION); WHILE OPTION IN ['1','2','3'] DO BEGIN WRITE('QUANTITY? ');READLN(QUAN); WRITE('PRICE? ');READLN(PRICE); CHECKNADD(OPTION,QUAN,PRICE,OK); IF NOT OK THEN ERROR ELSE SUBTOTAL := SUBTOTAL + (QUAN * PRICE); WRITELN; WRITE ('ENTER YOUR CHOICE - 1,2,3 OR ANY OTHER KEY FOR SUBTOTAL --> '); READLN(OPTION); END; (* WHILE *) WRITELN; WRITE(CHR(26)); WRITELN('SUBTOTAL = ',SUBTOTAL:8:2); TAX := SALESTAX(SUBTOTAL); WRITELN('SALESTAX = ',TAX:8:2); WRITECHR(' ',11);WRITECHR('-',8);WRITELN; TOTAL := SUBTOTAL+TAX; WRITELN(' TOTAL = ',TOTAL:8:2); CHANGE(TOTAL); END;(* REGISTER *) PROCEDURE MAINMENU; VAR CHOICE : CHAR; BEGIN REPEAT WRITELN(CHR(26)); WRITECHR('=',79); WRITELN; WRITECHR(' ',30);WRITELN('THE FOG COMPUTER STORE'); WRITECHR('=',79); WRITELN;WRITELN;WRITELN; WRITELN('YOUR SELECTIONS'); WRITECHR('-',15); WRITELN;WRITELN; WRITELN('1 CASH REGISTER'); WRITELN('2 DAILY TOTALS'); WRITELN('3 QUIT PROGRAM'); WRITELN;WRITELN; WRITECHR('_',79); WRITELN; REPEAT WRITE('PLEASE MAKE YOUR SELECTION 1,2 OR 3 --> '); READLN(CHOICE); IF NOT (CHOICE IN ['1','2','3']) THEN ERROR; UNTIL CHOICE IN ['1','2','3']; WRITELN(CHR(26)); CASE CHOICE OF '1' : REGISTER; '2' : DAYTOTAL; '3' : TERMINATE; END; (* CASE *) UNTIL CHOICE = '3'; END; (* MAINMENU *) BEGIN OPONE := 0; OPTWO := 0; OPTHREE := 0; MAINMENU; END. END. (' TOTAL = ',TOTAL:8:2); CHANGE(TOTAL); END;(* REGISTER *) PROCEDURE MAINMENU; VAR CHOICE : CHAR; BEGIN REPEAT WRITELN(CHR(26)); WRITECHR('=',79); WRITELN; WRITECHR(' ',30);WRITELN('THE FOG COMPUTER STORE'); WRITECHR('=',79); WRITELN;WRITELN;WRITELN; WRITELN('YOUR SELECTIONS'); WRITECHR('-',15); WRITELN;WRITELN; WRITELN('1 CASH REGISTER'); WRITELN('2 DAILY TOTALS'); WRITELN('3 QUIT PROGRAM'); WRITELN;WRITELN; WRITECHR('_',79); WRITELN; REPEAT WRITE('PLEASE MAKE YOUR SELECTION 1,2 OR 3 --> '); READLN(CHOICE); IF NOT (CHOICE ͫCopyright (C) 1984 BORLAND IncANCR DMVinal selectedP(= EERTG0G4~7#~=% o&ͦoͦܐԩͣ}!!"8~#(}:$= +*!Z!*B!!:(=2!Z: <2!!!:O::O:!*B! !45(!.+/ 0y0( d!kZ!{Z͈͈o&  :(y ͠|( *"x2y( >28!?"9!!>2 :D]SXN]D [ (!e}̈́A8Q0G: x@!\w# (   yV. V!h6# (*(.(!8}(*(̈́w#>?> w#a{ |͒}͛Ɛ'@'7||}>"C"6# ""͐ͩ*B"[R5*"^#V#^#V#N#FO/o&9O/o&9!9(> (G!9 w#E͊w}8uRB0 >R@RR!+ͨ z R!+ͨ z <!+ͨ z <!+ͨ z <!#ͨ z <!+ͨ z T]KB!z> S>))0 = |JJDMgo>jB0 7?= H\<z5+)+<z {0Gɯgo||H}||/g}/o#}o&K[xAJSJDM!b"!6J"DM'ͬͬdͬ ͬ} wͦWͧ _}8(8J`9{T]=o`9y w >uJ u` }>(; xQ }} ˸T}ٕ(0D=C ,= ( [ 0%D , 7 ͏ ?(8u x O - ; 8˸x X ,-xG}; }م 9; .>#n0[ D = - nx P ,-(-˸G,-; }ٕ? 9.>͏ 8u ?= u+-(>O 0u O 8͏ ?x P , 78ƀ8ƀ8ox٨!دoGOW_gɷɷ|لg{ً_zيWyىOxوG|ٔg{ٛ_zٚWyٙOx٘Gxٸyٹzٺ{ٻ|ټx٨ xx(ͼ ?}ٽÏ }ց; <(; 7D = |٤g{٣_z٢Wy١Ox٠GD u J }x>uu}ƀ/ƀo; -J }0W-J W,}l˸ͨ 8 ; ` x( -ͨ 8J -ͨ 8,J }l8;*!` ! >u` ` u--- J ,,,-xGg?+2n*8t z~,->uxua}.; OJ , ; !U >,k- o&0%,` }g; }؉}颋.:}8c~I$I~L*kٷx˸; }0G,͙<},-(-J ! >0 a` o8 Oþ >um.`1pF,t6|!wS<.z}[|%FXc~ur1}Oٯx(<˸ͨ 8; !~Jͨ 0O!><ͨ 8 =  7 <` O ; 7 0 W-J OT0 j oD,:j !I}袋.}8c~I$I~L!>u` ` 77 ` = O nf^VNF!DLT\I!!53!r1!\!> x #-= o˸xO(- }(x>8(C ,C `iM!>u|; |J>| )=|(DMbo˸ͦ88ͦx(0 8> Mx(>-Ͳ{(ay(Ͱͦ \z(>.Ͳ (Ͱ ~ͦ{>EͲ>+|(|Dg>-Ͳ|/ 0:p# ~# +>0w#,-  60#J˸}րogM| .(C = ~> x0w#xG%P %P ZJDM%P = _~65i+~hìx-Sx9?+{Η@}|C C gZJDM0D ,7}o˸  #yO!@9i&   # w# /w# w#!9! E9!!9~(+F͊!"9!(#>2*Ͳ"|>" :( ͆ *6#w*6#6 !\$![ (̈́( #:~CONTRMKBDLSTAUXUSR>2$*#~ Ͷ$*:> >w###6  #6++p>2S-$Ͷ:*6###ww#w$w#w: ##N#F*B> w#w#[s#r>2S$Ͷ$*6 #-Nw#Fwq#p#6#w#w#w* :( ͒: *^ F* < >26"~͟*-w#ww#͟"~ <@*Ͳ!\  <ʮ!\$> >2*|>! * \$\<(!: [1Á\!(f"> 2:!<"F( #~#6e>!["N>!~8>O6*"w (=(&("( :(N 8y(~#x+% (6*#~[*#~ *~(h#"b=  8 J= B== ͯ}8= ͵}/ͭ !*###~-_~(4Q6*>2>*##w:>*##~*#~(E[ ( ( ( !][ ( ( ((w#(6!]~-#8~>7  [>OkͼMs #rkͼpX á[ [ (( #w(q*#~[ (  *##~6͜O$*#~(08ʦ=ʦ==ʩ=ʬò+###~-_q46͡> *:4^q}Ò*|(M|( M6-#͐ͦ[R8 (G> ͒C~͒#*ͦC!h !lTRUEFALSEͦ!9^#(~#(G~͒#> ͒> Ò "F![(#RR0*4#4> RR *4 #4(>>2$*V(/˖:(#~+ x y2!͵( =( X:(R*:(###~-_-͌X> :("͟"*^˞*V˖0 SRѷR8A* N#F#s#r$ 0})jS\*###w* N#FB ͟r+s> !T]>)j)0 0= UR!#U*^#V#N#F#^#V>">!2DM"~x(L* :O(o:" C}=( ?*-N#Fp+qq#p! * F+N+++V+^Bq#p>>> SRѷR* s#r$ s#r"S"! N#FB(^x * 6#[<(H*! Kq#p##K[! *! 4 #4! x *$ *>w""{_!"*nf}(HR0nf" ^VMDnfutqp*s#r*s#r"* 5KB!>u~#fo{_"*R0RnfR0KqputsrNF( ^VNF^V*SutKqp R*R(~w~wnf ut"6# * *!""*NFy(* "*B0Cnf* [R*"*RS[s#r^#VS>O"w2x2!"" @*>2"!"""!\Ͳ*: !~6go(\R*s#r_2x( s x(T]DMR0 -a%}̈́o*!~6o&͠|ͣ}%^C User break1:% I/O% Run-time% error ͒%, PC=[R"͍% Program aborted*1!͍!;Ͳ8!!!!5z "R͐b*#!!!!F5zX "*!R!$͐b*#- !!F5zʎ "*!R!$͐b*#c !!5z "!*R!$͐b*#Ù !!5z "!F*R!$͐b*# !_!!! s!Y!!! s!S!!!՞ s![! ́ INITIAL INVESTMENT? = $! !q͐b![! ́ ANNUAL INTEREST RATE? = ! !q́ %͐b![! ́ YEARS OF INVESTMENT? = *!!͐b![! ́ MONTHLY INVESTMENT? = $!՞ !q͐b![! ́͐b![́͐b![! !$! !q́ THIS IS THE FINAL BALANCE͐b![́͐b![́͐b!_!!! s!Y!!! s!k!!!՞ s![! ́ INITIAL VALUE OF THE LOAN = $! !q͐b![! ́ ANNUAL INTEREST RATE = ! !q́% ͐b![! ́ LENGTH OF LOAN = *!!́ Years͐b![! ́ *!́ Months͐b![! ́ FINAL BALLOON PAYMENT = $!՞ !q͐b![́͐b![́͐b!S!!! s!e!!!  s![! !$! !q́" THIS IS THE PAYMENT OF EACH MONTH͐b![́͐b![́͐b![! !$! !q́ THIS IS THE FINAL PAYMENT͐b![́͐b![́͐b" !!Ŕ INITIAL INVESTMENT? = $___͐b!!Ŕ ANNUAL INTEREST RATE? = ___ %͐b!!Ŕ YEARS OF INVESTMENT? = __͐b!!Ŕ MONTHLY INVESTMENT? = $___͐b!!!_+_b!!!Y+_b!!!!+_b!!!S+_b!Y! !5͡*!! "%!!/͡!*%5zD'"'!/!!5ͳ !/͡*'# '!S!!5ͳ !/!ͼ !5 !A͡!_!/ !G͡!A!Gͳ !e͡!e!!!  s!! *!NEʫ(R!$! !q́ THIS IS THE FINAL BALANCE͐b!!Ŕ Do you want a hard copy? Y/N͐b!-!!8!{b*{&(!YNEʫ( *!NEJ*!!!*!5zD*"'!! 5zu)"!S!!5ͳ !A͡!_!!5ͳ !G͡!A!Gͳ !e͡!e!_͡*#(!e!!!  sR!$! ! q́ Balance at end of year *'!͐b*!N*'*!N}oE/*!"Ŕ Press any key to continue͐b!8!{b*!"*'#(!"*!NE+R͐bR͐bR͐b ![! ͐b!*!5z+"'!! 5z7+"!S!!5ͳ !A͡!_!!5ͳ !G͡!A!Gͳ !e͡!e!_͡*#é*!e!!!  s![! !$! ! q́ Balance at end of year *'!͐b*!=NE+!"![! ͐b*!"*'#Õ*!"" !!Ŕ) INITIAL VALUE OF THE LOAN = $____ ͐b!!Ŕ) ANNUAL INTEREST RATE = ____% ͐b!!Ŕ* LENGTH OF LOAN = ___ Years ͐b!!Ŕ* & ___ Months͐b!!Ŕ' FINAL BALLOON PAYMENT = $___ ͐b!#!!_+_b!#!!Y+_b!#!!!+_b!#!!+_b!#!!k+_b!Y! !5͡*!! *"%!!/͡!*%5z&."'!/!!5ͳ !/͡*'#-!!/ !;͡!_!k!; ͼ !A͡!!;ͼ !5 !G͡!A!G !S͡!A!G !kͳ !e͡*!NES1Ŕ4Payment # | Payment | Principal | Interest | Balance͐b!_!)͡!*%5zM1"!S!)!5 ͼ !;͡!_!;ͼ !)͡!)!_͡!S!;ͼ !e͡!S!!! s!;!!!  s!e!!!ʞ s!)!!! sŔ# *!́ $! !q́ $! !q́ $!ʞ !q́ $! ! q͐b*!N**%N}oE81!"Ŕ Press any key to continue͐b!8!{bŔ4Payment # | Payment | Principal | Interest | Balance͐b*!"*#K/!"*!NE3"![! ͐b!Y!!! s![! ́5Payment # | Payment | Principal | Interest | Balance͐b!_!)͡!*%5z3"!S!)!5 ͼ !;͡!_!;ͼ !)͡!)!_͡!S!;ͼ !e͡!S!!! s!;!!!  s!e!!!ʞ s!)!!! s![! ́# *!́ $! !q́ $! !q́ $!ʞ !q́ $! ! q͐b**%NEl3![! ͐b*!=NE3!"![! ͐b![! ́5Payment # | Payment | Principal | Interest | Balance͐b*!"*#1!"*!NE15!S!!! s!e!!!  s!! R!$! !q́" THIS IS THE PAYMENT OF EACH MONTH͐b!! R!$! !q́ THIS IS THE FINAL PAYMENT͐b!!Ŕ Do you want a hard copy? Y/N͐b!-!!8!{b*{&(!YNE15"!"*#!"#*#R5Ŕ- "... There is none righteous, no, not one." ͐bŔ+ Rom. 3:10͐b7RE6Ŕ- "For all have sinned, and come short of the ͐bŔ, glory of God." Rom. 3:23͐b7R7Ŕ- "For the wages of sin is death; but the gift͐bŔ. of God is eternal life through Jesus Christ ͐bŔ- our Lord." Rom. 6:23͐b7R7Ŕ+ "That if thou shalt confess with thy mouth͐bŔ- the Lord Jesus, and shalt believe in thine ͐bŔ* heart that God hath raised him from the ͐bŔ+ dead, thou shalt be saved." Rom. 10:9͐b*#!NE8!"#Ŕ* This program written by Charles J. Arnett͐bŔ* of Union, Ohio Phone No. 513-836-3272 ͐bŔ* Please call if you have any questions ͐bŔ or comments ͐bR͐b!"!"#ŔType M for Menu͐b!8!zb*!NE(9!"!!85!! Ŕ$ Type S to Run the Savings program ͐b!! Ŕ1 Type G to show the Growth of the savings program͐b!! Ŕ: Type C for hard Copy of the Growth of the savings program͐b!!Ŕ! Type L to Run the Loan program ͐b!!Ŕ+ Type P For Hard copy of Loan Amortization ͐b!!Ŕ* Type D For Display of Loan Amortization ͐b!!Ŕ Type Q to quit program ͐b!8!zb*z&(}2y*y&PR.;!"+à;DRD;!"+à;CRZ;!"͏%à;GRp;!"͏%à;SR€;͏%à;LR;+à;MR ;!"*y&!QNE9!!+6;CRC!"͏%L;GRG!"͏%b;SRS͏%x;#Ŕ* This program written by Charles J. Arnett͐bŔ* of Union, Ohio Phone No. 513-836-3272 ͐bŔ* Please call if you have any questions ͐bŔ or comments ͐bR͐b!"!"#ŔType M for Menu{ MONEY Version 2 7/04/85 } { Created by Charles J. Arnett } { 111 Worman Dr. } { Union OH 45322 } { 1-513-836-3272 } { This program is used to calculate } { Money accounts. ie. IRA's, Savings, or Loan payments } ---------------------------------------------------------------- MONEY2 The program Money2 is the same as Money1 except you can use the Loan program for fractional parts of years. If your loan is for 18 months you can use Money2. Money1 is only for whole number of years. I didn't rework the savings portion, because I think most people will want their savings accounts for a specific number of years. --------------------------------------------------------------- MONEY1 The program MONEY1 will operate on any CP/M 2.2 machine. To use this program on CP/M 3.x you must run TPATCH.COM first. When the MENU appears, select the program that you wish to run. The Savings Program will prompt you at to an initial ammount, a monthly investment, the annual interest rate, and the number of years of the account. This program assumes that you make your first month's investment at the same time you put in your initial ammount. This works for an IRA account also. Any difference between this program and your bank may be in the type of compounding. This program coumpounds monthly. After you have ran this program you will be given the choice of getting a hard copy if your computer is connected toa printer. The hard copy shows only the final balance at the end of the account. If you would like to see your yearly growth on an IRA or regular savings use option G. If you want a hard copy of your yearly growth use Option C. The Loan Program is equally simply to use. The program will prompt you as to the initial ammount of the Loan, the annual interest rate, the number of years of the Loan, and the ballon payment. Note the ballon payment is added to the monthly payment to give the final payment. After the program calculates your monthly payment, interest if figured monthly on the unpayed balance, you will be given the opportunity to gety a hard copy of the loan information. Option D will display the Loan amoratization information on the screen for you. This was designed for an 80 column display. Option P will print out the monthly amoratization informatin on your LST divice. THis was written in Turbo Pascal and the source code is given for your convience. If you modify it and put it back on the BBs please give it a new number and add a note stating what the change was for. If you have any questions or would like me to modify the program for you please call me. Charles J. Arnett 111 Worman. Dr Union Ohio 45322 1-513-836-3272 mber of years of the Loan, and the ballon payment. Note the ballon payment is added to the monthly payment to give the fin{ Created by Charles J. Arnett } { 111 Worman Dr. } { Union OH 45322 } { 1-513-836-3272 } { Version 1.00 June 29, 1985 } { Version 2.00 July 4, 1985 } { Rev. 2 is adding months to duration of Loan. } { You can now figure loan for fractional part of years } { This program is used to calculate } { Money accounts. ie. IRA's, Savings, or Loan payments } PROGRAM Money; VAR Answer,Kind,Kind1,Enuf : CHAR; VAR S,L,P,D,Q,G,C : CHAR; VAR BalloonPayment, FinalAmount, InitialAmount, AnnualInterestRate, MonthlyAmount, F,R,H,W,X,Z,U : REAL; VAR I, Y, VerseCount, YearsOfAccount, AA, BB, CC, DD, EE : INTEGER; VAR J, K, A1, B1, C1, D1, K1, J1, I1 : STRING[10]; Procedure ClearScreen; Begin GOTOXY(20,20); FOR BB := 1 TO 30 DO WRITELN; { This will clear any screen } gotoXY(1,1); End; Procedure DrawBox; Begin FOR AA := 1 TO 70 DO BEGIN gotoXY(AA,1); WRITELN('$'); END; FOR AA := 1 TO 70 DO BEGIN gotoXY(AA,21); WRITELN('$'); END; FOR AA := 1 TO 20 DO BEGIN GOTOXY(1,AA); WRITELN('$'); END; FOR AA := 1 TO 20 DO BEGIN GOTOXY(70,AA); WRITELN('$'); END; End; { End Draw Box } Procedure PrintSavings; begin { Begin routine to print savings } STR(InitialAmount:6:2,A1); STR(AnnualInterestRate:6:2,B1); STR(MonthlyAmount:6:2,D1); WRITELN(Lst,Chr(09),' INITIAL INVESTMENT? = $',A1); WRITELN(Lst,Chr(09),' ANNUAL INTEREST RATE? = ',B1,' %'); WRITELN(Lst,Chr(09),' YEARS OF INVESTMENT? = ',YearsOfAccount); WRITELN(Lst,Chr(09),' MONTHLY INVESTMENT? = $',D1); WRITELN(Lst,Chr(09),''); WRITELN(Lst,''); WRITELN(Lst,Chr(09),'$',J,' THIS IS THE FINAL BALANCE'); WRITELN(Lst,''); WRITELN(Lst,''); end; { End routine to Print Savings routine } Procedure PrintLoan; begin { Print Loan Summery } STR(InitialAmount:6:2,A1); STR(AnnualInterestRate:6:2,B1); STR(BalloonPayment:6:2,D1); WRITELN(Lst,Chr(09), ' INITIAL VALUE OF THE LOAN = $',A1); WRITELN(Lst,Chr(09), ' ANNUAL INTEREST RATE = ',B1,'% '); WRITELN(Lst,Chr(09), ' LENGTH OF LOAN = ',YearsOfAccount,' Years'); WRITELN(Lst,Chr(09), ' ',EE,' Months'); WRITELN(Lst,Chr(09), ' FINAL BALLOON PAYMENT = $',D1); WRITELN(LST,''); WRITELN(LST,''); STR(MonthlyAmount:4:2,K); STR(FinalAmount:4:2,J); WRITELN(Lst,Chr(09),'$',K,' THIS IS THE PAYMENT OF EACH MONTH'); WRITELN(LST,''); WRITELN(LST,''); WRITELN(LST,Chr(09),'$',J,' THIS IS THE FINAL PAYMENT'); WRITELN(LST,''); WRITELN(LST,''); end; { End routine to Print Loan summery } PROCEDURE Savings; BEGIN { Ira or savings account } ClearScreen; DrawBox; GOTOXY(4,3); WRITELN(' INITIAL INVESTMENT? = $___'); GOTOXY(4,4); WRITELN(' ANNUAL INTEREST RATE? = ___ %'); GOTOXY(4,5); WRITELN(' YEARS OF INVESTMENT? = __'); GOTOXY(4,6); WRITELN(' MONTHLY INVESTMENT? = $___'); GOTOXY(29,3); READLN(InitialAmount); GOTOXY(29,4); READLN(AnnualInterestRate); GOTOXY(29,5); READLN(YearsOfAccount); GOTOXY(29,6); READLN(MonthlyAmount); X := AnnualInterestRate/1200; { Monthly Interest } Y := YearsOfAccount*12; { Number of months } Z := 1; FOR I := 1 to Y DO { Total Interest } Z := Z * (1 + X); H := MonthlyAmount*(1+X)*((Z-1)/X); { Growth of monthly investment } R := InitialAmount*Z; { Growth of initial investment } FinalAmount := H+R; { Total growth } STR(FinalAmount:6:2,J); GOTOXY(20,10); if DD = 0 THEN BEGIN WRITELN ('$',J,' THIS IS THE FINAL BALANCE'); GOTOXY(5,18); WRITELN(' Do you want a hard copy? Y/N'); GOTOXY(45,18); READ(KBD,Answer); If UpCase(Answer) = 'Y' then PrintSavings; End; { end regular savings account } if DD = 1 THEN {Display yearly Growth of Saavings } BEGIN ClearScreen; GOTOXY(1,1); FOR I := 1 to YearsOfAccount DO { Total Interest } begin FOR CC := 1 to 12 do BEGIN H := MonthlyAmount*(1 + X); { Growth of monthly investment } R := InitialAmount*(1 + X); { Growth of initial investment } FinalAmount := H+R; { Total growth } InitialAmount := FinalAmount; END; STR(FinalAmount:6:2,J); WRITELN ('$',J:9,' Balance at end of year ',I); IF (DD = 20) OR (I = YearsOfAccount ) THEN BEGIN DD := 1; WRITELN(' Press any key to continue'); READ(KBD,ANSWER); ClearScreen; END; DD := DD + 1; End; DD := 8; End; { end of display yearly growth } if DD = 2 THEN { Print yearly Growth of Saavings } BEGIN WriteLn; WriteLn; WriteLn;  PrintSavings; WriteLn(Lst,Chr(12)); FOR I := 1 to YearsOfAccount DO { Total Interest } begin FOR CC := 1 to 12 do BEGIN H := MonthlyAmount*(1 + X); { Growth of monthly investment } R := InitialAmount*(1 + x); { Growth of initial investment } FinalAmount := H+R; { Total growth } InitialAmount := FinalAmount; END; STR(FinalAmount:6:2,J); WRITELN (LST,CHR(09),'$',J:9,' Balance at end of year ',I); IF DD = 61 THEN BEGIN DD := 1; WRITELN(Lst,Chr(12)); END; DD := DD + 1; End; { Print list of growth } END; DD := 8; END; { End savings routine } PROCEDURE Loan; BEGIN ClearScreen; DrawBox; GOTOXY(3,3); WRITELN( ' INITIAL VALUE OF THE LOAN = $____ '); GOTOXY(3,4); WRITELN( ' ANNUAL INTEREST RATE = ____% '); GOTOXY(3,5); WRITELN( ' LENGTH OF LOAN = ___ Years '); GOTOXY(3,6); WRITELN( '  & ___ Months'); GOTOXY(3,7); WRITELN( ' FINAL BALLOON PAYMENT = $___ '); gotoxy(35,3); READLN(InitialAmount); gotoxy(35,4); READLN(AnnualInterestRate); gotoxy(35,5); READLN(YearsOfAccount); gotoxy(35,6); READLN(EE); gotoxy(35,7); READLN(BalloonPayment); X := AnnualInterestRate/1200; { Monthly Interest } Y := (YearsOfAccount*12) + EE; { Number of months } Z := 1; FOR I := 1 to Y DO { Total Interest } Z := Z * (1 + X); W := 1/Z; { Reciprocal of Interest } H := InitialAmount-(BalloonPayment*W); { Initial loan minus effective value of ballon payment } R := (1-W)/X; MonthlyAmount := H/R; { Monthly payments } FinalAmount := (H/R) + BalloonPayment; { Monthly payment plus final ballon payment } if DD = 1 then { Dispay Amortization chart } begin ClearScreen; Writeln('Payment # | Payment | Principal | Interest | Balance'); U := InitialAmount; for CC := 1 to Y do begin  W := MonthlyAmount - (U*X); { Principal } U := InitialAmount - W; { New Balance } InitialAmount := U; FinalAmount := MonthlyAmount - W; { Interest } STR(MonthlyAmount:4:2,K); STR(W:4:2,J); STR(FinalAmount:4:2,K1); STR(U:4:2,J1); Writeln('# ',CC:3,' $',K:7,' $',J:7,' $',K1:7,' $',J1:9); IF (DD = 20) OR (CC = Y ) THEN BEGIN DD := 1; WRITELN(' Press any key to continue'); READ(KBD,ANSWER); ClearScreen; Writeln('Payment # | Payment | Principal | Interest | Balance'); END; DD := DD + 1; End; DD := 8; End; { Print out amortization chart } if DD = 2 then begin PrintLoan; WriteLn(Lst,Chr(12)); STR(AnnualInterestRate:2:2,I1); Writeln(Lst,Chr(09),'Payment # | Payment | Principal | Interest | Balance'); U := InitialAmount; for CC := 1 to Y do begin W := MonthlyAmount - (U*X); { Principal } U := InitialAmount - W; { New Balance } InitialAmount := U; FinalAmount := MonthlyAmount - W; { Interest } STR(MonthlyAmount:4:2,K); STR(W:4:2,J); STR(FinalAmount:4:2,K1); STR(U:4:2,J1); Writeln(Lst,Chr(09),'# ',CC:3,' $',K:7,' $',J:7,' $',K1:7,' $',J1:9); IF CC = Y THEN WRITELN(Lst,Chr(12)); IF DD = 61 THEN BEGIN DD := 1; WRITELN(Lst,Chr(12)); Writeln(Lst,Chr(09),'Payment # | Payment | Principal | Interest | Balance'); END; DD := DD + 1; End; DD := 8; End; { End Hard copy of amortization } If DD = 0 then Begin STR(MonthlyAmount:4:2,K); STR(FinalAmount:4:2,J); gotoxy(15,10); WRITELN('$',K,' THIS IS THE PAYMENT OF EACH MONTH'); gotoxy(15,12); WRITELN('$',J,' THIS IS THE FINAL PAYMENT'); GOTOXY(5,18); WRITELN(' Do you want a hard copy? Y/N'); GOTOXY(45,18); READ(KBD,Answer); If UpCase(Answer) = 'Y' then PrintLOAN; End; DD := 8; End; Procedure RomansRoad; Begin VerseCount := VerseCount + 1; Case VerseCount of 1 : begin WriteLn(' "... There is none righteous, no, not one." '); WriteLn(' Rom. 3:10'); end; 2 : begin WriteLn(' "For all have sinned, and come short of the '); WriteLn(' glory of God." Rom. 3:23'); end; 3 : begin WriteLn(' "For the wages of sin is death; but the gift'); WriteLn(' of God is eternal life through Jesus Christ '); WriteLn(' our Lord." Rom. 6:23'); end; 4 : begin WriteLn(' "That if thou shalt confess with thy mouth'); WriteLn(' the Lord Jesus, and shalt believe in thine '); WriteLn(' heart that God hath raised him from the '); WriteLn(' dead, thou shalt be saved." Rom. 10:9');  end; end; if VerseCount = 4 then VerseCount := 0; end; Begin { start main routine } ClearScreen; WRITELN(' This program written by Charles J. Arnett'); WRITELN(' of Union, Ohio Phone No. 513-836-3272 '); WRITELN(' Please call if you have any questions '); writeln(' or comments '); WriteLn; DD := 8; VerseCount := 0; WriteLn('Type M for Menu'); READ(KBD,Kind); REPEAT IF DD = 8 THEN ClearScreen; DD := 0; gotoXY(2,5); RomansRoad; gotoXY(3,09); WRITELN(' Type S to Run the Savings program '); gotoXY(3,11); WRITELN(' Type G to show the Growth of the savings program'); gotoXY(3,13); WRITELN(' Type C for hard Copy of the Growth of the savings program'); gotoXY(3,15); WRITELN(' Type L to Run the Loan program '); gotoXY(3,17); WRITELN(' Type P For Hard copy of Loan Amortization '); gotoXY(3,19); WRITELN(' Type D For Display of Loan Amortization '); gotoXY(3,21); WRITELN(' Type Q to quit program '); READ(KBD,Kind); Kind1 := UpCase(Kind); Case Kind1 of 'P' : Begin DD := 2; Loan; End; 'D' : Begin DD := 1; Loan; End; 'C' : Begin DD := 2; Savings; End; 'G' : Begin DD := 1; Savings; End; 'S' : Savings; 'L' : Loan; 'M' : DD := 8; End; UNTIL Kind1 = 'Q'; GOTOXY(1,23) END.  WRITELN(' Type S to Run the Savings program '); gotoXY(3,11); WRITELN(' Type G to show the Growth of the savings program'); gotoXY(3,13); WRITELN(' Type C for hard Copy of the Growth of the savings program'); gotoXY(3,15); WRITELN(' Type L to Run the Loan program '); gotoXY(3,17); WRITELN(' Type P For Hard copy of Loan Amortization '); gotoXY(3,19); WRITELN(' Type D For Display of Loan Amortization '); gotoXY(3,21); WRITELN(' Type Q to quit program '); READ(KBD,Kinv4Copyright (C) 1983 BORLAND Inc Osborne 1= ()TERP<~7#~= o&ͦoͦc|ͣ}!!" ~#(}:8= +ͥ*!v-!pͥ*|!!:(=2!-: <2!~!!Y:jO:l:kO:m!ͥ*n! !i45(!+/ 0y0( d!9-!I-[[o&  :(y ͠|( r*"x2y( >28!"9!!>2 0&+!0 [ (!ePWA8Q0G: x@!\w# (   L). )!h6# (*(.(!8}(*(Ww#>?> w#a{ |e}nƐ'@'ý7||}>"C ""*B"[R*"^#V#^#V#N#FO/o&9O/o&9!9(> (G!9 w#EMw}8"RB0 >RRR!+k = R!+k = !+k = !+k = !#k = !+k = T]KB!z> S>))0 = |  DMgo>jB0 7?= H<͡z5)<z {0Gɯgo|| }||/g}/o#}o&K[xAJSJDM!b"!6J"DM'oodo o} $yWj _}8(8J`9{T]=o`9y $͙ >" 8# }>(́ x }} ˸T}ٕ(0D= ,= (  0% , 7 R ?(88 x  - 8˸x   ͠ ,-xG} }م 9 .>#n0  = - nx  ,-(-˸G,- }ٕ? 9.>R 88 ?= u+-(> 08  8R ?x  , 78ƀ8ƀ8ox٨!دoGOW_gɷɷ|لg{ً_zيWyىOxوG|ٔg{ٛ_zٚWyٙOx٘Gxٸyٹzٺ{ٻ|ټx٨u xx( ?}ٽR }ց <( 7 = |٤g{٣_z٢Wy١Ox٠G 8͉ }x>"8}ƀ/ƀó ͙ - }0- ,}l˸k 8 ́ # x(͙ -k 8 -k 8, }l8;*!# ! >8# # 8---͙ ,,,-xGg?+2n*8t z~,->"x"$}.́  ,͙ ́ ! >,.-͙ o&0%͔,# ͙ }g }؉}颋.:}8c~I$I~L*.ٷx˸́ }0G,\<}͔,-(- ! >0 $# o8 Á >"m.`1pF,t6|!wS<.z}[|%FXc~ur1}ٯx(<˸k 8́ !~Jk 0ͺO!Z>k 8 =  ͙ # ͙ ́ ͺ͙ 0 - OT0 j oD,:j !I}袋.}8c~I$I~L!>8# # ͙ # = Ù nf^VNF!DLT\I!!53!r1!!> x #-= o˸x(-͙ }(x>8( , `i!>"| | >)=|(DMbo˸y88yx(0 8> x(>-q{(ay(oe z(>.q (o =e{>Eq>+|(|Dg>-q|/ 0:p# ~# +>0w#,-  60# ˸}րogM͇| .( = ~> x0w#xG% % ZJDM% = _~65(+~hìx-Sx9?+{Η@}|  gZJDM0 ,7}o˸ #yO!@9i&  #w#/w#w#!9! E9!!9~(+FM!"9!(#>2*u"|>":( E *6#w*6#6 !\$!u[ (W( #:~CONTRMKBDLSTAUXUSR>2ͭ*#~ u*:> >w###6Õ  #6++p>2Su:*6###ww#w$w#w: ͳ##N#F*B>w#w#[s#rò>2u*6 #-Nw#Fwq#p#6#w#w#w͞* :( Q: *^ F* < >26"~^*-w#ww#Ͳ^"~ <@*u!\  >2*|>! * \$\<(!: [1Á\!(f"́> 2:!"F( #~#6$>!"N>!~8>O6*"w (=(&("( :( 8y(~#ͽ7+ (6*#~́*#~ *~(h#"b=  8ͽ ̶J= B== ͯ}8= ͵}/l !*###~-_~(46*>2>*##w:>*##~*#~(E͋ ( ( ( ͕!] ( ( ((w#(͕́̕6!]~-#8~>7́ Õ͕>O*{͍̈́s #r*{/͍ d͋ ͕ (( #w(͕́̕q*#~ʶ (͕́ ͕ Õ*##~6[O*#~(08ʦ=ʦ==ʩ=ʬò+###~-_q46`>*:4^q}Q*|(|( 6-#Sy[R8 (G> QC~Q#*ͳyC!' !+TRUEFALSEy!9^#~#(G~Q#> Q> Q "F!(#R0ͳ*4#4>R *4 #4(Ͳ>>2*V(/˖:(#~+ x y!t( =( X:(R*:(###~-_-K< =>:("^"*^˞*V˖0 SѷR8A* N#F#s#r 0})jS\*###w* N#FB ^r+s>!T]>)j)0 0= R!#*^#V#N#F#^#V>">!2DM"~ʲx(L* :O(o:" C}=( ?*-N#Fp+qq#p! * F+N+++V+^Bq#p>>>SѷR* s#r$ s#r*"[R0s#r>"[^#VS!9[R8[R>O"w2x2!"" ͵*>2"!"""!\u*: ͭ!~6go(\R*s#r_2x( s x(T]DMR0 -a%Ù}Wo*!~6o&͠|ͣ}^C User break1: I/O Run-time error e, PC=[R"` Program aborted*1!`!0}ͅå0"~"~*~^#V"~*~^#V*~s#r*~*~s#r"~"~!}2}~*~*~!RzR"{~!*{~+)^#V!*{~!+)^#V^EI!*{~+)!*{~!+)͔!}2}~*{~#*}~&!E"w~"y~*y~*w~zʢ"m~!~*m~+)!s#r*m~#|*y~!*w~zb"o~*y~*o~!RzY"q~!*o~+)^#V!*q~+)^#V^E*!~*o~+)!~*o~+)^#V!s#rP!~*q~+)!~*q~+)^#V!s#r*q~#*o~#ó*y~*w~zʫ"m~!!~*m~+)^#V+)!*m~+)^#Vs#r*m~#m*y~*w~z"m~!*m~+)!*m~+)^#Vs#r*m~#ö "_~"a~!*a~+)^#V"W~*a~*a~"Y~*Y~*_~^E, þ *Y~*_~r!*Y~+)^#V!*Y~!+)^#Vr}oEv *Y~!"Y~!*Y~+)^#V*W~JEʘ þ !*a~+)!*Y~+)^#Vs#r*Y~"a~!E !*a~+)*W~s#r"i~"k~*i~!͡*k~!z!"c~*c~*i~*c~+!*i~*k~!zf!"c~!*c~!!+)!*c~+)͔*c~+.!"S~"U~*U~!*S~z2""K~*K~"M~!*M~+)^#V"I~*M~*U~^*I~!*M~!R+)^#Vr}oE"!*M~+)!*M~!R+)^#Vs#r*M~!R"M~å!!*M~+)*I~s#r*K~#Ä!!;~͛"E~"G~*G~*E~rED#*G~"?~*E~!"=~!*G~+)^#V";~*?~!"?~!*?~+)^#V*;~7E|"*=~!R"=~!*=~+)^#V*;~JEʤ"*?~*=~rE"!*?~+)!*=~+)͔*?~*=~^E|"!*G~+)!*=~+)͔*G~*=~!R3"*?~*E~3";~õ>$ !!~͛"'~")~*)~*'~!͡"!~!*)~+)^#V!*!~+)^#VJ!*!~+)^#V!*'~+)^#VJ}oE#*!~"+~1$!*)~+)^#V!*'~+)^#VJ!*'~+)^#V!*!~+)^#VJ}oE+$*'~"+~1$*)~"+~*+~ !~õ!-~͛"7~"9~*7~*9~R! ^E{%*9~"1~*7~!"/~!*9~+)!*9~*7~P#+)͔!*9~+)^#V"-~*1~!"1~!*1~+)^#V*-~7Eʳ$*/~!R"/~!*/~+)^#V*-~JE$*1~*/~rE1%!*1~+)!*/~+)͔*1~*/~^Eʳ$!*9~+)!*/~+)͔*9~*/~!RM#*1~*7~M#-~õ!~͛"~"~*~*~z(&"~*~"~*~!*~z&"~!*~+)^#V!*~+)^#VrE%*~"~*~#%!*~+)!*~+)͔*~#ä%~õ!~͛"~"~*~*~R!͡" ~* ~*~7E@'* ~*~z/'"~*~"~!*~+)^#V"~*~* ~R*~7*~!*~* ~R+)^#Vr}oE'!*~+)!*~* ~R+)^#Vs#r*~* ~R"~Ù&!*~+)*~s#r*~#x&* ~!͡" ~]&~õS(!}͛"}!!*}͇+)^#V!!*}͇!+)^#VJE'!*}+)!!*}͇+)^#Vs#r!~*}+)!~!*}͇+)^#Vs#rJ(!*}+)!!*}͇!+)^#Vs#r!~*}+)!~!*}͇!+)^#Vs#r}õ !}͛"}"~*}!*}͇!Rz("}!*}+)!*}*}R!+)^#Vs#r!~*}+)*}s#r*}#Ä(*}!R*~z)"}*}L'*}+(*~*}zʟ)"}!*}+)!*~+)^#Vs#r!~*~+)^#V"}!*}+)!s#r*}!͡"}*}*~7Eʖ)*}L'*}!͡"}n)*}#) }õ!}͛"}!*}!z)"}!*}+)!,*}+)^#Vs#r*}#)}õ!}͛"}O@Number of items to sort: *}ͭ!*}^#Vzʊ*"}!,*}+)!s#r*}#a*!,*}^#V!+)!s#r*}^#Vͨ)}õ!}͛"}!*}M#!*}z+"}!,*}+)!*}+)^#Vs#r*}#*}õ!}͛"}O!*}zʒ+"}!*}+)^#V!͵*}! !Eʉ+O*}#C+}õ!}͛}2}*ͨ)*&E+*+O@ready?͠E+@ begin*}&BR,!*,CR-,!*e,HRE,!*,IR],!*g!,LRu,!*1&,QR,!*3",RR°,!*M#!*g!,SR,!*̈́%,TR,!*I'@ endO*&E-*+}õ!}͛O@Options:OO! e.! 0@B Bubble sort.O! e.! 0@C Count sort.O! e.! 0@D toggle Display of list.O! e.! 0@ H Heap sort.O! e.! 0@I Insertion sort.O! e.! 0@L sheLL sort.O! e.! 0@N Number of items to sort.O! e.! 0@P Presort master list.O! e.! 0@Q Quick sort.O! e.! 0@R quick sort 2.O! e.! 0@S Selection sort.O! e.! 0@ T Tree sort.O! e.! 0@X eXit program.OO@Your choice? !!}͚*}&}2}O*}&BR0CR0HR0IR0LR0QR0RR0SR0TR%0*}&͛+Ù0DR?0*&}o}2Ù0NRS0!*Ù0PRg0*ͼ*Ù0XRw0rÙ0O@ Not on menu.O -}õ!}2 -r&}o}2-0NRN!*G0PRP*ͼ*[0XRXro0OSORT.CO͠ i progra shel designe t allo compariso o numbe o sortin砠 algorithms SORT.PAӠ i th correspondin Turb Pasca sourc file Th progra men allow th use t generat desire numbe o rando integer (u t 2000 bu tre sor ca handl onl 1600) Th maste lis ca b presorte i desired an displa o th number ca b toggle o o off Th othe men choice allo th use t tes th particula sorting methods. Th individua sortin algorithm appea a name procedure withi SORT.PAS The wer writte t gai understandin o th sorts an wer optimize fo clea expressio rathe tha versatilit o speed T compar th spee o th variou algorithms time th interva betwee m respons t th promp "Ready? an th momen whe th sorte lis bega t prin out teste eac sor o 40 an 80 rando integers an the o th sam numbe set afte presorting wit th followin result (time in seconds): SORT 400 800 400 (PS) 800 (PS) bubble 29.7 114.8 .3 .3 count 17.8 70.2 18.0 71.0 insert 11.5 42.2 .4 .4 select 9.2 35.6 9.1 35.4 tree 6.3 14.1 6.3 14.0 shell 1.9 4.0 1.1 2.1 heap 1.6 3.5 1.7 3.6 quick1 1.1 2.1 8.7 failed quick2 1.0 2.0 .7 1.2 Th firs fou sort ar o clas tha take tim proportiona t * t sor items shel sor i i a intermediat clas tha take tim proportiona t roughl * 1.25 an th othe fou ar i th bes cas clas tha take tim proportiona t lo n Not tha tw o th ver simpl sort (bubbl an insertion ar excellen o list tha ar alread sorte o nearl so Tre sor i wors tha shel sor a thi lo becaus o hig overhead bu woul eventuall catc u a muc large n Th simpl quic sor i notoriousl ba o presorte lists--a 80 i fail du t stac overflo durin recursiv calls Th improve quic sor overcome thi proble an wil b th fastes sor o thi collectio fo al bu ver unlikel sequence o numbers (I fe rar cases hea sor wil bea it sinc th improve quicksor stil ha ba wors case whil hea sor take about the same time for best and worse case lists.)el sor i i a intermediat clas tha take tim proportiona t roughl * 1.25 an th othe fou ar i th bes cas clas tha take tim proportiona t lo n Not tha tw o th ver simpl sort (bubbl an insertion ar excellen o list tha ar alread sorte o nearl so Tre sor i wors tha shel sor a type list = array[1..2000] of integer; longlist = array[1..3199] of integer; var n : integer; (* number of items to sort *) toggle : boolean; (* controls display of list *) master : list; (* random values for sorting *) a : list; (* working list to be sorted *) aux1 : longlist; (* auxiliary arrays used by *) aux2 : longlist; (* count and tree sort *) (* Internal arrays in count and tree sort are forced to overlay aux1 and aux2 using the absolute address variable ability of Turbo Pascal. This saves some critical space in the program so that large lists can be sorted without a heap stack collision. *) (***** COMMON PROCEDURES USED BY SORTING ALGORITHMS *****************) procedure swap(var i, j : integer); var t : integer; begin t := i; i := j; j := t; end; (***** BUBBLE SORT **************************************************) (* The list is scanned repeatedly, and adjacent items that are out of order are swapped. When a pass occurs with no swaps, the list is sorted. *) procedure bubble(lb, ub : integer); var swapped : boolean; cell : integer; begin repeat swapped := false; for cell := lb to ub - 1 do begin if (a[cell] > a[cell + 1]) then begin swap(a[cell], a[cell + 1]); swapped := true; end; end; until (swapped = false); end; (***** COUNT SORT ***************************************************) (* An auxiliary array is created with one cell for each item in the list, and these cells are set to 1. Each pair of items is compared, and the auxiliary cell corresponding to the higher item is incremented. The auxiliary cells then give the number of items smaller than any given item, which establishes its position in the sorted list. *) procedure count(lb, ub : integer); var left, right, cell : integer; sorted : list absolute aux1; count : list absolute aux2; begin for cell := lb to ub do count[cell] := 1; for right := lb + 1 to ub do begin for left := lb to right - 1 do begin if (a[right] > a[left]) then count[right] := count[right] + 1 else count[left] := count[left] + 1; end; end; for cell := lb to ub do sorted[count[cell]] := a[cell]; for cell := lb to ub do a[cell] := sorted[cell]; end; (***** HEAP SORT ****************************************************) (* The items are rearranged into a "heap", where each item at position i is larger than the two items at positions 2i and 2i + 1. The top item in the heap is then repeatedly removed and placed in its final position, with the heap being consolidated after each such removal. *) procedure heap(lb, ub : integer); var cell : integer; procedure siftup(parent, top : integer); label done; var child, copy : integer; begin copy := a[parent]; repeat child := parent + parent; if (child > top) then goto done else begin if (child < top) and (a[child] < a[child + 1]) then child := child + 1; if (a[child] <= copy) then goto done else begin a[parent] := a[child]; parent := child; end; end; until (false); done: a[parent] := copy; end; begin for cell := (ub div 2) downto (lb + 1) do siftup(cell, ub); for cell := ub downto (lb + 1) do begin siftup(1, cell); swap(a[1], a[cell]); end; end; (***** INSERTION SORT ***********************************************) (* The first item is considered as the nucleus of a sorted lefthand sublist. Each succeeding item to the right is compared backward along the left sublist and inserted at the correct position in the sorted portion. *) procedure insert(lb, ub : integer); var cell, newcell, newval : integer; begin for newcell := lb + 1 to ub do begin cell := newcell; newval := a[cell]; while (cell > lb) and (newval < a[cell - 1]) do begin a[cell] := a[cell - 1]; cell := cell - 1; end; a[cell] := newval; end; end; (***** SIMPLE QUICK SORT *****************************************) {$A-} (* compiler toggle to allow recursion *) (* A pivotal value is chosen and the list is rearranged so that all values to the left are less than or equal to the pivot and all values to the right are greater than or equal to the pivot. The same procedure is then called recursively to deal with the left and right sublists. When all sublists are of length one, the list is sorted. In this version, the pivot is simply chosen to be the leftmost member of each sublist. *) procedure quick1(lb, ub : integer); var left, right, pivot : integer; begin if (lb < ub) then begin left := lb; right := ub + 1; pivot := a[lb]; repeat repeat left := left + 1 until (a[left] >= pivot); repeat right := right - 1 until (a[right] <= pivot); if (left < right) then swap(a[left], a[right]); until (left > right); swap(a[lb], a[right]); quick1(lb, right - 1); quick1(left, ub); end; end; (***** IMPROVED QUICK SORT *****************************************) (* This version includes two improvements: (1) The pivot is chosen to be the median of the leftmost, rightmost and middle items in each sublist; and (2) sublists of less than ten items are left unsorted. The partly sorted list can then be rapidly brought into complete order with insertion sort. *) procedure quick2(lb, ub : integer); const CUTOFF = 10; var left, right, pivot : integer; function med(lb, ub : integer) : integer; var mid : integer; begin mid := (lb + ub) div 2; if (a[lb] <= a[mid]) and (a[mid] <= a[ub]) then med := mid else if (a[lb] <= a[ub]) and (a[ub] <= a[mid]) then med := ub else med := lb; end; begin if (ub - lb > CUTOFF) then begin left := lb; right := ub + 1; swap(a[lb], a[med(lb, ub)]); pivot := a[lb]; repeat repeat left := left + 1 until (a[left] >= pivot); repeat right := right - 1 until (a[right] <= pivot); if (left < right) then swap(a[left], a[right]); until (left > right);  swap(a[lb], a[right]); quick2(lb, right - 1); quick2(left, ub); end; end; (***** SIMPLE SELECTION SORT ****************************************) (* The smallest item is found and placed in the leftmost cell. On each succeeding pass, the smallest remaining unsorted item is found and placed at the end of the sorted lefthand portion. *) {procedure select(lb, ub : integer); var left, right : integer; begin for left := lb to ub do for right := left + 1 to ub do if (a[left] > a[right]) then swap(a[left], a[right]); end;} (***** IMPROVED SELECTION SORT **************************************) (* In this faster version, most calls on swap are replaced by an explicit temporary variable, which represents the position holding the lowest item yet found at a given time during one pass. *) procedure select(lb, ub : integer); var left, right, low : integer; begin for left := lb to ub do  begin low := left; for right := left + 1 to ub do if (a[right] < a[low]) then low := right; swap(a[left], a[low]); end; end; (***** SIMPLE SHELL SORT ********************************************) (* The list is divided into a number of interlaced sublists in which items are separated by a gap initially equal to half the length of the list. On each pass, the gap is cut in half until on the last pass, adjacent items are being compared. During each pass, items on each of the current sublists are sorted by insertion sort. *) {procedure shell(lb, ub : integer); var gap, left, right : integer; begin gap := (ub - lb) div 2; while (gap >= lb) do begin for right := gap to ub do begin left := right - gap; while ((left >= lb) and (a[left] > a[left + gap])) do begin swap(a[left], a[left + gap]); left := left - gap;  end; end; gap := gap div 2; end; end;} (***** IMPROVED SHELL SORT ******************************************) (* This version saves some time in the inner loop with a better version of insertion sort that uses a temporary variable to cut down on swaps. *) procedure shell(lb, ub : integer); var gap, left, right, newval : integer; begin gap := (ub - lb) div 2; while (gap >= lb) do begin for right := gap to ub do begin left := right; newval := a[left]; while (left - gap >= lb) and (newval < a[left - gap]) do begin a[left] := a[left - gap]; left := left - gap; end; a[left] := newval; end; gap := gap div 2; end; end; (***** TREE SORT ****************************************************) (* In one auxiliary array, the items are arranged in a tree where each position i contains a copy of the smaller item at positions 2i and 2i + 1. A second auxiliary array contains pointers to the original position of each item in the first auxiliary array. The first (smallest) item in the tree is repeatedly removed and transfered to its final position in the sorted list. Then, it is replaced at its original position with a value higher than any item in the list, and the tree is rearranged to move the new smallest item to the top. *) procedure tree(lb, ub : integer); var cell, node : integer; value : longlist absolute aux1; pointer : longlist absolute aux2; procedure minimum(cell : integer); begin if (value[2 * cell] <= value[2 * cell + 1]) then begin value[cell] := value[2 * cell]; pointer[cell] := pointer[2 * cell]; end else begin value[cell] := value[2 * cell + 1]; pointer[cell] := pointer[2 * cell + 1]; end; end; begin for cell := ub to (2 * ub - 1) do begin value[cell] := a[cell - ub + 1]; pointer[cell] := cell; end; for cell := (ub - 1) downto lb do minimum(cell); for cell := lb to ub do begin a[cell] := value[lb]; node := pointer[lb]; value[node] := MAXINT; node := node div 2; while (node >= lb) do begin minimum(node); node := node div 2; end; end; end; (***** MAIN PROGRAM INFRASTRUCTURE **********************************) procedure reset(n : integer); var i : integer; begin for i := 1 to n + 1 do a[i] := master[i]; end; procedure init(var n : integer); var i : integer; begin writeln; write('Number of items to sort: '); readln(n); for i := 1 to n do master[i] := random(2000); master[n + 1] := MAXINT; reset(n); end; procedure presort(n : integer); var i : integer; begin quick2(1, n); for i := 1 to n do master[i] := a[i]; end; procedure show(n : integer); var i : integer; begin writeln; for i := 1 to n do begin write(a[i] : 5); if (i mod 10 = 0) then writeln; end; end; procedure dosort(c : char); begin reset(n); if (toggle) then show(n); writeln; write('ready?'); repeat until keypressed; write(' begin'); case c of 'B' : bubble(1, n); 'C' : count(1, n); 'H' : heap(1, n); 'I' : insert(1, n); 'L' : shell(1, n); 'Q' : quick1(1, n); 'R' : begin quick2(1, n); insert(1, n); end; 'S' : select(1, n); 'T' : tree(1, n); end; writeln(' end'); if (toggle) then show(n); end; procedure menu; var c : char; begin writeln; write('Options:'); writeln; writeln; writeln(' ' : 10, 'B Bubble sort.'); writeln(' ' : 10, 'C Count  sort.'); writeln(' ' : 10, 'D toggle Display of list.'); writeln(' ' : 10, 'H Heap sort.'); writeln(' ' : 10, 'I Insertion sort.'); writeln(' ' : 10, 'L sheLL sort.'); writeln(' ' : 10, 'N Number of items to sort.'); writeln(' ' : 10, 'P Presort master list.'); writeln(' ' : 10, 'Q Quick sort.'); writeln(' ' : 10, 'R quick sort 2.'); writeln(' ' : 10, 'S Selection sort.'); writeln(' ' : 10, 'T Tree sort.'); writeln(' ' : 10, 'X eXit program.'); writeln; write('Your choice? '); read(kbd, c); c := upcase(c); writeln; case c of 'B', 'C', 'H', 'I', 'L', 'Q', 'R', 'S', 'T' : dosort(c); 'D' : toggle := not toggle; 'N' : init(n); 'P' : presort(n); 'X' : halt; else begin writeln; writeln('Not on menu.'); end; end; menu; end; (***** MAIN PROGRAM *************************************************) begin toggle := true; menu; end. I Insertion sort.'); writeln(' ' : 10, 'L sheLL sort.'); writeln(' ' : 10, 'N Number of items to sort.'); writeln(' ' : 10, 'P Presort master list.'); writeln(' ' : 10, 'Q Quick sort.'); writeln(' ' : 10, 'R quick sort 2.'); writeln(' ' : 10, 'S Selection sort.'); writeln(' ' : 10, 'T Tree sort.'); writeln(' ' : 10, 'X eXit program.'); writeln; write('Your choice? '); read(kbd, c); c := upcase(c); writeln; case c of 'B', 'C', 'H', 'I', 'L', 'Q', 'R', 'S', 'T' : dosort(c); 'D' : toggle := not toggle; 'N' : init(n); 'P' : presort(n); 'X' : halt; else begin writeln; writeln('Not on menu.'); end; end; menu; end; (***** MAIN PROGRAM *************************************************) begin togHB230002.FOG TURBO TIPS A Picture's Worth A Thousand (Reserved) Words by Herb Bowie On堠 o th man nic thing abou Turb Pasca i it extensibility programme ca writ hi ow general-purpos procedure an functions an includ the i progra whe necessar b mean o th inclusio feature I thi way th languag ca b extende t includ feature no otherwis available. Man hig leve language allo th programme t us pictur strin t specif forma fo displayin outpu o user' termina o printer o editin user' input Wit th inclusio o th followin functions th Turb Pasca programme ca als us thi hand feature. SAYPIC Thi functio format characte strin an allow th programme t specif th desire forma b mean o pictur string Th firs inpu paramete i th strin t b formatted whic ma b o an lengt u t StringMax whic i typ tha mus b define prio t thi function an th nex one. Th secon inpu paramete i th pictur strin representin th desire forma o th outpu string Th followin character hav specia meaning whe encountere i th pictur string. # - Any digit may occupy this position. 9 - Same as #. $ - Will be used to replace leading zeros. - Wil caus leadin zero t b replace b spaces - I th numbe i positive the plu sig wil appea i thi position. - - I th numbe i negative the minu sig wil appea i thi position. X - Any character may occupy this position. - An lette i th alphabet uppe o lowe case o space ma occup thi position. - Sam a X bu lowe cas character wil b converte t uppe case - An characte othe tha <>.,;:=?*[ݠ ma occup thi positio (an characte lega i CP/ fil name). An othe characte appearin i th pictur strin wil appea a i i th outpu string. Thi functio simpl return th formatte strin a th resul o th function rathe tha writin i anywhere t allo th programmer to do whatever he wants with the resulting string. Th functio work b takin th inpu string on characte a time an mappin i agains th pictur string Not tha integer o rea numbers a wel a strings ma b formatte usin thi functio b firs convertin the t string b usin th ST procedure. GETPIC Thi functio allow th use t ke i characte strin an allow th programme t specif th desire forma o th outpu strin b mean o pictur string Th firs inpu paramete i strin representin th initia defaul valu o th strin t b input Not tha thi defaul valu shoul b th sam lengt a th pictur string I necessary functio S!AYPIà ma b use b th programme t adjus th lengt o th defaul string. Th secon paramete i th pictur string Th sam character hav th sam specia meaning a i th pictur strin i SAYPIC Eac tim th use enter a acceptabl character th functio wil advanc th curso t th nex position I th use enter characte tha i no acceptabl a th curren position the th functio wil loo ahea t tr t fin followin positio wher th characte i acceptable I suc positio i found the th user' entr wil g there an th curso wil b advance t th nex positio followin th poin o entry. Notic tha th curso wil no automaticall ski pas literal i th pictur string I th use enter th literal the i wil b accepte an th curso advanced i th use enter som othe value the th functio wil loo ahead a describe above t fin positio wher tha valu wil b acceptable. Th use ma als ente th followin contro codes whic hav specia meanings. ^ - Move th curso lef on position unles i i currentl a th leftmos position ^H - same as ^S. ^Ġ- Move th curso righ on position unles i i currentl a th rightmos position. ^L - Same as ^D. ^ - Clear th field b settin al variabl position t eithe blank o zeros a appropriate ^ - Toggle betwee overwrit an inser mode Overwrit i th initia default ^ - Delete th characte a th curren curso position. ^ - Turn o Decima Poin insertion whic i initiall off Turnin thi o move th curso t th positio jus lef o th decima point i ther i one o t th las numeri position i ther i n decima point Digit entere䠠 subsequentl wil b inserte a th堠 sam position whil shiftin othe digit t th left unti th use enter decima point Thi i grea an natura wa fo use t ente numbers I i th programmer' responsibilit t positio th curso appropriatel befor usin thi function I i als hi responsiblit t displa th defaul value i h wishes befor calling this function. Not tha thi functio require th us o som termina I/ command no buil int Turb Pascal th abilit t mov th curso lef on position th abilit t mov i righ on position an th abilit t mak i beep Thes hav bee implemente fo th Osborn 1 an ma nee t b change b th programme fo othe computers. Th sampl progra PICTURE.PA demonstrate th us o thes functions and whe run wil allo th programme t tes th functions. program Picture; type StringMax = string [255]; String2 = string [2]; const (* CRT Variables *) CRTBeepStr : string2 = #07; CsrLeftStr : string2 = #08; CsrRightStr : string2 = #12; var InString: StringMax; InPic : StringMax; Choice : char; {$I B:CRT.Prc } {$I B:SayPic.Fnc } {$I B:GetPic.Fnc } begin ClrScr; repeat writeln; writeln ('1 = SayPic'); writeln ('2 = GetPic'); writeln ('9 = Exit Program'); writeln; write ('Enter your choice: '); Choice := GetPic ('0', '#'); writeln; case Choice of '1': begin writeln; write ('Enter Picture: '); readln (InPic); writeln; write ('Enter String: '); readln (InString); writeln; write ('Output String: '); writeln (SayPic (InString, InPic)); end; '2': begin writeln; write ('Enter Picture: '); readln (InPic); writeln; write ('Enter String: '); readln (InString); InString := SayPic (InString, InPic); writeln; write ('GetPic: '); write (InString); CsrLeft (length (InPic)); InString := GetPic (InString, InPic); writeln; writeln; write ('Output String: '); writeln (InString); end; end; until Choice = '9'; end.  Exit Program'); writeln; write ('Enter your choice: '); Choice := GetPic ('0', '#'); writeln; case Choice of '1': begin writeln; write ('Enter Picture: '); readln (InPic); writeln; write ('Enter String: '); readln (InString); writeln; write ('Output String: '); writeln (SayPic (InString, InPic)); end; '2': begin writeln; write ('Enter Picture:"(* GetPic.Fnc *) (* Output: String input by user and formatted*) (* according to format defined by *) (* picture string. *) (* Input 1: Initial, default value for string.*) (* Input 2: String representing format *) (* picture. The characters found in *) (* this string will be interpreted *) (* according to the following table. *) (* # - Any digit. *) (* 9 - Same as #. *) (* + - If the number is positive, *) (* then a plus sign is to *) (* appear in this position. *) (* - - If the number is negative, *) (* then a minus sign will *) (* appear in this position. *) (* X - Any character. *) (* A - Any letter in the alphabet, *) (* upper or lower case, or a *) (* space. *) (* ! - Any character. Lower case *) (* letters will be converted *) (* to upper. *) (* F - Any character other than *) (* <>.,;:=?*[]. (Any character*) (* legal in a file name.) *) (* Any other character will appear in*) (* the formatted string as is. *) (* Input from screen: The user may enter the *) (* following control codes. *) (* ^S - Move cursor left one. *) (* ^H - Same as ^S. *) (* ^D - Move cursor right one. *) (* ^L - Move cursor right one. *) (* ^Y - Clear field. *) (* ^I - Overwrite/Insert toggle *) (* (overwrite default) *) (* ^G - Delete character. *) (* ^P - Begin at decimal point, and*) (* shift existing characters *) (* to the left. *) function GetPic (InString: StringMax; Format: StringMax): StringMax; type Characters = set of char; ASCII = set of 0..127; const Digits: Characters = ['0'..'9']; SignChars: Characters = ['+', '-', ' ']; Alpha: Characters = [' ','a'..'z','A'..'Z']; FileChars: Characters = [' '..'+','-','/'..'9','@'..'Z','\','^'..'z']; ControlOrds: ASCII = [1..27]; DigitChars: Characters = ['#', '9', 'Z', '*', '$']; var WorkString: StringMax; WorkChar: char; FormatChar: char; I, J: integer; FormatLength: integer; WorkOrd: integer; InsertMode: boolean; NumberMode: boolean; procedure ReadChar; begin read (kbd, WorkChar); WorkOrd := ord(WorkChar); end; function FillChar (FormatChar: char): char; begin case FormatChar of 'X', 'A', '!', 'F', '-': FillChar := ' '; '#', '9', 'Z', '*', '$': FillChar := '0'; '+': FillChar := '+'; else FillChar := FormatChar; end; end; function FormatMatch (InChar: char; FormatChar: char): boolean; begin FormatMatch := false; case FormatChar of 'X', '!': FormatMatch := true; 'A': if InChar in Alpha then FormatMatch := true; 'F': if InChar in FileChars then FormatMatch := true; '#', '9', '*', '$', 'Z': if InChar in Digits then FormatMatch := true; '+', '-': if InChar in SignChars then FormatMatch := true; else if InChar = FormatChar then FormatMatch := true; end; end; begin FormatLength := length(Format); WorkString := InString; InsertMode := false; NumberMode := false; I := 1; ReadChar; while WorkOrd <> 13 do begin if WorkOrd in ControlOrds then (* Control Chr *) begin if ((WorkOrd = 4) (* ^D/^L - Move cursor right *) or (WorkOrd = 12) or (WorkChar = CsrRightStr)) then if I < FormatLength then begin CsrRight (1); I := I + 1; NumberMode := false; end else CRTBeep else if (WorkOrd = 7) then (* ^G - Delete Char *) begin J := I; FormatChar := Format [I]; while ((J < FormatLength) and (Format [J + 1] = FormatChar)) do begin WorkChar# := WorkString [J + 1]; WorkString [J] := WorkChar; write (WorkChar); J := J + 1; end; WorkChar := FillChar (FormatChar); WorkString [J] := WorkChar; write (WorkChar); CsrLeft (J - I + 1); NumberMode := false; end else if ((WorkOrd = 08) (* ^H/^S - Move Cursor Left *) or (WorkOrd = 19) or (WorkChar = CsrLeftStr)) then if I > 1 then begin CsrLeft (1); I := I - 1; NumberMode := false; end else CRTBeep else if WorkOrd = 09 then (* ^I - Toggle Insert Mode *) begin InsertMode := not InsertMode; NumberMode := false; end else if WorkOrd = 16 then (* ^P - Insert Data at decimal point *) begin while ((I <= FormatLength) and (Format [I + 1] in DigitChars)) do begin I := I + 1; CsrRight (1); end; InsertMode := false; NumberMode := not NumberMode; end else if WorkOrd = 25 then (* ^Y - Clear Field *) begin WorkString := ''; for J := 1 to FormatLength do begin FormatChar := Format [J]; WorkString := WorkString + FillChar(FormatChar); end; CsrLeft (I - 1); Write (WorkString); CsrLeft (FormatLength); I := 1; NumberMode := false; end else CrtBeep; end else begin J := I; while ((J <= FormatLength) and (not FormatMatch (WorkChar, Format [J]))) do J := J + 1; if J <= FormatLength then begin CsrRight (J - I); I := J; FormatChar := Format [I]; if (FormatChar = '!') or (FormatChar = 'F') then WorkChar := upcase (WorkChar) else if ((FormatChar = '+') or (FormatChar = '-')) and (WorkChar <> FormatChar) then WorkChar := ' '; if WorkChar = '.' then NumberMode := false; if NumberMode then begin J := I; while ((J > 1) and (Format [J - 1] = Format [J])) do begin J := J - 1; CsrLeft (1); end; while J < I do begin WorkString [J] := WorkString [J + 1]; write (WorkString [J]); J := J + 1; end; end (* End Number Mode *) else if InsertMode then begin J := I; while ((J < FormatLength) and (Format [J + 1] = Format [J])) do begin J := J + 1; CsrRight (1); end; while J > I do begin  WorkString [J] := WorkString [J - 1]; write (WorkString [J]); CsrLeft (2); J := J - 1; end; end; (* End Insert Mode *) WorkString [I] := WorkChar; write (WorkChar); if ((NumberMode) or (I = FormatLength)) then CsrLeft (1) else I := I + 1; end else CrtBeep; end; ReadChar; end; (* user input ended by *) CsrRight (FormatLength - I); GetPic := WorkString; end;  J := J + 1; end; end (* End Number Mode *) else if InsertMode then begin J := I; while ((J < FormatLength) and (Format [J + 1] = Format [J])) do begin J := J + 1; CsrRight (1); end; while J > I do begin (* SayPic.Fnc *) (* Output: String formatted according to *) (* format defined by picture string. *) (* Input 1: String to be formatted. *) (* Input 2: String representing format *) (* picture. The characters found in *) (* this string will be interpreted *) (* according to the following table. *) (* # - Any digit. *) (* 9 - Same as #. *) (* $ - Replaces leading zeros. *) (* * - Replaces leading zeros. *) (* Z - Prints spaces instead of *) (* leading zeros. *) (* + - If the number is positive, *) (* then a plus sign is to *) (* appear in this position. *) (* - - If the number is negative, *) (* then a minus sign will *)$ (* appear in this position. *) (* X - Any character. *) (* A - Any letter in the alphabet, *) (* upper or lower case, or a *) (* space. *) (* ! - Any character. Lower case *) (* letters will be converted *) (* to upper. *) (* F - Any character other than *) (* <>.,;:=?*[]. (Any character*) (* legal in a file name.) *) (* Any other character will appear in*) (* the formatted string as is. *) function SayPic (InString: StringMax; Format: StringMax): StringMax; type Characters = set of char; const Digits: Characters = ['0'..'9', ' ']; Alpha: Characters = [' ','a'..'z','A'..'Z']; FileChars: Characters = [' '..'+','-','/'..'9','@'..'Z','\','^'..'z']; var WorkString: StringMax; WorkChar: char; FormatChar: char; FillChar: char; InChar: char; FormatSign: char; InStringSign: char; SignPosition: integer; I, J, K: integer; FormatLength: integer; InStringLength: integer; FormatDecPos: integer; InStringDecPos: integer; PicFound: boolean; PictureN: boolean; DigitFound: boolean; LeadingZeros: boolean; procedure GetInChar; begin InChar := InString [J]; if InChar in Digits then DigitFound := true else if (InChar = '+') or (InChar = '-') then InStringSign := InChar; end; procedure FormatN; begin if FormatDecPos = 0 then begin WorkString := ''; FormatDecPos := FormatLength + 1 end else WorkString := '.'; InStringDecPos := pos('.', InString);  if InStringDecPos = 0 then InStringDecPos := InStringLength + 1; InStringSign := '+'; (* Starting at decimal point, go left *) J := InStringDecPos - 1; for I := (FormatDecPos - 1) downto 1 do begin FormatChar := Format [I]; case FormatChar of '+', '-': WorkString := ' ' + WorkString; '$', '*', 'Z', '9', '#': begin DigitFound := false; while ((not DigitFound) and (J > 0)) do begin GetInChar; J := J - 1; end; if DigitFound then begin if InChar = ' ' then InChar := '0'; WorkString := InChar + WorkString end else WorkString := '0' + WorkString; end; else WorkString := FormatChar + WorkString; end end; (* End of Format string on left *) while J > 0 do  begin GetInChar; J := J - 1; end; (* work from decimal point right *) J := InStringDecPos + 1; for I := (FormatDecPos + 1) to FormatLength do begin FormatChar := Format [I]; case FormatChar of '+', '-': WorkString := WorkString + ' '; '$', '*', 'Z', '9', '#': begin DigitFound := false; while ((not DigitFound) and (J <= InStringLength)) do begin GetInChar; J := J + 1; end; if DigitFound then begin if InChar = ' ' then InChar := '0'; WorkString := WorkString + InChar end else WorkString := WorkString + '0'; end; else WorkString := WorkString + FormatChar; end (* End of case FormatChar *) end; (* End of Format string on right *) (* Move in Sign *)  if (InStringSign = FormatSign) and (FormatSign <> ' ') then WorkString [SignPosition] := InStringSign; (* Suppress leading zeros *) I := 1; LeadingZeros := true; while (LeadingZeros) and (I <= FormatLength) do begin FormatChar := Format [I]; case FormatChar of '+', '-': ; '#', '9': LeadingZeros := false; ',': WorkString [I] := FillChar; 'Z', '$', '*': begin if FormatChar = 'Z' then FillChar := ' ' else FillChar := FormatChar; WorkChar := WorkString [I]; if WorkChar = '0' then WorkString [I] := FillChar else LeadingZeros := false; end; end; (* End of case FormatChar *) I := I +1; end (* End of while LeadingZeros *) end; (* End of procedure FormatN *) procedure WorkPad; begin case FormatChar of % '*', '$', 'Z', '9', '#': WorkString := WorkString + '0'; 'X', 'A', 'F', '!': WorkString := WorkString + ' '; else WorkString := WorkString + FormatChar; end; end; procedure FormatX; begin WorkString := ''; J := 1; for I := 1 to InStringLength do begin WorkChar := InString [I]; PicFound := false; K := J; while ((not PicFound) and (J <= FormatLength)) do begin FormatChar := Format [J]; J := J + 1; case FormatChar of 'X', '!': PicFound := true; '*', '$', 'Z', '9', '#': if WorkChar in digits then PicFound := true; 'A': if WorkChar in Alpha then PicFound := true; 'F': if WorkChar in FileChars then PicFound := true; else if WorkChar = FormatChar then  PicFound := true end; if not PicFound then WorkPad; end; (* End of search for picture char *) if PicFound then begin if (FormatChar = '!') or (FormatChar = 'F') then WorkChar := upcase(WorkChar); WorkString := WorkString + WorkChar; end else begin J := K; WorkString := copy(WorkString, 1, J) end end; (* End of InString *) while J <= FormatLength do begin FormatChar := Format [J]; J := J + 1; WorkPad; end end; begin I := 1; PictureN := true; FormatDecPos := 0; SignPosition := 0; FormatSign := ' '; FormatLength := length(Format); InStringLength := length(InString); while ((PictureN) and (I <= FormatLength)) do begin FormatChar := Format [I]; if ((FormatChar = '.') and (FormatDecPos = 0)) then FormatDecPos := I else if ((FormatChar = ',') and (FormatDecPos = 0)) then else if ((FormatChar in ['+', '-']) and ((I = 1) or (I = FormatLength)) and (FormatSign = ' ')) then begin SignPosition := I; FormatSign := FormatChar end else if FormatChar in ['$', '*', 'Z', '#', '9'] then else PictureN := false; I := I + 1 end; if PictureN then FormatN else FormatX; SayPic := WorkString; end;  end; begin I := 1; PictureN := true; FormatDecPos := 0; SignPosition := 0; FormatSign := ' '; FormatLength := length(Format); InStringLength := length(InString); while ((PictureN) and (I <= FormatLength)) do begin FormatChar := Format [I]; if ((FormatChar = '.') and (FormatDecPos = 0)) then FormatDecPos  This is the release date of the disk. !K"K$K%K&K'K(K)K+K,K-K.K/K2K3K4K5K6K7K8K9K:K;KK?K@KAKBKCKDKEKFKGKHKIKJKKKLKMKNKOKPKQKRKSKTKUKVKWKXKYKZK[K\K]K^K_K`KaKbKcKdKeKfKgKhKiKjKkKlKmKnKoKpKqKrKsKtKuKvKwKxKyKzK{K|K}K~KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKLCRT .PRC 4C 0D 2048 16 DISKFILE.FNC 6A D3 640 5 HEXTOCHR.FNC C8 71 1152 9 LCRJUST .FNC 14 74 1664 13 LST .PRC F9 D3 768 6 MANYCHAR.FNC A5 FA 640 5 REPLACE .FNC 46 47 1152 9 SAYBOOL .FNC 57 D2 512 4 SQUEEZE .FNC E9 D9 1152 9 SYSINIT .PRC AD 51 1536 12 TRIM .FNC 24 43 1152 9 WAIT .PRC 99 2F 384 3 FOGSTORE Fog Library Disk FOG-CPM.028 Copyright (1986) by Fog International Computer Users Group to the extent not copyrighted by the original author for the exclusive use and enjoyment of its members. Any reproduction or distribution for profit or personal gain is strictly forbidden. For information, contact FOG, P. O. Box 3474, Daly City, CA. 94015-0474. as part of the description of a file indicates that the program is distributed on a "try first, pay if you like it" basis. If you find the program(s) meet your need, please refer to the author's documentation for information on becoming a registered user. Only by registering and paying for the programs you like and use will the authors of such programs continue development. Often, more complete documentation, additional modules, and new releases are available only to registered users. Disk 2 of 2. Turbo Pascal programs. Filename Description -02-00 .86 This is the release date of the disk. & -CPM028 .DOC This is the description of the disk contents. SLIST .PAS 1B83 12K ver. 1.00A [SLIST 9 of 29] SLIST1 .INC 3A9E 7K ver. 1.00A [SLIST 10 of 29] SLIST2 .INC 1ED1 6K ver. 1.00A [SLIST 11 of 29] SLIST3 .INC 1CED 6K ver. 1.00A [SLIST 12 of 29] SYSCONST.CON 65AD 1K ver. 1.00A [SLIST 13 of 29] SYSTYPE .TYP ECDC 1K ver. 1.00A [SLIST 14 of 29] SYSVAR .VAR E1C4 1K ver. 1.00A [SLIST 15 of 29] CENTER .FNC 6380 2K ver. 1.00A [SLIST 16 of 29] CPM .PRC 9D7E 5K ver. 1.00A [SLIST 17 of 29] CRT .PRC 4C0D 2K ver. 1.00A [SLIST 18 of 29] DISKFILE.FNC 6AD3 1K ver. 1.00A [SLIST 19 of 29] HEXTOCHR.FNC C871 2K ver. 1.00A [SLIST 20 of 29] LCRJUST .FNC 1474 2K ver. 1.00A [SLIST 21 of 29] LST .PRC F9D3 1K ver. 1.00A [SLIST 22 of 29] MANYCHAR.FNC A5FA 1K ver. 1.00A [SLIST 23 of 29] REPLACE .FNC 4647 2K ver. 1.00A [SLIST 24 of 29] SAYBOOL .FNC 57D2 1K ver. 1.00A [SLIST 25 of 29] SQUEEZE .FNC E9D9 2K ver. 1.00A [SLIST 26 of 29] SYSINIT .PRC AD51 2K ver. 1.00A [SLIST 27 of 29] TRIM .FNC 2443 2K ver. 1.00A [SLIST 28 of 29] WAIT .PRC 992F 1K ver. 1.00A [SLIST 29 of 29] FOGSTORE.COM 2E92 12K [FOGSTORE 1 of 3] This is a Turbo Pascal tutorial, which uses a "store" as a demo. Documentation and Pascal source code are included. FOGSTORE.DOC 2E08 6K [FOGSTORE 2 of 3] FOGSTORE.PAS 41E7 6K [FOGSTORE 3 of 3] MONEY2 .COM 742F 15K ver. 2 [MONEY 1 of 3] This program calculates IRA's, Savings, or loan payments. Pascal Source code is included. MONEY2 .DOC 875D 3K ver. 2 [MONEY 2 of 3] MONEY2 .PAS E494 12K ver. 2 [MONEY 3 of 3] SORTS .COM CD41 12K [SORTS 1 of 3] This program does a comparison of different sorting algorithms. Bubble, sount, insert, select, tree, shell, heap, quick1, and quick2. Pascal source code and documentation is included. SORTS .DOC 5C98 3K [SORTS 2 of 3] SORTS .PAS BEC6 15K [SORTS 3 of 3] PICTURE .DOC E1A0 6K [Picture 1 of 4] This set contains a discussion and demo of Getpic and Saypic. The Demo source code in Pascal is included. PICTURE .PAS 5D7C 2K [Picture 2 of 4] GETPIC .FNC C183 9K [Picture 3 of 4] SAYPIC .FNC 81D4 9K [Picture 4 of 4] .FNC 6AD3 1K ver. 1.00A [SLIST 19 of 29] HEXTOCHR.FNC C871 2K ver. 1.00A [SLIST 20 of 29] LCRJUST .FNC 1474 2K ver. 1.00A [SLIST 21 of 29] LST .PRC F9D3 1K ver. 1.00A [SLIST 22 of 29] MANYCHAR.FNC A5FA 1K ver. 1.00A [SLI'