|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 33920 (0x8480)
Types: TextFile
Names: »CALC.PAS«
└─⟦98ebcd56b⟧ Bits:30004773 Turbo Pascal v.2.00B for CP/M-86
└─ ⟦this⟧ »CALC.PAS«
æ This program is donated to the Public Domain for å
æ non commercial use only å
æHere is a note to the compiler: å
æ$R-,U-,V-,X-,A+,C-å
program MicroCalc;
const
FXMax: Char = 'G'; æ Maximum number of columns in spread sheet å
FYMax = 21; æ Maximum number of lines in spread sheet å
type
Anystring = stringÆ70Å;
SheetIndex = 'A'..'G';
Attributes = (Constant,Formula,Txt,OverWritten,Locked,Calculated);
æ The spreadsheet is made out of Cells every Cell is defined as å
æ the following record:å
CellRec = record
CellStatus: set of Attributes; æ Status of cell (see type def.) å
Contents: StringÆ70Å; æ Contains a formula or some text å
Value: Real; æ Last calculated cell value å
DEC,FW: 0..20; æ Decimals and Cell Whith å
end;
Cells = arrayÆSheetIndex,1..FYMaxÅ of CellRec;
const
XPOS: arrayÆSheetIndexÅ of integer = (3,14,25,36,47,58,68);
var
Sheet: Cells; æ Definition of the spread sheet å
FX: SheetIndex; æ Culumn of current cell å
FY: Integer; æ Line of current cell å
Ch: Char; æ Last read character å
MCFile: file of CellRec; æ File to store sheets in å
AutoCalc: boolean; æ Recalculate after each entry? å
æ For easy reference the procedures and functions are grouped in mo-å
æ dules called MC-MOD00 through MC-MOD05. å
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD00 *å
æ* PURPOSE: Micellaneous utilities and commands. *å
æ*******************************************************************å
procedure Msg(S: AnyString);
begin
GotoXY(1,24);
ClrEol;
Write(S);
end;
procedure Flash(X: integer; S: AnyString; Blink: boolean);
begin
HighVideo;
GotoXY(X,23);
Write(S);
if Blink then
begin
repeat
GotoXY(X,23);
Blink:=not Blink; if Blink then HighVideo else LowVideo;
Write(S);
Delay(175);
until KeyPressed;
end;
LowVideo;
end;
procedure Auto;
begin
AutoCalc:=not AutoCalc;
if AutoCalc then Flash(60,'AutoCalc: ON ',false)
else Flash(60,'AutoCalc: OFF',false);
end;
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD01 *å
æ* PURPOSE: Display grid and initialize all cells *å
æ* in the spread sheet. *å
æ*******************************************************************å
procedure Grid;
var I: integer;
Count: Char;
begin
HighVideo;
For Count:='A' to FXMax do
begin
GotoXY(XPosÆCountÅ,1);
Write(Count);
end;
GotoXY(1,2);
for I:=1 to FYMax do writeln(I:2);
LowVideo;
if AutoCalc then Flash(60,'AutoCalc: ON' ,false)
else Flash(60,'AutoCalc: OFF',false);
Flash(33,' Type / for Commands',false);
end;
procedure Init;
var
I: SheetIndex;
J: Integer;
LastName: stringÆ2Å;
begin
for I:='A' to FXMAX do
begin
for J:=1 to FYMAX do
begin
with SheetÆI,JÅ do
begin
CellStatus:=ÆTxtÅ;
Contents:='';
Value:=0;
DEC:=2; æ Default number of decimals å
FW:=10; æ Default field width å
end;
end;
end;
AutoCalc:=True;
FX:='A'; FY:=1; æ First field in upper left corner å
end;
procedure Clear;
begin
HighVideo;
GotoXY(1,24); ClrEol;
Write('Clear this worksheet? (Y/N) ');
repeat Read(Kbd,Ch) until Upcase(Ch) in Æ'Y','N'Å;
Write(Upcase(Ch));
if UpCase(Ch)='Y' then
begin
ClrScr;
Init;
Grid;
end;
end;
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD02 *å
æ* PURPOSE: Display values in cells and move between *å
æ* cells in the spread sheet. *å
æ*******************************************************************å
procedure FlashType;
begin
with SheetÆFX,FYÅ do
begin
GotoXY(1,23);
Write(FX,FY:2,' ');
if Formula in CellStatus then write('Formula:') else
if Constant in CellStatus then Write('Numeric ') else
if Txt in CellStatus then Write('Text ');
GotoXY(1,24); ClrEol;
if Formula in CellStatus then Write(Contents);
end;
end;
æ The following procedures move between the Cells on the calc sheet.å
æ Each Cell has an associated record containing its X,Y coordinates å
æ and data. See the type definition for "Cell". å
procedure GotoCell(GX: SheetIndex; GY: integer);
begin
with SheetÆGX,GYÅ do
begin
HighVideo;
GotoXY(XPosÆGXÅ,GY+1);
Write(' ');
GotoXY(XPosÆGXÅ,GY+1);
if Txt in CellStatus then Write(Contents)
else
begin
if DEC>=0 then Write(Value:FW:DEC)
else Write(Value:FW);
end;
FlashType;
GotoXY(XPosÆGXÅ,GY+1);
end;
LowVideo;
end;
æ.CP20å
procedure LeaveCell(FX:SheetIndex;FY: integer);
begin
with SheetÆFX,FYÅ do
begin
GotoXY(XPosÆFXÅ,FY+1);
LowVideo;
if Txt in CellStatus then Write(Contents)
else
begin
if DEC>=0 then Write(Value:FW:DEC)
else Write(Value:FW);
end;
end;
end;
æ.CP20å
procedure Update;
var
UFX: SheetIndex;
UFY: integer;
begin
ClrScr;
Grid;
for UFX:='A' to FXMax do for UFY:=1 to FYMax do
if SheetÆUFX,UFYÅ.Contents<>'' then LeaveCell(UFX,UFY);
GotoCell(FX,FY);
end;
æ.CP20å
procedure MoveDown;
var Start: integer;
begin
LeaveCell(FX,FY);
Start:=FY;
repeat
FY:=FY+1;
if FY>FYMax then FY:=1;
until (SheetÆFX,FYÅ.CellStatus*ÆOverWritten,LockedÅ=ÆÅ) or (FY=Start);
if FY<>Start then GotoCell(FX,FY);
end;
æ.CP20å
procedure MoveUp;
var Start: integer;
begin
LeaveCell(FX,FY);
Start:=FY;
repeat
FY:=FY-1;
if FY<1 then FY:=FYMax;
until (SheetÆFX,FYÅ.CellStatus*ÆOverWritten,LockedÅ=ÆÅ) or (FY=Start);
if FY<>Start then GotoCell(FX,FY);
end;
æ.CP20å
procedure MoveRight;
var Start: SheetIndex;
begin
LeaveCell(FX,FY);
Start:=FX;
repeat
FX:=Succ(FX);
if FX>FXMax then
begin
FX:='A';
FY:=FY+1;
if FY>FYMax then FY:=1;
end;
until (SheetÆFX,FYÅ.CellStatus*ÆOverWritten,LockedÅ=ÆÅ) or (FX=Start);
if FX<>Start then GotoCell(FX,FY);
end;
æ.CP20å
procedure MoveLeft;
var Start: SheetIndex;
begin
LeaveCell(FX,FY);
Start:=FX;
repeat
FX:=Pred(FX);
if FX<'A' then
begin
FX:=FXMax;
FY:=FY-1;
if FY<1 then FY:=FYMax;
end;
until (SheetÆFX,FYÅ.CellStatus*ÆOverWritten,LockedÅ=ÆÅ) or (FX=Start);
if FX<>Start then GotoCell(FX,FY);
end;
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD03 *å
æ* PURPOSE: Read, Save and Print a spread sheet. *å
æ* Display on-line manual. *å
æ*******************************************************************å
type
String3 = stringÆ3Å;
var
FileName: stringÆ14Å;
Line: stringÆ100Å;
function Exist(FileN: AnyString): boolean;
var F: file;
begin
æ$I-å
assign(F,FileN);
reset(F);
æ$I+å
if IOResult<>0 then Exist:=false
else Exist:=true;
end;
procedure GetFileName(var Line: AnyString; FileType:String3);
begin
Line:='';
repeat
Read(Kbd,Ch);
if Upcase(Ch) in Æ'A'..'Z',^MÅ then
begin
write(Upcase(Ch));
Line:=Line+Ch;
end;
until (Ch=^M) or (length(Line)=8);
if Ch=^M then Delete(Line,Length(Line),1);
if Line<>'' then Line:=Line+'.'+FileType;
end;
æ.CP20å
procedure Save;
var I: SheetIndex;
J: integer;
begin
HighVideo;
Msg('Save: Enter filename ');
GetFileName(Filename,'MCS');
if FileName<>'' then
begin
Assign(MCFile,FileName);
Rewrite(MCFile);
for I:='A' to FXmax do
begin
for J:=1 to FYmax do
write(MCfile,SheetÆI,JÅ);
end;
Grid;
Close(MCFile);
LowVideo;
GotoCell(FX,FY);
end;
end;
æ.CP30å
procedure Load;
begin
HighVideo;
Msg('Load: Enter filename ');
GetFileName(Filename,'MCS');
if (Filename<>'') then if (not exist(FileName)) then
repeat
Msg('File not Found: Enter another filename ');
GetFileName(Filename,'MCS');
until exist(FileName) or (FileName='');
if FileName<>'' then
begin
ClrScr;
Msg('Please Wait. Loading definition...');
Assign(MCFile,FileName);
Reset(MCFile);
for FX:='A' to FXmax do
for FY:=1 to FYmax do read(MCFile,SheetÆFX,FYÅ);
FX:='A'; FY:=1;
LowVideo;
UpDate;
end;
GotoCell(FX,FY);
end;
æ.PAå
procedure Print;
var
I: SheetIndex;
J,Count,
LeftMargin: Integer;
P: stringÆ20Å;
MCFile: Text;
begin
HighVideo;
Msg('Print: Enter filename "P" for Printer> ');
GetFileName(Filename,'LST');
Msg('Left margin > '); Read(LeftMargin);
if FileName='P.LST' then FileName:='LST:';
Msg('Printing to: ' + FileName + '....');
Assign(MCFile,FileName);
Rewrite(MCFile);
For Count:=1 to 5 do Writeln(MCFile);
for J:=1 to FYmax do
begin
Line:='';
for I:='A' to FXmax do
begin
with SheetÆI,JÅ do
begin
while (Length(Line)<XPOSÆIÅ-4) do Line:=Line+' ';
if (Constant in CellStatus) or (Formula in CellStatus) then
begin
if not (Locked in CellStatus) then
begin
if DEC>0 then Str(Value:FW:DEC,P) else Str(Value:FW,P);
Line:=Line+P;
end;
end else Line:=Line+Contents;
end; æ With å
end; æ One line å
For Count:=1 to LeftMargin do Write(MCFile,' ');
writeln(MCFile,Line);
end; æ End Column å
Grid;
Close(MCFile);
LowVideo;
GotoCell(FX,FY);
end;
æ.PAå
procedure Help;
var
H: text;
HelpFileName: stringÆ14Å;
Line: stringÆ80Å;
I,J: integer;
Bold: boolean;
begin
if Exist('CALC.HLP') then
begin
Assign(H,'CALC.HLP');
Reset(H);
while not Eof(H) do
begin
ClrScr; I:=1; Bold:=false; LowVideo;
Readln(H,Line);
repeat
For J:=1 to Length(Line) do
begin
if LineÆJÅ=^B then
begin
Bold:=not Bold;
if Bold then HighVideo else LowVideo;
end else write(LineÆJÅ);
end;
Writeln;
I:=I+1;
Readln(H,Line);
until Eof(H) or (I>23) or (Copy(Line,1,3)='.PA');
GotoXY(26,24); HighVideo;
write('<<< Please press any key to continue >>>');
LowVideo;
read(Kbd,Ch);
end;
GotoXY(20,24); HighVideo;
write('<<< Please press <RETURN> to start MicroCalc >>>');
LowVideo;
Readln(Ch);
UpDate;
end else æ Help file did not exist å
begin
Msg('To get help the file CALC.HLP must be on your disk. Press <RETURN>');
repeat Read(kbd,Ch) until Ch=^M;
GotoCell(FX,FY);
end;
end;
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD04 *å
æ* PURPOSE: Evaluate formulas. *å
æ* Recalculate spread sheet. *å
æ* *å
æ* NOTE: This module contains recursive procedures *å
æ* and is for computer scientists only. *å
æ*******************************************************************å
var
Form: Boolean;
æ$A-å
procedure Evaluate(var IsFormula: Boolean; æ True if formulaå
var Formula: AnyString; æ Fomula to evaluateå
var Value: Real; æ Result of formula å
var ErrPos: Integer);æ Position of error å
const
Numbers: set of Char = Æ'0'..'9'Å;
EofLine = ^M;
var
Pos: Integer; æ Current position in formula å
Ch: Char; æ Current character being scanned å
EXY: stringÆ3Å; æ Intermidiate string for conversion å
æ Procedure NextCh returns the next character in the formula å
æ The variable Pos contains the position ann Ch the character å
procedure NextCh;
begin
repeat
Pos:=Pos+1;
if Pos<=Length(Formula) then
Ch:=FormulaÆPosÅ else Ch:=eofline;
until Ch<>' ';
end æ NextCh å;
function Expression: Real;
var
E: Real;
Opr: Char;
function SimpleExpression: Real;
var
S: Real;
Opr: Char;
function Term: Real;
var
T: Real;
function SignedFactor: Real;
function Factor: Real;
type
StandardFunction = (fabs,fsqrt,fsqr,fsin,fcos,
farctan,fln,flog,fexp,ffact);
StandardFunctionList = arrayÆStandardFunctionÅ of stringÆ6Å;
const
StandardFunctionNames: StandardFunctionList =('ABS','SQRT','SQR','SIN','COS',
'ARCTAN','LN','LOG','EXP','FACT');
var
E,EE,L: Integer; æ intermidiate variables å
Found:Boolean;
F: Real;
Sf:StandardFunction;
OldEFY, æ Current cell å
EFY,
SumFY,
Start:Integer;
OldEFX,
EFX,
SumFX:SheetIndex;
CellSum: Real;
function Fact(I: Integer): Real;
begin
if I > 0 then begin Fact:=I*Fact(I-1); end
else Fact:=1;
end æ Fact å;
æ.PAå
begin æ Function Factor å
if Ch in Numbers then
begin
Start:=Pos;
repeat NextCh until not (Ch in Numbers);
if Ch='.' then repeat NextCh until not (Ch in Numbers);
if Ch='E' then
begin
NextCh;
repeat NextCh until not (Ch in Numbers);
end;
Val(Copy(Formula,Start,Pos-Start),F,ErrPos);
end else
if Ch='(' then
begin
NextCh;
F:=Expression;
if Ch=')' then NextCh else ErrPos:=Pos;
end else
if Ch in Æ'A'..'G'Å then æ Maybe a cell reference å
begin
EFX:=Ch;
NextCh;
if Ch in Numbers then
begin
F:=0;
EXY:=Ch; NextCh;
if Ch in Numbers then
begin
EXY:=EXY+Ch;
NextCh;
end;
Val(EXY,EFY,ErrPos);
IsFormula:=true;
if (Constant in SheetÆEFX,EFYÅ.CellStatus) and
not (Calculated in SheetÆEFX,EFYÅ.CellStatus) then
begin
Evaluate(Form,SheetÆEFX,EFYÅ.contents,f,ErrPos);
SheetÆEFX,EFYÅ.CellStatus:=SheetÆEFX,EFYÅ.CellStatus+ÆCalculatedÅ
end else if not (Txt in SheetÆEFX,EFYÅ.CellStatus) then
F:=SheetÆEFX,EFYÅ.Value;
if Ch='>' then
begin
OldEFX:=EFX; OldEFY:=EFY;
NextCh;
EFX:=Ch;
NextCh;
if Ch in Numbers then
begin
EXY:=Ch;
NextCh;
if Ch in Numbers then
begin
EXY:=EXY+Ch;
NextCh;
end;
val(EXY,EFY,ErrPos);
Cellsum:=0;
for SumFY:=OldEFY to EFY do
begin
for SumFX:=OldEFX to EFX do
begin
F:=0;
if (Constant in SheetÆSumFX,SumFYÅ.CellStatus) and
not (Calculated in SheetÆSumFX,SumFYÅ.CellStatus) then
begin
Evaluate(Form,SheetÆSumFX,SumFYÅ.contents,f,errPos);
SheetÆSumFX,SumFYÅ.CellStatus:=
SheetÆSumFX,SumFYÅ.CellStatus+ÆCalculatedÅ;
end else if not (Txt in SheetÆSumFX,SumFYÅ.CellStatus) then
F:=SheetÆSumFX,SumFYÅ.Value;
Cellsum:=Cellsum+f;
f:=Cellsum;
end;
end;
end;
end;
end;
end else
begin
found:=false;
for sf:=fabs to ffact do
if not found then
begin
l:=Length(StandardFunctionNamesÆsfÅ);
if copy(Formula,Pos,l)=StandardFunctionNamesÆsfÅ then
begin
Pos:=Pos+l-1; NextCh;
F:=Factor;
case sf of
fabs: f:=abs(f);
fsqrt: f:=sqrt(f);
fsqr: f:=sqr(f);
fsin: f:=sin(f);
fcos: f:=cos(f);
farctan: f:=arctan(f);
fln : f:=ln(f);
flog: f:=ln(f)/ln(10);
fexp: f:=exp(f);
ffact: f:=fact(trunc(f));
end;
Found:=true;
end;
end;
if not Found then ErrPos:=Pos;
end;
Factor:=F;
end æ function Factorå;
æ.PAå
begin æ SignedFactor å
if Ch='-' then
begin
NextCh; SignedFactor:=-Factor;
end else SignedFactor:=Factor;
end æ SignedFactor å;
begin æ Term å
T:=SignedFactor;
while Ch='^' do
begin
NextCh; t:=exp(ln(t)*SignedFactor);
end;
Term:=t;
end æ Term å;
begin æ SimpleExpression å
s:=term;
while Ch in Æ'*','/'Å do
begin
Opr:=Ch; NextCh;
case Opr of
'*': s:=s*term;
'/': s:=s/term;
end;
end;
SimpleExpression:=s;
end æ SimpleExpression å;
begin æ Expression å
E:=SimpleExpression;
while Ch in Æ'+','-'Å do
begin
Opr:=Ch; NextCh;
case Opr of
'+': e:=e+SimpleExpression;
'-': e:=e-SimpleExpression;
end;
end;
Expression:=E;
end æ Expression å;
begin æ procedure Evaluate å
if FormulaÆ1Å='.' then Formula:='0'+Formula;
if FormulaÆ1Å='+' then delete(Formula,1,1);
IsFormula:=false;
Pos:=0; NextCh;
Value:=Expression;
if Ch=EofLine then ErrPos:=0 else ErrPos:=Pos;
end æ Evaluate å;
æ.PAå
procedure Recalculate;
var
RFX: SheetIndex;
RFY:integer;
OldValue: real;
Err: integer;
begin
LowVideo;
GotoXY(1,24); ClrEol;
Write('Calculating..');
for RFY:=1 to FYMax do
begin
for RFX:='A' to FXMax do
begin
with SheetÆRFX,RFYÅ do
begin
if (Formula in CellStatus) then
begin
CellStatus:=CellStatus+ÆCalculatedÅ;
OldValue:=Value;
Evaluate(Form,Contents,Value,Err);
if OldValue<>Value then
begin
GotoXY(XPosÆRFXÅ,RFY+1);
if (DEC>=0) then Write(Value:FW:DEC)
else Write(Value:FW);
end;
end;
end;
end;
end;
GotoCell(FX,FY);
end;
æ.PAå
æ*******************************************************************å
æ* SOURCE CODE MODULE: MC-MOD05 *å
æ* PURPOSE: Read the contents of a cell and update *å
æ* associated cells. *å
æ*******************************************************************å
procedure GetLine(var S: AnyString; æ String to edit å
ColNO,LineNO, æ Where start line å
MAX, æ Max length å
ErrPos: integer; æ Where to begin å
UpperCase:Boolean); æ True if auto Upcase å
var
X: integer;
InsertOn: boolean;
OkChars: set of Char;
procedure GotoX;
begin
GotoXY(X+ColNo-1,LineNo);
end;
begin
OkChars:=Æ' '..'å'Å;
InsertOn:=true;
X:=1; GotoX;
Write(S);
if Length(S)=1 then X:=2;
if ErrPos<>0 then X:=ErrPos;
GotoX;
repeat
Read(Kbd,Ch);
if UpperCase then Ch:=UpCase(Ch);
case Ch of
^Æ: begin
S:=chr($FF); æ abort editing å
Ch:=^M;
end;
^D: begin æ Move cursor right å
X:=X+1;
if (X>length(S)+1) or (X>MAX) then X:=X-1;
GotoX;
end;
^G: begin æ Delete right char å
if X<=Length(S) then
begin
Delete(S,X,1);
Write(copy(S,X,Length(S)-X+1),' ');
GotoX;
end;
end;
^S,^H: begin æ Move cursor left å
X:=X-1;
if X<1 then X:=1;
GotoX;
end;
^F: begin æ Move cursor to end of line å
X:=Length(S)+1;
GotoX;
end;
^A: begin æ Move cursor to beginning of line å
X:=1;
GotoX;
end;
#127: begin æ Delete left char å
X:=X-1;
if (Length(S)>0) and (X>0) then
begin
Delete(S,X,1);
Write(copy(S,X,Length(S)-X+1),' ');
GotoX;
if X<1 then X:=1;
end else X:=1;
end;
^V: InsertOn:= not InsertOn;
æ.PAå
else
begin
if Ch in OkChars then
begin
if InsertOn then
begin
insert(Ch,S,X);
Write(copy(S,X,Length(S)-X+1),' ');
end else
begin
write(Ch);
if X=length(S) then S:=S+Ch
else SÆXÅ:=Ch;
end;
if Length(S)+1<=MAX then X:=X+1
else OkChars:=ÆÅ; æ Line too Long å
GotoX;
end else
if Length(S)+1<=Max then
OkChars:= Æ' '..'å'Å; æ Line ok again å
end;
end;
until CH=^M;
end;
æ.PAå
procedure GetCell(FX: SheetIndex;FY: Integer);
var
S: AnyString;
NewStat: Set of Attributes;
ErrorPosition: Integer;
I: SheetIndex;
Result: Real;
Abort: Boolean;
IsForm: Boolean;
æ Procedure ClearCells clears the current cell and its associated å
æ cells. An associated cell is a cell overwritten by data from the å
æ current cell. The data can be text in which case the cell has the å
æ attribute "OverWritten". If the data is a result from an expressionå
æ and the field with is larger tahn 11 then the cell is "Locked" å
procedure ClearCells;
begin
I:=FX;
repeat
with SheetÆI,FYÅ do
begin
GotoXY(XPosÆIÅ,FY+1);
write(' '); I:=Succ(I);
end;
until (ÆOverWritten,LockedÅ*SheetÆI,FYÅ.CellStatus=ÆÅ);
æ Cell is not OVerWritten not Locked å
end;
æ.CP20å
æ The new type of the cell is flashed at the bottom of the Sheet å
æ Notice that a constant of type array is used to indicate the type å
procedure FlashType;
begin
HighVideo;
GotoXY(5,23);
LowVideo;
end;
æ.CP20å
procedure GetFormula;
begin
FlashType;
repeat
GetLine(S,1,24,70,ErrorPosition,True);
if S<>Chr($FF) then
begin
Evaluate(IsForm,S,Result,ErrorPosition);
if ErrorPosition<>0 then
Flash(15,'Error at cursor'+^G,false)
else Flash(15,' ',false);
end;
until (ErrorPosition=0) or (S=Chr($FF));
if IsForm then NewStat:=NewStat+ÆFormulaÅ;
end;
æ.CP20å
æ Procedure GetText calls the procedure GetLine with the current å
æ cells X,Y position as parameters. This means that text entering å
æ takes place direcly at the cells posion on the Sheet. å
procedure GetText;
begin
FlashType;
with SheetÆFX,FYÅ do GetLine(S,XPosÆFXÅ,FY+1,70,ErrorPosition,False);
end;
æ.CP20å
æ Procedure EditCell loads a copy of the current cells contents in å
æ in the variable S before calling either GetText or GetFormula. In å
æ this way no changes are made to the current cell. å
procedure EditCell;
begin
with SheetÆFX,FYÅ do
begin
S:=Contents;
if Txt in CellStatus then GetText else GetFormula;
end;
end;
æ.PAå
æ Procedure UpdateCells is a little more complicated. Basically it å
æ makes sure to tag and untag cells which has been overwritten or å
æ cleared from data from another cell. It also updates the current å
æ with the new type and the contents which still is in the temporaly å
æ variable "S". å
procedure UpdateCells;
var
Flength: Integer;
begin
SheetÆFX,FYÅ.Contents:=S;
if Txt in NewStat æSheetÆFX,FYÅ.CellStatuså then
begin
I:=FX; FLength:=Length(S);
repeat
I:=Succ(I);
with SheetÆI,FYÅ do
begin
FLength:=Flength-11;
if (Flength>0) then
begin
CellStatus:=ÆOverwritten,TxtÅ;
Contents:='';
end else
begin
if OverWritten in CellStatus then
begin
CellStatus:=ÆTxtÅ;
GotoCell(I,FY);LeaveCell(I,FY);
end;
end;
end;
until (I=FXMax) or (SheetÆI,FYÅ.Contents<>'');
SheetÆFX,FYÅ.CellStatus:=ÆTxtÅ;
end else æ string changed to formula or constant å
begin æ Event number two å
I:=FX;
repeat
with SheetÆI,FYÅ do
begin
if OverWritten in CellStatus then
begin
CellStatus:=ÆTxtÅ;
Contents:='';
end;
I:=Succ(I);
end;
until not (OverWritten in SheetÆI,FYÅ.CellStatus);
with SheetÆFX,FYÅ do
begin
CellStatus:=ÆConstantÅ;
if IsForm then CellStatus:=CellStatus+ÆFormulaÅ;
Value:=Result;
end;
end;
end;
æ.PAå
æ Procedure GetCell finnaly starts here. This procedure uses all å
æ all the above local procedures. First it initializes the temporaly å
æ variable "S" with the last read character. It then depending on å
æ this character calls GetFormula, GetText, or EditCell. å
begin æ procedure GetCell å
S:=Ch; ErrorPosition:=0; Abort:=false;
NewStat:=ÆÅ;
if Ch in Æ'0'..'9','+','-','.','(',')'Å then
begin
NewStat:=ÆConstantÅ;
if not (Formula in SheetÆFX,FYÅ.CellStatus) then
begin
GotoXY(11,24); ClrEol;
ClearCells;
GetFormula;
end else
begin
Flash(15,'Edit formula Y/N?',true);
repeat read(Kbd,Ch) until UpCase(CH) in Æ'Y','N'Å;
Flash(15,' ',false);
if UpCase(Ch)='Y' then EditCell Else Abort:=true;
end;
end else
begin
if Ch=^Æ then
begin
NewStat:=(SheetÆFX,FYÅ.CellStatus)*ÆTxt,ConstantÅ;
EditCell;
end else
begin
if formula in SheetÆFX,FYÅ.CellStatus then
begin
Flash(15,'Edit formula Y/N?',true);
repeat read(Kbd,Ch) until UpCase(CH) in Æ'Y','N'Å;
Flash(15,' ',false);
if UpCase(Ch)='Y' then EditCell Else Abort:=true;
end else
begin
NewStat:=ÆTxtÅ;
ClearCells;
GetText;
end;
end;
end;
if not Abort then
begin
if S<>Chr($FF) then UpDateCells;
GotoCell(FX,FY);
if AutoCalc and (Constant in SheetÆFX,FYÅ.CellStatus) then Recalculate;
if Txt in NewStat then
begin
GotoXY(3,FY+1); Clreol;
For I:='A' to FXMax do
LeaveCell(I,FY);
end;
end;
Flash(15,' ',False);
GotoCell(FX,FY);
end;
æ.PAå
æ Procedure Format is used to å
procedure Format;
var
J,FW,DEC,
FromLine,ToLine: integer;
Lock: Boolean;
procedure GetInt(var I: integer; Max: Integer);
var
S: stringÆ8Å;
Err: Integer;
Ch: Char;
begin
S:='';
repeat
repeat Read(Kbd,Ch) until Ch in Æ'0'..'9','-',^MÅ;
if Ch<>^M then
begin
Write(Ch); S:=S+Ch;
Val(S,I,Err);
end;
until (I>=Max) or (Ch=^M);
if I>Max then I:=Max;
end;
begin
HighVideo;
Msg('Format: Enter number of decimals (Max 11): ');
GetInt(DEC,11);
Msg('Enter Cell whith remember if larger than 10 next column will lock: ');
GetInt(FW,20);
Msg('From which line in column '+FX+': ');
GetInt(FromLine,FYMax);
Msg('To which line in column '+FX+': ');
GetInt(ToLine,FYMax);
if FW>10 then Lock:=true else Lock:=False;
for J:=FromLine to ToLine do
begin
SheetÆFX,JÅ.DEC:=DEC;
SheetÆFX,JÅ.FW:=FW;
with SheetÆSucc(FX),JÅ do
begin
if Lock then
begin
CellStatus:=CellStatus+ÆLocked,TxtÅ;
Contents:='';
end else CellStatus:=CellStatus-ÆLockedÅ;
end;
end;
NormVideo;
UpDate;
GotoCell(FX,FY);
end;
æ.PAå
æ*********************************************************************å
æ* START OF MAIN PROGRAM PROCEDURES *å
æ*********************************************************************å
æ Procedure Commands is activated from the main loop in this program å
æ when the user types a slash (/). a procedure activates a procedureå
æ which will execute the command. These procedures are located in theå
æ above modules. å
æ For easy reference the source code module number is shown in a å
æ comment on the right following the procedure call. å
procedure Commands;
begin
GotoXY(1,24);
HighVideo;
Write('/ restore Quit, Load, Save, Recalculate, Print, Format, AutoCalc, Help ');
Read(Kbd,Ch);
Ch:=UpCase(Ch);
case Ch of æ In module å
'Q': Halt;
'F': Format; æ 04 å
'S': Save; æ 03 å
'L': Load; æ 03 å
'H': Help; æ 03 å
'R': Recalculate; æ 05 å
'A': Auto; æ 00 å
'/': Update; æ 01 å
'C': Clear; æ 01 å
'P': Print; æ 03 å
end;
Grid; æ 01 å
GotoCell(FX,FY); æ 02 å
end;
æ Procedure Hello says hello and activates the help procedure if the å
æ user presses anything but Return å
procedure Wellcome;
procedure Center(S: AnyString);
var I: integer;
begin
for I:=1 to (80-Length(S)) div 2 do Write(' ');
writeln(S);
end;
begin æ procedure Wellcome å
ClrScr; GotoXY(1,9);
Center('Welcome to MicroCalc. A Turbo demonstation program');
Center('Press any key for help or <RETURN> to start');
GotoXY(40,12);
Read(Kbd,Ch);
if Ch<>^M then Help;
end;
æ.PAå
æ*********************************************************************å
æ* THIS IS WHERE THE PROGRAM STARTS EXECUTING *å
æ*********************************************************************å
begin
Init; æ 01 å
Wellcome;
ClrScr; Grid; æ 01 å
GotoCell(FX,FY);
repeat
Read(Kbd,Ch);
case Ch of
^E: MoveUp; æ 02 å
^X,^J: MoveDown; æ 02 å
^D,^M,^F: MoveRight; æ 02 å
^S,^A: MoveLeft; æ 02 å
'/': Commands;
^Æ: GetCell(FX,FY); æ 04 å
else
if Ch in Æ' '..'ü'Å then
GetCell(FX,FY); æ 04 å
end;
until true=false; æ (program stops in procedure Commands) å
end.
«eof»