OS_Develop/dos_compilers
OS_Develop/dos_compilers
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

borland turbo pascal v4

Browse Source
This commit is contained in:
davidly 2024-07-01 21:08:56 -07:00
parent b791cd023a
commit 7b05b54898
74 changed files with 107385 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

386
Borland Turbo Pascal v4/ARTY4.PAS Normal file
View File

@ -0,0 +1,386 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program Arty4;
{ This program is a demonstration of the Borland Graphics Interface(BGI)
provided with Turbo Pascal 4.0.
To run this program you will need the following files:
TURBO.EXE (or TPC.EXE)
TURBO.TPL - The standard units
GRAPH.TPU - The Graphics unit
*.BGI - The graphics device drivers
To run the program from the Development Environment do the following:
1. Load ARTY4.PAS into the editor
2. Press ALT-R to run the program
From the command line type:
TPC ARTY4 /R
Runtime Commands for ARTY4
--------------------------
<B> - changes background color
<C> - changes drawcolor
<ESC> - exits program
Any other key pauses, then regenerates the drawing
}
uses
Crt, Graph;
const
Memory = 100;
Windows = 4;
type
ResolutionPreference = (Lower, Higher);
ColorList = array [1..Windows] of integer;
var
Xmax,
Ymax,
ViewXmax,
ViewYmax : integer;
Line: array [1..Memory] of record
LX1,LY1: integer;
LX2,LY2: integer;
LColor : ColorList;
end;
X1,X2,Y1,Y2,
CurrentLine,
ColorCount,
IncrementCount,
DeltaX1,DeltaY1,DeltaX2,DeltaY2: integer;
Colors: ColorList;
Ch: char;
BackColor:integer;
GraphDriver, GraphMode : integer;
MaxColors : word;
MaxDelta : integer;
ChangeColors: Boolean;
procedure Frame;
begin
SetViewPort(0, 0, Xmax, Ymax-(TextHeight('M')+4)-1,ClipOn);
SetColor(MaxColors);
Rectangle(0, 0, Xmax-1, (Ymax-(TextHeight('M')+4)-1)-1);
SetViewPort(1, 1, Xmax-2, (Ymax-(TextHeight('M')+4)-1)-2,ClipOn);
end { Frame };
procedure FullPort;
{ Set the view port to the entire screen }
begin
SetViewPort(0, 0, Xmax, Ymax, ClipOn);
end; { FullPort }
procedure MessageFrame(Msg:string);
begin
FullPort;
SetColor(MaxColors);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
SetLineStyle(SolidLn, 0, NormWidth);
SetFillStyle(EmptyFill, 0);
Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
{ Go back to the main window }
Frame;
end { MessageFrame };
procedure WaitToGo;
var
Ch : char;
begin
MessageFrame('Press any key to continue... Esc aborts');
repeat until KeyPressed;
Ch := ReadKey;
if Ch = #27 then begin
CloseGraph;
Writeln('All done.');
Halt(1);
end
else
ClearViewPort;
MessageFrame('Press a key to stop action, Esc quits.');
end; { WaitToGo }
procedure TestGraphError(GraphErr: integer);
begin
if GraphErr <> grOk then begin
Writeln('Graphics error: ', GraphErrorMsg(GraphErr));
repeat until keypressed;
ch := readkey;
Halt(1);
end;
end;
procedure Init;
var
Err, I: integer;
StartX, StartY: integer;
Resolution: ResolutionPreference;
s: string;
begin
Resolution := Lower;
if paramcount > 0 then begin
s := paramstr(1);
if s[1] = '/' then
if upcase(s[2]) = 'H' then
Resolution := Higher;
end;
CurrentLine := 1;
ColorCount := 0;
IncrementCount := 0;
Ch := ' ';
GraphDriver := Detect;
DetectGraph(GraphDriver, GraphMode);
TestGraphError(GraphResult);
case GraphDriver of
CGA : begin
MaxDelta := 7;
GraphDriver := CGA;
GraphMode := CGAC1;
end;
MCGA : begin
MaxDelta := 7;
case GraphMode of
MCGAMed, MCGAHi: GraphMode := MCGAC1;
end;
end;
EGA : begin
MaxDelta := 16;
If Resolution = Lower then
GraphMode := EGALo
else
GraphMode := EGAHi;
end;
EGA64 : begin
MaxDelta := 16;
If Resolution = Lower then
GraphMode := EGA64Lo
else
GraphMode := EGA64Hi;
end;
HercMono : MaxDelta := 16;
EGAMono : MaxDelta := 16;
PC3270 : begin
MaxDelta := 7;
GraphDriver := CGA;
GraphMode := CGAC1;
end;
ATT400 : case GraphMode of
ATT400C1,
ATT400C2,
ATT400Med,
ATT400Hi :
begin
MaxDelta := 7;
GraphMode := ATT400C1;
end;
end;
VGA : begin
MaxDelta := 16;
end;
end;
InitGraph(GraphDriver, GraphMode, '');
TestGraphError(GraphResult);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
MaxColors := GetMaxColor;
BackColor := 0;
ChangeColors := TRUE;
Xmax := GetMaxX;
Ymax := GetMaxY;
ViewXmax := Xmax-2;
ViewYmax := (Ymax-(TextHeight('M')+4)-1)-2;
StartX := Xmax div 2;
StartY := Ymax div 2;
for I := 1 to Memory do with Line[I] do begin
LX1 := StartX; LX2 := StartX;
LY1 := StartY; LY2 := StartY;
end;
X1 := StartX;
X2 := StartX;
Y1 := StartY;
Y2 := StartY;
end; {init}
procedure AdjustX(var X,DeltaX: integer);
var
TestX: integer;
begin
TestX := X+DeltaX;
if (TestX<1) or (TestX>ViewXmax) then begin
TestX := X;
DeltaX := -DeltaX;
end;
X := TestX;
end;
procedure AdjustY(var Y,DeltaY: integer);
var
TestY: integer;
begin
TestY := Y+DeltaY;
if (TestY<1) or (TestY>ViewYmax) then begin
TestY := Y;
DeltaY := -DeltaY;
end;
Y := TestY;
end;
procedure SelectNewColors;
begin
if not ChangeColors then exit;
Colors[1] := Random(MaxColors)+1;
Colors[2] := Random(MaxColors)+1;
Colors[3] := Random(MaxColors)+1;
Colors[4] := Random(MaxColors)+1;
ColorCount := 3*(1+Random(5));
end;
procedure SelectNewDeltaValues;
begin
DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
IncrementCount := 2*(1+Random(4));
end;
procedure SaveCurrentLine(CurrentColors: ColorList);
begin
with Line[CurrentLine] do
begin
LX1 := X1;
LY1 := Y1;
LX2 := X2;
LY2 := Y2;
LColor := CurrentColors;
end;
end;
procedure Draw(x1,y1,x2,y2,color:word);
begin
SetColor(color);
Graph.Line(x1,y1,x2,y2);
end;
procedure Regenerate;
var
I: integer;
begin
Frame;
for I := 1 to Memory do with Line[I] do begin
Draw(LX1,LY1,LX2,LY2,LColor[1]);
Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,LColor[2]);
Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,LColor[3]);
Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,LColor[4]);
end;
WaitToGo;
Frame;
end;
procedure Updateline;
begin
Inc(CurrentLine);
if CurrentLine > Memory then CurrentLine := 1;
Dec(ColorCount);
Dec(IncrementCount);
end;
procedure CheckForUserInput;
begin
if KeyPressed then begin
Ch := ReadKey;
if Upcase(Ch) = 'B' then begin
if BackColor > MaxColors then BackColor := 0 else Inc(BackColor);
SetBkColor(BackColor);
end
else
if Upcase(Ch) = 'C' then begin
if ChangeColors then ChangeColors := FALSE else ChangeColors := TRUE;
ColorCount := 0;
end
else if Ch<>#27 then Regenerate;
end;
end;
procedure DrawCurrentLine;
var c1,c2,c3,c4: integer;
begin
c1 := Colors[1];
c2 := Colors[2];
c3 := Colors[3];
c4 := Colors[4];
if MaxColors = 1 then begin
c2 := c1; c3 := c1; c4 := c1;
end;
Draw(X1,Y1,X2,Y2,c1);
Draw(ViewXmax-X1,Y1,ViewXmax-X2,Y2,c2);
Draw(X1,ViewYmax-Y1,X2,ViewYmax-Y2,c3);
if MaxColors = 3 then c4 := Random(3)+1; { alternate colors }
Draw(ViewXmax-X1,ViewYmax-Y1,ViewXmax-X2,ViewYmax-Y2,c4);
SaveCurrentLine(Colors);
end;
procedure EraseCurrentLine;
begin
with Line[CurrentLine] do begin
Draw(LX1,LY1,LX2,LY2,0);
Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,0);
Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,0);
Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,0);
end;
end;
procedure DoArt;
begin
SelectNewColors;
repeat
EraseCurrentLine;
if ColorCount = 0 then SelectNewColors;
if IncrementCount=0 then SelectNewDeltaValues;
AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
if Random(5)=3 then begin
x1 := (x1+x2) div 2; { shorten the lines }
y2 := (y1+y2) div 2;
end;
DrawCurrentLine;
Updateline;
CheckForUserInput;
until Ch=#27;
end;
begin
Init;
Frame;
MessageFrame('Press a key to stop action, Esc quits.');
DoArt;
CloseGraph;
RestoreCrtMode;
Writeln('The End.');
end.


BIN
Borland Turbo Pascal v4/ATT.BGI Normal file
View File

Binary file not shown.

157
Borland Turbo Pascal v4/BCD.PAS Normal file
View File

@ -0,0 +1,157 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit BCD;
{ The BCD version of Turbo Pascal 3.0 (TURBOBCD.COM) supports
10-byte binary coded decimal reals with 18 significant digits
and a range of 1E-63 to 1E+63. The BCD real data type is not
supported by Turbo Pascal 4.0, and this unit provides a routine
for converting 3.0 BCD reals to 6-byte reals (software reals)
or 10-byte 8087 extended reals.
Before you convert a Turbo Pascal 3.0 BCD program to run under
4.0, you need to select a 4.0 real data type for your floating
point values. If you do not have an 8087, or if your program is
to run on machines without an 8087, your only option is to use
the familiar 6-byte Real, which provides 11-12 significant digits
with a range of 2.9E-39 to 1.7E+38. This type is also supported by
the standard version of Turbo Pascal 3.0. If you are planning to
use the 8087, we suggest you select the 10-byte Extended type,
which provides 19-20 significant digits with a range of 1.9E-4951
to 1.1E+4932. Once you have selected a data type, you need to write
a conversion program that translates your old data files using the
conversion routine provided here.
The Decimal type defined by this unit corresponds to the 3.0 BCD
Real, and the DecToFloat routine converts a Decimal variable to a
6-byte Real or to a 10-byte Extended.
The BCD unit uses conditional compilation constructs to define a
type Float which is equivalent to either Real or Extended,
depending on the kind of numeric processing you select (software
or hardware). To compile a program that uses the BCD unit, first
select software or hardware floating point, using the Options/
Compiler/Numeric processing menu, and then do a Compile/Build,
which automatically recompiles BCD.PAS.
The following program shows how to convert a 3.0 data file that
contains records with BCD fields. The program defines an equivalent
of the 3.0 record (OldDataRec) using the Decimal type for fields
that contain BCD reals. In the corresponding 4.0 record (NewDataRec),
floating point fields are declared using the Float type, which is
either Real or Extended depending on the floating point model
selected. During the conversion, all Decimal fields are converted
to Float using the DecToFloat function, whereas all non-real fields
are copied directly.
program ConvertBCD;
uses BCD;
type
OldDataRec = record
Name: string[15];
InPrice,OutPrice: Decimal;
InStock,MinStock: Integer;
end;
NewDataRec = record
Name: string[15];
InPrice,OutPrice: Float;
InStock,MinStock: Integer;
end;
var
OldFile: file of OldDataRec;
NewFile: file of NewDataRec;
Old: OldDataRec;
New: NewDataRec;
begin
Assign(OldFile,'OLDFILE.DTA'); Reset(F);
Assign(NewFile,'NEWFILE.DTA'); Rewrite(F);
while not Eof(OldFile) do
begin
Read(OldFile,Old);
New.Name := Old.Name;
New.InPrice := DecToFloat(Old.InPrice);
New.OutPrice := DecToFloat(Old.OutPrice);
New.InStock := Old.InStock;
New.MinStock := Old.MinStock;
Write(NewFile,New);
end;
Close(OldFile);
Close(NewFile);
end.
The range of a BCD real is larger than that of a 6-byte software
real. Therefore, when converting to 6-byte reals, BCD values larger
than 1E+38 are converted to 1E+38, and BCD values less than 2.9E-39
are converted to zero.
}
interface
type
Decimal = array[0..9] of Byte;
{$IFOPT N-}
Float = Real;
{$ELSE}
Float = Extended;
{$ENDIF}
function DecToFloat(var D: Decimal): Float;
implementation
function DecToFloat(var D: Decimal): Float;
var
E,L,P: Integer;
V: Float;
function Power10(E: Integer): Float;
var
I: Integer;
P: Float;
begin
I:=0; P:=1.0;
repeat
if Odd(E) then
case I of
0: P:=P*1E1;
1: P:=P*1E2;
2: P:=P*1E4;
3: P:=P*1E8;
4: P:=P*1E16;
5: P:=P*1E32;
end;
E:=E shr 1; Inc(I);
until E=0;
Power10:=P;
end;
begin
{$IFOPT N-}
if D[0] and $7F>38+$3F then V:=10E37 else
{$ENDIF}
begin
V:=0.0; L:=1;
while (L<=9) and (D[L]=0) do Inc(L);
if L<=9 then
begin
for P:=9 downto L do
begin
V:=V*100.0+((D[P] shr 4)*10+D[P] and $0F);
end;
E:=D[0] and $7F-($3F+(10-L)*2);
if E>=0 then V:=V*Power10(E) else
begin
if E<-32 then
begin
V:=V/1E32; E:=E+32;
end;
V:=V/Power10(-E);
end;
end;
end;
if D[0] and $80=0 then DecToFloat:=V else DecToFloat:=-V;
end;
end.


BIN
Borland Turbo Pascal v4/BINOBJ.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/CGA.BGI Normal file
View File

Binary file not shown.

75
Borland Turbo Pascal v4/CPASDEMO.C Normal file
View File

@ -0,0 +1,75 @@
/* Copyright (c) 1985, 87 by Borland International, Inc.
This module demonstrates how to write Turbo C routines that
can be linked into a Turbo Pascal program. Routines in this
module call Turbo Pascal routines in CPASDEMO.PAS.
See the instructions in the file CPASDEMO.PAS on running
this demonstration program */
typedef unsigned int word;
typedef unsigned char byte;
typedef unsigned long longword;
extern void setcolor(byte newcolor); /* procedure defined in
Turbo Pascal program */
extern word factor; /* variable declared in Turbo Pascal program */
word sqr(int i)
{
setcolor(1);
return(i * i);
} /* sqr */
word hibits(word w)
{
setcolor(2);
return(w >> 8);
} /* hibits */
byte suc(byte b)
{
setcolor(3);
return(++b);
} /* suc */
byte upr(byte c)
{
setcolor(4);
return((c >= 'a') && (c <= 'z') ? c - 32 : c);
} /* upr */
char prd(char s)
{
setcolor(5);
return(--s);
} /* prd */
long lobits(long l)
{
setcolor(6);
return((longword)l & 65535);
} /* lobits */
void strupr(char *s)
{
int counter;
for (counter = 1; counter <= s[0]; counter++) /* Note that the routine */
s[counter] = upr(s[counter]); /* skips Turbo Pascal's */
setcolor(7); /* length byte */
} /* strupr */
byte boolnot(byte b)
{
setcolor(8);
return(b == 0 ? 1 : 0);
} /* boolnot */
word multbyfactor(word w)
{
setcolor(9); /* note that this function accesses the Turbo Pascal */
return(w * factor); /* declared variable factor */
} /* multbyfactor */


126
Borland Turbo Pascal v4/CPASDEMO.PAS Normal file
View File

@ -0,0 +1,126 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program CPASDEMO;
(*
This program demonstrates how to interface Turbo Pascal and Turbo C.
Turbo C is used to generate an .OBJ file (CPASDEMO.OBJ). Then
this .OBJ is linked into this Turbo Pascal program using the {$L}
compiler directive.
NOTES:
1. Data declared in the Turbo C module cannot be accessed from
the Turbo Pascal program. Shared data must be declared in
Pascal.
2. If the C functions are only used in the implementation section
of a unit, declare them NEAR. If they are declared in the
interface section of a unit, declare them FAR. Always compile
the Turbo C modules using the small memory model.
3. Turbo C runtime library routines cannot be used because their
modules do not have the correct segment names. However, if you have
the Turbo C runtime library source (available from Borland),
you can use individual library modules by recompiling
them using CTOPAS.BAT. If you do recompile them, make sure
that you include prototypes in your C module for all C
library functions that you use.
4. Some of the code that Turbo C generates are calls to internal
routines. These cannot be used without recompiling the relevant
parts of the Turbo C runtime library source code.
In order to run this demonstration program you will need the following
files:
TCC.EXE and TURBO.CFG or
TC.EXE and CTOPAS.TC
To run the demonstration program CPASDEMO.EXE do the following:
1. First create a CPASDEMO.OBJ file compatible with Turbo Pascal 4.0
using Turbo C.
a) If you are using the Turbo C integrated environment (TC.EXE)
then at the DOS prompt execute:
TC /CCTOPAS.TC CPASDEMO.C
then create the .OBJ file by pressing ALT-F9.
b) If you are using the Turbo C command line version (TCC.EXE)
then at the DOS prompt execute:
TCC CPASDEMO.C
Note: Use the same configuration file (TURBO.CFG or CTOPAS.TC)
when you create your own Turbo C modules for use with
Turbo Pascal 4.0
2. Compile and execute the Turbo Pascal program CPASDEMO.PAS
This simple program calls each of the functions defined in the Turbo C
module. Each of the Turbo C functions changes the current display color
by calling the Turbo Pascal procedure SetColor. }
*)
uses Crt;
var
Factor : Word;
{$L CPASDEMO.OBJ} { link in the Turbo C-generated .OBJ module }
function Sqr(I : Integer) : Word; external;
{ Change the text color and return the square of I }
function HiBits(W : Word) : Word; external;
{ Change the text color and return the high byte of W }
function Suc(B : Byte) : Byte; external;
{ Change the text color and return B + 1 }
function Upr(C : Char) : Char; external;
{ Change the text color and return the upper case of C }
function Prd(S : ShortInt) : ShortInt; external;
{ Change the text color and return S - 1 }
function LoBits(L : LongInt) : LongInt; external;
{ Change the text color and return the low word of L }
procedure StrUpr(var S : string); external;
{ Change the text color and return the upper case of S - Note that the Turbo }
{ C routine must skip the length byte of the string. }
function BoolNot(B : Boolean) : Boolean; external;
{ Change the text color and return NOT B }
function MultByFactor(W : Word) : Word; external;
{ Change the text color and return W * Factor - note Turbo C's access of }
{ Turbo Pascal's global variable. }
procedure SetColor(NewColor : Byte); { A procedure that changes the current }
begin { display color by changing the CRT }
TextAttr := NewColor; { variable TextAttr }
end; { SetColor }
var
S : string;
begin
Writeln(Sqr(10)); { Call each of the functions defined }
Writeln(HiBits(30000)); { passing it the appropriate info. }
Writeln(Suc(200));
Writeln(Upr('x'));
Writeln(Prd(-100));
Writeln(LoBits(100000));
S := 'abcdefg';
StrUpr(S);
Writeln(S);
Writeln(BoolNot(False));
Factor := 100;
Writeln(MultbyFactor(10));
SetColor(LightGray);
end.


86
Borland Turbo Pascal v4/CRT.DOC Normal file
View File

@ -0,0 +1,86 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ CRT Unit Interface Documentation }
{ }
{ Copyright (c) 1987 Borland International, Inc. }
{ }
{*******************************************************}
{$D-,I-,S-}
unit Crt;
interface
const
{ CRT modes }
BW40 = 0; { 40x25 B/W on Color Adapter }
CO40 = 1; { 40x25 Color on Color Adapter }
BW80 = 2; { 80x25 B/W on Color Adapter }
CO80 = 3; { 80x25 Color on Color Adapter }
Mono = 7; { 80x25 on Monochrome Adapter }
Font8x8 = 256; { Add-in for ROM font }
{ Mode constants for 3.0 compatibility }
C40 = CO40;
C80 = CO80;
{ Foreground and background color constants }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
{ Foreground color constants }
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Add-in for blinking }
Blink = 128;
var
CheckBreak: Boolean; { Enable Ctrl-Break }
CheckEOF: Boolean; { Enable Ctrl-Z }
DirectVideo: Boolean; { Enable direct video addressing }
CheckSnow: Boolean; { Enable snow filtering }
LastMode: Word; { Current text mode }
TextAttr: Byte; { Current text attribute }
WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates }
SaveInt1B: Pointer; { Saved interrupt $1B }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Word);
procedure Window(X1,Y1,X2,Y2: Byte);
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;
implementation


147
Borland Turbo Pascal v4/CRTDEMO.PAS Normal file
View File

@ -0,0 +1,147 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program CrtDemo;
{ Example program that uses the Crt unit. Uses the following routines
from the Crt unit:
ClrScr
DelLine
GoToXY
InsLine
KeyPressed
ReadKey
TextBackground
TextColor
TextMode
WhereX
WhereY
Window
Write
WriteLn;
Also uses LastMode and WindMax variables from Crt unit.
1. Init routine:
- Save original video mode. On an EGA or VGA, use the 8x8 font
(43 lines on an EGA, 50 on VGA).
- Setup LastRow to preserve last line on screen for messages
(preserves last 2 lines in 40-column mode). Setup LastCol.
- Initialize the random number generator.
2. MakeWindow routine:
- Puts up random-sized, random-colored windows on screen.
3. Program body:
- Call Init
- Loop until Contrl-C is typed:
- Echo keystrokes (Turbo Pascal windows automatically wrap
and scroll).
- Support special keys:
<Ins> inserts a line at the cursor
<Del> deletes a line at the cursor
<Up>,
<Dn>,
<Right>,
<Left> position the cursor in the window
<Alt-R> generate random text until a key is pressed
<Alt-W> creates another random window
<ESC> exits the program
}
uses Crt;
var
OrigMode,LastCol,LastRow: Word;
Ch: Char;
Done: Boolean;
procedure Initialize;
{ Initialize the video mode, LastCol, LastRow, and the random number }
{ generator. Paint the help line. }
begin
CheckBreak:=False; { turn off Contrl-C checking }
OrigMode:=LastMode; { Remember original video mode }
TextMode(Lo(LastMode)+Font8x8); { use 43 or 50 lines on EGA/VGA }
LastCol:=Lo(WindMax)+1; { get last column, row }
LastRow:=Hi(WindMax)+1;
GoToXY(1,LastRow); { put message line on screen }
TextBackground(Black);
TextColor(White);
Write(' Ins-InsLine ',
'Del-DelLine ',
#27#24#25#26'-Cursor ',
'Alt-W-Window ',
'Alt-R-Random ',
'Esc-Exit');
Dec(LastRow,80 div LastCol); { don't write on message line }
Randomize; { init random number generator }
end; { Init }
procedure MakeWindow;
{ Make a random window, with random background and foreground colors }
var
X,Y,Width,Height: Word;
begin
Width:=Random(LastCol-2)+2; { random window size }
Height:=Random(LastRow-2)+2;
X:=Random(LastCol-Width)+1; { random position on screen }
Y:=Random(LastRow-Height)+1;
Window(X,Y,X+Width,Y+Height);
if OrigMode = Mono then
begin
TextBackground(White);
TextColor(Black);
ClrScr;
Window(X+1,Y+1,X+Width-1,Y+Height-1);
TextBackground(Black);
TextColor(White);
ClrScr;
end
else
begin
TextBackground(Random(8));
TextColor(Random(7)+9);
end;
ClrScr;
end; { MakeWindow }
procedure RandomText;
{ Generate random text until a key is pressed. Filter out }
{ control characters. }
begin
repeat
Write(Chr(Random(256-32)+32));
until KeyPressed;
end; { RandomText }
begin { program body }
Initialize;
MakeWindow;
Done:=False;
repeat
Ch:=ReadKey;
case Ch of
#0: { Function keys }
begin
Ch:=ReadKey;
case Ch of
#17: MakeWindow; { Alt-W }
#19: RandomText; { Alt-R }
#45: Done:=True; { Alt-X }
#72: GotoXY(WhereX,WhereY-1); { Up }
#75: GotoXY(WhereX-1,WhereY); { Left }
#77: GotoXY(WhereX+1,WhereY); { Right }
#80: GotoXY(WhereX,WhereY+1); { Down }
#82: InsLine; { Ins }
#83: DelLine; { Del }
end;
end;
#3: Done:=True; { Ctrl-C }
#13: WriteLn; { Enter }
#27: Done:=True; { Esc }
else
Write(Ch);
end;
until Done;
TextMode(OrigMode);
end.


BIN
Borland Turbo Pascal v4/CTOPAS.TC Normal file
View File

Binary file not shown.

117
Borland Turbo Pascal v4/DOS.DOC Normal file
View File

@ -0,0 +1,117 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ DOS Unit Interface Documentation }
{ }
{ Copyright (c) 1987 Borland International, Inc. }
{ }
{*******************************************************}
{$D-,I-,S-}
unit Dos;
interface
const
{ Flags bit masks }
FCarry = $0001;
FParity = $0004;
FAuxiliary = $0010;
FZero = $0040;
FSign = $0080;
FOverflow = $0800;
{ File mode magic numbers }
fmClosed = $D7B0;
fmInput = $D7B1;
fmOutput = $D7B2;
fmInOut = $D7B3;
{ File attribute constants }
ReadOnly = $01;
Hidden = $02;
SysFile = $04;
VolumeID = $08;
Directory = $10;
Archive = $20;
AnyFile = $3F;
type
{ Registers record used by Intr and MsDos }
Registers = record
case Integer of
0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
end;
{ Typed-file and untyped-file record }
FileRec = record
Handle: Word;
Mode: Word;
RecSize: Word;
Private: array[1..26] of Byte;
UserData: array[1..16] of Byte;
Name: array[0..79] of Char;
end;
{ Textfile record }
TextBuf = array[0..127] of Char;
TextRec = record
Handle: Word;
Mode: Word;
BufSize: Word;
Private: Word;
BufPos: Word;
BufEnd: Word;
BufPtr: ^TextBuf;
OpenFunc: Pointer;
InOutFunc: Pointer;
FlushFunc: Pointer;
CloseFunc: Pointer;
UserData: array[1..16] of Byte;
Name: array[0..79] of Char;
Buffer: TextBuf;
end;
{ Search record used by FindFirst and FindNext }
SearchRec = record
Fill: array[1..21] of Byte;
Attr: Byte;
Time: Longint;
Size: Longint;
Name: string[12];
end;
{ Date and time record used by PackTime and UnpackTime }
DateTime = record
Year,Month,Day,Hour,Min,Sec: Word;
end;
var
DosError: Integer; { Error status variable }
procedure Intr(IntNo: Byte; var Regs: Registers);
procedure MsDos(var Regs: Registers);
procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
procedure SetDate(Year,Month,Day: Word);
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
procedure SetTime(Hour,Minute,Second,Sec100: Word);
function DiskFree(Drive: Byte): Longint;
function DiskSize(Drive: Byte): Longint;
procedure GetFAttr(var F; var Attr: Word);
procedure SetFAttr(var F; Attr: Word);
procedure GetFTime(var F; var Time: Longint);
procedure SetFTime(var F; Time: Longint);
procedure FindFirst(Path: String; Attr: Word; var F: SearchRec);
procedure FindNext(var F: SearchRec);
procedure UnpackTime(P: Longint; var T: DateTime);
procedure PackTime(var T: DateTime; var P: Longint);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
procedure Keep(ExitCode: Word);
procedure Exec(Path,CmdLine: String);
function DosExitCode: Word;
implementation


28
Borland Turbo Pascal v4/DOS_GT.BAK Normal file
View File

@ -0,0 +1,28 @@
type
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
end;
procedure get_time( var tt : timetype );
var
recpack: regpack;
ah,al,ch,cl,dh: byte;
begin
ah := $2c;
with recpack do
begin
ax := ah shl 8 + al;
end;
Intr( $21, recpack );
with recpack do
begin
tt.h := cx shr 8;
tt.m := cx mod 256;
tt.s := dx shr 8;
tt.l := dx mod 256;
end;
end;


19
Borland Turbo Pascal v4/DOS_GT.PAS Normal file
View File

@ -0,0 +1,19 @@
procedure get_time( var tt : timetype );
var
regs: registers;
begin
regs.AH := $2c;
regs.AL := 0;
Intr( $21, regs );
with regs do
begin
tt.h := CX shr 8;
tt.m := CX mod 256;
tt.s := DX shr 8;
tt.l := DX mod 256;
end;
end;


35
Borland Turbo Pascal v4/DRIVERS.PAS Normal file
View File

@ -0,0 +1,35 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit Drivers;
{ Sample unit to accompany GRLINK.PAS. This unit links all the BGI graphics
driver into a single TPU file. This makes it easy to link the driver files
directly into an .EXE file. See GRLINK.PAS for more information.
}
interface
procedure ATTDriverProc;
procedure CgaDriverProc;
procedure EgaVgaDriverProc;
procedure HercDriverProc;
procedure PC3270DriverProc;
implementation
procedure ATTDriverProc; external;
{$L ATT.OBJ }
procedure CgaDriverProc; external;
{$L CGA.OBJ }
procedure EgaVgaDriverProc; external;
{$L EGAVGA.OBJ }
procedure HercDriverProc; external;
{$L HERC.OBJ }
procedure PC3270DriverProc; external;
{$L PC3270.OBJ }
end.


42
Borland Turbo Pascal v4/E.PAS Normal file
View File

@ -0,0 +1,42 @@
program e;
const
DIGITS = 200;
type
arrayType = array[ 0..DIGITS ] of integer;
var
high, n, x : integer;
a : arrayType;
begin
high := DIGITS;
x := 0;
n := high - 1;
while n > 0 do begin
a[ n ] := 1;
n := n - 1;
end;
a[ 1 ] := 2;
a[ 0 ] := 0;
while high > 9 do begin
high := high - 1;
n := high;
while 0 <> n do begin
a[ n ] := x MOD n;
x := 10 * a[ n - 1 ] + x DIV n;
n := n - 1;
end;
Write( x );
end;
writeln;
writeln( 'done' );
end.


BIN
Borland Turbo Pascal v4/EGAVGA.BGI Normal file
View File

Binary file not shown.

439
Borland Turbo Pascal v4/EMS.PAS Normal file
View File

@ -0,0 +1,439 @@
program Ems_Test;
{ *************************************************************
* This program shows you how to use the basic functions of *
* the LIM Expanded Memory Specification. Since it does not *
* use any of the LIM EMS 4.0 function calls, you can also *
* use it on systems with EMS versions less than 4.0 *
************************************************************* }
{ Written by:
Peter Immarco.
Thought Dynamics
Manhattan Beach, CA
Compuserve ID# 73770,123
*** Public Domain ***
Used by permission of the author.
}
{ This program does the following:
+------------------------------------------------------------+
| * Makes sure the LIM Expanded Memory Manager (EMM) has |
| been installed in memory |
| * Displays the version number of the EMM present in memory |
| * Determines if there are enough pages (16k blocks) of |
| memory for our test program's usage. It then displays |
| the total number of EMS pages present in the system, |
| and how many are available for our usage |
| * Requests the desired number of pages from the EMM |
| * Maps a logical page onto one of the physical pages given |
| to us |
| * Displays the base address of our EMS memory page frame |
| * Performs a simple read/write test on the EMS memory given|
| to us |
| * Returns the EMS memory given to us back to the EMM, and |
| exits |
+------------------------------------------------------------|}
{ All the calls are structured to return the result or error
code of the Expanded Memory function performed as an integer.
If the error code is not zero, which means the call failed,
a simple error procedure is called and the program terminates.}
uses Crt, Dos;
Type
ST3 = string[3];
ST80 = string[80];
ST5 = string[5];
Const
EMM_INT = $67;
DOS_Int = $21;
GET_PAGE_FRAME = $41;
GET_UNALLOCATED_PAGE_COUNT= $42;
ALLOCATE_PAGES = $43;
MAP_PAGES = $44;
DEALLOCATE_PAGES = $45;
GET_VERSION = $46;
STATUS_OK = 0;
{ We'll say we need 1 EMS page for our application }
APPLICATION_PAGE_COUNT = 1;
Var
Regs: Registers;
Emm_Handle,
Page_Frame_Base_Address,
Pages_Needed,
Physical_Page,
Logical_Page,
Offset,
Error_Code,
Pages_EMS_Available,
Total_EMS_Pages,
Available_EMS_Pages: Word;
Version_Number,
Pages_Number_String: ST3;
Verify: Boolean;
{ * --------------------------------------------------------- * }
{ The function Hex_String converts an Word into a four
character hexadecimal number(string) with leading zeroes. }
Function Hex_String(Number: Word): ST5;
Function Hex_Char(Number: Word): Char;
Begin
If Number<10 then
Hex_Char:=Char(Number+48)
else
Hex_Char:=Char(Number+55);
end; { Function Hex_Char }
Var
S: ST5;
Begin
S:='';
S:=Hex_Char( (Number shr 1) div 2048);
Number:=( ((Number shr 1) mod 2048) shl 1)+
(Number and 1) ;
S:=S+Hex_Char(Number div 256);
Number:=Number mod 256;
S:=S+Hex_Char(Number div 16);
Number:=Number mod 16;
S:=S+Hex_Char(Number);
Hex_String:=S+'h';
end; { Function Hex_String }
{ * --------------------------------------------------------- * }
{ The function Emm_Installed checks to see if the Expanded
Memory Manager (EMM) is loaded in memory. It does this by
looking for the string 'EMMXXXX0', which should be located
at 10 bytes from the beginning of the code segment pointed
to by the EMM interrupt, 67h }
Function Emm_Installed: Boolean;
Var
Emm_Device_Name : string[8];
Int_67_Device_Name : string[8];
Position : Word;
Regs : registers;
Begin
Int_67_Device_Name:='';
Emm_Device_Name :='EMMXXXX0';
with Regs do
Begin
{ Get the code segment pointed to by Interrupt 67h, the EMM
interrupt by using DOS call $35, 'get interrupt vector' }
AH:=$35;
AL:=EMM_INT;
Intr(DOS_int,Regs);
{ The ES pseudo-register contains the segment address pointed
to by Interrupt 67h }
{ Create an 8 character string from the 8 successive bytes
pointed to by ES:$0A (10 bytes from ES) }
For Position:=0 to 7 do
Int_67_Device_Name:=
Int_67_Device_Name+Chr(mem[ES:Position+$0A]);
Emm_Installed:=True;
{ Is it the EMM manager signature, 'EMMXXXX0'? then EMM is
installed and ready for use, if not, then the EMM manager
is not present }
If Int_67_Device_Name<>Emm_Device_Name
then Emm_Installed:=False;
end; { with Regs do }
end; { Function Emm_Installed }
{ * --------------------------------------------------------- * }
{ This function returns the total number of EMS pages present
in the system, and the number of EMS pages that are
available for our use }
Function EMS_Pages_Available
(Var Total_EMS_Pages,Pages_Available: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Get_Unallocated_Page_Count;
intr(EMM_INT,Regs);
{ The number of EMS pages available is returned in BX }
Pages_Available:=BX;
{ The total number of pages present in the system is
returned in DX }
Total_EMS_Pages:=DX;
{ Return the error code }
EMS_Pages_Available:=AH
end;
end; { EMS_Pages_Available }
{ * --------------------------------------------------------- * }
{ This function requests the desired number of pages from the
EMM }
Function Allocate_Expanded_Memory_Pages
(Pages_Needed: Word; Var Handle: Word ): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:= Allocate_Pages;
{ Put the desired number of pages in BX }
BX:=Pages_Needed;
intr(EMM_INT,Regs);
{ Our EMS handle is returned in DX }
Handle:=DX;
{ Return the error code }
Allocate_Expanded_Memory_Pages:=AH;
end;
end; { Function Allocate_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function maps a logical page onto one of the physical
pages made available to us by the
Allocate_Expanded_Memory_Pages function }
Function Map_Expanded_Memory_Pages
(Handle,Logical_Page,Physical_Page: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Map_Pages;
{ Put the physical page number to be mapped into AL }
AL:=Physical_Page;
{ Put the logical page number to be mapped in BX }
BX:=Logical_Page;
{ Put the EMS handle assigned to us earlier in DX }
DX:=Handle;
Intr(EMM_INT,Regs);
{ Return the error code }
Map_Expanded_Memory_Pages:=AH;
end; { with Regs do }
end; { Function Map_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function gets the physical address of the EMS page
frame we are using. The address returned is the segment
of the page frame. }
Function Get_Page_Frame_Base_Address
(Var Page_Frame_Address: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Get_Page_Frame;
intr(EMM_INT,Regs);
{ The page frame base address is returned in BX }
Page_Frame_Address:=BX;
{ Return the error code }
Get_Page_Frame_Base_Address:=AH;
end; { Regs }
end; { Function Get_Page_Frame_Base_Address }
{ * --------------------------------------------------------- * }
{ This function releases the EMS memory pages allocated to
us, back to the EMS memory pool. }
Function Deallocate_Expanded_Memory_Pages
(Handle: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-register }
AH:=DEALLOCATE_PAGES;
{ Put the EMS handle assigned to our EMS memory pages in DX }
DX:=Emm_Handle;
Intr(EMM_INT,Regs);
{ Return the error code }
Deallocate_Expanded_Memory_Pages:=AH;
end; { with Regs do }
end; { Function Deallocate_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function returns the version number of the EMM as
a 3 character string. }
Function Get_Version_Number(Var Version_String: ST3): Word;
Var
Regs: Registers;
Word_Part,Fractional_Part: Char;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-register }
AH:=GET_VERSION;
Intr(EMM_INT,Regs);
{ See if call was successful }
If AH=STATUS_OK then
Begin
{ The upper four bits of AH are the Word portion of the
version number, the lower four bits are the fractional
portion. Convert the Word value to ASCII by adding 48. }
Word_Part := Char( AL shr 4 + 48);
Fractional_Part:= Char( AL and $F +48);
Version_String:= Word_Part+'.'+Fractional_Part;
end; { If AH=STATUS_OK }
{ Return the function calls error code }
Get_Version_Number:=AH;
end; { with Regs do }
end; { Function Get_Version_Number }
{ * --------------------------------------------------------- * }
{ This procedure prints an error message passed by the caller,
prints the error code passed by the caller in hex, and then
terminates the program with the an error level of 1 }
Procedure Error(Error_Message: ST80; Error_Number: Word);
Begin
Writeln(Error_Message);
Writeln(' Error_Number = ',Hex_String(Error_Number) );
Writeln('EMS test program aborting.');
Halt(1);
end; { Procedure Error_Message }
{ * --------------------------------------------------------- * }
{ EMS_TEST }
{ This program is an example of the basic EMS functions that you
need to execute in order to use EMS memory with Turbo Pascal }
Begin
ClrScr;
Window(5,2,77,22);
{ Determine if the Expanded Memory Manager is installed, If
not, then terminate 'main' with an ErrorLevel code of 1. }
If not (Emm_Installed) then
Begin
Writeln('The LIM Expanded Memory Manager is not installed.');
Halt(1);
end;
{ Get the version number and display it }
Error_Code:= Get_Version_Number(Version_Number);
If Error_Code<>STATUS_OK then
Error('Error trying to get the EMS version number ',
Error_code)
else
Writeln('LIM Expanded Memory Manager, version ',
Version_Number,' is ready for use.');
Writeln;
{ Determine if there are enough expanded memory pages for this
application. }
Pages_Needed:=APPLICATION_PAGE_COUNT;
Error_Code:=
EMS_Pages_Available(Total_EMS_Pages,Available_EMS_Pages);
If Error_Code<>STATUS_OK then
Error('Error trying to determine the number of EMS pages available.',
Error_code);
Writeln('There are a total of ',Total_EMS_Pages,
' expanded memory pages present in this system.');
Writeln(' ',Available_EMS_Pages,
' of those pages are available for your usage.');
Writeln;
{ If there is an insufficient number of pages for our application,
then report the error and terminate the EMS test program }
If Pages_Needed>Available_EMS_Pages then
Begin
Str(Pages_Needed,Pages_Number_String);
Error('We need '+Pages_Number_String+
' EMS pages. There are not that many available.',
Error_Code);
end; { Pages_Needed>Available_EMS_Pages }
{ Allocate expanded memory pages for our usage }
Error_Code:= Allocate_Expanded_Memory_Pages(Pages_Needed,Emm_Handle);
Str(Pages_Needed,Pages_Number_String);
If Error_Code<>STATUS_OK then
Error('EMS test program failed trying to allocate '+Pages_Number_String+
' pages for usage.',Error_Code);
Writeln(APPLICATION_PAGE_COUNT,
' EMS page(s) allocated for the EMS test program.');
Writeln;
{ Map in the required logical pages to the physical pages
given to us, in this case just one page }
Logical_Page :=0;
Physical_Page:=0;
Error_Code:=
Map_Expanded_Memory_Pages(
Emm_Handle,Logical_Page,Physical_Page);
If Error_Code<>STATUS_OK then
Error('EMS test program failed trying to map '+
'logical pages onto physical pages.',Error_Code);
Writeln('Logical Page ',Logical_Page,
' successfully mapped onto Physical Page ',
Physical_Page);
Writeln;
{ Get the expanded memory page frame address }
Error_Code:= Get_Page_Frame_Base_Address(Page_Frame_Base_Address);
If Error_Code<>STATUS_OK then
Error('EMS test program unable to get the base Page'+
' Frame Address.',Error_Code);
Writeln('The base address of the EMS page frame is - '+
Hex_String(Page_Frame_Base_Address) );
Writeln;
{ Write a test pattern to expanded memory }
For Offset:=0 to 16382 do
Mem[Page_Frame_Base_Address:Offset]:=Offset mod 256;
{ Make sure that what is in EMS memory is what we just wrote }
Writeln('Testing EMS memory.');
Offset:=1;
Verify:=True;
while (Offset<=16382) and (Verify=True) do
Begin
If Mem[Page_Frame_Base_Address:Offset]<>Offset mod 256 then
Verify:=False;
Offset:=Succ(Offset);
end; { while (Offset<=16382) and (Verify=True) }
{ If it isn't report the error }
If not Verify then
Error('What was written to EMS memory was not found during '+
'memory verification test.',0);
Writeln('EMS memory test successful.');
Writeln;
{ Return the expanded memory pages given to us back to the
EMS memory pool before terminating our test program }
Error_Code:=Deallocate_Expanded_Memory_Pages(Emm_Handle);
If Error_Code<>STATUS_OK then
Error('EMS test program was unable to deallocate '+
'the EMS pages in use.',Error_Code);
Writeln(APPLICATION_PAGE_COUNT,
' page(s) deallocated.');
Writeln;
Writeln('EMS test program completed.');
end.


46
Borland Turbo Pascal v4/FIB8087.PAS Normal file
View File

@ -0,0 +1,46 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
{$N+}
program Fib8087;
{
Sample program from P-335 in the Owner's Handbook that
demonstrates how to avoid 8087 stack overflow in recursive
functions that use the 8087 math co-processor. Local variables
are used to store temporary results on the 8086 stack.
Note: THIS PROGRAM REQUIRES A MATH CO-PROCESSOR
}
var
i : integer;
function Fib(N : integer) : extended;
{ calculate the fibonacci sequence for N }
var
F1, F2 : extended;
begin
if N = 0 then
Fib := 0.0
else
if N = 1 then
Fib := 1.0
else
begin
(* Use this line instead of the 3 lines that follow this
comment to cause an 8087 stack overflow for values of
N >= 8:
Fib := Fib(N - 1) + Fib(N - 2); { will cause overflow for N > 8 }
*)
F1 := Fib(N - 1); { store results in temporaries on 8086 }
F2 := Fib(N - 2); { stack to avoid 8087 stack overflow }
Fib := F1 + F2;
end;
end; { Fib }
begin
for i := 0 to 15 do
Writeln(i, '. ', Fib(i));
end.


31
Borland Turbo Pascal v4/FONTS.PAS Normal file
View File

@ -0,0 +1,31 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit Fonts;
{ Sample unit to accompany GRLINK.PAS. This unit links all the BGI graphics
fonts into a single TPU file. This makes it easy to incorporate the font
files directly into an .EXE file. See GRLINK.PAS for more information.
}
interface
procedure GothicFontProc;
procedure SansSerifFontProc;
procedure SmallFontProc;
procedure TriplexFontProc;
implementation
procedure GothicFontProc; external;
{$L GOTH.OBJ }
procedure SansSerifFontProc; external;
{$L SANS.OBJ }
procedure SmallFontProc; external;
{$L LITT.OBJ }
procedure TriplexFontProc; external;
{$L TRIP.OBJ }
end.


BIN
Borland Turbo Pascal v4/GOTH.CHR Normal file
View File

Binary file not shown.

249
Borland Turbo Pascal v4/GR3DEMO.PAS Normal file
View File

@ -0,0 +1,249 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program GR3DEMO;
{
TURTLEGRAPHICS DEMO PROGRAM
This programs demonstrates the use of Turbo Pascal 3.0's
turtle graphics by using Version 4.0's GRAPH3 unit.
NOTE: You must have a color graphics adapter to use this
program.
PSEUDO CODE
1. Initialize program variables.
2. Play with the turtle routines.
a. Start with medium resolution graphics.
b. Read a character and manipulate the turtle until
the user pressed <ESC> or ^C.
3. Reset screen to text mode and quit.
Here is a list of the commands that this program uses:
Function Keys:
F1 Turns turtle to the left.
F2 Turns turtle to the right.
Cursor Keys:
They point the turtle:
Up arrow, north
Down arrow, south
Right arrow, east
Left arrow: west
Home, northwest
PgUp, northeast
PgDn, southeast
End: southwest
Alpha keys:
0 thru 9: Set the magnitude for speed.
(i.e. 0 is stop, 1 is slow, 9 is fast)
H: Sets video mode to High resolution.
M: Sets video mode to Medium resolution.
W: TOGGLE: Wrap on / off
P: TOGGLE: PenUp / PenDown.
T: TOGGLE: Hide / show the turtle.
C: Changes the color (or intensity) of the lines.
+: Homes the turtle.
<ESC>: Quits the turtle demo.
}
uses
Crt,
Turbo3,
Graph3;
const
TurtleSpeed = 50;
type
ToggleCommands = (PenOn, WrapOn, TurtleOn);
var
ToggleRay : array[PenOn..TurtleOn] of boolean;
Magnitude, { Sets speed: 0 = stopped, 9 = fast }
Color, { Current palette color }
CurentPalette: Integer; { Current Palette }
procedure Init;
var Toggle: ToggleCommands;
procedure VerifyGraphicsCard;
var ch : char;
begin
ClrScr;
Writeln('You must have a color graphics adapter to use this program.');
write('CONTINUE? (Y/N): ');
repeat
ch := UpCase(ReadKey);
if ch in ['N', #27, ^C] then
begin
TextMode(LastMode);
Halt;
end;
until ch = 'Y';
end; { VerifyGraphicsCard }
begin
VerifyGraphicsCard;
Magnitude := 0; { Stopped }
Color := 0;
for Toggle := PenOn to TurtleOn do
ToggleRay[Toggle] := true; { Start with all commands toggled on }
end;
procedure PlayWithTurtle;
var
InKey: Char;
FunctionKey: Boolean; { TRUE if a function key was pressed }
procedure NewScreen(SetRes : char);
procedure DrawBox(x, y, w, h : integer);
begin
Draw(x, y, x + w, y, 1); { top }
Draw(x, y, x, y + h, 1); { left side }
Draw(x, y + h, x + w, y + h, 1); { bottom }
Draw(x + w, y + h, x + w, y, 1); { right side }
end; { DrawBox }
procedure HiResOn;
const
CharHeight = 10;
begin
HiRes;
HiResColor(Yellow);
DrawBox(0, 0, 639, 199-CharHeight);
TurtleWindow(319, 99-(CharHeight DIV 2), 638, 198-CharHeight);
end; { HiResOn }
procedure MediumResOn;
const
CharHeight = 20;
begin
GraphColorMode;
DrawBox(0, 0, 319, 199-CharHeight);
TurtleWindow(159, 99-(CharHeight DIV 2), 318, 198-CharHeight);
end; { MediumResOn }
begin
case SetRes of
'M' : begin
MediumResOn;
GoToXY(1, 24);
writeln('SPEED:0-9 TOGGLES:Pen,Wrap,Turtle,Color');
write(' TURN: F1,F2, HOME: +, RES: Hi,Med');
end;
'H' : begin
HiResOn;
GoToXY(1, 25);
write(' SPEED: 0-9 TOGGLES: Pen,Wrap,Turtle,Color');
write(' TURN: F1,F2 HOME: + RES: Hi,Med');
end;
end; { case }
Showturtle;
home;
Wrap;
Magnitude := 0;
end; { NewScreen }
function GetKey(var FunctionKey: Boolean): char;
var ch: char;
begin
ch := ReadKey;
If (Ch = #0) Then { it must be a function key }
begin
ch := ReadKey;
FunctionKey := true;
end
else FunctionKey := false;
GetKey := Ch;
end;
procedure TurtleDo(InKey : char; FunctionKey : boolean);
const
NorthEast = 45;
SouthEast = 135;
SouthWest = 225;
NorthWest = 315;
procedure DoFunctionCommand(FunctionKey: char);
begin
case FunctionKey of
'H': SetHeading(North); { Up arrow Key }
'P': SetHeading(South); { Down arrow Key }
'M': SetHeading(East); { Left arrow Key }
'K': SetHeading(West); { Right arrow Key }
'I': SetHeading(NorthEast); { PgUp }
'Q': SetHeading(SouthEast); { PgDn }
'G': SetHeading(NorthWest); { Home }
'O': SetHeading(SouthWest); { End }
'<': SetHeading(Heading+5); { F1 }
';': SetHeading(Heading-5); { F2 }
end
end { Do function command };
begin
If FunctionKey then DoFunctionCommand(Upcase(InKey))
else
case upcase(InKey) of
'P': begin
ToggleRay[PenOn] := NOT ToggleRay[PenOn];
case ToggleRay[PenOn] of
true : PenUp;
false : PenDown;
end; { case }
end;
'W': begin
ToggleRay[WrapOn] := NOT ToggleRay[WrapOn];
case ToggleRay[WrapOn] of
true : Wrap;
false : NoWrap;
end; { case }
end;
'T': begin
ToggleRay[TurtleOn] := NOT ToggleRay[TurtleOn];
case ToggleRay[TurtleOn] of
true : ShowTurtle;
false : HideTurtle;
end; { case }
end;
'+': Home;
'C': begin
Color := succ(color) mod 4;
SetPenColor(Color);
end;
'0'..'9': Magnitude := Sqr(ord(inkey) - ord('0'));
'M': begin
NewScreen('M'); { medium resolution graphics }
end;
'H': begin
NewScreen('H'); { HiRes graphics }
end;
end; { case }
end; { TurtleDo }
begin { PlayWithTurtle }
NewScreen('M'); { start with medium resolution graphics }
repeat
TurtleDelay(TurtleSpeed);
repeat
if Magnitude <> 0 then forwd(Magnitude);
until KeyPressed;
Inkey := GetKey(FunctionKey);
TurtleDo(InKey, FunctionKey);
until UpCase(Inkey) in [#27, ^C];
end; { PlayWithTurtle }
begin { program body }
Init;
PlayWithTurtle;
ClearScreen;
TextMode(LastMode);
end.


304
Borland Turbo Pascal v4/GRAPH.DOC Normal file
View File

@ -0,0 +1,304 @@
{*********************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ GRAPH Unit Interface Documentation }
{ }
{ Copyright (c) 1987 by Borland International, Inc. }
{ }
{*********************************************************}
{$D-,R-,S-}
unit Graph;
interface
const
{ GraphResult error return codes: }
grOk = 0;
grNoInitGraph = -1;
grNotDetected = -2;
grFileNotFound = -3;
grInvalidDriver = -4;
grNoLoadMem = -5;
grNoScanMem = -6;
grNoFloodMem = -7;
grFontNotFound = -8;
grNoFontMem = -9;
grInvalidMode = -10;
grError = -11; { generic error }
grIOerror = -12;
grInvalidFont = -13;
grInvalidFontNum = -14;
grInvalidDeviceNum = -15;
{ define graphics drivers }
Detect = 0; { requests autodetection }
CGA = 1;
MCGA = 2;
EGA = 3;
EGA64 = 4;
EGAMono = 5;
RESERVED = 6;
HercMono = 7;
ATT400 = 8;
VGA = 9;
PC3270 = 10;
{ graphics modes for each driver }
CGAC0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
CGAC1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
CGAC2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
CGAC3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
CGAHi = 4; { 640x200 1 page }
MCGAC0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
MCGAC1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
MCGAC2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
MCGAC3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
MCGAMed = 4; { 640x200 1 page }
MCGAHi = 5; { 640x480 1 page }
EGALo = 0; { 640x200 16 color 4 page }
EGAHi = 1; { 640x350 16 color 2 page }
EGA64Lo = 0; { 640x200 16 color 1 page }
EGA64Hi = 1; { 640x350 4 color 1 page }
EGAMonoHi = 3; { 640x350 64K on card, 1 page; 256K on card, 2 page }
HercMonoHi = 0; { 720x348 2 page }
ATT400C0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
ATT400C1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
ATT400C2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
ATT400C3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
ATT400Med = 4; { 640x200 1 page }
ATT400Hi = 5; { 640x400 1 page }
VGALo = 0; { 640x200 16 color 4 page }
VGAMed = 1; { 640x350 16 color 2 page }
VGAHi = 2; { 640x480 16 color 1 page }
PC3270Hi = 0; { 720x350 1 page }
{ Colors for SetPalette and SetAllPalette: }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Line styles and widths for Get/SetLineStyle: }
SolidLn = 0;
DottedLn = 1;
CenterLn = 2;
DashedLn = 3;
UserBitLn = 4; { User-defined line style }
NormWidth = 1;
ThickWidth = 3;
{ Set/GetTextStyle constants: }
DefaultFont = 0; { 8x8 bit mapped font }
TriplexFont = 1; { "Stroked" fonts }
SmallFont = 2;
SansSerifFont = 3;
GothicFont = 4;
HorizDir = 0; { left to right }
VertDir = 1; { bottom to top }
UserCharSize = 0; { user-defined char size }
{ Clipping constants: }
ClipOn = true;
ClipOff = false;
{ Bar3D constants: }
TopOn = true;
TopOff = false;
{ Fill patterns for Get/SetFillStyle: }
EmptyFill = 0; { fills area in background color }
SolidFill = 1; { fills area in solid fill color }
LineFill = 2; { --- fill }
LtSlashFill = 3; { /// fill }
SlashFill = 4; { /// fill with thick lines }
BkSlashFill = 5; { \\\ fill with thick lines }
LtBkSlashFill = 6; { \\\ fill }
HatchFill = 7; { light hatch fill }
XHatchFill = 8; { heavy cross hatch fill }
InterleaveFill = 9; { interleaving line fill }
WideDotFill = 10; { Widely spaced dot fill }
CloseDotFill = 11; { Closely spaced dot fill }
UserFill = 12; { user defined fill }
{ BitBlt operators for PutImage: }
NormalPut = 0; { MOV }
XORPut = 1; { XOR }
OrPut = 2; { OR }
AndPut = 3; { AND }
NotPut = 4; { NOT }
{ Horizontal and vertical justification for SetTextJustify: }
LeftText = 0;
CenterText = 1;
RightText = 2;
BottomText = 0;
{ CenterText = 1; already defined above }
TopText = 2;
const
MaxColors = 15;
type
PaletteType = record
Size : byte;
Colors : array[0..MaxColors] of shortint;
end;
LineSettingsType = record
LineStyle : word;
Pattern : word;
Thickness : word;
end;
TextSettingsType = record
Font : word;
Direction : word;
CharSize : word;
Horiz : word;
Vert : word;
end;
FillSettingsType = record { Pre-defined fill style }
Pattern : word;
Color : word;
end;
FillPatternType = array[1..8] of byte; { User defined fill style }
PointType = record
X, Y : integer;
end;
ViewPortType = record
x1, y1, x2, y2 : integer;
Clip : boolean;
end;
ArcCoordsType = record
X, Y : integer;
Xstart, Ystart : integer;
Xend, Yend : integer;
end;
var
GraphGetMemPtr : Pointer; { allows user to steal heap allocation }
GraphFreeMemPtr : Pointer; { allows user to steal heap de-allocation }
{ *** high-level error handling *** }
function GraphErrorMsg(ErrorCode : integer) : String;
function GraphResult : integer;
{ *** detection, initialization and crt mode routines *** }
procedure DetectGraph(var GraphDriver, GraphMode : integer);
procedure InitGraph(var GraphDriver : integer;
var GraphMode : integer;
PathToDriver : String);
function RegisterBGIfont(font : pointer) : integer;
function RegisterBGIdriver(driver : pointer) : integer;
procedure SetGraphBufSize(BufSize : word);
procedure GetModeRange(GraphDriver : integer; var LoMode, HiMode : integer);
procedure SetGraphMode(Mode : integer);
function GetGraphMode : integer;
procedure GraphDefaults;
procedure RestoreCrtMode;
procedure CloseGraph;
function GetX : integer;
function GetY : integer;
function GetMaxX : integer;
function GetMaxY : integer;
{ *** Screen, viewport, page routines *** }
procedure ClearDevice;
procedure SetViewPort(x1, y1, x2, y2 : integer; Clip : boolean);
procedure GetViewSettings(var ViewPort : ViewPortType);
procedure ClearViewPort;
procedure SetVisualPage(Page : word);
procedure SetActivePage(Page : word);
{ *** point-oriented routines *** }
procedure PutPixel(X, Y : integer; Pixel : word);
function GetPixel(X, Y : integer) : word;
{ *** line-oriented routines *** }
procedure LineTo(X, Y : integer);
procedure LineRel(Dx, Dy : integer);
procedure MoveTo(X, Y : integer);
procedure MoveRel(Dx, Dy : integer);
procedure Line(x1, y1, x2, y2 : integer);
procedure GetLineSettings(var LineInfo : LineSettingsType);
procedure SetLineStyle(LineStyle : word;
Pattern : word;
Thickness : word);
{ *** polygon, fills and figures *** }
procedure Rectangle(x1, y1, x2, y2 : integer);
procedure Bar(x1, y1, x2, y2 : integer);
procedure Bar3D(x1, y1, x2, y2 : integer; Depth : word; Top : boolean);
procedure DrawPoly(NumPoints : word; var PolyPoints);
procedure FillPoly(NumPoints : word; var PolyPoints);
procedure GetFillSettings(var FillInfo : FillSettingsType);
procedure GetFillPattern(var FillPattern : FillPatternType);
procedure SetFillStyle(Pattern : word; Color : word);
procedure SetFillPattern(Pattern : FillPatternType; Color : word);
procedure FloodFill(X, Y : integer; Border : word);
{ *** arc, circle, and other curves *** }
procedure Arc(X, Y : integer; StAngle, EndAngle, Radius : word);
procedure GetArcCoords(var ArcCoords : ArcCoordsType);
procedure Circle(X, Y : integer; Radius : word);
procedure Ellipse(X, Y : integer;
StAngle, EndAngle : word;
XRadius, YRadius : word);
procedure GetAspectRatio(var Xasp, Yasp : word);
procedure PieSlice(X, Y : integer; StAngle, EndAngle, Radius : word);
{ *** color and palette routines *** }
procedure SetBkColor(Color : word);
procedure SetColor(Color : word);
function GetBkColor : word;
function GetColor : word;
procedure SetAllPalette(var Palette);
procedure SetPalette(ColorNum : word; Color : shortint);
procedure GetPalette(var Palette : PaletteType);
function GetMaxColor : word;
{ *** bit-image routines *** }
function ImageSize(x1, y1, x2, y2 : integer) : word;
procedure GetImage(x1, y1, x2, y2 : integer; var BitMap);
procedure PutImage(X, Y : integer; var BitMap; BitBlt : word);
{ *** text routines *** }
procedure GetTextSettings(var TextInfo : TextSettingsType);
procedure OutText(TextString : string);
procedure OutTextXY(X, Y : integer; TextString : string);
procedure SetTextJustify(Horiz, Vert : word);
procedure SetTextStyle(Font, Direction : word; CharSize : word);
procedure SetUserCharSize(MultX, DivX, MultY, DivY : word);
function TextHeight(TextString : string) : word;
function TextWidth(TextString : string) : word;
implementation


BIN
Borland Turbo Pascal v4/GRAPH.TPU Normal file
View File

Binary file not shown.

67
Borland Turbo Pascal v4/GRAPH3.DOC Normal file
View File

@ -0,0 +1,67 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ GRAPH3 Unit Interface Documentation }
{ (Turbo Pascal 3.0 Compatibility Unit) }
{ }
{ Copyright (c) 1987 Borland International, Inc. }
{ }
{*******************************************************}
{$D-,I-,S-}
unit Graph3;
interface
uses Crt;
const
North = 0;
East = 90;
South = 180;
West = 270;
procedure GraphMode;
procedure GraphColorMode;
procedure HiRes;
procedure HiResColor(Color: Integer);
procedure Palette(N: Integer);
procedure GraphBackground(Color: Integer);
procedure GraphWindow(X1,Y1,X2,Y2: Integer);
procedure Plot(X,Y,Color: Integer);
procedure Draw(X1,Y1,X2,Y2,Color: Integer);
procedure ColorTable(C1,C2,C3,C4: Integer);
procedure Arc(X,Y,Angle,Radius,Color: Integer);
procedure Circle(X,Y,Radius,Color: Integer);
procedure GetPic(var Buffer; X1,Y1,X2,Y2: Integer);
procedure PutPic(var Buffer; X,Y: Integer);
function GetDotColor(X,Y: Integer): Integer;
procedure FillScreen(Color: Integer);
procedure FillShape(X,Y,FillCol,BorderCol: Integer);
procedure FillPattern(X1,Y1,X2,Y2,Color: Integer);
procedure Pattern(var P);
procedure Back(Dist: Integer);
procedure ClearScreen;
procedure Forwd(Dist: Integer);
function Heading: Integer;
procedure HideTurtle;
procedure Home;
procedure NoWrap;
procedure PenDown;
procedure PenUp;
procedure SetHeading(Angle: Integer);
procedure SetPenColor(Color: Integer);
procedure SetPosition(X,Y: Integer);
procedure ShowTurtle;
procedure TurnLeft(Angle: Integer);
procedure TurnRight(Angle: Integer);
procedure TurtleDelay(Delay: integer);
procedure TurtleWindow(X,Y,W,H: Integer);
function TurtleThere: Boolean;
procedure Wrap;
function Xcor: Integer;
function Ycor: Integer;
implementation


1282
Borland Turbo Pascal v4/GRDEMO.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Borland Turbo Pascal v4/GREP.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/GREXAMPL.ARC Normal file
View File

Binary file not shown.

31
Borland Turbo Pascal v4/GRLINK.MAK Normal file
View File

@ -0,0 +1,31 @@
# Build sample program that uses FONTS.TPU and DRIVERS.TPU
grlink.exe: drivers.tpu fonts.tpu
tpc grlink /m
# Build unit with all fonts linked in
fonts.tpu: fonts.pas goth.obj litt.obj sans.obj trip.obj
tpc fonts
goth.obj: goth.chr
binobj goth.chr goth GothicFontProc
litt.obj: litt.chr
binobj litt.chr litt SmallFontProc
sans.obj: sans.chr
binobj sans.chr sans SansSerifFontProc
trip.obj: trip.chr
binobj trip.chr trip TriplexFontProc
# Build unit with all drivers linked in
drivers.tpu: drivers.pas cga.obj egavga.obj herc.obj pc3270.obj att.obj
tpc drivers
cga.obj: cga.bgi
binobj cga.bgi cga CGADriverProc
egavga.obj: egavga.bgi
binobj egavga.bgi egavga EGAVGADriverProc
herc.obj: herc.bgi
binobj herc.bgi herc HercDriverProc
pc3270.obj: pc3270.bgi
binobj pc3270.bgi pc3270 PC3270DriverProc
att.obj: att.bgi
binobj att.bgi att ATTDriverProc


126
Borland Turbo Pascal v4/GRLINK.PAS Normal file
View File

@ -0,0 +1,126 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program GrLink;
{ This program demonstrates how to link graphics driver and font files
into an EXE file. BGI graphic's drivers and fonts are kept in
separate disk files so they may be dynamically loaded at runtime.
However, sometimes it is preferable to place all auxiliary files
directly into an .EXE. This program, along with its make file
(GRLINK.MAK) and two units (DRIVERS.PAS and FONTS.PAS) links all
the drivers and fonts directly into GRLINK.EXE.
Have these 3 programs in the current drive or directory, or
have them available via a path (both are on Disk II):
MAKE.EXE - Make utility that will build GRLINK.EXE
BINOBJ.EXE - utility program to convert any file into an .OBJ file
Place in the current drive or directory the following files (all
are on Disk III):
GRLINK.PAS - this sample program
DRIVERS.PAS - Pascal unit that will link in all BGI drivers
FONTS.PAS - Pascal unit that will link in all BGI fonts
*.CHR - BGI font files
*.BGI - BGI driver files
GRLINK.MAK - "make" file that builds DRIVERS.TPU, FONT.TPU, and
finally GRLINK.EXE
DIRECTIONS:
1. Run MAKE on the GRLINK.MAK file by typing the following command
at a DOS prompt:
make -fgrlink.mak
Using BINOBJ.EXE, this will first build .OBJ files out of the driver
files (*.BGI) and then call Turbo Pascal to compile DRIVERS.PAS.
Next, the font files (*.CHR) will be converted to .OBJs and
FONTS.PAS will be compiled. Finally, GRLINK.PAS will be compiled
(it uses DRIVERS.TPU and FONTS.TPU).
2. Run GRLINK.EXE. It contains all the drivers and all the fonts, so it
will run on any system with a graphics card supported by the Graph
unit (CGA, EGA, EGA 64 K, EGA monochrome, Hercules monochrome,
VGA, MCGA, IBM 3270 PC and AT&T 6400).
EXPLANATION
GRLINK.PAS uses DRIVERS.TPU and FONTS.TPU in its uses statement:
uses Drivers, Fonts;
Then, it "registers" the drivers it intends to use (in this case,
all of them, so it will run on any graphics card). Then it registers
all of the fonts it will use (again all of them, just for demonstration
purposes) and finally it does some very modest graphics.
You can easily modify GRLINK.PAS for your own use by commenting out
the calls to RegisterBGIdriver and RegisterBGIfont for drivers and
fonts that your program doesn't use.
For a detailed explanation of registering and linking drivers and fonts,
refer to the RegisterBGIdriver and RegisterBGIfont descriptions in
GRAPH.DOC (on Disk III).
}
uses Graph, { library of graphics routines }
Drivers, { all the BGI drivers }
Fonts; { all the BGI fonts }
var
GraphDriver, GraphMode, Error : integer;
procedure Abort(Msg : string);
begin
Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
Halt(1);
end;
begin
{ Register all the drivers }
if RegisterBGIdriver(@CGADriverProc) < 0 then
Abort('CGA');
if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
Abort('EGA/VGA');
if RegisterBGIdriver(@HercDriverProc) < 0 then
Abort('Herc');
if RegisterBGIdriver(@ATTDriverProc) < 0 then
Abort('AT&T');
if RegisterBGIdriver(@PC3270DriverProc) < 0 then
Abort('PC 3270');
{ Register all the fonts }
if RegisterBGIfont(@GothicFontProc) < 0 then
Abort('Gothic');
if RegisterBGIfont(@SansSerifFontProc) < 0 then
Abort('SansSerif');
if RegisterBGIfont(@SmallFontProc) < 0 then
Abort('Small');
if RegisterBGIfont(@TriplexFontProc) < 0 then
Abort('Triplex');
GraphDriver := Detect; { autodetect the hardware }
InitGraph(GraphDriver, GraphMode, ''); { activate graphics }
if GraphResult <> grOk then { any errors? }
begin
Writeln('Graphics init error: ', GraphErrorMsg(GraphDriver));
Halt(1);
end;
MoveTo(5, 5);
OutText('Drivers and fonts were ');
MoveTo(5, 20);
SetTextStyle(GothicFont, HorizDir, 4);
OutText('Built ');
SetTextStyle(SmallFont, HorizDir, 4);
OutText('into ');
SetTextStyle(TriplexFont, HorizDir, 4);
OutText('EXE ');
SetTextStyle(SansSerifFont, HorizDir, 4);
OutText('file!');
Rectangle(0, 0, GetX, GetY + TextHeight('file!') + 1);
Readln;
CloseGraph;
end.


BIN
Borland Turbo Pascal v4/HERC.BGI Normal file
View File

Binary file not shown.

246
Borland Turbo Pascal v4/HILB.PAS Normal file
View File

@ -0,0 +1,246 @@
{$N-}
program Hilb;
{
The program performs simultaneous solution by Gauss-Jordan
elimination.
--------------------------------------------------
From: Pascal Programs for Scientists and Engineers
Alan R. Miller, Sybex
n x n inverse hilbert matrix
solution is 1 1 1 1 1
double precision version
--------------------------------------------------
INSTRUCTIONS
1. Compile and run the program using the $N- (Numeric Processing :
Software) compiler directive.
2. if you have a math coprocessor in your computer, compile and run the
program using the $N+ (Numeric Processing : Hardware) compiler
directive. Compare the speed and precision of the results to those
of example 1.
}
const
maxr = 10;
maxc = 10;
type
{$IFOPT N+} { use extended type if using 80x87 }
real = extended;
{$ENDIF}
ary = array[1..maxr] of real;
arys = array[1..maxc] of real;
ary2s = array[1..maxr, 1..maxc] of real;
var
y : arys;
coef : arys;
a, b : ary2s;
n, m, i, j : integer;
error : boolean;
procedure gaussj
(var b : ary2s; (* square matrix of coefficients *)
y : arys; (* constant vector *)
var coef : arys; (* solution vector *)
ncol : integer; (* order of matrix *)
var error: boolean); (* true if matrix singular *)
(* Gauss Jordan matrix inversion and solution *)
(* Adapted from McCormick *)
(* Feb 8, 81 *)
(* B(N,N) coefficient matrix, becomes inverse *)
(* Y(N) original constant vector *)
(* W(N,M) constant vector(s) become solution vector *)
(* DETERM is the determinant *)
(* ERROR = 1 if singular *)
(* INDEX(N,3) *)
(* NV is number of constant vectors *)
var
w : array[1..maxc, 1..maxc] of real;
index: array[1..maxc, 1..3] of integer;
i, j, k, l, nv, irow, icol, n, l1 : integer;
determ, pivot, hold, sum, t, ab, big: real;
procedure swap(var a, b: real);
var
hold: real;
begin (* swap *)
hold := a;
a := b;
b := hold
end (* procedure swap *);
begin (* Gauss-Jordan main program *)
error := false;
nv := 1 (* single constant vector *);
n := ncol;
for i := 1 to n do
begin
w[i, 1] := y[i] (* copy constant vector *);
index[i, 3] := 0
end;
determ := 1.0;
for i := 1 to n do
begin
(* search for largest element *)
big := 0.0;
for j := 1 to n do
begin
if index[j, 3] <> 1 then
begin
for k := 1 to n do
begin
if index[k, 3] > 1 then
begin
writeln(' ERROR: matrix singular');
error := true;
exit; (* abort *)
end;
if index[k, 3] < 1 then
if abs(b[j, k]) > big then
begin
irow := j;
icol := k;
big := abs(b[j, k])
end
end (* k loop *)
end
end (* j loop *);
index[icol, 3] := index[icol, 3] + 1;
index[i, 1] := irow;
index[i, 2] := icol;
(* interchange rows to put pivot on diagonal *)
if irow <> icol then
begin
determ := - determ;
for l := 1 to n do
swap(b[irow, l], b[icol, l]);
if nv > 0 then
for l := 1 to nv do
swap(w[irow, l], w[icol, l])
end; (* if irow <> icol *)
(* divide pivot row by pivot column *)
pivot := b[icol, icol];
determ := determ * pivot;
b[icol, icol] := 1.0;
for l := 1 to n do
b[icol, l] := b[icol, l] / pivot;
if nv > 0 then
for l := 1 to nv do
w[icol, l] := w[icol, l] / pivot;
(* reduce nonpivot rows *)
for l1 := 1 to n do
begin
if l1 <> icol then
begin
t := b[l1, icol];
b[l1, icol] := 0.0;
for l := 1 to n do
b[l1, l] := b[l1, l] - b[icol, l] * t;
if nv > 0 then
for l := 1 to nv do
w[l1, l] := w[l1, l] - w[icol, l] * t;
end (* if l1 <> icol *)
end
end (* i loop *);
if error then exit;
(* interchange columns *)
for i := 1 to n do
begin
l := n - i + 1;
if index[l, 1] <> index[l, 2] then
begin
irow := index[l, 1];
icol := index[l, 2];
for k := 1 to n do
swap(b[k, irow], b[k, icol])
end (* if index *)
end (* i loop *);
for k := 1 to n do
if index[k, 3] <> 1 then
begin
writeln(' ERROR: matrix singular');
error := true;
exit; (* abort *)
end;
for i := 1 to n do
coef[i] := w[i, 1];
end (* procedure gaussj *);
procedure get_data(var a : ary2s;
var y : arys;
var n, m : integer);
(* setup n-by-n hilbert matrix *)
var
i, j : integer;
begin
for i := 1 to n do
begin
a[n,i] := 1.0/(n + i - 1);
a[i,n] := a[n,i]
end;
a[n,n] := 1.0/(2*n -1);
for i := 1 to n do
begin
y[i] := 0.0;
for j := 1 to n do
y[i] := y[i] + a[i,j]
end;
writeln;
if n < 7 then
begin
for i:= 1 to n do
begin
for j:= 1 to m do
write( a[i,j] :7:5, ' ');
writeln( ' : ', y[i] :7:5)
end;
writeln
end (* if n<7 *)
end (* procedure get_data *);
procedure write_data;
(* print out the answers *)
var
i : integer;
begin
for i := 1 to m do
write( coef[i] :13:9);
writeln;
end (* write_data *);
begin (* main program *)
a[1,1] := 1.0;
n := 2;
m := n;
repeat
get_data (a, y, n, m);
for i := 1 to n do
for j := 1 to n do
b[i,j] := a[i,j] (* setup work array *);
gaussj (b, y, coef, n, error);
if not error then write_data;
n := n+1;
m := n
until n > maxr;
end.


211
Borland Turbo Pascal v4/LISTER.PAS Normal file
View File

@ -0,0 +1,211 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program SourceLister;
{
SOURCE LISTER DEMONSTRATION PROGRAM
This is a simple program to list your TURBO PASCAL source programs.
PSEUDO CODE
1. Find Pascal source file to be listed
2. Initialize program variables
3. Open main source file
4. Process the file
a. Read a character into line buffer until linebuffer full or eoln;
b. Search line buffer for include file.
c. If line contains include file command:
Then process include file and extract command from line buffer
Else print out the line buffer.
d. Repeat step 4.a thru 4.c until eof(main file);
INSTRUCTIONS
1. Compile and run the program:
a. In the Development Environment load LISTER.PAS and
press ALT-R.
b. From the command line type TPC LISTER.PAS /R
2. Specify the file to print.
}
uses
Printer;
const
PageWidth = 80;
PrintLength = 55;
PathLength = 65;
FormFeed = #12;
VerticalTabLength = 3;
type
WorkString = string[126];
FileName = string[PathLength];
var
CurRow : integer;
MainFileName: FileName;
MainFile: text;
search1,
search2,
search3,
search4: string[5];
procedure Initialize;
begin
CurRow := 0;
search1 := '{$'+'I'; { different forms that the include compiler }
search2 := '{$'+'i'; { directive can take. }
search3 := '(*$'+'I';
search4 := '(*$'+'i';
end {initialize};
function Open(var fp:text; name: Filename): boolean;
begin
Assign(fp,Name);
{$I-}
Reset(fp);
{$I+}
Open := IOResult = 0;
end { Open };
procedure OpenMain;
begin
if ParamCount = 0 then
begin
Write('Enter filename: ');
Readln(MainFileName);
end
else
MainFileName := ParamStr(1);
if (MainFileName = '') or not Open(MainFile,MainFileName) then
begin
Writeln('ERROR: file not found (', MainFileName, ')');
Halt(1);
end;
end {Open Main};
procedure VerticalTab;
var i: integer;
begin
for i := 1 to VerticalTabLength do Writeln(LST);
end {vertical tab};
procedure ProcessLine(PrintStr: WorkString);
begin
CurRow := Succ(CurRow);
if Length(PrintStr) > PageWidth then Inc(CurRow);
if CurRow > PrintLength then
begin
Write(LST,FormFeed);
VerticalTab;
CurRow := 1;
end;
Writeln(LST,PrintStr);
end {Process line};
procedure ProcessFile;
{ This procedure displays the contents of the Turbo Pascal program on the }
{ printer. It recursively processes include files if they are nested. }
var
LineBuffer: WorkString;
function IncludeIn(var CurStr: WorkString): boolean;
var
ChkChar: char;
column: integer;
begin
ChkChar := '-';
column := Pos(search1,CurStr);
if column <> 0 then
chkchar := CurStr[column+3]
else
begin
column := Pos(search3,CurStr);
if column <> 0 then
chkchar := CurStr[column+4]
else
begin
column := Pos(search2,CurStr);
if column <> 0 then
chkchar := CurStr[column+3]
else
begin
column := Pos(search4,CurStr);
if column <> 0 then
chkchar := CurStr[column+4]
end;
end;
end;
if ChkChar in ['+','-'] then IncludeIn := False
else IncludeIn := True;
end { IncludeIn };
procedure ProcessIncludeFile(var IncStr: WorkString);
var NameStart, NameEnd: integer;
IncludeFile: text;
IncludeFileName: Filename;
Function Parse(IncStr: WorkString): WorkString;
begin
NameStart := Pos('$I',IncStr)+2;
while IncStr[NameStart] = ' ' do
NameStart := Succ(NameStart);
NameEnd := NameStart;
while (not (IncStr[NameEnd] in [' ','}','*']))
and ((NameEnd - NameStart) <= PathLength) do
Inc(NameEnd);
Dec(NameEnd);
Parse := Copy(IncStr,NameStart,(NameEnd-NameStart+1));
end {Parse};
begin {Process include file}
IncludeFileName := Parse(IncStr);
if not Open(IncludeFile,IncludeFileName) then
begin
LineBuffer := 'ERROR: include file not found (' +
IncludeFileName + ')';
ProcessLine(LineBuffer);
end
else
begin
while not EOF(IncludeFile) do
begin
Readln(IncludeFile,LineBuffer);
{ Turbo Pascal 4.0 allows nested include files so we must
check for them and do a recursive call if necessary }
if IncludeIn(LineBuffer) then
ProcessIncludeFile(LineBuffer)
else
ProcessLine(LineBuffer);
end;
Close(IncludeFile);
end;
end {Process include file};
begin {Process File}
VerticalTab;
Writeln('Printing . . . ');
while not EOF(mainfile) do
begin
Readln(MainFile,LineBuffer);
if IncludeIn(LineBuffer) then
ProcessIncludeFile(LineBuffer)
else
ProcessLine(LineBuffer);
end;
Close(MainFile);
Write(LST,FormFeed); { move the printer to the beginning of the next }
{ page }
end {Process File};
begin
Initialize; { initialize some global variables }
OpenMain; { open the file to print }
ProcessFile; { print the program }
end.


BIN
Borland Turbo Pascal v4/LITT.CHR Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/MAKE.EXE Normal file
View File

Binary file not shown.

143
Borland Turbo Pascal v4/MCALC.PAS Normal file
View File

@ -0,0 +1,143 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
Program MCalc;
uses Crt, Dos, MCVars, MCUtil, MCDisply, MCParser, MCLib, MCInput, MCommand;
var
Ch : Char;
procedure Run;
{ The main program loop }
var
Input : Char;
begin
Stop := False;
ClearInput;
repeat
DisplayCell(CurCol, CurRow, HIGHLIGHT, NOUPDATE);
CurCell := Cell[CurCol, CurRow];
ShowCellType;
GotoXY(1, 25);
Input := GetKey;
case Input of
'/' : MainMenu;
F1 : Recalc;
F2 : EditCell(CurCell);
DELKEY : begin
DeleteCell(CurCol, CurRow, UPDATE);
PrintFreeMem;
if AutoCalc then
Recalc;
end; { DELKEY }
PGUPKEY : begin
if CurRow <= SCREENROWS then
begin
CurRow := 1;
TopRow := 1;
end
else if TopRow <= SCREENROWS then
begin
CurRow := Succ(CurRow - TopRow);
TopRow := 1;
end
else begin
Dec(TopRow, SCREENROWS);
Dec(CurRow, SCREENROWS);
end;
SetBottomRow;
DisplayScreen(NOUPDATE);
end; {PGUPKEY }
PGDNKEY : begin
Inc(TopRow, SCREENROWS);
Inc(CurRow, SCREENROWS);
if (CurRow > MAXROWS) and (TopRow > MAXROWS) then
begin
CurRow := MAXROWS;
TopRow := Succ(MAXROWS - SCREENROWS);
end
else if TopRow > Succ(MAXROWS - SCREENROWS) then
begin
CurRow := Succ(CurRow) - (TopRow + SCREENROWS - MAXROWS);
TopRow := Succ(MAXROWS - SCREENROWS);
end;
SetBottomRow;
DisplayScreen(NOUPDATE);
end; { PGDNKEY }
CTRLLEFTKEY : begin
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if LeftCol = 1 then
CurCol := 1
else begin
CurCol := Pred(LeftCol);
RightCol := CurCol;
SetLeftCol;
SetRightCol;
DisplayScreen(NOUPDATE);
end;
end; { CTRLLEFTKEY }
CTRLRIGHTKEY : begin
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if RightCol = MAXCOLS then
CurCol := RightCol
else begin
CurCol := Succ(RightCol);
LeftCol := CurCol;
SetRightCol;
SetLeftCol;
DisplayScreen(NOUPDATE);
end;
end; { CTRLRIGHTKEY }
HOMEKEY : begin
CurRow := 1;
CurCol := 1;
LeftCol := 1;
TopRow := 1;
SetRightCol;
SetBottomRow;
DisplayScreen(NOUPDATE);
end; { HOMEKEY }
ENDKEY : begin
CurCol := LastCol;
RightCol := CurCol;
BottomRow := LastRow;
CurRow := BottomRow;
SetTopRow;
SetLeftCol;
SetRightCol;
DisplayScreen(NOUPDATE);
end; { ENDKEY }
UPKEY : MoveRowUp;
DOWNKEY : MoveRowDown;
LEFTKEY : MoveColLeft;
RIGHTKEY : MoveColRight;
else if Input in [' '..'~'] then
GetInput(Input);
end; { case }
until Stop;
end; { Run }
begin
CheckBreak := False;
SetColor(TXTCOLOR);
ClrScr;
SetColor(MSGHEADERCOLOR);
WriteXY(MSGHEADER, (80 - Length(MSGHEADER)) shr 1, 10);
SetColor(PROMPTCOLOR);
WriteXY(MSGKEYPRESS, (80 - Length(MSGKEYPRESS)) shr 1, 12);
GotoXY(80, 25);
Ch := GetKey;
ClrScr;
InitVars;
Changed := False;
RedrawScreen;
if (ParamCount > 0) then
LoadSheet(ParamStr(1));
ClearInput;
Run;
SetColor(LightGray);
TextMode(OldMode);
SetCursor(OldCursor);
end.


357
Borland Turbo Pascal v4/MCDISPLY.PAS Normal file
View File

@ -0,0 +1,357 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCDISPLY;
interface
uses Crt, Dos, MCVars, MCUtil;
var
InsCursor, ULCursor, NoCursor, OldCursor : Word;
procedure MoveToScreen(var Source, Dest; Len : Word);
{ Moves memory to screen memory }
procedure MoveFromScreen(var Source, Dest; Len : Word);
{ Moves memory from screen memory }
procedure WriteXY(S : String; Col, Row : Word);
{ Writes text in a particular location }
procedure MoveText(OldX1, OldY1, OldX2, OldY2, NewX1, NewY1 : Word);
{ Moves text from one location to another }
procedure Scroll(Direction, Lines, X1, Y1, X2, Y2, Attrib : Word);
{ Scrolls an area of the screen }
function GetCursor : Word;
{ Returns the current cursor }
procedure SetCursor(NewCursor : Word);
{ Sets a new cursor }
function GetSetCursor(NewCursor : Word) : Word;
{ Sets a new cursor and returns the current one }
procedure SetColor(Color : Word);
{ Sets the foreground and background color based on a single color }
procedure PrintCol;
{ Prints the column headings }
procedure PrintRow;
{ Prints the row headings }
procedure ClearInput;
{ Clears the input line }
procedure ChangeCursor(InsMode : Boolean);
{ Changes the cursor shape based on the current insert mode }
procedure ShowCellType;
{ Prints the type of cell and what is in it }
procedure PrintFreeMem;
{ Prints the amount of free memory }
procedure ErrorMsg(S : String);
{ Prints an error message at the bottom of the screen }
procedure WritePrompt(Prompt : String);
{ Prints a prompt on the screen }
function EGAInstalled : Boolean;
{ Tests for the presence of an EGA }
implementation
const
MaxLines = 43;
type
ScreenType = array[1..MaxLines, 1..80] of Word;
ScreenPtr = ^ScreenType;
var
DisplayPtr : ScreenPtr;
procedure MoveToScreen; external;
procedure MoveFromScreen; external;
{$L MCMVSMEM.OBJ}
procedure WriteXY;
begin
GotoXY(Col, Row);
Write(S);
end; { WriteXY }
procedure MoveText;
var
Counter, Len : Word;
begin
Len := Succ(OldX2 - OldX1) shl 1;
if NewY1 < OldY1 then
begin
for Counter := 0 to OldY2 - OldY1 do
MoveFromScreen(DisplayPtr^[OldY1 + Counter, OldX1],
DisplayPtr^[NewY1 + Counter, NewX1], Len)
end
else begin
for Counter := OldY2 - OldY1 downto 0 do
MoveFromScreen(DisplayPtr^[OldY1 + Counter, OldX1],
DisplayPtr^[NewY1 + Counter, NewX1], Len)
end;
end; { MoveText }
procedure Scroll;
begin
if Lines = 0 then
Window(X1, Y1, X2, Y2)
else begin
case Direction of
UP : begin
MoveText(X1, Y1 + Lines, X2, Y2, X1, Y1);
Window(X1, Succ(Y2 - Lines), X2, Y2);
end;
DOWN : begin
MoveText(X1, Y1, X2, Y2 - Lines, X1, Y1 + Lines);
Window(X1, Y1, X2, Pred(Y1 + Lines));
end;
LEFT : begin
MoveText(X1 + Lines, Y1, X2, Y2, X1, Y1);
Window(Succ(X2 - Lines), Y1, X2, Y2);
end;
RIGHT : begin
MoveText(X1, Y1, X2 - Lines, Y2, X1 + Lines, Y1);
Window(X1, Y1, Pred(X1 + Lines), Y2);
end;
end; { case }
end;
SetColor(Attrib);
ClrScr;
Window(1, 1, 80, ScreenRows + 5);
end; { Scroll }
function GetCursor;
var
Reg : Registers;
begin
with Reg do
begin
AH := 3;
BH := 0;
Intr($10, Reg);
GetCursor := CX;
end; { Reg }
end; { GetCursor }
procedure SetCursor;
var
Reg : Registers;
begin
with Reg do
begin
AH := 1;
BH := 0;
CX := NewCursor;
Intr($10, Reg);
end; { with }
end; { SetCursor }
function GetSetCursor;
begin
GetSetCursor := GetCursor;
SetCursor(NewCursor);
end; { GetSetCursor }
procedure SetColor;
begin
TextAttr := ColorTable[Color];
end; { SetColor }
procedure InitColorTable(BlackWhite : Boolean);
{ Sets up the color table }
var
Color, FG, BG, FColor, BColor : Word;
begin
if not BlackWhite then
begin
for Color := 0 to 255 do
ColorTable[Color] := Color;
end
else begin
for FG := Black to White do
begin
case FG of
Black : FColor := Black;
Blue..LightGray : FColor := LightGray;
DarkGray..White : FColor := White;
end; { case }
for BG := Black to LightGray do
begin
if BG = Black then
BColor := Black
else begin
if FColor = White then
FColor := Black;
BColor := LightGray;
end;
ColorTable[FG + (BG shl 4)] := FColor + (BColor shl 4);
end;
end;
for FG := 128 to 255 do
ColorTable[FG] := ColorTable[FG - 128] or $80;
end;
end; { InitColorTable }
procedure PrintCol;
var
Col : Word;
begin
Scroll(UP, 0, 1, 2, 80, 2, HEADERCOLOR);
for Col := LeftCol to RightCol do
WriteXY(CenterColString(Col), ColStart[Succ(Col - LeftCol)], 2);
end; { PrintCol }
procedure PrintRow;
var
Row : Word;
begin
SetColor(HEADERCOLOR);
for Row := 0 to Pred(ScreenRows) do
WriteXY(Pad(WordToString(Row + TopRow, 1), LEFTMARGIN), 1, Row + 3);
end; { PrintRow }
procedure ClearInput;
begin
SetColor(TXTCOLOR);
GotoXY(1, ScreenRows + 5);
ClrEol;
end; { ClearInput }
procedure ChangeCursor;
begin
if InsMode then
SetCursor(InsCursor)
else
SetCursor(ULCursor);
end; { ChangeCursor }
procedure ShowCellType;
var
ColStr : String[2];
S : IString;
Color : Word;
begin
FormDisplay := not FormDisplay;
S := CellString(CurCol, CurRow, Color, NOFORMAT);
ColStr := ColString(CurCol);
SetColor(CELLTYPECOLOR);
GotoXY(1, ScreenRows + 3);
if CurCell = Nil then
Write(ColStr, CurRow, ' ', MSGEMPTY, ' ':10)
else begin
case CurCell^.Attrib of
TXT :
Write(ColStr, CurRow, ' ', MSGTEXT, ' ':10);
VALUE :
Write(ColStr, CurRow, ' ', MSGVALUE, ' ':10);
FORMULA :
Write(ColStr, CurRow, ' ', MSGFORMULA, ' ':10);
end; { case }
end;
SetColor(CELLCONTENTSCOLOR);
WriteXY(Pad(S, 80), 1, ScreenRows + 4);
FormDisplay := not FormDisplay;
end; { ShowCellType }
procedure PrintFreeMem;
begin
SetColor(MEMORYCOLOR);
GotoXY(Length(MSGMEMORY) + 2, 1);
Write(MemAvail:6);
end; { PrintFreeMem }
procedure ErrorMsg;
var
Ch : Char;
begin
Sound(1000); { Beeps the speaker }
Delay(500);
NoSound;
SetColor(ERRORCOLOR);
WriteXY(S + ' ' + MSGKEYPRESS, 1, ScreenRows + 5);
GotoXY(Length(S) + Length(MSGKEYPRESS) + 3, ScreenRows + 5);
Ch := ReadKey;
ClearInput;
end; { ErrorMsg }
procedure WritePrompt;
begin
SetColor(PROMPTCOLOR);
GotoXY(1, ScreenRows + 4);
ClrEol;
Write(Prompt);
end; { WritePrompt }
procedure InitDisplay;
{ Initializes various global variables - must be called before using the
above procedures and functions.
}
var
Reg : Registers;
begin
Reg.AH := 15;
Intr($10, Reg);
ColorCard := Reg.AL <> 7;
if ColorCard then
DisplayPtr := Ptr($B800, 0)
else
DisplayPtr := Ptr($B000, 0);
InitColorTable((not ColorCard) or (Reg.AL = 0) or (Reg.AL = 2));
end; { InitDisplay }
function EGAInstalled;
var
Reg : Registers;
begin
Reg.AX := $1200;
Reg.BX := $0010;
Reg.CX := $FFFF;
Intr($10, Reg);
EGAInstalled := Reg.CX <> $FFFF;
end; { EGAInstalled }
begin
InitDisplay;
NoCursor := $2000;
OldCursor := GetSetCursor(NoCursor);
OldMode := LastMode;
if (LastMode and Font8x8) <> 0 then
ScreenRows := 38
else
ScreenRows := 20;
Window(1, 1, 80, ScreenRows + 5);
if ColorCard then
begin
ULCursor := $0607;
InsCursor := $0507;
end
else begin
ULCursor := $0B0C;
InsCursor := $090C;
end;
if EGAInstalled then
begin
UCommandString := UCOMMAND;
UMenuString := UMNU;
end
else begin
UCommandString := Copy(UCOMMAND, 1, 2);
UMenuString := Copy(UMNU, 1, 23);
end;
end.


241
Borland Turbo Pascal v4/MCINPUT.PAS Normal file
View File

@ -0,0 +1,241 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCINPUT;
interface
uses Crt, Dos, MCVars, MCUtil, MCDisply, MCParser, MCLib;
function GetKey : Char;
{ Reads the next keyboard character }
function EditString(var S : IString; Legal : IString;
MaxLength : Word) : Boolean;
{ Allows the user to edit a string with only certain characters allowed -
Returns TRUE if ESC was not pressed, FALSE is ESC was pressed.
}
procedure GetInput(C : Char);
{ Reads and acts on an input string from the keyboard that started with C }
function GetWord(var Number : Word; Low, High : Word) : Boolean;
{ Reads in a positive word from low to high }
function GetCell(var Col, Row : Word) : Boolean;
{ Reads in a cell name that was typed in - Returns False if ESC was pressed }
function GetYesNo(var YesNo : Char; Prompt : String) : Boolean;
{ Prints a prompt and gets a yes or no answer - returns TRUE if ESC was
pressed, FALSE if not.
}
function GetCommand(MsgStr, ComStr : String) : Word;
{ Reads in a command and acts on it }
implementation
function GetKey;
var
C : Char;
begin
C := ReadKey;
repeat
if C = NULL then
begin
C := ReadKey;
if Ord(C) > 127 then
C := NULL
else
GetKey := Chr(Ord(C) + 128);
end
else
GetKey := C;
until C <> NULL;
end; { GetKey }
function EditString;
var
CPos : Word;
Ins : Boolean;
Ch : Char;
begin
Ins := True;
ChangeCursor(Ins);
CPos := Succ(Length(S));
SetColor(White);
repeat
GotoXY(1, ScreenRows + 5);
Write(S, '':(79 - Length(S)));
GotoXY(CPos, ScreenRows + 5);
Ch := GetKey;
case Ch of
HOMEKEY : CPos := 1;
ENDKEY : CPos := Succ(Length(S));
INSKEY : begin
Ins := not Ins;
ChangeCursor(Ins);
end;
LEFTKEY : if CPos > 1 then
Dec(CPos);
RIGHTKEY : if CPos <= Length(S) then
Inc(CPos);
BS : if CPos > 1 then
begin
Delete(S, Pred(CPos), 1);
Dec(CPos);
end;
DELKEY : if CPos <= Length(S) then
Delete(S, CPos, 1);
CR : ;
UPKEY, DOWNKEY : Ch := CR;
ESC : S := '';
else begin
if ((Legal = '') or (Pos(Ch, Legal) <> 0)) and
((Ch >= ' ') and (Ch <= '~')) and
(Length(S) < MaxLength) then
begin
if Ins then
Insert(Ch, S, CPos)
else if CPos > Length(S) then
S := S + Ch
else
S[CPos] := Ch;
Inc(CPos);
end;
end;
end; { case }
until (Ch = CR) or (Ch = ESC);
ClearInput;
ChangeCursor(False);
EditString := Ch <> ESC;
SetCursor(NoCursor);
end; { EditString }
procedure GetInput;
var
S : IString;
begin
S := C;
if (not EditString(S, '', MAXINPUT)) or (S = '') then
Exit;
Act(S);
Changed := True;
end; { GetInput }
function GetWord;
var
I, Error : Word;
Good : Boolean;
Num1, Num2 : String[5];
Message : String[80];
S : IString;
begin
GetWord := False;
S := '';
Str(Low, Num1);
Str(High, Num2);
Message := MSGBADNUMBER + ' ' + Num1 + ' to ' + Num2 + '.';
repeat
if not EditString(S, '1234567890', 4) then
Exit;
Val(S, I, Error);
Good := (Error = 0) and (I >= Low) and (I <= High);
if not Good then
ErrorMsg(Message);
until Good;
Number := I;
GetWord := True;
end; { GetWord }
function GetCell;
var
Len, NumLen, OldCol, OldRow, Posit, Error : Word;
Data : IString;
NumString : IString;
First, Good : Boolean;
begin
NumLen := RowWidth(MAXROWS);
OldCol := Col;
OldRow := Row;
First := True;
Good := False;
Data := '';
repeat
if not First then
ErrorMsg(MSGBADCELL);
First := False;
Posit := 1;
if not EditString(Data, '', NumLen + 2) then
begin
Col := OldCol;
Row := OldRow;
GetCell := False;
Exit;
end;
if (Data <> '') and (Data[1] in Letters) then
begin
Col := Succ(Ord(UpCase(Data[1])) - Ord('A'));
Inc(Posit);
if (Posit <= Length(Data)) and (Data[Posit] in LETTERS) then
begin
Col := Col * 26;
Inc(Col, Succ(Ord(UpCase(Data[Posit])) - Ord('A')));
Inc(Posit);
end;
if Col <= MAXCOLS then
begin
NumString := Copy(Data, Posit, Succ(Length(Data) - Posit));
Val(NumString, Row, Error);
if (Row <= MAXROWS) and (Error = 0) then
Good := True;
end;
end;
until Good;
GetCell := True;
end; { GetCell }
function GetYesNo;
begin
SetCursor(ULCursor);
GetYesNo := False;
WritePrompt(Prompt + ' ');
repeat
YesNo := UpCase(GetKey);
if YesNo = ESC then
Exit;
until YesNo in ['Y', 'N'];
SetCursor(NoCursor);
GetYesNo := True;
end; { GetYesNo }
function GetCommand;
var
Counter, Len : Word;
Ch : Char;
begin
Len := Length(MsgStr);
GotoXY(1, ScreenRows + 4);
ClrEol;
for Counter := 1 to Len do
begin
if MsgStr[Counter] in ['A'..'Z'] then
SetColor(COMMANDCOLOR)
else
SetColor(LOWCOMMANDCOLOR);
Write(MsgStr[Counter]);
end;
GotoXY(1, ScreenRows + 5);
repeat
Ch := UpCase(GetKey);
until (Pos(Ch, ComStr) <> 0) or (Ch = ESC);
ClearInput;
if Ch = ESC then
GetCommand := 0
else
GetCommand := Pos(Ch, ComStr);
end; { GetCommand }
begin
end.


503
Borland Turbo Pascal v4/MCLIB.PAS Normal file
View File

@ -0,0 +1,503 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCLIB;
interface
uses Crt, Dos, MCVars, MCUtil, MCDisply, MCParser;
procedure DisplayCell(Col, Row : Word; Highlighting, Updating : Boolean);
{ Displays the contents of a cell }
function SetOFlags(Col, Row : Word; Display : Boolean) : Word;
{ Sets the overwrite flag on cells starting at (col + 1, row) - returns
the number of the column after the last column set.
}
procedure ClearOFlags(Col, Row : Word; Display : Boolean);
{ Clears the overwrite flag on cells starting at (col, row) }
procedure UpdateOFlags(Col, Row : Word; Display : Boolean);
{ Starting in col, moves back to the last TEXT cell and updates all flags }
procedure DeleteCell(Col, Row : Word; Display : Boolean);
{ Deletes a cell }
procedure SetLeftCol;
{ Sets the value of LeftCol based on the value of RightCol }
procedure SetRightCol;
{ Sets the value of rightcol based on the value of leftcol }
procedure SetTopRow;
{ Figures out the value of toprow based on the value of bottomrow }
procedure SetBottomRow;
{ Figures out the value of bottomrow based on the value of toprow }
procedure SetLastCol;
{ Sets the value of lastcol based on the current value }
procedure SetLastRow;
{ Sets the value of lastrow based on the current value }
procedure ClearLastCol;
{ Clears any data left in the last column }
procedure DisplayCol(Col : Word; Updating : Boolean);
{ Displays a column on the screen }
procedure DisplayRow(Row : Word; Updating : Boolean);
{ Displays a row on the screen }
procedure DisplayScreen(Updating : Boolean);
{ Displays the current screen of the spreadsheet }
procedure RedrawScreen;
{ Displays the entire screen }
procedure FixFormula(Col, Row, Action, Place : Word);
{ Modifies a formula when its column or row designations need to change }
procedure ChangeAutoCalc(NewMode : Boolean);
{ Changes and prints the current AutoCalc value on the screen }
procedure ChangeFormDisplay(NewMode : Boolean);
{ Changes and prints the current formula display value on the screen }
procedure Recalc;
{ Recalculates all of the numbers in the speadsheet }
procedure Act(S : String);
{ Acts on a particular input }
implementation
procedure DisplayCell;
var
Color : Word;
S : IString;
begin
if Updating and
((Cell[Col, Row] = Nil) or (Cell[Col, Row]^.Attrib <> FORMULA)) then
Exit;
S := CellString(Col, Row, Color, DOFORMAT);
if Highlighting then
begin
if Color = ERRORCOLOR then
Color := HIGHLIGHTERRORCOLOR
else
Color := HIGHLIGHTCOLOR;
end;
SetColor(Color);
WriteXY(S, ColStart[Succ(Col - LeftCol)], Row - TopRow + 3);
end; { DisplayCell }
function SetOFlags;
var
Len : Integer;
begin
Len := Length(Cell[Col, Row]^.T) - ColWidth[Col];
Inc(Col);
while (Col <= MAXCOLS) and (Len > 0) and (Cell[Col, Row] = nil) do
begin
Format[Col, Row] := Format[Col, Row] or OVERWRITE;
Dec(Len, ColWidth[Col]);
if Display and (Col >= LeftCol) and (Col <= RightCol) then
DisplayCell(Col, Row, NOHIGHLIGHT, NOUPDATE);
Inc(Col);
end;
SetOFlags := Col;
end; { SetOFlags }
procedure ClearOFlags;
begin
while (Col <= MAXCOLS) and (Format[Col, Row] >= OVERWRITE) and
(Cell[Col, Row] = nil) do
begin
Format[Col, Row] := Format[Col, Row] and (not OVERWRITE);
if Display and (Col >= LeftCol) and (Col <= RightCol) then
DisplayCell(Col, Row, NOHIGHLIGHT, NOUPDATE);
Inc(Col);
end;
end; { ClearOFlags }
procedure UpdateOFlags;
var
Dummy : Word;
begin
while (Cell[Col, Row] = nil) and (Col > 1) do
Dec(Col);
if (Cell[Col, Row]^.Attrib = TXT) and (Col >= 1) then
Dummy := SetOFlags(Col, Row, Display);
end; { UpdateOFlags }
procedure DeleteCell;
var
CPtr : CellPtr;
Size : Word;
begin
CPtr := Cell[Col, Row];
if CPtr = nil then
Exit;
case CPtr^.Attrib of
TXT : begin
Size := Length(CPtr^.T) + 3;
ClearOFlags(Succ(Col), Row, Display);
end;
VALUE : Size := SizeOf(Real) + 2;
FORMULA : Size := SizeOf(Real) + Length(CPtr^.Formula) + 3;
end; { case }
Format[Col, Row] := Format[Col, Row] and (not OVERWRITE);
FreeMem(CPtr, Size);
Cell[Col, Row] := nil;
if Col = LastCol then
SetLastCol;
if Row = LastRow then
SetLastRow;
UpdateOFlags(Col, Row, Display);
Changed := True;
end; { DeleteCell }
procedure SetLeftCol;
var
Col : Word;
Total : Integer;
begin
Total := 81;
Col := 0;
while (Total > LEFTMARGIN) and (RightCol - Col > 0) do
begin
Dec(Total, ColWidth[RightCol - Col]);
if Total > LEFTMARGIN then
ColStart[SCREENCOLS - Col] := Total;
Inc(Col);
end;
if Total > LEFTMARGIN then
Inc(Col);
Move(ColStart[SCREENCOLS - Col + 2], ColStart, Pred(Col));
LeftCol := RightCol - Col + 2;
Total := Pred(ColStart[1] - LEFTMARGIN);
if Total <> 0 then
begin
for Col := LeftCol to RightCol do
Dec(ColStart[Succ(Col - LeftCol)], Total);
end;
PrintCol;
end; { SetLeftCol }
procedure SetRightCol;
var
Total, Col : Word;
begin
Total := Succ(LEFTMARGIN);
Col := 1;
repeat
begin
ColStart[Col] := Total;
Inc(Total, ColWidth[Pred(LeftCol + Col)]);
Inc(Col);
end;
until (Total > 81) or (Pred(LeftCol + Col) > MAXCOLS);
if Total > 81 then
Dec(Col);
RightCol := LeftCol + Col - 2;
PrintCol;
end; { SetRightCol }
procedure SetTopRow;
begin
if BottomRow < ScreenRows then
BottomRow := ScreenRows;
TopRow := Succ(BottomRow - ScreenRows);
PrintRow;
end; { SetTopRow }
procedure SetBottomRow;
begin
if TopRow + ScreenRows > Succ(MAXROWS) then
TopRow := Succ(MAXROWS - ScreenRows);
BottomRow := Pred(TopRow + ScreenRows);
PrintRow;
end; { SetBottomRow }
procedure SetLastCol;
var
Row, Col : Word;
begin
for Col := LastCol downto 1 do
begin
for Row := 1 to LastRow do
begin
if Cell[Col, Row] <> nil then
begin
LastCol := Col;
Exit;
end;
end;
end;
LastCol := 1;
end; { SetLastCol }
procedure SetLastRow;
var
Row, Col : Word;
begin
for Row := LastRow downto 1 do
begin
for Col := 1 to LastCol do
begin
if Cell[Col, Row] <> nil then
begin
LastRow := Row;
Exit;
end;
end;
end;
LastRow := 1;
end; { SetLastRow }
procedure ClearLastCol;
var
Col : Word;
begin
Col := ColStart[Succ(RightCol - LeftCol)] + ColWidth[RightCol];
if (Col < 80) then
Scroll(UP, 0, Col, 3, 80, ScreenRows + 2, White);
end; { ClearLastCol }
procedure DisplayCol;
var
Row : Word;
begin
for Row := TopRow to BottomRow do
DisplayCell(Col, Row, NOHIGHLIGHT, Updating);
end; { DisplayCol }
procedure DisplayRow;
var
Col : Word;
begin
for Col := LeftCol to RightCol do
DisplayCell(Col, Row, NOHIGHLIGHT, Updating);
end; { DisplayRow }
procedure DisplayScreen;
var
Row : Word;
begin
for Row := TopRow to BottomRow do
DisplayRow(Row, Updating);
ClearLastCol;
end; { DisplayScreen }
procedure RedrawScreen;
begin
CurRow := 1;
CurCol := 1;
LeftCol := 1;
TopRow := 1;
SetRightCol;
SetBottomRow;
GotoXY(1, 1);
SetColor(MSGMEMORYCOLOR);
Write(MSGMEMORY);
GotoXY(29, 1);
SetColor(PROMPTCOLOR);
Write(MSGCOMMAND);
ChangeAutocalc(Autocalc);
ChangeFormDisplay(FormDisplay);
PrintFreeMem;
DisplayScreen(NOUPDATE);
end; { RedrawScreen }
procedure FixFormula;
var
FormLen, ColStart, RowStart, CurPos, FCol, FRow : Word;
CPtr : CellPtr;
Value : Real;
S : String[5];
NewFormula : IString;
Good : Boolean;
begin
CPtr := Cell[Col, Row];
CurPos := 1;
NewFormula := CPtr^.Formula;
while CurPos < Length(NewFormula) do
begin
if FormulaStart(NewFormula, CurPos, FCol, FRow, FormLen) then
begin
if FCol > 26 then
begin
RowStart := CurPos + 2;
ColStart := RowStart - 2;
end
else begin
RowStart := Succ(CurPos);
ColStart := Pred(RowStart);
end;
case Action of
COLADD : begin
if FCol >= Place then
begin
if FCol = 26 then
begin
if Length(NewFormula) = MAXINPUT then
begin
DeleteCell(Col, Row, NOUPDATE);
Good := AllocText(Col, Row, NewFormula);
Exit;
end;
end;
S := ColString(FCol);
Delete(NewFormula, ColStart, Length(S));
S := ColString(Succ(FCol));
Insert(S, NewFormula, ColStart);
end;
end;
ROWADD : begin
if FRow >= Place then
begin
if RowWidth(Succ(FRow)) <> RowWidth(FRow) then
begin
if Length(NewFormula) = MAXINPUT then
begin
DeleteCell(Col, Row, NOUPDATE);
Good := AllocText(Col, Row, NewFormula);
Exit;
end;
end;
S := WordToString(FRow, 1);
Delete(NewFormula, RowStart, Length(S));
S := WordToString(Succ(FRow), 1);
Insert(S, NewFormula, RowStart);
end;
end;
COLDEL : begin
if FCol > Place then
begin
S := ColString(FCol);
Delete(NewFormula, ColStart, Length(S));
S := ColString(Pred(FCol));
Insert(S, NewFormula, ColStart);
end;
end;
ROWDEL : begin
if FRow > Place then
begin
S := WordToString(FRow, 1);
Delete(NewFormula, RowStart, Length(S));
S := WordToString(Pred(FRow), 1);
Insert(S, NewFormula, RowStart);
end;
end;
end; { case }
Inc(CurPos, FormLen);
end
else
Inc(CurPos);
end;
if Length(NewFormula) <> Length(CPtr^.Formula) then
begin
Value := CPtr^.FValue;
DeleteCell(Col, Row, NOUPDATE);
Good := AllocFormula(Col, Row, NewFormula, Value);
end
else
CPtr^.Formula := NewFormula;
end; { FixFormula }
procedure ChangeAutoCalc;
var
S : String[15];
begin
if (not AutoCalc) and NewMode then
Recalc;
AutoCalc := NewMode;
if AutoCalc then
S := MSGAUTOCALC
else
S := '';
SetColor(MSGAUTOCALCCOLOR);
GotoXY(73, 1);
Write(S:Length(MSGAUTOCALC));
end; { ChangeAutoCalc }
procedure ChangeFormDisplay;
var
S : String[15];
begin
FormDisplay := NewMode;
if FormDisplay then
S := MSGFORMDISPLAY
else
S := '';
SetColor(MSGFORMDISPLAYCOLOR);
GotoXY(65, 1);
Write(S:Length(MSGFORMDISPLAY));
end; { ChangeFormDisplay }
procedure Recalc;
var
Col, Row, Attrib : Word;
begin
for Col := 1 to LastCol do
begin
for Row := 1 to LastRow do
begin
if ((Cell[Col, Row] <> nil) and (Cell[Col, Row]^.Attrib = FORMULA)) then
begin
Cell[Col, Row]^.FValue := Parse(Cell[Col, Row]^.Formula, Attrib);
Cell[Col, Row]^.Error := Attrib >= 4;
end;
end;
end;
DisplayScreen(UPDATE);
end; { Recalc }
procedure Act;
var
Attrib, Dummy : Word;
Allocated : Boolean;
V : Real;
begin
DeleteCell(CurCol, CurRow, UPDATE);
V := Parse(S, Attrib);
case (Attrib and 3) of
TXT : begin
Allocated := AllocText(CurCol, CurRow, S);
if Allocated then
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
end;
VALUE : Allocated := AllocValue(CurCol, CurRow, V);
FORMULA : Allocated := AllocFormula(CurCol, CurRow, UpperCase(S), V);
end; { case }
if Allocated then
begin
if Attrib >= 4 then
begin
Cell[CurCol, CurRow]^.Error := True;
Dec(Attrib, 4);
end
else
Cell[CurCol, CurRow]^.Error := False;
Format[CurCol, CurRow] := Format[CurCol, CurRow] and (not OVERWRITE);
ClearOFlags(Succ(CurCol), CurRow, UPDATE);
if Attrib = TXT then
Dummy := SetOFlags(CurCol, CurRow, UPDATE);
if CurCol > LastCol then
LastCol := CurCol;
if CurRow > LastRow then
LastRow := CurRow;
if AutoCalc then
Recalc;
end
else
ErrorMsg(MSGLOMEM);
PrintFreeMem;
end; { Act }
begin
end.


149
Borland Turbo Pascal v4/MCMVSMEM.ASM Normal file
View File

@ -0,0 +1,149 @@
; Copyright (c) 1985, 87 by Borland International, Inc.
TITLE MCMVSMEM
DATA SEGMENT WORD PUBLIC
ASSUME DS:DATA
EXTRN CheckSnow : BYTE
DATA ENDS
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC MoveToScreen, MoveFromScreen
; procedure MoveToScreen(var Source, Dest; Len : Word);
MoveToScreen PROC FAR
push bp
mov bp,sp
push bp ; Save Turbo's BP
push ds ; and DS
mov bh,ds:CheckSnow ; Load CheckSnow value
lds si,dword ptr [bp+12] ; Source pointer into DS:SI
les di,dword ptr [bp+8] ; Dest pointer into ES:DI
mov cx,[bp+6] ; Len value into CX
cmp cx,0 ; Quit if Len = 0
je x0
cmp si,di
jle x1
cld ; Set string direction to forward
jmp short x2
x1:
add si,cx
sub si,2
add di,cx
sub di,2
std
x2:
cmp bh,0
je x7
x3:
shr cx,1 ; Change bytes to words
mov dx,3DAh ; Point DX to CGA status port
mov bl,9 ; Move horiz. + vertical retrace mask to bl
x4:
lodsw ; Grab a video word
mov bp,ax ; Save it in BP
x5:
in al,dx ; Get 6845 status
rcr al,1 ; Check horizontal retrace
jb x5 ; Loop if in horizontal retrace: this prevents
; starting in mid-retrace, since there is
; exactly enough time for 1 and only 1 STOSW
; during horizontal retrace
cli ; No ints during critical section
x6:
in al,dx ; Get 6845 status
and al,bl ; Check for both kinds of retrace: IF the
; video board does not report horizontal
; retrace while in vertical retrace, this
; will allow several characters to be
; stuffed in during vertical retrace
jz x6 ; Loop if equal to zero
mov ax,bp ; Get the video word
stosw ; Store the video word
sti ; Allow interrupts
loop x4 ; Go do next word
jmp short x0
x7:
shr cx,1 ; Change bytes to words
rep movsw
x0:
pop ds ; Restore DS
pop bp ; and BP
mov sp,bp
pop bp
ret 10
MoveToScreen ENDP
; procedure MoveFromScreen(var Source, Dest; Len : Word);
MoveFromScreen PROC FAR
push bp
mov bp,sp
push bp ; Save Turbo's BP
push ds ; and DS
mov bh,ds:CheckSnow ; Load CheckSnow value
lds si,dword ptr [bp+12] ; Source pointer into DS:SI
les di,dword ptr [bp+8] ; Dest pointer into ES:DI
mov cx,[bp+6] ; Len value into CX
cmp cx,0 ; Quit if Len = 0
je y0
cmp si,di
jle y1
cld ; Set string direction to forward
jmp short y2
y1:
add si,cx
sub si,2
add di,cx
sub di,2
std
y2:
cmp bh,0
je y6
y3:
shr cx,1 ; Change bytes to words
mov dx,3DAh ; Point DX to CGA status port
y4:
in al,dx ; Get 6845 status
rcr al,1 ; Check horizontal retrace
jb y4 ; Loop if in horizontal retrace: this prevents
; starting in mid-retrace, since there is
; exactly enough time for 1 and only 1 LODSW
; during horizontal retrace
cli ; No ints during critical section
y5:
in al,dx ; Get 6845 status
rcr al,1 ; Check for horizontal retrace: LODSW is 1
; clock cycle slower than STOSW; because of
; this, the vertical retrace trick can't be
; used because it causes flicker! (RCR AL,1
; is 1 cycle faster than AND AL,AH)
jnb y5 ; Loop if not in retrace
lodsw ; Load the video word
sti ; Allow interrupts
stosw ; Store the video word
loop y4 ; Go do next word
jmp short y0
y6:
shr cx,1 ; Change bytes to words
rep movsw
y0:
pop ds ; Restore DS
pop bp ; and BP
mov sp,bp
pop bp
ret 10
MoveFromScreen ENDP
CODE ENDS
END


BIN
Borland Turbo Pascal v4/MCMVSMEM.OBJ Normal file
View File

Binary file not shown.

874
Borland Turbo Pascal v4/MCOMMAND.PAS Normal file
View File

@ -0,0 +1,874 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCOMMAND;
interface
uses Crt, Dos, MCVars, MCUtil, MCDisply, MCParser, MCLib, MCInput;
procedure CheckForSave;
{ If the spreadsheet has been changed, will ask the user if they want to
save it.
}
procedure MoveRowUp;
{ Moves up 1 row }
procedure MoveRowDown;
{ Moves down one row }
procedure MoveColLeft;
{ Moves left one column }
procedure MoveColRight;
{ Moves right one column }
procedure EditCell(ECell : CellPtr);
{ Edits a selected cell }
procedure ClearSheet;
{ Clears the current spreadsheet }
procedure LoadSheet(FileName : IString);
{ Loads a new spreadsheet }
procedure SaveSheet;
{ Saves the current spreadsheet }
function PageRows(Row : Word; TopPage, Border : Boolean) : Word;
{ Returns the number of rows to print }
function PageCols(Col, Columns : Word; Border : Boolean) : Word;
{ Returns the number of columns to print starting at col }
procedure PrintSheet;
{ Prints a copy of the spreadsheet to a file or to the printer }
procedure SetColWidth(Col : Word);
{ Sets the new column width for a selected column }
procedure GotoCell;
{ Moves to a selected cell }
procedure FormatCells;
{ Prompts the user for a selected format and range of cells }
procedure DeleteCol(Col : Word);
{ Deletes a column }
procedure InsertCol(Col : Word);
{ Inserts a column }
procedure DeleteRow(Row : Word);
{ Deletes a row }
procedure InsertRow(Row : Word);
{ Inserts a row }
procedure SMenu;
{ Executes the commands in the spreadsheet menu }
procedure CMenu;
{ Executes the commands in the column menu }
procedure RMenu;
{ Executes the commands in the row menu }
procedure UMenu;
{ Executes the commands in the utility menu }
procedure MainMenu;
{ Executes the commands in the main menu }
implementation
const
Name : String[80] = MSGNAME;
var
Rec : CellRec;
procedure CheckForSave;
var
Save : Char;
begin
if Changed and GetYesNo(Save, MSGSAVESHEET) and (Save = 'Y') then
SaveSheet;
end; { CheckForSave }
procedure MoveRowUp;
begin
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if CurRow > TopRow then
Dec(CurRow)
else if TopRow > 1 then
begin
Scroll(DOWN, 1, Succ(LEFTMARGIN), 3, 80, ScreenRows + 2, WHITE);
Dec(TopRow);
DisplayRow(TopRow, NOUPDATE);
Dec(CurRow);
SetBottomRow;
end;
end; { MoveRowUp }
procedure MoveRowDown;
begin
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if CurRow < BottomRow then
Inc(CurRow)
else if BottomRow < MAXROWS then
begin
Scroll(UP, 1, Succ(LEFTMARGIN), 3, 80, ScreenRows + 2, WHITE);
Inc(TopRow);
Inc(CurRow);
SetBottomRow;
DisplayRow(BottomRow, NOUPDATE);
end;
end; { MoveRowDown }
procedure MoveColLeft;
var
Col, OldLeftCol : Word;
OldColStart : array[1..SCREENCOLS] of Byte;
begin
OldLeftCol := LeftCol;
Move(ColStart, OldColStart, Sizeof(ColStart));
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if (CurCol > LeftCol) then
Dec(CurCol)
else if (LeftCol <> 1) then
begin
Dec(CurCol);
Dec(LeftCol);
SetRightCol;
SetLeftCol;
if OldLeftCol <= RightCol then
Scroll(RIGHT, Pred(ColStart[Succ(OldLeftCol - LeftCol)] - LEFTMARGIN),
Succ(LEFTMARGIN), 3, 80, ScreenRows + 2, WHITE);
ClearLastCol;
for Col := LeftCol to Pred(OldLeftCol) do
DisplayCol(Col, NOUPDATE);
end;
end; { MoveColLeft }
procedure MoveColRight;
var
Col, OldLeftCol, OldRightCol : Word;
OldColStart : array[1..SCREENCOLS] of Byte;
begin
OldLeftCol := LeftCol;
Move(ColStart, OldColStart, Sizeof(ColStart));
OldRightCol := RightCol;
DisplayCell(CurCol, CurRow, NOHIGHLIGHT, NOUPDATE);
if CurCol < RightCol then
Inc(CurCol)
else if RightCol < MAXCOLS then
begin
Inc(CurCol);
Inc(RightCol);
SetLeftCol;
SetRightCol;
if OldRightCol >= LeftCol then
Scroll(LEFT, Pred(OldColStart[Succ(LeftCol - OldLeftCol)] - LEFTMARGIN),
Succ(LEFTMARGIN), 3, 80, ScreenRows + 2, WHITE);
ClearLastCol;
for Col := Succ(OldRightCol) to RightCol do
DisplayCol(Col, NOUPDATE);
end;
end; { MoveColRight }
procedure EditCell;
var
S : IString;
begin
if ECell = nil then
Exit;
case ECell^.Attrib of
TXT : S := ECell^.T;
VALUE : Str(ECell^.Value:1:MAXPLACES, S);
FORMULA : S := ECell^.Formula;
end; { case }
if (not EditString(S, '', MAXINPUT)) or (S = '') then
Exit;
Act(S);
Changed := True;
end; { EditCell }
procedure ClearSheet;
var
Col, Row : Word;
begin
for Row := 1 to LastRow do
begin
for Col := 1 to LastCol do
DeleteCell(Col, Row, NOUPDATE);
end;
InitVars;
SetRightCol;
SetBottomRow;
DisplayScreen(NOUPDATE);
PrintFreeMem;
Changed := False;
end; { ClearSheet }
procedure LoadSheet;
var
Dummy, Size, RealLastCol, RealLastRow : Word;
F : File;
Check : String[80];
Allocated : Boolean;
Blocks : Word;
RealSize : Byte;
begin
RealLastCol := 1;
RealLastRow := 1;
if FileName = '' then
begin
WritePrompt(MSGFILENAME);
if not EditString(FileName, '', MAXINPUT) then
Exit;
end;
if not Exists(FileName) then
begin
ErrorMsg(MSGNOEXIST);
Exit;
end;
Assign(F, FileName);
Reset(F, 1);
if IOResult <> 0 then
begin
ErrorMsg(MSGNOOPEN);
Exit;
end;
BlockRead(F, Check[1], Length(Name), Blocks);
Check[0] := Chr(Length(Name));
if Check <> Name then
begin
ErrorMsg(MSGNOMICROCALC);
Close(F);
Exit;
end;
BlockRead(F, Size, 1, Blocks);
BlockRead(F, RealSize, 1, Blocks);
if RealSize <> SizeOf(Real) then
begin
ErrorMsg(MSGBADREALS);
Close(F);
Exit;
end;
SetColor(PROMPTCOLOR);
GotoXY(1, ScreenRows + 5);
Write(MSGLOADING);
GotoXY(Succ(Length(MSGLOADING)), ScreenRows + 5);
ClearSheet;
BlockRead(F, LastCol, SizeOf(LastCol), Blocks);
BlockRead(F, LastRow, SizeOf(LastRow), Blocks);
BlockRead(F, Size, SizeOf(Size), Blocks);
BlockRead(F, ColWidth, Sizeof(ColWidth), Blocks);
repeat
BlockRead(F, CurCol, SizeOf(CurCol), Blocks);
BlockRead(F, CurRow, SizeOf(CurRow), Blocks);
BlockRead(F, Format[CurCol, CurRow], 1, Blocks);
BlockRead(F, Size, SizeOf(Size), Blocks);
BlockRead(F, Rec, Size, Blocks);
case Rec.Attrib of
TXT : begin
Allocated := AllocText(CurCol, CurRow, Rec.T);
if Allocated then
Dummy := SetOFlags(CurCol, CurRow, NOUPDATE);
end;
VALUE : Allocated := AllocValue(CurCol, CurRow, Rec.Value);
FORMULA : Allocated := AllocFormula(CurCol, CurRow, Rec.Formula,
Rec.Fvalue);
end; { case }
if not Allocated then
begin
ErrorMsg(MSGFILELOMEM);
LastRow := RealLastRow;
LastCol := RealLastCol;
Format[CurCol, CurRow] := DEFAULTFORMAT;
end
else begin
Cell[CurCol, CurRow]^.Error := Rec.Error;
if CurCol > RealLastCol then
RealLastCol := CurCol;
if CurRow > RealLastRow then
RealLastRow := CurRow;
end;
until (not Allocated) or (EOF(F));
PrintFreeMem;
Close(F);
CurCol := 1;
CurRow := 1;
SetRightCol;
DisplayScreen(NOUPDATE);
SetColor(White);
GotoXY(1, ScreenRows + 5);
ClrEol;
Changed := False;
end; { LoadSheet }
procedure SaveSheet;
var
FileName : IString;
EndOfFile, Overwrite : Char;
Size, Col, Row : Word;
F : File;
CPtr : CellPtr;
Blocks : Word;
RealSize : Byte;
begin
EndOfFile := #26;
FileName := '';
RealSize := SizeOf(Real);
WritePrompt(MSGFILENAME);
if not EditString(FileName, '', MAXINPUT) then
Exit;
Assign(F, FileName);
if Exists(FileName) then
begin
if (not GetYesNo(Overwrite, MSGOVERWRITE)) or (Overwrite = 'N') then
Exit;
Reset(F, 1);
end
else
Rewrite(F, 1);
if IOResult <> 0 then
begin
ErrorMsg(MSGNOOPEN);
Exit;
end;
SetColor(PROMPTCOLOR);
GotoXY(1, ScreenRows + 5);
Write(MSGSAVING);
GotoXY(Length(MSGSAVING) + 1, ScreenRows + 5);
BlockWrite(F, Name[1], Length(Name), Blocks);
BlockWrite(F, EndOfFile, 1, Blocks);
BlockWrite(F, RealSize, 1, Blocks);
BlockWrite(F, LastCol, SizeOf(LastCol), Blocks);
BlockWrite(F, LastRow, SizeOf(LastRow), Blocks);
Size := MAXCOLS;
BlockWrite(F, Size, SizeOf(Size), Blocks);
BlockWrite(F, ColWidth, Sizeof(ColWidth), Blocks);
for Row := 1 to LastRow do
begin
for Col := LastCol downto 1 do
begin
if Cell[Col, Row] <> nil then
begin
CPtr := Cell[Col, Row];
case CPtr^.Attrib of
TXT : Size := Length(CPtr^.T) + 3;
VALUE : Size := Sizeof(Real) + 2;
FORMULA : Size := Length(CPtr^.Formula) + Sizeof(Real) + 3;
end; { case }
BlockWrite(F, Col, SizeOf(Col), Blocks);
BlockWrite(F, Row, SizeOf(Row), Blocks);
BlockWrite(F, Format[Col, Row], 1, Blocks);
BlockWrite(F, Size, SizeOf(Size), Blocks);
BlockWrite(F, CPtr^, Size, Blocks);
end;
end;
end;
Close(F);
SetColor(White);
GotoXY(1, ScreenRows + 5);
ClrEol;
Changed := False;
end; { SaveSheet }
function PageRows;
var
Rows : Word;
begin
if TopPage then
Rows := 66 - TOPMARGIN
else
Rows := 66;
if Border then
Dec(Rows);
if Pred(Row + Rows) > LastRow then
PageRows := Succ(LastRow - Row)
else
PageRows := Rows;
end; { PageRows }
function PageCols;
var
Len : Integer;
FirstCol : Word;
begin
if (Col = 1) and Border then
Len := Columns - LEFTMARGIN
else
Len := Columns;
FirstCol := Col;
while (Len > 0) and (Col <= LastCol) do
begin
Dec(Len, ColWidth[Col]);
Inc(Col);
end;
if Len < 0 then
Dec(Col);
PageCols := Col - FirstCol;
end; { PageCols }
procedure PrintSheet;
var
FileName : IString;
S : String[132];
ColStr : String[MAXCOLWIDTH];
F : Text;
Columns, Counter1, Counter2, Counter3, Col, Row, LCol, LRow, Dummy,
Printed, OldLastCol : Word;
Answer : Char;
Border, TopPage : Boolean;
begin
Col := 1;
WritePrompt(MSGPRINT);
FileName := '';
if not EditString(FileName, '', MAXINPUT) then
Exit;
if FileName = '' then
FileName := 'PRN';
Assign(F, FileName);
{$I-}
Rewrite(F);
if IOResult <> 0 then
begin
ErrorMsg(MSGNOOPEN);
Exit;
end;
{$I+}
OldLastCol := LastCol;
for Counter1 := 1 to LastRow do
begin
for Counter2 := LastCol to MAXCOLS do
begin
if Format[Counter2, Counter1] >= OVERWRITE then
LastCol := Counter2;
end;
end;
if not GetYesNo(Answer, MSGCOLUMNS) then
Exit;
if Answer = 'Y' then
Columns := 132
else
Columns := 80;
if not GetYesNo(Answer, MSGBORDER) then
Exit;
Border := Answer = 'Y';
while Col <= LastCol do
begin
Row := 1;
TopPage := True;
LCol := PageCols(Col, Columns, Border) + Col;
while Row <= LastRow do
begin
LRow := PageRows(Row, TopPage, Border) + Row;
Printed := 0;
if TopPage then
begin
for Counter1 := 1 to TOPMARGIN do
begin
Writeln(F);
Inc(Printed);
end;
end;
for Counter1 := Row to Pred(LRow) do
begin
if Border and (Counter1 = Row) and (TopPage) then
begin
if (Col = 1) and Border then
begin
S[0] := Chr(LEFTMARGIN);
FillChar(S[1], LEFTMARGIN, ' ');
end
else
S := '';
for Counter3 := Col to Pred(LCol) do
begin
ColStr := CenterColString(Counter3);
S := S + ColStr;
end;
Writeln(F, S);
Printed := Succ(Printed);
end;
if (Col = 1) and Border then
S := Pad(WordToString(Counter1, 1), LEFTMARGIN)
else
S := '';
for Counter2 := Col to Pred(LCol) do
S := S + CellString(Counter2, Counter1, Dummy, DOFORMAT);
Writeln(F, S);
Inc(Printed);
end;
Row := LRow;
TopPage := False;
if Printed < 66 then
Write(F, FORMFEED);
end;
Col := LCol;
end;
Close(F);
LastCol := OldLastCol;
end; { PrintSheet }
procedure SetColWidth;
var
Width, Row : Word;
begin
WritePrompt(MSGCOLWIDTH);
if not GetWord(Width, MINCOLWIDTH, MAXCOLWIDTH) then
Exit;
ColWidth[Col] := Width;
SetRightCol;
if RightCol < Col then
begin
RightCol := Col;
SetLeftCol;
SetRightCol;
end;
for Row := 1 to LastRow do
begin
if (Cell[Col, Row] <> nil) and (Cell[Col, Row]^.Attrib = TXT) then
ClearOFlags(Succ(Col), Row, NOUPDATE)
else
ClearOFlags(Col, Row, NOUPDATE);
UpdateOFlags(Col, Row, NOUPDATE);
end;
DisplayScreen(NOUPDATE);
Changed := True;
end; { SetColWidth }
procedure GotoCell;
begin
WritePrompt(MSGGOTO);
if not GetCell(CurCol, CurRow) then
Exit;
LeftCol := CurCol;
TopRow := CurRow;
SetBottomRow;
SetRightCol;
SetLeftCol;
DisplayScreen(NOUPDATE);
end; { GotoCell }
procedure FormatCells;
var
Col, Row, Col1, Col2, Row1, Row2, NewFormat, ITemp : Word;
Temp : Char;
begin
NewFormat := 0;
WritePrompt(MSGCELL1);
if not GetCell(Col1, Row1) then
Exit;
WritePrompt(MSGCELL2);
if not GetCell(Col2, Row2) then
Exit;
if (Col1 <> Col2) and (Row1 <> Row2) then
ErrorMsg(MSGDIFFCOLROW)
else begin
if Col1 > Col2 then
Switch(Col1, Col2);
if Row1 > Row2 then
Switch(Row1, Row2);
if not GetYesNo(Temp, MSGRIGHTJUST) then
Exit;
NewFormat := NewFormat + (Ord(Temp = 'Y') * RJUSTIFY);
if not GetYesNo(Temp, MSGDOLLAR) then
Exit;
NewFormat := NewFormat + (Ord(Temp = 'Y') * DOLLAR);
if not GetYesNo(Temp, MSGCOMMAS) then
Exit;
NewFormat := NewFormat + (Ord(Temp = 'Y') * COMMAS);
if (NewFormat and DOLLAR) <> 0 then
NewFormat := NewFormat + 2
else begin
WritePrompt(MSGPLACES);
if not GetWord(ITemp, 0, MAXPLACES) then
Exit;
NewFormat := NewFormat + ITemp;
end;
for Col := Col1 to Col2 do
begin
for Row := Row1 to Row2 do
begin
Format[Col, Row] := (Format[Col, Row] and OVERWRITE) or NewFormat;
if (Col >= LeftCol) and (Col <= RightCol) and
(Row >= TopRow) and (Row <= BottomRow) then
DisplayCell(Col, Row, NOHIGHLIGHT, NOUPDATE);
end;
end;
end;
Changed := True;
end; { FormatCells }
procedure DeleteCol;
var
OldLastCol, Counter, Row : Word;
begin
if Col > LastCol then
Exit;
OldLastCol := LastCol;
for Counter := 1 to LastRow do
DeleteCell(Col, Counter, NOUPDATE);
PrintFreeMem;
if Col <> OldLastCol then
begin
Move(Cell[Succ(Col), 1], Cell[Col, 1], MAXROWS * Sizeof(CellPtr) *
(OldLastCol - Col));
Move(Format[Succ(Col), 1], Format[Col, 1], MAXROWS * (OldLastCol - Col));
Move(ColWidth[Succ(Col)], ColWidth[Col], OldLastCol - Col);
end;
FillChar(Cell[OldLastCol, 1], MAXROWS * Sizeof(CellPtr), 0);
FillChar(Format[OldLastCol, 1], MAXROWS, DEFAULTFORMAT);
ColWidth[OldLastCol] := DEFAULTWIDTH;
SetRightCol;
if CurCol > RightCol then
begin
Inc(RightCol);
SetLeftCol;
end;
ClearLastCol;
if OldLastCol = LastCol then
Dec(LastCol);
for Counter := 1 to LastCol do
begin
for Row := 1 to LastRow do
begin
if (Cell[Counter, Row] <> nil) and
(Cell[Counter, Row]^.Attrib = FORMULA) then
FixFormula(Counter, Row, COLDEL, Col);
UpdateOFlags(Col, Row, NOUPDATE);
end;
end;
for Counter := Col to RightCol do
DisplayCol(Counter, NOUPDATE);
LastCol := MAXCOLS;
SetLastCol;
Changed := True;
Recalc;
end; { DeleteCol }
procedure InsertCol;
var
Counter, Row : Word;
begin
if (LastCol = MAXCOLS) or (Col > LastCol) then
Exit;
if Col <> LastCol then
begin
Move(Cell[Col, 1], Cell[Col + 1, 1], MAXROWS * Sizeof(CellPtr) *
Succ(LastCol - Col));
Move(Format[Col, 1], Format[Col + 1, 1], MAXROWS * Succ(LastCol - Col));
Move(ColWidth[Col], ColWidth[Col + 1], Succ(LastCol - Col));
end;
if LastCol < MAXCOLS then
Inc(LastCol);
FillChar(Cell[Col, 1], MAXROWS * Sizeof(CellPtr), 0);
FillChar(Format[Col, 1], MAXROWS, DEFAULTFORMAT);
ColWidth[Col] := DEFAULTWIDTH;
SetRightCol;
if CurCol > RightCol then
begin
Inc(RightCol);
SetLeftCol;
end;
for Counter := 1 to LastCol do
begin
for Row := 1 to LastRow do
begin
if (Cell[Counter, Row] <> nil) and
(Cell[Counter, Row]^.Attrib = FORMULA) then
FixFormula(Counter, Row, COLADD, Col);
UpdateOFlags(Col, Row, NOUPDATE);
end;
end;
for Counter := Col to RightCol do
DisplayCol(Counter, NOUPDATE);
LastCol := MAXCOLS;
SetLastCol;
Changed := True;
Recalc;
end; { InsertCol }
procedure DeleteRow;
var
OldLastRow, Counter, RowC : Word;
begin
if Row > LastRow then
Exit;
OldLastRow := LastRow;
for Counter := 1 to LastCol do
DeleteCell(Counter, Row, NOUPDATE);
PrintFreeMem;
if Row <> OldLastRow then
begin
for Counter := 1 to MAXCOLS do
begin
Move(Cell[Counter, Succ(Row)], Cell[Counter, Row],
Sizeof(CellPtr) * (OldLastRow - Row));
Move(Format[Counter, Succ(Row)], Format[Counter, Row],
OldLastRow - Row);
end;
end;
for Counter := 1 to LastCol do
begin
Cell[Counter, OldLastRow] := nil;
Format[Counter, OldLastRow] := DEFAULTFORMAT;
end;
if OldLastRow = LastRow then
Dec(LastRow);
for Counter := 1 to LastCol do
begin
for RowC := 1 to LastRow do
begin
if (Cell[Counter, RowC] <> nil) and
(Cell[Counter, RowC]^.Attrib = FORMULA) then
FixFormula(Counter, RowC, ROWDEL, Row);
end;
end;
for Counter := Row to BottomRow do
DisplayRow(Counter, NOUPDATE);
LastRow := MAXROWS;
SetLastRow;
Changed := True;
Recalc;
end; { DeleteRow }
procedure InsertRow;
var
Counter, RowC : Word;
begin
if (LastRow = MAXROWS) or (Row > LastRow) then
Exit;
if Row <> LastRow then
begin
for Counter := 1 to MAXCOLS do
begin
Move(Cell[Counter, Row], Cell[Counter, Succ(Row)],
Sizeof(CellPtr) * Succ(LastRow - Row));
Move(Format[Counter, Row], Format[Counter, Succ(Row)],
Succ(LastRow - Row));
end;
end;
Inc(LastRow);
for Counter := 1 to LastCol do
begin
Cell[Counter, Row] := nil;
Format[Counter, Row] := DEFAULTFORMAT;
end;
for Counter := 1 to LastCol do
begin
for RowC := 1 to LastRow do
begin
if (Cell[Counter, RowC] <> nil) and
(Cell[Counter, RowC]^.Attrib = FORMULA) then
FixFormula(Counter, RowC, ROWADD, Row);
end;
end;
for Counter := Row to BottomRow do
DisplayRow(Counter, NOUPDATE);
LastRow := MAXROWS;
SetLastRow;
Changed := True;
Recalc;
end; { InsertRow }
procedure SMenu;
var
FileName : IString;
X : Word;
begin
FileName := '';
case GetCommand(SMNU, SCOMMAND) of
1 : begin
CheckForSave;
LoadSheet(FileName);
end;
2 : SaveSheet;
3 : PrintSheet;
4 : begin
CheckForSave;
ClearSheet;
end;
end; { case }
end; { SMenu }
procedure CMenu;
begin
case GetCommand(CMNU, CCOMMAND) of
1 : InsertCol(CurCol);
2 : DeleteCol(CurCol);
3 : SetColWidth(CurCol);
end; { case }
end; { CMenu }
procedure RMenu;
begin
case GetCommand(RMNU, RCOMMAND) of
1 : InsertRow(CurRow);
2 : DeleteRow(CurRow);
end; { case }
end; { CMenu }
procedure UMenu;
begin
case GetCommand(UMenuString, UCommandString) of
1 : Recalc;
2 : begin
ChangeFormDisplay(not FormDisplay);
DisplayScreen(UPDATE);
end;
3 : begin
if ScreenRows = 38 then
begin
ScreenRows := 20;
TextMode(Lo(LastMode));
SetCursor(NoCursor);
RedrawScreen;
end
else begin
TextMode(Lo(LastMode) + Font8x8);
if (LastMode and Font8x8) <> 0 then
begin
ScreenRows := 38;
SetCursor(NoCursor);
RedrawScreen;
end;
end;
end;
end; { case }
end; { UMenu }
procedure MainMenu;
begin
case GetCommand(MNU, COMMAND) of
1 : SMenu;
2 : FormatCells;
3 : begin
DeleteCell(CurCol, CurRow, UPDATE);
PrintFreeMem;
if AutoCalc then
Recalc;
end;
4 : GotoCell;
5 : CMenu;
6 : RMenu;
7 : EditCell(CurCell);
8 : UMenu;
9 : ChangeAutoCalc(not AutoCalc);
10 : begin
CheckForSave;
Stop := True;
end;
end; { case }
GotoXY(1, ScreenRows + 4);
ClrEol;
end; { MainMenu }
begin
end.


580
Borland Turbo Pascal v4/MCPARSER.PAS Normal file
View File

@ -0,0 +1,580 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCPARSER;
interface
uses Crt, Dos, MCVars, MCUtil, MCDisply;
function CellValue(Col, Row : Word) : Real;
{ Finds the Value of a particular cell }
function Parse(S : String; var Att : Word) : Real;
{ Parses the string s - returns the Value of the evaluated string, and puts
the attribute in Att: TXT = 0, CONSTANT = 1, FORMULA = 2, +4 = ERROR.
}
implementation
const
PLUS = 0;
MINUS = 1;
TIMES = 2;
DIVIDE = 3;
EXPO = 4;
COLON = 5;
OPAREN = 6;
CPAREN = 7;
NUM = 8;
CELLT = 9;
FUNC = 10;
EOL = 11;
BAD = 12;
MAXFUNCNAMELEN = 5;
type
TokenRec = record
State : Byte;
case Byte of
0 : (Value : Real);
1 : (Row, Col : Word);
2 : (FuncName : String[MAXFUNCNAMELEN]);
end;
var
Stack : array [1..PARSERSTACKSIZE] of TokenRec;
CurToken : TokenRec;
StackTop, TokenType : Word;
MathError, TokenError, IsFormula : Boolean;
Input : IString;
function IsFunc(S : String) : Boolean;
{ Checks to see if the start of the Input string is a legal function.
Returns TRUE if it is, FALSE otherwise.
}
var
Len : Word;
begin
Len := Length(S);
if Pos(S, Input) = 1 then
begin
CurToken.FuncName := Copy(Input, 1, Len);
Delete(Input, 1, Len);
IsFunc := True;
end
else
IsFunc := False;
end; { IsFunc }
function NextToken : Word;
{ Gets the next Token from the Input stream }
var
NumString : String[80];
FormLen, Place, Len, NumLen, Check : Word;
FirstChar : Char;
Decimal : Boolean;
begin
if Input = '' then
begin
NextToken := EOL;
Exit;
end;
while (Input <> '') and (Input[1] = ' ') do
Delete(Input, 1, 1);
if Input[1] in ['0'..'9', '.'] then
begin
NumString := '';
Len := 1;
Decimal := False;
while (Len <= Length(Input)) and
((Input[Len] in ['0'..'9']) or
((Input[Len] = '.') and (not Decimal))) do
begin
NumString := NumString + Input[Len];
if Input[1] = '.' then
Decimal := True;
Inc(Len);
end;
if (Len = 2) and (Input[1] = '.') then
begin
NextToken := BAD;
Exit;
end;
if (Len <= Length(Input)) and (Input[Len] = 'E') then
begin
NumString := NumString + 'E';
Inc(Len);
if Input[Len] in ['+', '-'] then
begin
NumString := NumString + Input[Len];
Inc(Len);
end;
NumLen := 1;
while (Len <= Length(Input)) and (Input[Len] in ['0'..'9']) and
(NumLen <= MAXEXPLEN) do
begin
NumString := NumString + Input[Len];
Inc(NumLen);
Inc(Len);
end;
end;
if NumString[1] = '.' then
NumString := '0' + NumString;
Val(NumString, CurToken.Value, Check);
if Check <> 0 then
MathError := True;
NextToken := NUM;
Delete(Input, 1, Length(NumString));
Exit;
end
else if Input[1] in LETTERS then
begin
if IsFunc('ABS') or
IsFunc('ATAN') or
IsFunc('COS') or
IsFunc('EXP') or
IsFunc('LN') or
IsFunc('ROUND') or
IsFunc('SIN') or
IsFunc('SQRT') or
IsFunc('SQR') or
IsFunc('TRUNC') then
begin
NextToken := FUNC;
Exit;
end;
if FormulaStart(Input, 1, CurToken.Col, CurToken.Row, FormLen) then
begin
Delete(Input, 1, FormLen);
IsFormula := True;
NextToken := CELLT;
Exit;
end
else begin
NextToken := BAD;
Exit;
end;
end
else begin
case Input[1] of
'+' : NextToken := PLUS;
'-' : NextToken := MINUS;
'*' : NextToken := TIMES;
'/' : NextToken := DIVIDE;
'^' : NextToken := EXPO;
':' : NextToken := COLON;
'(' : NextToken := OPAREN;
')' : NextToken := CPAREN;
else
NextToken := BAD;
end;
Delete(Input, 1, 1);
Exit;
end; { case }
end; { NextToken }
procedure Push(Token : TokenRec);
{ Pushes a new Token onto the stack }
begin
if StackTop = PARSERSTACKSIZE then
begin
ErrorMsg(MSGSTACKERROR);
TokenError := True;
end
else begin
Inc(StackTop);
Stack[StackTop] := Token;
end;
end; { Push }
procedure Pop(var Token : TokenRec);
{ Pops the top Token off of the stack }
begin
Token := Stack[StackTop];
Dec(StackTop);
end; { Pop }
function GotoState(Production : Word) : Word;
{ Finds the new state based on the just-completed production and the
top state.
}
var
State : Word;
begin
State := Stack[StackTop].State;
if (Production <= 3) then
begin
case State of
0 : GotoState := 1;
9 : GotoState := 19;
20 : GotoState := 28;
end; { case }
end
else if Production <= 6 then
begin
case State of
0, 9, 20 : GotoState := 2;
12 : GotoState := 21;
13 : GotoState := 22;
end; { case }
end
else if Production <= 8 then
begin
case State of
0, 9, 12, 13, 20 : GotoState := 3;
14 : GotoState := 23;
15 : GotoState := 24;
16 : GotoState := 25;
end; { case }
end
else if Production <= 10 then
begin
case State of
0, 9, 12..16, 20 : GotoState := 4;
end; { case }
end
else if Production <= 12 then
begin
case State of
0, 9, 12..16, 20 : GotoState := 6;
5 : GotoState := 17;
end; { case }
end
else begin
case State of
0, 5, 9, 12..16, 20 : GotoState := 8;
end; { case }
end;
end; { GotoState }
function CellValue;
var
CPtr : CellPtr;
begin
CPtr := Cell[Col, Row];
if (CPtr = nil) then
CellValue := 0
else begin
if (CPtr^.Error) or (CPtr^.Attrib = TXT) then
MathError := True;
if CPtr^.Attrib = FORMULA then
CellValue := CPtr^.FValue
else
CellValue := CPtr^.Value;
end;
end; { CellValue }
procedure Shift(State : Word);
{ Shifts a Token onto the stack }
begin
CurToken.State := State;
Push(CurToken);
TokenType := NextToken;
end; { Shift }
procedure Reduce(Reduction : Word);
{ Completes a reduction }
var
Token1, Token2 : TokenRec;
Counter : Word;
begin
case Reduction of
1 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
CurToken.Value := Token1.Value + Token2.Value;
end;
2 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
CurToken.Value := Token2.Value - Token1.Value;
end;
4 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
CurToken.Value := Token1.Value * Token2.Value;
end;
5 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
if Token1.Value = 0 then
MathError := True
else
CurToken.Value := Token2.Value / Token1.Value;
end;
7 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
if Token2.Value <= 0 then
MathError := True
else if (Token1.Value * Ln(Token2.Value) < -EXPLIMIT) or
(Token1.Value * Ln(Token2.Value) > EXPLIMIT) then
MathError := True
else
CurToken.Value := Exp(Token1.Value * Ln(Token2.Value));
end;
9 : begin
Pop(Token1);
Pop(Token2);
CurToken.Value := -Token1.Value;
end;
11 : begin
Pop(Token1);
Pop(Token2);
Pop(Token2);
CurToken.Value := 0;
if Token1.Row = Token2.Row then
begin
if Token1.Col < Token2.Col then
TokenError := True
else begin
for Counter := Token2.Col to Token1.Col do
CurToken.Value := CurToken.Value + CellValue(Counter, Token1.Row);
end;
end
else if Token1.Col = Token2.Col then
begin
if Token1.Row < Token2.Row then
TokenError := True
else begin
for Counter := Token2.Row to Token1.Row do
CurToken.Value := CurToken.Value + CellValue(Token1.Col, Counter);
end;
end
else
TokenError := True;
end;
13 : begin
Pop(CurToken);
CurToken.Value := CellValue(CurToken.Col, CurToken.Row);
end;
14 : begin
Pop(Token1);
Pop(CurToken);
Pop(Token1);
end;
16 : begin
Pop(Token1);
Pop(CurToken);
Pop(Token1);
Pop(Token1);
if Token1.FuncName = 'ABS' then
CurToken.Value := Abs(CurToken.Value)
else if Token1.FuncName = 'ATAN' then
CurToken.Value := ArcTan(CurToken.Value)
else if Token1.FuncName = 'COS' then
CurToken.Value := Cos(CurToken.Value)
else if Token1.FuncName = 'EXP' then
begin
if (CurToken.Value < -EXPLIMIT) or (CurToken.Value > EXPLIMIT) then
MathError := True
else
CurToken.Value := Exp(CurToken.Value);
end
else if Token1.FuncName = 'LN' then
begin
if CurToken.Value <= 0 then
MathError := True
else
CurToken.Value := Ln(CurToken.Value);
end
else if Token1.FuncName = 'ROUND' then
begin
if (CurToken.Value < -1E9) or (CurToken.Value > 1E9) then
MathError := True
else
CurToken.Value := Round(CurToken.Value);
end
else if Token1.FuncName = 'SIN' then
CurToken.Value := Sin(CurToken.Value)
else if Token1.FuncName = 'SQRT' then
begin
if CurToken.Value < 0 then
MathError := True
else
CurToken.Value := Sqrt(CurToken.Value);
end
else if Token1.FuncName = 'SQR' then
begin
if (CurToken.Value < -SQRLIMIT) or (CurToken.Value > SQRLIMIT) then
MathError := True
else
CurToken.Value := Sqr(CurToken.Value);
end
else if Token1.FuncName = 'TRUNC' then
begin
if (CurToken.Value < -1E9) or (CurToken.Value > 1E9) then
MathError := True
else
CurToken.Value := Trunc(CurToken.Value);
end;
end;
3, 6, 8, 10, 12, 15 : Pop(CurToken);
end; { case }
CurToken.State := GotoState(Reduction);
Push(CurToken);
end; { Reduce }
function Parse;
var
FirstToken : TokenRec;
Accepted : Boolean;
Counter : Word;
begin
Accepted := False;
TokenError := False;
MathError := False;
IsFormula := False;
Input := UpperCase(S);
StackTop := 0;
FirstToken.State := 0;
FirstToken.Value := 0;
Push(FirstToken);
TokenType := NextToken;
repeat
case Stack[StackTop].State of
0, 9, 12..16, 20 : begin
if TokenType = NUM then
Shift(10)
else if TokenType = CELLT then
Shift(7)
else if TokenType = FUNC then
Shift(11)
else if TokenType = MINUS then
Shift(5)
else if TokenType = OPAREN then
Shift(9)
else
TokenError := True;
end;
1 : begin
if TokenType = EOL then
Accepted := True
else if TokenType = PLUS then
Shift(12)
else if TokenType = MINUS then
Shift(13)
else
TokenError := True;
end;
2 : begin
if TokenType = TIMES then
Shift(14)
else if TokenType = DIVIDE then
Shift(15)
else
Reduce(3);
end;
3 : Reduce(6);
4 : begin
if TokenType = EXPO then
Shift(16)
else
Reduce(8);
end;
5 : begin
if TokenType = NUM then
Shift(10)
else if TokenType = CELLT then
Shift(7)
else if TokenType = FUNC then
Shift(11)
else if TokenType = OPAREN then
Shift(9)
else
TokenError := True;
end;
6 : Reduce(10);
7 : begin
if TokenType = COLON then
Shift(18)
else
Reduce(13);
end;
8 : Reduce(12);
10 : Reduce(15);
11 : begin
if TokenType = OPAREN then
Shift(20)
else
TokenError := True;
end;
17 : Reduce(9);
18 : begin
if TokenType = CELLT then
Shift(26)
else
TokenError := True;
end;
19 : begin
if TokenType = PLUS then
Shift(12)
else if TokenType = MINUS then
Shift(13)
else if TokenType = CPAREN then
Shift(27)
else
TokenError := True;
end;
21 : begin
if TokenType = TIMES then
Shift(14)
else if TokenType = DIVIDE then
Shift(15)
else
Reduce(1);
end;
22 : begin
if TokenType = TIMES then
Shift(14)
else if TokenType = DIVIDE then
Shift(15)
else
Reduce(2);
end;
23 : Reduce(4);
24 : Reduce(5);
25 : Reduce(7);
26 : Reduce(11);
27 : Reduce(14);
28 : begin
if TokenType = PLUS then
Shift(12)
else if TokenType = MINUS then
Shift(13)
else if TokenType = CPAREN then
Shift(29)
else
TokenError := True;
end;
29 : Reduce(16);
end; { case }
until Accepted or TokenError;
if TokenError then
begin
Att := TXT;
Parse := 0;
Exit;
end;
if IsFormula then
Att := FORMULA
else
Att := VALUE;
if MathError then
begin
Inc(Att, 4);
Parse := 0;
Exit;
end;
Parse := Stack[StackTop].Value;
end; { Parse }
begin
end.


417
Borland Turbo Pascal v4/MCUTIL.PAS Normal file
View File

@ -0,0 +1,417 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCUTIL;
interface
uses Crt, Dos, MCVars;
function Pad(S : String; Len : Word) : String;
{ Pads a string on the right with spaces to a specified length }
function Spaces(Num : Word) : String;
{ Returns a string of the specified number of spaces }
function UpperCase(S : String) : String;
{ Returns a string of all upper case letters }
function WordToString(Num, Len : Word) : String;
{ Changes a word to a string }
function RealToString(Num : Real; Len, Places : Word) : String;
{ Changes a real to a string }
function AllocText(Col, Row : Word; S : String) : Boolean;
{ Allocates space for a text cell }
function AllocValue(Col, Row : Word; Amt : Real) : Boolean;
{ Allocates space for a value cell }
function AllocFormula(Col, Row : Word; S : String; Amt : Real) : Boolean;
{ Allocates space for a formula cell }
function RowWidth(Row : Word) : Word;
{ Returns the width in spaces of row }
function FormulaStart(Input : String; Place : Word;
var Col, Row, FormLen : Word) : Boolean;
{ Returns TRUE if the string is the start of a formula, FALSE otherwise.
Also returns the column, row, and length of the formula.
}
function ColString(Col : Word) : String;
{ Changes a column number to a string }
function CenterColString(Col : Word) : String;
{ Changes a column to a centered string }
function TextString(InString : String; Col, FValue : Word;
Formatting : Boolean) : String;
{ Sets the string representation of text }
function ValueString(CPtr : CellPtr; Value : Real; Col, FValue : Word;
var Color : Word; Formatting : Boolean) : String;
{ Sets the string representation of a value }
function CellString(Col, Row : Word; var Color : Word;
Formatting : Boolean) : String;
{ Creates an output string for the data in the cell in (col, row), and
also returns the color of the cell }
procedure Switch(var Val1, Val2 : Word);
{ Swaps the first and second values }
procedure InitVars;
{ Initializes various global variables }
function Exists(FileName : String) : Boolean;
{ Returns True if the file FileName exists, False otherwise }
implementation
{$F+}
function HeapFunc(Size : Word) : Word;
{ Used to handle heap errors }
begin
HeapFunc := 1; { Forces New or GetMem to return a nil pointer }
end; { HeapFunc }
{$F-}
function Pad;
begin
if Length(S) < Len then
FillChar(S[Succ(Length(S))], Len - Length(S), ' ');
S[0] := Chr(Len);
Pad := S;
end; { Pad }
function Spaces;
var
S : String;
begin
S[0] := Chr(Num);
FillChar(S[1], Num, ' ');
Spaces := S;
end; { Spaces }
function UpperCase;
var
Counter : Word;
begin
for Counter := 1 to Length(S) do
S[Counter] := UpCase(S[Counter]);
UpperCase := S;
end; { UpperCase }
function WordToString;
var
S : String[5];
begin
Str(Num:Len, S);
WordToString := S;
end; { WordToString }
function RealToString;
var
S : String[80];
begin
Str(Num:Len:Places, S);
RealToString := S;
end; { RealToString }
function AllocText;
var
CPtr : CellPtr;
begin
AllocText := False;
GetMem(CPtr, Length(S) + 3);
if CPtr = nil then
Exit;
CPtr^.Attrib := TXT;
CPtr^.Error := False;
CPtr^.T := S;
Cell[Col, Row] := CPtr;
AllocText := True;
end; { AllocText }
function AllocValue;
var
CPtr : CellPtr;
begin
AllocValue := False;
GetMem(CPtr, SizeOf(Real) + 2);
if CPtr = nil then
Exit;
CPtr^.Attrib := VALUE;
CPtr^.Error := False;
CPtr^.Value := Amt;
Cell[Col, Row] := CPtr;
AllocValue := True;
end; { AllocValue }
function AllocFormula;
var
CPtr : CellPtr;
begin
AllocFormula := False;
GetMem(CPtr, Length(S) + SizeOf(Real) + 3);
if CPtr = nil then
Exit;
CPtr^.Attrib := FORMULA;
CPtr^.Error := False;
CPtr^.Formula := S;
CPtr^.FValue := Amt;
Cell[Col, Row] := CPtr;
AllocFormula := True;
end; { AllocFormula }
function RowWidth;
begin
RowWidth := Succ(Trunc(Ln(Row) / Ln(10)));
end; { RowWidth }
function FormulaStart;
var
OldPlace, Len, MaxLen : Word;
Start : IString;
NumString : String[10];
begin
FormulaStart := False;
OldPlace := Place;
MaxLen := RowWidth(MAXROWS);
if not (Input[Place] in LETTERS) then
Exit;
Col := Succ(Ord(Input[Place]) - Ord('A'));
Inc(Place);
if Input[Place] in LETTERS then
begin
Col := Col * 26;
Col := Succ(Col + Ord(Input[Place]) - Ord('A'));
Inc(Place);
end;
if Col > MAXCOLS then
Exit;
Start := Copy(Input, Place, MaxLen);
Len := 0;
while (Place <= Length(Input)) and
(Input[Place] in ['0'..'9']) and (Len < MaxLen) do
begin
Inc(Len);
Inc(Place);
end;
if Len = 0 then
Exit;
NumString := Copy(Start, 1, Len);
Val(NumString, Row, Len);
if Row > MAXROWS then
Exit;
FormLen := Place - OldPlace;
FormulaStart := True;
end; { FormulaStart }
function ColString;
begin
if Col <= 26 then
ColString := Chr(Pred(Col) + Ord('A'))
else
ColString := Chr((Pred(Col) div 26) + Pred(Ord('A'))) +
Chr((Pred(Col) mod 26) + Ord('A'));
end; { ColString }
function CenterColString;
var
S : String[2];
Spaces1, Spaces2 : Word;
begin
S := ColString(Col);
Spaces1 := (ColWidth[Col] - Length(S)) shr 1;
Spaces2 := ColWidth[Col] - Length(S) - Spaces1;
CenterColString := Spaces(Spaces1) + S + Spaces(Spaces2);
end; { CenterColString }
function TextString;
var
OutString : String[80];
begin
if ((FValue and RJUSTIFY) <> 0) and Formatting then
begin
OutString := InString;
if Length(OutString) < ColWidth[Col] then
begin
while Length(OutString) < ColWidth[Col] do
OutString := ' ' + OutString;
end
else
OutString[0] := Chr(ColWidth[Col]);
end
else begin
if Formatting then
OutString := Pad(InString, ColWidth[Col])
else
OutString := InString;
end;
TextString := OutString;
end; { TextString }
function ValueString;
var
VString : String[MAXCOLWIDTH];
FString : String[3];
Width, P : Word;
begin
if Formatting then
begin
Str(CPtr^.Value:1:(FValue and 15), VString);
if (FValue and COMMAS) <> 0 then
begin
P := Pos('.', VString);
if P = 0 then
P := Succ(Length(VString));
while P > 4 do
begin
P := P - 3;
if VString[Pred(P)] <> '-' then
Insert(',', VString, P);
end;
end;
if (FValue and DOLLAR) <> 0 then
begin
if VString[1] = '-' then
begin
FString := ' $';
Width := ColWidth[Col] - 2;
end
else begin
FString := ' $ ';
Width := ColWidth[Col] - 3;
end;
end
else begin
Width := ColWidth[Col];
FString := '';
end;
if (FValue and RJUSTIFY) <> 0 then
begin
if Length(VString) > Width then
Delete(VString, Succ(Width), Length(VString) - Width)
else begin
while Length(VString) < Width do
VString := ' ' + VString;
end;
end
else
VString := Pad(VString, Width);
VString := FString + VString;
end
else
Str(Value:1:MAXPLACES, VString);
Color := VALUECOLOR;
ValueString := VString;
end; { ValueString }
function CellString;
var
CPtr : CellPtr;
OldCol, P, NewCol, FormatValue : Word;
S : String[80];
V : Real;
begin
CPtr := Cell[Col, Row];
if CPtr = nil then
begin
if (not Formatting) or (Format[Col, Row] < OVERWRITE) then
begin
S := Spaces(ColWidth[Col]);
Color := BLANKCOLOR;
end
else begin
NewCol := Col;
Dec(NewCol);
while Cell[NewCol, Row] = nil do
Dec(NewCol);
OldCol := NewCol;
P := 1;
while (NewCol < Col) do
begin
Inc(P, ColWidth[NewCol]);
Inc(NewCol);
end;
S := Copy(Cell[OldCol, Row]^.T, P, ColWidth[Col]);
S := S + Spaces(ColWidth[Col] - Length(S));
Color := TXTCOLOR;
end;
end
else begin
FormatValue := Format[Col, Row];
if CPtr^.Error and (Formatting or (CPtr^.Attrib = VALUE)) then
begin
S := Pad(MSGERRORTXT, ColWidth[Col]);
Color := ERRORCOLOR;
end
else begin
case CPtr^.Attrib of
TXT : begin
S := TextString(CPtr^.T, Col, FormatValue, Formatting);
Color := TXTCOLOR;
end;
FORMULA : begin
if FormDisplay then
begin
S := TextString(CPtr^.Formula, Col, FormatValue, Formatting);
Color := FORMULACOLOR;
end
else begin
V := CPtr^.FValue;
S := ValueString(CPtr, V, Col, FormatValue, Color, Formatting);
end;
end;
VALUE : begin
V := CPtr^.Value;
S := ValueString(CPtr, V, Col, FormatValue, Color, Formatting);
end;
end; { case }
end;
end;
CellString := S;
end; { CellString }
procedure Switch;
var
Temp : Word;
begin
Temp := Val1;
Val1 := Val2;
Val2 := Temp;
end; { Switch }
procedure InitVars;
begin
LeftCol := 1;
TopRow := 1;
CurCol := 1;
Currow := 1;
LastCol := 1;
LastRow := 1;
AutoCalc := True;
FormDisplay := False;
FillChar(ColWidth, SizeOf(ColWidth), DEFAULTWIDTH);
FillChar(Cell, SizeOf(Cell), 0);
FillChar(Format, SizeOf(Format), DEFAULTFORMAT);
end; { InitVars }
function Exists;
var
SR : SearchRec;
begin
FindFirst(FileName, ReadOnly + Hidden + SysFile, SR);
Exists := (DosError = 0) and (Pos('?', FileName) = 0) and
(Pos('*', FileName) = 0);
end; { Exists }
begin
HeapError := @HeapFunc;
end.


195
Borland Turbo Pascal v4/MCVARS.PAS Normal file
View File

@ -0,0 +1,195 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
unit MCVARS;
interface
uses Crt;
{$IFOPT N+}
type
Real = Extended;
const
EXPLIMIT = 11356;
SQRLIMIT = 1E2466;
MAXPLACES = 8;
MAXEXPLEN = 4;
{$ELSE}
const
EXPLIMIT = 88;
SQRLIMIT = 1E18;
MAXPLACES = 4;
MAXEXPLEN = 3;
{$ENDIF}
const
MSGHEADER = 'MICROCALC - A Turbo Pascal Demonstration Program';
MSGKEYPRESS = 'Press any key to continue.';
MSGCOMMAND = 'Press / for the list of commands';
MSGMEMORY = 'Memory Available:';
MSGLOMEM = 'Not enough memory to allocate cell.';
MSGERRORTXT = 'ERROR';
MSGEMPTY = 'Empty';
MSGTEXT = 'Text';
MSGVALUE = 'Value';
MSGFORMULA = 'Formula';
MSGAUTOCALC = 'AutoCalc';
MSGFORMDISPLAY = 'Form';
MSGFILENAME = 'Enter the file name of the spreadsheet:';
MSGNAME = 'Turbo Pascal MicroCalc Spreadsheet';
MSGCOLWIDTH = 'Enter the new column width:';
MSGNOOPEN = 'Can''t open the file.';
MSGOVERWRITE = 'The file exists. Do you want to overwrite it?';
MSGFILELOMEM = 'Not enough memory for entire spreadsheet.';
MSGNOMICROCALC = 'That is not a Turbo Pascal MicroCalc spreadsheet.';
MSGBADREALS = 'The reals in the file are in a different format.';
MSGNOEXIST = 'The file does not exist.';
MSGGOTO = 'Enter the cell to go to:';
MSGBADNUMBER = 'You must enter a number from';
MSGBADCELL = 'That is not a legal cell.';
MSGCELL1 = 'Enter the first cell to format:';
MSGCELL2 = 'Enter the last cell to format:';
MSGDIFFCOLROW = 'The row or the column must be the same.';
MSGRIGHTJUST = 'Do you want the cell right-justified?';
MSGDOLLAR = 'Do you want numbers in a dollar format?';
MSGCOMMAS = 'Do you want commas in numbers?';
MSGPLACES = 'How many decimal places should the number be rounded to?';
MSGCOLUMNS = 'Do you want to print in 132 columns?';
MSGPRINT = 'Enter the file name to print to, or press ENTER to print on the printer.';
MSGBORDER = 'Print the border?';
MSGLOADING = 'Loading...';
MSGSAVING = 'Saving...';
MSGSAVESHEET = 'Save current spreadsheet?';
MSGSTACKERROR = 'Parser stack overflow.';
MNU = 'Spreadsheet, Format, Delete, Goto, Col, Row, Edit, Utility, Auto, Quit';
COMMAND = 'SFDGCREUAQ';
SMNU = 'Load, Save, Print, Clear';
SCOMMAND = 'LSPC';
CMNU = 'Insert, Delete, Width';
CCOMMAND = 'IDW';
RMNU = 'Insert, Delete';
RCOMMAND = 'ID';
UMNU = 'Recalc, Formula display, Toggle 43-line mode';
UCOMMAND = 'RFT';
MAXCOLS = 100; { Maximum is 702 }
MAXROWS = 100;
LEFTMARGIN = 3;
MINCOLWIDTH = 3;
MAXCOLWIDTH = 77;
SCREENCOLS = 26;
DEFAULTWIDTH = 10;
DEFAULTFORMAT = $42;
MAXINPUT = 79;
TOPMARGIN = 5;
PARSERSTACKSIZE = 20;
TXTCOLOR = White;
ERRORCOLOR = 140; { LightRed + Blink }
VALUECOLOR = LightCyan;
FORMULACOLOR = LightMagenta;
BLANKCOLOR = Black;
HEADERCOLOR = 79; { White on Red }
HIGHLIGHTCOLOR = 31; { White on Blue }
HIGHLIGHTERRORCOLOR = 159; { White + Blink on Blue }
MSGAUTOCALCCOLOR = LightCyan;
MSGFORMDISPLAYCOLOR = LightMagenta;
MSGMEMORYCOLOR = LightGreen;
MSGHEADERCOLOR = LightCyan;
PROMPTCOLOR = Yellow;
COMMANDCOLOR = LightCyan;
LOWCOMMANDCOLOR = White;
MEMORYCOLOR = LightRed;
CELLTYPECOLOR = LightGreen;
CELLCONTENTSCOLOR = Yellow;
HIGHLIGHT = True;
NOHIGHLIGHT = False;
UPDATE = True;
NOUPDATE = False;
DOFORMAT = True;
NOFORMAT = False;
LEFT = 0;
RIGHT = 1;
UP = 2;
DOWN = 3;
TXT = 0;
VALUE = 1;
FORMULA = 2;
COLADD = 0;
COLDEL = 1;
ROWADD = 2;
ROWDEL = 3;
OVERWRITE = $80;
RJUSTIFY = $40;
COMMAS = $20;
DOLLAR = $10;
LETTERS : set of Char = ['A'..'Z', 'a'..'z'];
NULL = #0;
BS = #8;
FORMFEED = #12;
CR = #13;
ESC = #27;
HOMEKEY = #199;
ENDKEY = #207;
UPKEY = #200;
DOWNKEY = #208;
PGUPKEY = #201;
PGDNKEY = #209;
LEFTKEY = #203;
INSKEY = #210;
RIGHTKEY = #205;
DELKEY = #211;
CTRLLEFTKEY = #243;
CTRLRIGHTKEY = #244;
F1 = #187;
F2 = #188;
F3 = #189;
F4 = #190;
F5 = #191;
F6 = #192;
F7 = #193;
F8 = #194;
F9 = #195;
F10 = #196;
type
IString = String[MAXINPUT];
CellRec = record
Error : Boolean;
case Attrib : Byte of
TXT : (T : IString);
VALUE : (Value : Real);
FORMULA : (Fvalue : Real;
Formula : IString);
end;
CellPtr = ^CellRec;
var
Cell : array [1..MAXCOLS, 1..MAXROWS] of CellPtr;
CurCell : CellPtr;
Format : array [1..MAXCOLS, 1..MAXROWS] of Byte;
ColWidth : array [1..MAXCOLS] of Byte;
ColStart : array [1..SCREENCOLS] of Byte;
LeftCol, RightCol, TopRow, BottomRow, CurCol, CurRow, LastCol,
LastRow : Word;
Changed, FormDisplay, AutoCalc, Stop, ColorCard : Boolean;
ColorTable : array [0..255] of Byte;
ScreenRows : Byte;
OldMode : Word;
UMenuString : String[80];
UCommandString : String[3];
implementation
begin
end.


BIN
Borland Turbo Pascal v4/PC3270.BGI Normal file
View File

Binary file not shown.

20
Borland Turbo Pascal v4/PRINTER.DOC Normal file
View File

@ -0,0 +1,20 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ PRINTER Unit Interface Documentation }
{ }
{ Copyright (c) 1987 Borland International, Inc. }
{ }
{*******************************************************}
{$D-,I-,S-}
unit Printer;
interface
var
Lst: Text;
implementation


48
Borland Turbo Pascal v4/PROCPTR.PAS Normal file
View File

@ -0,0 +1,48 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program ProcPtr;
{ This example program shows how to use a pointer and an inline
directive to call 2 different procedures with the same parameters.
CallProc is an inline directive (or macro) with the same parameters
as both One and TheOther. A global pointer variable, ProcAddr,
contains the address of the procedure to call. Then a call is made
to CallProc, which in turn does a far call to the address stored
in ProcAddr.
Warning: This technique is recommended only for those programmers with
assembly language programming experience.
For more information about inline directives, refer to P-367 in the
Owner's Handbook.
}
var
ProcAddr : pointer;
procedure CallProc(var i : integer; w : word; s : string);
Inline($FF/$1E/ProcAddr);
{$F+}
procedure One(var i : integer; w : word; s : string);
begin
Writeln('First One,');
end;
{$F-}
{$F+}
procedure TheOther(var i : integer; w : word; s : string);
begin
Writeln('then TheOther');
end;
{$F-}
var
i : integer;
begin
ProcAddr := @One;
CallProc(i, 7, 'data'); { first call one }
ProcAddr := @TheOther;
CallProc(i, 5, 'more data'); { then call the other }
end.


498
Borland Turbo Pascal v4/Q&A Normal file
View File

@ -0,0 +1,498 @@
COMMON QUESTIONS AND ANSWERS
----------------------------
1. Is there still a limit to the size of the code and data
segments like there was in 3.0?
The total size of a program's code is only limited by the
memory you have available; but each unit (module) can be
no larger than 64K, since it has to have its own code
segment.
The data segment is still no more than 64K, but the heap
is unlimited just as in 3.0. In fact, we've rewritten the
heap manager to make it much more efficient. There's no
waste when allocating memory (in 3.0, all blocks were
rounded up to a factor of 8), and you can install a heap
error routine that gets called if an allocation request
fails. All in all, 4.0's heap manager is much faster than
version 3.0 (see page 339).
2. Can Turbo Pascal run on generic MS-DOS machines?
TPC.EXE will run on generic machines when you use the /Q
option. The System, Dos and Printer standard units will
operate correctly on MS-DOS generic machines. Generated
.EXE's are MS-DOS compatible as long as you don't use the
special PC units (such as Crt, Graph, and Graph3). You may
not be able to use the 8087 floating- point math package,
depending on whether your machine has PC-compatible math
coprocessor support.
3. Does Turbo Pascal 4.0 support large integers?
Yes, TP 4.0 has virtually any incarnation of 8-, 16-, and
32-bit integers: shortint, integer, longint, byte, and
word (see page 209).
4. Will the Toolboxes for 3.0 be ported to version 4.0 of Turbo
Pascal?
Yes, all toolboxes have been upgraded to work with Turbo
Pascal 4.0. Contact our customer service department about
upgrading your toolboxes.
5. Does Turbo Pascal version 4.0 support any form of conditional
compilation like Turbo C does?
Yes, Turbo 4.0 includes conditional compilation support.
You use {$DEFINE ...} and {$UNDEF ...} for symbols and
{$IFDEF ...}. Using the {$IFOPT ...} conditional
directive, you can even test the settings of compiler
directives like R-, N+, and others. For the command-line
compiler, you can define symbols with the /D directive. In
the integrated compiler, you can also define symbols via a
pull-down menu item (see page 94 and 534).
6. How much of the 64K in the data segment is actually
available to my program?
The amount of data segment used by the run-time library
depends on which standard units you use in your program.
Here is the data segment usage (in bytes) for each unit:
UNIT Data Size
---- ---------
SYSTEM 585
DOS 6
CRT 26
PRINTER 256
GRAPH 834
TURBO3 256
GRAPH3 0
=========
1963
The total size of the data segment is 65520 bytes. If you
used only the system unit, the amount of data segment
space left over would be
65520 - 585 = 64935 bytes
(see page 293 and 339).
7. What is the largest global data structure you can
allocate?
The maximum size of a single variable that can be
allocated on the heap is 65521 bytes (see page 340).
8. How do I find out how much code and data were generated by
the compiler for a program or unit?
If you are using the integrated environment, build your
program or unit and then use the get info command in the
compile menu. This will bring up a window of information
about the current program or unit including the size of
code and data (see page 157).
If you are using the command line compiler, the size of
generated code and data is displayed on the screen at the
end of compilation.
9. Are the .OBJ files generated by TP 4.0 compatible with Turbo C
and/or Turbo Prolog?
You can write assembly language routines and link in .OBJ
files by using [$L] compiler directives. Turbo Pascal 4.0
generates .TPU (Turbo Pascal Unit) files, not .OBJ files.
We've made that decision for many reasons:
A. TP 4.0's .TPU files are smaller than .OBJ's, and they
contain symbolic information important to the support
of pascal's strict type conventions (types,
constants, etc.).
B. .TPU files allow "smart linking" - elimination of
unused code on a procedure-by-procedure basis.
C. .TPU's allow built-in project management through
version 4.0's Make and Build commands.
D. .TPU's allow faster compilation speeds (27,000 lines
per minute)
You can link in .OBJ files from Turbo C too. For
assembler, you can use MASM and A86 (a shareware assembler
available on Compuserve) (see page 360).
10. Will the $L compiler directive work for compiler object files
other than assembler?
That depends on the language. TURBO requires all the code
in the .OBJ to be in *one* CODE segment, and all the data
to be in *one* DATA segment. With assembly language that's
easy, but it may not work with some high-level language
compilers (see page 360).
11. Does the built-in linker link in unused data?
Yes, all data defined in your program and units will be
linked in whether it is used or not. The linker only
strips unused code (see page 350).
12. If two units use a third unit, does the third unit get
included twice in my program?
No. All your units are "linked" together when you compile
your program. Only one copy of each procedure and function
used is generated. There is NO duplication of runtime
code. In fact, Turbo Pascal 4.0 has "smart linking," which
eliminates any dead code not used in the final .EXE.
13. What happens if you attempt to link another unit in which the
compiler directives are set differently?
Compiler directives are local to the unit they are
declared in. Thus, the compiler directives in one unit, or
in a main program, have no effect on the directives set in
another unit.
14. Can I create my own .TPL file?
Yes, but Turbo Pascal will only use the TURBO.TPL library
file. If you want to add your own units to the TURBO.TPL
file, you can use the unit mover program (TPUMOVER.EXE).
For example, you might want a customized version of
TURBO.TPL for each of the programs you're developing. A
corresponding configuration file for Turbo Pascal would
specify a different Turbo directory and thus fetch the
appropriate .TPL file for each of your projects (see page
101).
15. What rules should I follow when writing an interrupt
handler?
The following is a list of rules to keep in mind when
writing an interrupt handler:
A. Use GetIntVec and SetIntVec to install/uninstall
interrupt handlers
B. Use the interrupt directive
C. Be careful about reentrancy. Don't use any calls to
DOS or to Turbo Pascal's heap management routines in
your interrupt handler
D. Interrupt procedures and functions must use the far
call model (use the {$F+} option)
E. Be proficient with the BIOS and assembly language
before attempting to write an interrupt handler
(see page 369).
16. Does a procedure or function in a program have to be of a
near or far call model?
Most programmers never need to worry about memory call
models because Turbo Pascal automatically selects the
correct call model. A routine is always near call model
unless
1) it is declared in the interface section of a unit
2) you override the default call model by using the {$F+}
compiler option
You should use the {$F+} option to override the default
call model if you are writing interrupt handlers, error
handlers or exit procs (see page 358).
17. How do I write reentrant code in Turbo Pascal?
If a routine follows these rules it is reentrant:
A. All data is allocated on the stack
B. The routine doesn't use any global variables
C. The routine can be interrupted at any time without
affecting the execution of the routine
D. The routine doesn't call any other routines that are
not reentrant (eg DOS I/O)
(see page 369 and 370).
18. What is the best approach to taking advantage of the new IEEE
floating-point types?
The new IEEE floating-point types are only available when
compiling and running on a machine with a numeric
coprocessor. If your program will be running on machines
without the numeric coprocesser, then you can't use the
new floating-point types (see page 331).
When developing programs that will be compiled and run on
machines with and without the 8087 coprocessor, you should
use a declaration similar to the following one. This
redefines the standard floating-point identifiers to avoid
having to maintain two versions of your programs:
{$IFDEF CPU87}
{$N+}
{ if there is a math coprocessor chip, then define }
{ the type real to be an IEEE double precision }
type
real = double;
{$ELSE}
{$N-}
{ if there is no math coprocessor chip, then define }
{ the IEEE types to be the same as the Turbo Pascal }
{ 6 byte real }
type
double = real;
single = real;
comp = real;
extended = real;
{$ENDIF}
19. What type is comp? What is it useful for?
The comp type is a cross between an integer and a real
type. Comp is only available when you have a numeric
coprocessor chip installed. The compiler treats it as a
real type without an exponent. Thus comp is useful when
you need to store extremely large numbers but don't need a
decimal point. For example, you might use variables of
type comp to store amounts in cents and divide the value
of the variable by 100 to determine what the value in
dollars and cents would be (see page 351).
20. How many significant digits do the 8087 floating-point types
provide?
Type Digits of precision
-------- -------------------
single 7-8
double 15-16
extended 19-20
comp 19-20
21. Are the intermediate results of real number expressions
stored in the 8087 registers?
Yes. When using the 8087 math package, all the intermediate
results of a real number expression are stored in the 8087
registers in full 80-bit precision. See the FIB8087.PAS
example program that shows you how to avoid 8087 stack
overflow when doing recursion with floating point (see
page 335).
22. How does rounding work with IEEE floating point?
The 8087 math coprocessor uses a different method for
rounding numbers than what you may be used to. In order to
acheive a more even distribution of values, the 8087 uses
a method sometimes called "Banker's Rounding." This method
dictates that a number will always be rounded to the
nearest EVEN number. Note that this is quite different
than always rounding UP. A couple of examples are:
Round(0.5) = 0
Round(1.5) = 2
(see page 331).
23. How do you do I/O redirection?
If you want to do DOS I/O redirection when running an .EXE
file generated by Turbo Pascal, DON'T use the Crt unit, or
make sure you assign a text file variable to the standard
DOS output device.
Assign(Output,''); { assign a text file variable }
{ to a null file name }
ReWrite(Output); { do a rewrite here }
Any output that you want redirected must now be written to
the file variable Output. This will cause output to be
redirected to the DOS standard output file (see page 383).
24. How do you go about upgrading version 3.0 programs with
lots of chain files?
Chaining is not possible with .EXE files. Control can be
passed to another program by use of the EXEC procedure in
the DOS unit (see page 403).
25. Are overlays still supported in 4.0?
Overlays are not supported in 4.0; most of the reason for
using them is gone. Version 4.0 now supports large code
model, and it also generates much better code. This means
that a lot of programs that used overlays to fit into 64K
will now fit with no problem. For those who still need to
use overlays, you can use the Exec procedure to link up
applications or continue using version 3.0. We will
provide an intelligent overlay manager in a future
release.
26. Is there any support in Turbo Pascal 4.0 for file and record
locking?
There's a standard variable in the SYSTEM unit called
FileMode, which you can use to assign an open mode for use
in all subsequent Resets. There are no record-locking
routines implemented in the standard version, but they are
easily implemented through MsDos calls (see page 296).
27. Do Turbo Pascal 4.0 programs improve program execution?
Typically programs are 30% smaller, and programs run from
15% to 30% faster.
28. Does Turbo 4.0 support procedure parameters?
Turbo Pascal 4.0 does not support procedure parameters.
However, the @ operator can be used to take the address of
a procedure or function, which can then be passed on to
another procedure or function. Calling via such a pointer
is easily accomplished through an inline macro (see pages
249 and 367).
29. Can you use identifiers other than scalar in the case statement?
Case statements allow the following ordinal types: Char,
Boolean, Integer, and user defined enumeration. Basically,
that's the same as Turbo Pascal 3.0 (see page 257).
30. Is the runtime license policy the same as in version 3.0?
YES, there are no royalties!
31. What about a debugger, who has one for 4.0?
You can use any debugger that can process .MAP files.
TPMAP on the distribution disk converts .TPM files to .MAP
files. You can use debuggers like Periscope, PFIX+, and
SYMDEB to step source code and look at data (see page
127).
32. C has static variables, is there anything similar in 4.0?
You can declare private global variables in the
implementation part of a unit. Such variables are only
visible within that unit. Like other globals, they retain
their values across calls (see page 63 and 276).
Typed constant declarations declared within a procedure or
function also behave exactly like C's static variables.
They are local in scope but since they are allocated in
the data segment, they retain their values from call to
call (see page 231).
33. What Turbo Pascal 3.0 code will cause the most problems
converting to version 4.0?
With our UPGRADE program (Chapter 8), it's not very
difficult to port your code to 4.0. It depends a lot on
the type of programs you write.
The passing of parameters on the stack is done much more
efficiently now, so changes will have to be made to inline
(in general). Most of the changes are voluntary: using new
types, breaking your program into modules to take
advantage of separate compilation. (The UPGRADE program
has a special option to help you unitize your program too.
It does all the "typing" for you.)
Some stricter type-checking is performed. For example, the
Dos unit now defines the often-seen registers record type
(AX, BX...); MsDos and Intr now take this type. In this
case, you can type-cast or change the type identifier and
recompile.
34. How do I use .BIN files provided by third-party vendors with
4.0?
We've included a utility on your distribution disk called
BINOBJ.EXE, which converts binary files into .OBJ files
that are linkable to your Turbo Pascal 4.0 programs. In
general this will only work if the binary files contain
data, not code. Contact your third-party vendor to see if
they also provide .OBJ versions of their programs. (See
BINOBJ.DOC on Disk II.)
35. Why does TURBO try to read from another drive when I run it?
When you leave Turbo Pascal, it saves the name and path of
the file you were last editing in a pick list. The next
time you load Turbo, it checks this pick list and tries to
load the file you were last editing. If the file you were
last editing was in another drive, Turbo will try to read
from that drive. This also occurs if you have installed
another drive as your Turbo Directory (see page 165).
36. Does Turbo Pascal 4.0 support EMS?
Turbo Pascal 4.0 does not use EMS. You will need to need
to write your own interface to the drivers provided with
your EMS hardware. EMS.PAS on the distribution disk shows
you how to access EMS memory.
37. How can I allocate my own I/O buffer for a text file?
You can use the procedure SetTextBuf to allocate your own
text file buffer either in the data segment or on the heap
(see page 481).
38. After installing TURBO.EXE using the TINST.EXE program,
why aren't the new settings used?
You probably have a .TP file in the current or Turbo
directory being loaded and the settings in the .TP file
overrides the settings installed by TINST. Delete the .TP
file (see page 164).
39. Is the string size limit still 255 characters?
Yes, it's just like in 3.0; you can write your own
routines to handle greater than 255 character strings (see
page 354).
40. Can we still write to file 'Con' without changes?
The 'Con' file is gone, but you can still write to the
screen with a simple Write with no file variable. The file
system has been completely redesigned to allow you to
write your own text file device drivers. With these, you can
implement a Pascal-like text file interface to any device,
such as serial ports, windowing systems, memory, etc (see
page 370).
41. What is constant merging?
When you use the same string constant more than once in a
program, the compiler only saves one copy of this string.
In the generated program, a pointer is created that
references the one copy of this string in the generated
.EXE file (see page 348).
42. Have Turbo Pascal 3.0 run-time error codes changed in
Turbo Pascal 4.0?
Yes, error codes have changed; refer to the Appendix I in
the reference manual. The TURBO3 unit contains a version
3.0 compatible IOResult function (see page 323).
43. What books can I read that will help me with Turbo Pascal
4.0?
The Turbo Pascal Tutor is an excellent reference to Turbo
Pascal. Also, Osborne/McGraw Hill has a line of books
about Borland's products.


67
Borland Turbo Pascal v4/QSORT.PAS Normal file
View File

@ -0,0 +1,67 @@
{ Copyright (c) 1985, 87 by Borland International, Inc. }
program qsort;
{$R-}
{$S-}
uses Crt;
{ This program demonstrates the quicksort algorithm, which }
{ provides an extremely efficient method of sorting arrays in }
{ memory. The program generates a list of 1000 random numbers }
{ between 0 and 29999, and then sorts them using the QUICKSORT }
{ procedure. Finally, the sorted list is output on the screen. }
{ Note that stack and range checks are turned off (through the }
{ compiler directive above) to optimize execution speed. }
const
max = 1000;
type
list = array[1..max] of integer;
var
data: list;
i: integer;
{ QUICKSORT sorts elements in the array A with indices between }
{ LO and HI (both inclusive). Note that the QUICKSORT proce- }
{ dure provides only an "interface" to the program. The actual }
{ processing takes place in the SORT procedure, which executes }
{ itself recursively. }
procedure quicksort(var a: list; Lo,Hi: integer);
procedure sort(l,r: integer);
var
i,j,x,y: integer;
begin
i:=l; j:=r; x:=a[(l+r) DIV 2];
repeat
while a[i]<x do i:=i+1;
while x<a[j] do j:=j-1;
if i<=j then
begin
y:=a[i]; a[i]:=a[j]; a[j]:=y;
i:=i+1; j:=j-1;
end;
until i>j;
if l<j then sort(l,j);
if i<r then sort(i,r);
end;
begin {quicksort};
sort(Lo,Hi);
end;
begin {qsort}
Write('Now generating 1000 random numbers...');
Randomize;
for i:=1 to max do data[i]:=Random(30000);
Writeln;
Write('Now sorting random numbers...');
quicksort(data,1,max);
Writeln;
for i:=1 to 1000 do Write(data[i]:8);
end.


282
Borland Turbo Pascal v4/README Normal file
View File

@ -0,0 +1,282 @@
WELCOME TO TURBO PASCAL 4.0
---------------------------
This README file contains important information about Turbo
Pascal 4.0. For the latest information about the compiler, the
accompanying programs, and the manual, read this in its
entirety.
TABLE OF CONTENTS
-----------------
1. Files on the Disks
2. How to Get Help (!)
3. Corrections/Additions to the Manual
4. Toshiba 3100 and AT&T Graphics Driver
1. FILES ON THE DISKS
---------------------
DISK I: COMPILER
-----------------
README COM - Program to display README file
TURBO EXE - Turbo Pascal Integrated Development Environment
TURBO TPL - Resident units for Turbo Pascal
TURBO HLP - Turbo Pascal Help File
TPC EXE - Command-line version of Turbo Pascal
TINST EXE - Installation program for TURBO.EXE
README - This file!
DISK II: UTILITIES/EXAMPLES
----------------------------
UPGRADE EXE - Program that converts 3.0 programs to 4.0
UPGRADE DTA - Data file for UPGRADE.EXE
TPMAP EXE - .TPM to .MAP conversion utility
TPUMOVER EXE - Unit mover utility
TPCONFIG EXE - .TP to .CFG conversion utility
BINOBJ EXE - Utility to convert a binary file to an .OBJ
MAKE EXE - Utility to aid in project management
GREP COM - Utility to search text files for strings
TOUCH COM - Utility to change the dates and times of files
CRTDEMO PAS - Example program for the Crt unit
GR3DEMO PAS - Example program for the Graph3 unit (turtle graphics)
QSORT PAS - Standard QuickSort program example
LISTER PAS - Program example that uses the Printer unit
HILB PAS - Floating-point example program for Hilbert matrix
FIB8087 PAS - Recursive example that uses the 8087 math
coprocessor and avoids 8087 stack overflow
PROCPTR PAS - Example program that shows how to use procedure
pointers and inline directives
EMS PAS - Example program that shows how to use expanded
memory from your programs
BCD PAS - Unit to convert Turbo Pascal 3.0 BCD reals to
Turbo Pascal 4.0 real numbers
CPASDEMO PAS - Example program that shows how to link .OBJ files
generated by Turbo C with Turbo Pascal programs
CPASDEMO C - C program for use with CPASDEMO.PAS
CTOPAS TC - Turbo C configuration file to use with TC.EXE for
producing .OBJ files that can be linked with Turbo
Pascal (see CPASDEMO.PAS)
TURBOC CFG - Turbo C configuration file to use with TCC.EXE for
producing .OBJ files that can be linked with Turbo
Pascal (see CPASDEMO.PAS)
SYSTEM DOC - Interface section listing for the System unit
DOS DOC - Interface section listing for the Dos unit
CRT DOC - Interface section listing for the Crt unit
PRINTER DOC - Interface section listing for the Printer unit
GRAPH3 DOC - Interface section listing for the Graph3 unit
TURBO3 DOC - Interface section listing for the Turbo3 unit
Q&A - Common Questions and Answers
DISK III: GRAPHICS/MICROCALC
-----------------------------
GRAPH DOC - Interface section listing for the Graph unit
GRAPH TPU - Borland Graphics Interface (BGI) Graph unit
ATT BGI - Graphics device driver for AT&T 6300 graphics
CGA BGI - Graphics device driver for CGA and MCGA graphics
EGAVGA BGI - Graphics device driver for EGA and VGA
HERC BGI - Graphics device driver for Hercules monographics
PC3270 BGI - Graphics device driver for 3270PC graphics
GOTH CHR - Gothic font character set
LITT CHR - Small font character set
SANS CHR - Sans serif font character set
TRIP CHR - Triplex font character set
GRDEMO PAS - Example program for the Graph unit
ARTY4 PAS - Example program for the Graph unit
GRLINK PAS - Example program for the Graph unit that shows how to
link font and driver files into an .EXE file
DRIVERS PAS - Example unit for use with GRLINK.PAS
FONTS PAS - Example unit source for use with GRLINK.PAS
GRLINK MAK - Make file for use with GRLINK.PAS
MCALC PAS - MicroCalc example program
MC?????? PAS - Supporting units for MicroCalc
MCMVSMEM ASM - Assembler routine used by MicroCalc
MCMVSMEM OBJ - Assembled version of MCMVSMEM.ASM
UNPACK COM - Utility to unpack GREXAMPL.ARC
GREXAMPL ARC - Binary file that contains revised graphics
examples from the programs for Graph unit.
FILELIST - List of the example programs in GREXAMPL.ARC
and the corresponding procedure/function names
and manual page numbers.
ARC PAS - Arc example program
ARCCOORD PAS - GetArcCoords example program
ASPECT PAS - GetAspectRatio example program
BAR PAS - Bar example program
BAR3D PAS - Bar3D example program
CIRCLE PAS - Circle example program
CLOSEGR PAS - CloseGraph example program
CLRDEV PAS - ClearDevice example program
CLRVP PAS - ClearViewPort example program
DETECT PAS - DetectGraph example program
DRPOLY PAS - DrawPoly example program
ELLIPSE PAS - Ellipse example program
FILLPOLY PAS - FillPoly example program
FLOOD PAS - FloodFill example program
GETBKCOL PAS - GetBkColor example program
GETCOL PAS - GetColor example program
GETFILLS PAS - GetFillSettings example program
GETGRMD PAS - GetGraphMode example program
GETLNS PAS - GetLineSettings example program
GETMAXX PAS - GetMaxX example program
GETMAXY PAS - GetMaxY example program
GETPAL PAS - GetPalette example program
GETPIX PAS - GetPixel example program
GETTXTS PAS - GetTxtSettings example program
GETVS PAS - GetViewSettings example program
GETX PAS - GetX example program
GETY PAS - GetY example program
GRERRMSG PAS - GraphErrorMsg example program
GRRES PAS - GraphResult example program
IMSIZE PAS - ImageSize example program
INITGR PAS - InitGraph example program
LINE PAS - Line example program
LINEREL PAS - LineRel example program
LINETO PAS - LineTo example program
MOVEREL PAS - MoveRel example program
MOVETO PAS - MoveTo example programs
OUTTXT PAS - OutText example program
OUTTXTXY PAS - OutTextXY example program
PIESLICE PAS - PieSlice example program
PUTIM PAS - PutImage example program
PUTPIX PAS - PutPixel example program
RECT PAS - Rectangle example program
RESCRT PAS - RestoreCrtMode example program
SETACTPG PAS - SetActivePage example program
SETALLP PAS - SetAllPalette example program
SETBKCOL PAS - SetBkColor example program
SETCOL PAS - SetColor example program
SETFLPAT PAS - SetFillPattern example program
SETGRMOD PAS - SetGraphMode example program
SETLNSTY PAS - SetLineStyle example program
SETPAL PAS - SetPalette example program
SETTXTJS PAS - SetTextJustify example program
SETTXTST PAS - SetTextStyle example program
SETVISPG PAS - SetVisualPage example program
SETVP PAS - SetViewPort example program
TXTHT PAS - TextHeight example program
2. HOW TO GET HELP
------------------
If you need help with Turbo Pascal, please read this file and the
Reference Manual.
If you still have a question and need technical assistance, help is
available from the following sources:
1. Type GO BPROGA on the CompuServe bulletin board system for instant
access to the Borland forums with their libraries of technical
information and answers to common questions. In addition, all
example programs from the manual are available on CompuServe in
machine-readable form.
If you are not a member of CompuServe, see the enclosed special
offer, and write for full details on how to receive a free IntroPak
containing a $15 credit toward your first month's online charges.
2. Check with your local software dealer or users' group.
3. Write to: Borland International
Turbo Pascal Technical Support
4585 Scotts Valley Drive
Scotts Valley, CA 95066
Please remember to include your serial number or we will be unable
to process your letter.
4. If you have an urgent problem, you can call the Borland
Technical Support Department at (408) 438-5300.
Please have the following information ready before calling:
A. Product name and serial number from your original distribution
disk. Please have your serial number ready or we will be
unable to process your call.
B. Computer brand, model, and the brands and model numbers of any
additional hardware.
C. Operating system and version number (the version number can be
determined by typing VER at the DOS prompt).
D. Contents of your AUTOEXEC.BAT file.
E. Contents of your CONFIG.SYS file.
3. CORRECTIONS/ADDITIONS TO THE MANUAL
--------------------------------------
Graphics examples
-----------------
For your convenience, we have included a packed file, GREXAMPL.ARC,
that contains every example graphics program from the reference
section of the Owner's Handbook. In order to view or compile these
examples, you must first unpack them by using UNPACK.COM. The
simplest way to unpack the archived examples is to type the
following at the DOS prompt:
UNPACK GREXAMPL
This will extract all the files from GREXAMPL.ARC and place them
into the current directory. For a list of other options, type UNPACK
at the DOS prompt and then press <Enter>.
P-63 Interface Section
If the procedure (or function) is external, the keyword external
may only appear in the implementation section.
P-493 TextColor Procedure: Add the following to the bottom of the
list of Crt color constants:
{ Add-in for blinking }
Blink = 128;
P-586 Automatic Compaq Detection Override
The integrated environment will detect whether you are using a
Compaq computer and automatically use its black-and-white color
set. This gives better contrast on the composite monitors
built-in to the vast majority of Compaq computers. If you are
using a Compaq computer and a true color monitor, you can force
the integrated environment to use its color tables by running
TINST, typing "D" to install the Display mode, and selecting
Color.
4. TOSHIBA 3100 AND AT&T GRAPHICS DRIVER
----------------------------------------
The Toshiba 3100 series supports an AT&T-compatible, 640x400 mode.
The Toshiba does not use the same INT 10 mode setting as the AT&T
6300, however. To use the ATT.BGI driver on the Toshiba 3100 series,
make a 1-byte patch to the ATT.BGI file at location 655. Change
the value from 40 to 74 and save the file to disk.
Here is a list of the exact keystrokes required to make the patch,
using the DEBUG.COM program that comes with the MS-DOS operating
system:
debug att.bgi<Enter>
e655<Enter>
74<Enter>
w<Enter>
q<Enter>
This makes it possible for the ATT.BGI driver to run on the Toshiba,
but it will no longer work on an AT&T 6300 or true compatible (for
example, the Compaq III). To use the driver with an AT&T 6300 or
true compatible, reverse the preceding process and restore location 655
to its original value (40). You can also copy ATT.BGI from your
original Turbo Pascal distribution disks.
Remember that, by default, the Graph unit will select the CGA driver
for the AT&T 6300 and compatible graphics adapters (Compaq III,
Toshiba 3100 series, etc.). To use the AT&T driver, you must override
autodetection (see P-310).


BIN
Borland Turbo Pascal v4/README.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/SANS.CHR Normal file
View File

Binary file not shown.

31
Borland Turbo Pascal v4/SIEVE.PAS Normal file
View File

@ -0,0 +1,31 @@
program sieve;
const
size = 8190;
type
flagType = array[ 0..size ] of boolean;
var
i, k, prime, count, iter : integer;
flags : flagType;
begin
for iter := 1 to 10 do begin
count := 0;
for i := 0 to size do flags[ i ] := true;
for i := 0 to size do begin
if flags[ i ] then begin
prime := i + i + 3;
k := i + prime;
while k <= size do begin
flags[ k ] := false;
k := k + prime;
end;
count := count + 1;
end;
end;
end;
writeln( 'count of primes: ', count );
end.

38
Borland Turbo Pascal v4/SYSTEM.DOC Normal file
View File

@ -0,0 +1,38 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ SYSTEM Unit Interface Documentation }
{ (Only the variables are listed. For a complete }
{ reference to System functions and procedures, }
{ refer to the Owner's Handbook) }
{ }
{ Copyright (c) 1987 by Borland International, Inc. }
{ }
{*******************************************************}
unit System;
interface
var
Input: Text; { Input standard file }
Output: Text; { Output standatd file }
PrefixSeg: Word; { Program segment prefix }
HeapOrg: Pointer; { Heap origin }
HeapPtr: Pointer; { Heap pointer }
FreePtr: Pointer; { Free list pointer }
FreeMin: Word; { Minimum free list size }
HeapError: Pointer; { Heap error function }
ExitProc: Pointer; { Exit procedure }
ExitCode: Integer; { Exit code }
ErrorAddr: Pointer; { Runtime error address }
RandSeed: Longint; { Random seed }
SaveInt00: Pointer; { Saved interrupt $00 }
SaveInt02: Pointer; { Saved interrupt $02 }
SaveInt23: Pointer; { Saved interrupt $23 }
SaveInt24: Pointer; { Saved interrupt $24 }
SaveInt75: Pointer; { Saved interrupt $75 }
FileMode: Byte; { File open mode }
implementation


65
Borland Turbo Pascal v4/TIMEUTIL.PAS Normal file
View File

@ -0,0 +1,65 @@
type
timetype = record h, m, s, l : integer; end;
procedure time_difference( var tStart, tEnd, tDiff : timetype );
var
startSecond, startMinute, startHour : integer;
begin { time_difference }
startSecond := tStart.s;
startMinute := tStart.m;
startHour := tStart.h;
tDiff.l := tEnd.l - tStart.l;
if ( tDiff.l < 0 ) then
begin
tDiff.l := tDiff.l + 100;
startSecond := startSecond + 1;
end;
tDiff.s := tEnd.s - startSecond;
if ( tDiff.s < 0 ) then
begin
tDiff.s := tDiff.s + 60;
startMinute := startMinute + 1;
end;
tDiff.m := tEnd.m - startMinute;
if ( tDiff.m < 0 ) then
begin
tDiff.m := tDiff.m + 60;
startHour := startHour + 1;
end;
tDiff.h := tEnd.h - startHour;
if ( tDiff.h < 0 ) then
tDiff.h := tDiff.h + 12;
end;
procedure print_time_part( num : integer );
begin
if ( num < 10 ) then write( '0' );
write( num );
end;
procedure print_time( var t: timetype );
begin
print_time_part( t.h );
write( ':' );
print_time_part( t.m );
write( ':' );
print_time_part( t.s );
write( '.' );
print_time_part( t.l );
end;
procedure print_elapsed_time( var timeStart, timeEnd: timetype );
var
timeDiff: timetype;
begin
time_difference( timeStart, timeEnd, timeDiff );
write( 'elapsed time: ' );
print_time( timeDiff );
writeln;
end;


BIN
Borland Turbo Pascal v4/TINST.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TOUCH.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TPC.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TPCONFIG.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TPMAP.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TPUMOVER.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TRIP.CHR Normal file
View File

Binary file not shown.

273
Borland Turbo Pascal v4/TTT.PAS Normal file
View File

@ -0,0 +1,273 @@
{ App to prove you can't win at Tic-Tac-Toe }
{ use of byte instead of integer should be faster, but it's not }
program ttt;
uses Dos;
{$I timeutil.pas}
{$I dos_gt.pas}
const
scoreWin = 6;
scoreTie = 5;
scoreLose = 4;
scoreMax = 9;
scoreMin = 2;
scoreInvalid = 0;
pieceBlank = 0;
pieceX = 1;
pieceO = 2;
iterations = 1;
type
boardType = array[ 0..8 ] of integer;
funcArrayType = array[ 0..8 ] of pointer;
var
{ update evaluated after each run because longint operations are slow }
evaluated: longint;
moves: integer;
board: boardType;
timeStart, timeEnd: timetype;
scoreFuncs : funcArrayType;
procedure dumpBoard;
var
i : integer;
begin
Write( '{' );
for i := 0 to 8 do
Write( board[i] );
Write( '}' );
end;
function lookForWinner : integer;
var
t, p : integer;
begin
{dumpBoard;}
p := pieceBlank;
t := board[ 0 ];
if pieceBlank <> t then
begin
if ( ( ( t = board[1] ) and ( t = board[2] ) ) or
( ( t = board[3] ) and ( t = board[6] ) ) ) then
p := t;
end;
if pieceBlank = p then
begin
t := board[1];
if ( t = board[4] ) and ( t = board[7] ) then
p := t
else
begin
t := board[2];
if ( t = board[5] ) and ( t = board[8] ) then
p := t
else
begin
t := board[3];
if ( t = board[4] ) and ( t = board[5] ) then
p := t
else
begin
t := board[6];
if ( t = board[7] ) and ( t = board[8] ) then
p := t
else
begin
t := board[4];
if ( ( ( t = board[0] ) and ( t = board[8] ) ) or
( ( t = board[2] ) and ( t = board[6] ) ) ) then
p := t
end;
end;
end;
end;
end;
lookForWinner := p;
end;
function winner2( move: integer ) : integer;
var
x : integer;
begin
case move of
0: begin
x := board[ 0 ];
if not ( ( ( x = board[1] ) and ( x = board[2] ) ) or
( ( x = board[3] ) and ( x = board[6] ) ) or
( ( x = board[4] ) and ( x = board[8] ) ) )
then x := PieceBlank;
end;
1: begin
x := board[ 1 ];
if not ( ( ( x = board[0] ) and ( x = board[2] ) ) or
( ( x = board[4] ) and ( x = board[7] ) ) )
then x := PieceBlank;
end;
2: begin
x := board[ 2 ];
if not ( ( ( x = board[0] ) and ( x = board[1] ) ) or
( ( x = board[5] ) and ( x = board[8] ) ) or
( ( x = board[4] ) and ( x = board[6] ) ) )
then x := PieceBlank;
end;
3: begin
x := board[ 3 ];
if not ( ( ( x = board[4] ) and ( x = board[5] ) ) or
( ( x = board[0] ) and ( x = board[6] ) ) )
then x := PieceBlank;
end;
4: begin
x := board[ 4 ];
if not ( ( ( x = board[0] ) and ( x = board[8] ) ) or
( ( x = board[2] ) and ( x = board[6] ) ) or
( ( x = board[1] ) and ( x = board[7] ) ) or
( ( x = board[3] ) and ( x = board[5] ) ) )
then x := PieceBlank;
end;
5: begin
x := board[ 5 ];
if not ( ( ( x = board[3] ) and ( x = board[4] ) ) or
( ( x = board[2] ) and ( x = board[8] ) ) )
then x := PieceBlank;
end;
6: begin
x := board[ 6 ];
if not ( ( ( x = board[7] ) and ( x = board[8] ) ) or
( ( x = board[0] ) and ( x = board[3] ) ) or
( ( x = board[4] ) and ( x = board[2] ) ) )
then x := PieceBlank;
end;
7: begin
x := board[ 7 ];
if not ( ( ( x = board[6] ) and ( x = board[8] ) ) or
( ( x = board[1] ) and ( x = board[4] ) ) )
then x := PieceBlank;
end;
8: begin
x := board[ 8 ];
if not ( ( ( x = board[6] ) and ( x = board[7] ) ) or
( ( x = board[2] ) and ( x = board[5] ) ) or
( ( x = board[0] ) and ( x = board[4] ) ) )
then x := PieceBlank;
end;
end;
winner2 := x;
end;
function minmax( alpha: integer; beta: integer; depth: integer; move : integer ): integer;
var
p, value, pieceMove, score : integer;
begin
moves := moves + 1;
value := scoreInvalid;
if depth >= 4 then
begin
p := winner2( move );
{ p := TScoreFunc( scoreFuncs[ move ] ); }
{ p := LookForWinner; this is 10% slower than using function pointers }
if p <> pieceBlank then
begin
if p = pieceX then
value := scoreWin
else
value := scoreLose
end
else if depth = 8 then
value := scoreTie;
end;
if value = scoreInvalid then
begin
if Odd( depth ) then
begin
value := scoreMin;
pieceMove := pieceX;
end
else
begin
value := scoreMax;
pieceMove := pieceO;
end;
p := 0;
repeat
if board[ p ] = pieceBlank then
begin
board[ p ] := pieceMove;
score := minmax( alpha, beta, depth + 1, p );
board[ p ] := pieceBlank;
if Odd( depth ) then
begin
if ( score > value ) then
begin
value := score;
if ( value = scoreWin ) or ( value >= beta ) then p := 10
else if ( value > alpha ) then alpha := value;
end;
end
else
begin
if ( score < value ) then
begin
value := score;
if ( value = scoreLose ) or ( value <= alpha ) then p := 10
else if ( value < beta ) then beta := value;
end;
end;
end;
p := p + 1;
until p > 8;
end;
minmax := value;
end;
procedure runit( move : integer );
var score : integer;
begin
board[move] := pieceX;
score := minmax( scoreMin, scoreMax, 0, move );
board[move] := pieceBlank;
end;
var
i, errpos, loops: integer;
begin
loops := Iterations;
if 0 <> Length( ParamStr( 1 ) ) then
Val( ParamStr( 1 ), loops, errpos );
for i := 0 to 8 do
board[i] := pieceBlank;
evaluated := 0;
get_time( timeStart );
for i := 1 to loops do
begin
moves := 0;
runit( 0 );
runit( 1 );
runit( 4 );
evaluated := evaluated + moves;
end;
get_time( timeEnd );
print_elapsed_time( timeStart, timeEnd );
WriteLn( 'moves evaluated: ', evaluated );
WriteLn( 'iterations: ', loops );
end.


BIN
Borland Turbo Pascal v4/TURBO.EXE Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TURBO.HLP Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TURBO.TP Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/TURBO.TPL Normal file
View File

Binary file not shown.

35
Borland Turbo Pascal v4/TURBO3.DOC Normal file
View File

@ -0,0 +1,35 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 4.0 }
{ TURBO3 Unit Interface Documentation }
{ (Turbo Pascal 3.0 Compatibility Unit) }
{ }
{ Copyright (c) 1987 Borland International, Inc. }
{ }
{*******************************************************}
{$D-,I-,S-}
unit Turbo3;
interface
uses Crt;
var
Kbd: Text;
CBreak: Boolean absolute CheckBreak;
procedure AssignKbd(var F: Text);
function MemAvail: Integer;
function MaxAvail: Integer;
function LongFileSize(var F): Real;
function LongFilePos(var F): Real;
procedure LongSeek(var F; Pos: Real);
procedure NormVideo;
procedure HighVideo;
procedure LowVideo;
function IOresult: Integer;
implementation


13
Borland Turbo Pascal v4/TURBOC.CFG Normal file
View File

@ -0,0 +1,13 @@
-c
-p
-r-
-u-
-zCCODE
-zP
-zA
-zRCONST
-zS
-zT
-zDDATA
-zG
-zB

98305
Borland Turbo Pascal v4/Turbo_Pascal_Version_4.0_Owners_Manual_1987.pdf Normal file
View File

File diff suppressed because one or more lines are too long

BIN
Borland Turbo Pascal v4/UNPACK.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/UPGRADE.DTA Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v4/UPGRADE.EXE Normal file
View File

Binary file not shown.

1
Borland Turbo Pascal v4/m.bat Normal file
View File

@ -0,0 +1 @@
ntvdm -r:. tpc %1 /$S- /$R- /B