mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 22:11:12 +01:00
474 lines
11 KiB
ObjectPascal
474 lines
11 KiB
ObjectPascal
{
|
|
$Id$
|
|
This file is part of the Free Pascal Integrated Development Environment
|
|
Copyright (c) 1998 by Berczi Gabor
|
|
|
|
Calculator object for the IDE
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
{$I globdir.inc}
|
|
unit FPCalc;
|
|
|
|
interface
|
|
|
|
uses
|
|
Drivers,Objects,Commands,Views,Dialogs,App,
|
|
WViews,
|
|
FPViews;
|
|
|
|
const
|
|
MaxDecimals = 10;
|
|
MaxDigits = 30;
|
|
|
|
type
|
|
|
|
TCalcState = (csFirst, csValid, csError);
|
|
|
|
PCalcButton = ^TCalcButton;
|
|
TCalcButton = object(TButton)
|
|
procedure HandleEvent(var Event: TEvent); virtual;
|
|
end;
|
|
|
|
PCalcDisplay = ^TCalcDisplay;
|
|
TCalcDisplay = object(TView)
|
|
Status: TCalcState;
|
|
Number: string[MaxDigits];
|
|
Sign: Char;
|
|
_Operator: Char;
|
|
Operand: extended;
|
|
Memory: extended;
|
|
DispNumber: extended;
|
|
constructor Init(var Bounds: TRect);
|
|
constructor Load(var S: TStream);
|
|
function CalcKey(Key: string): boolean;
|
|
procedure Clear;
|
|
procedure Draw; virtual;
|
|
function GetPalette: PPalette; virtual;
|
|
procedure HandleEvent(var Event: TEvent); virtual;
|
|
procedure Store(var S: TStream);
|
|
private
|
|
procedure GetDisplay(var R: extended);
|
|
procedure SetDisplay(R: extended);
|
|
procedure Error;
|
|
end;
|
|
|
|
PCalculator = ^TCalculator;
|
|
TCalculator = object(TCenterDialog)
|
|
CD : PCalcDisplay;
|
|
constructor Init;
|
|
procedure HandleEvent(var Event: TEvent); virtual;
|
|
procedure Show; virtual;
|
|
procedure Close; virtual;
|
|
end;
|
|
|
|
{$ifndef NOOBJREG}
|
|
const
|
|
RCalcButton: TStreamRec = (
|
|
ObjType: 10139;
|
|
VmtLink: Ofs(TypeOf(TCalcButton)^);
|
|
Load: @TCalcButton.Load;
|
|
Store: @TCalcButton.Store
|
|
);
|
|
RCalcDisplay: TStreamRec = (
|
|
ObjType: 10140;
|
|
VmtLink: Ofs(TypeOf(TCalcDisplay)^);
|
|
Load: @TCalcDisplay.Load;
|
|
Store: @TCalcDisplay.Store
|
|
);
|
|
RCalculator: TStreamRec = (
|
|
ObjType: 10141;
|
|
VmtLink: Ofs(TypeOf(TCalculator)^);
|
|
Load: @TCalculator.Load;
|
|
Store: @TCalculator.Store
|
|
);
|
|
{$endif}
|
|
|
|
procedure RegisterFPCalc;
|
|
|
|
implementation
|
|
|
|
uses FPUtils,FPConst;
|
|
|
|
const
|
|
cmCalcButton = 100;
|
|
cmPressButton = 101;
|
|
|
|
procedure TCalcButton.HandleEvent(var Event: TEvent);
|
|
var
|
|
Call : boolean;
|
|
i : Sw_Word;
|
|
begin
|
|
Call:=true;
|
|
case Event.What of
|
|
evKeyDown :
|
|
case Event.KeyCode of
|
|
kbEnter : Call:=false;
|
|
end;
|
|
evBroadcast :
|
|
case Event.Command of
|
|
cmDefault : Call:=false;
|
|
cmPressButton :
|
|
begin
|
|
if (PString(Event.InfoPtr)^=Title^) or
|
|
((PString(Event.InfoPtr)^='^') and (Title^='x^y')) then
|
|
begin
|
|
Select;
|
|
DrawState(true);
|
|
i:=GetDosTicks+2;
|
|
repeat
|
|
until GetDosTicks>i;
|
|
DrawState(false);
|
|
ClearEvent(Event);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if Call then
|
|
inherited HandleEvent(Event);
|
|
end;
|
|
|
|
constructor TCalcDisplay.Init(var Bounds: TRect);
|
|
begin
|
|
inherited Init(Bounds);
|
|
Options := Options or ofSelectable;
|
|
EventMask := evKeyDown + evBroadcast;
|
|
Clear;
|
|
HelpCtx:={hcCalculatorLine}0;
|
|
end;
|
|
|
|
constructor TCalcDisplay.Load(var S: TStream);
|
|
begin
|
|
inherited Load(S);
|
|
S.Read(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
|
|
SizeOf(_Operator) + SizeOf(Operand));
|
|
end;
|
|
|
|
procedure TCalcDisplay.GetDisplay(var R: extended);
|
|
begin
|
|
{ Val(Sign + Number, R, E);}
|
|
R:=DispNumber;
|
|
end;
|
|
|
|
procedure TCalcDisplay.SetDisplay(R: extended);
|
|
var
|
|
S: string[MaxDigits];
|
|
begin
|
|
DispNumber:=R;
|
|
Str(R: 0: MaxDecimals, S);
|
|
if Pos('.',S)<>0 then
|
|
while (length(S)>1) and (S[length(S)]='0') do Dec(S[0]);
|
|
if S[1] <> '-' then Sign := ' ' else
|
|
begin
|
|
Delete(S, 1, 1);
|
|
Sign := '-';
|
|
end;
|
|
if Length(S) > MaxDigits + 1 + MaxDecimals then Error
|
|
else
|
|
begin
|
|
if S[Length(S)] = '.' then Dec(S[0]);
|
|
Number := S;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalcDisplay.Error;
|
|
begin
|
|
Status := csError;
|
|
Number := 'Error';
|
|
Sign := ' ';
|
|
DrawView;
|
|
end;
|
|
|
|
function TCalcDisplay.CalcKey(Key: string): boolean;
|
|
var
|
|
R,D: extended;
|
|
procedure CheckFirst;
|
|
begin
|
|
if Status = csFirst then
|
|
begin
|
|
Status := csValid;
|
|
{ Number := '0';
|
|
Sign := ' ';}
|
|
SetDisplay(0);
|
|
end;
|
|
end;
|
|
begin
|
|
CalcKey:=true;
|
|
Key := UpCaseStr(Key);
|
|
if (Status = csError) and (Key <> 'C') then Key := ' ';
|
|
if Key='X^Y' then Key:='^';
|
|
if length(Key)>1 then
|
|
begin
|
|
{ if Status = csFirst then}
|
|
begin
|
|
{ Status := csValid;}
|
|
GetDisplay(R);
|
|
if Key='1/X' then begin if R=0 then Error else SetDisplay(1/R) end else
|
|
if Key='SQR' then begin if R<0 then Error else SetDisplay(sqrt(R)) end else
|
|
if Key='X^2' then SetDisplay(R*R) else
|
|
if Key='M+' then Memory:=Memory+R else
|
|
if Key='M-' then Memory:=Memory-R else
|
|
if Key='M'#26 then SetDisplay(Memory) else
|
|
if Key='M'#27 then Memory:=R else
|
|
if Key='M'#29 then begin D:=Memory; Memory:=R; SetDisplay(D); end;
|
|
end;
|
|
end
|
|
else
|
|
case Key[1] of
|
|
'0'..'9':
|
|
if Length(Number)<MaxDigits then
|
|
begin
|
|
CheckFirst;
|
|
if Number = '0' then Number := '';
|
|
Number := Number + Key;
|
|
SetDisplay(StrToExtended(Number)); { !!! }
|
|
end;
|
|
'.':
|
|
begin
|
|
CheckFirst;
|
|
if Pos('.', Number) = 0 then Number := Number + '.';
|
|
end;
|
|
#8, #27:
|
|
begin
|
|
CheckFirst;
|
|
if Length(Number) = 1 then Number := '0' else Dec(Number[0]);
|
|
SetDisplay(StrToExtended(Number)); { !!! }
|
|
end;
|
|
'_', #241:
|
|
if Sign = ' ' then Sign := '-' else Sign := ' ';
|
|
'+', '-', '*', '/', '=', '%', #13, '^':
|
|
begin
|
|
if Status = csValid then
|
|
begin
|
|
Status := csFirst;
|
|
GetDisplay(R);
|
|
if Key = '%' then
|
|
case _Operator of
|
|
'+', '-': R := Operand * R / 100;
|
|
'*', '/': R := R / 100;
|
|
end;
|
|
case _Operator of
|
|
'^': SetDisplay(Power(Operand,R));
|
|
'+': SetDisplay(Operand + R);
|
|
'-': SetDisplay(Operand - R);
|
|
'*': SetDisplay(Operand * R);
|
|
'/': if R = 0 then Error else SetDisplay(Operand / R);
|
|
end;
|
|
end;
|
|
_Operator := Key[1];
|
|
GetDisplay(Operand);
|
|
end;
|
|
'C':
|
|
Clear;
|
|
else CalcKey:=false;
|
|
end;
|
|
DrawView;
|
|
end;
|
|
|
|
procedure TCalcDisplay.Clear;
|
|
begin
|
|
Status := csFirst;
|
|
Number := '0';
|
|
Sign := ' ';
|
|
_Operator := '=';
|
|
end;
|
|
|
|
procedure TCalcDisplay.Draw;
|
|
var
|
|
Color: Byte;
|
|
I: Integer;
|
|
B: TDrawBuffer;
|
|
begin
|
|
Color := GetColor(1);
|
|
I := Size.X - Length(Number) - 2;
|
|
MoveChar(B, ' ', Color, Size.X);
|
|
MoveChar(B[I], Sign, Color, 1);
|
|
MoveStr(B[I + 1], Number, Color);
|
|
WriteBuf(0, 0, Size.X, 1, B);
|
|
end;
|
|
|
|
function TCalcDisplay.GetPalette: PPalette;
|
|
const
|
|
P: string[1] = #19;
|
|
begin
|
|
GetPalette := @P;
|
|
end;
|
|
|
|
procedure TCalcDisplay.HandleEvent(var Event: TEvent);
|
|
var S: string[3];
|
|
begin
|
|
inherited HandleEvent(Event);
|
|
case Event.What of
|
|
evKeyDown:
|
|
if Owner<>nil then
|
|
if (Owner^.State and sfSelected)<>0 then
|
|
begin
|
|
S:=Event.CharCode;
|
|
Message(Owner,evBroadcast,cmPressButton,@S);
|
|
if CalcKey(Event.CharCode) then
|
|
ClearEvent(Event);
|
|
end;
|
|
evBroadcast:
|
|
if Event.Command = cmCalcButton then
|
|
begin
|
|
CalcKey(PButton(Event.InfoPtr)^.Title^);
|
|
ClearEvent(Event);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TCalcDisplay.Store(var S: TStream);
|
|
begin
|
|
TView.Store(S);
|
|
S.Write(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
|
|
SizeOf(_Operator) + SizeOf(Operand));
|
|
end;
|
|
|
|
{ TCalculator }
|
|
|
|
constructor TCalculator.Init;
|
|
const
|
|
Keys: array[0..29] of string[3] =
|
|
('M+', 'x^y','C' ,#27 ,'%' ,#241 ,
|
|
'M-', 'x^2','7' ,'8' ,'9' ,'/' ,
|
|
'M'#26,'1/x','4' ,'5' ,'6' ,'*' ,
|
|
'M'#27,'sqr','1' ,'2' ,'3' ,'-' ,
|
|
'M'#29,'log','0' ,'.' ,'=' ,'+' );
|
|
var
|
|
I: Integer;
|
|
P: PView;
|
|
R: TRect;
|
|
begin
|
|
R.Assign(5, 3, 43, 18);
|
|
inherited Init(R, 'Calculator');
|
|
Options := Options or ofFirstClick or ofTopSelect;
|
|
HelpCtx:=hcCalcWindow;
|
|
|
|
for I := 0 to 29 do
|
|
begin
|
|
R.A.X := (I mod 6) * 5 + 2;
|
|
R.A.Y := (I div 6) * 2 + 4;
|
|
R.B.X := R.A.X + 5;
|
|
R.B.Y := R.A.Y + 2;
|
|
if (I mod 6)=0 then Inc(R.B.X,1) else
|
|
if (I mod 6)=1 then begin R.Move(1,0); Inc(R.B.X,2) end else
|
|
R.Move(3,0);
|
|
P := New(PCalcButton, Init(R, Keys[I], cmCalcButton,
|
|
bfNormal + bfBroadcast+bfGrabFocus));
|
|
P^.Options := P^.Options {and not ofSelectable};
|
|
Insert(P);
|
|
end;
|
|
R.Assign(3, 2, 35, 3);
|
|
New(CD, Init(R));
|
|
CD^.Options:=CD^.Options or ofSelectable;
|
|
Insert(CD);
|
|
end;
|
|
|
|
procedure TCalculator.HandleEvent(var Event: TEvent);
|
|
var R: extended;
|
|
Re: real;
|
|
begin
|
|
if (State and sfSelected)<>0 then
|
|
case Event.What of
|
|
evCommand :
|
|
case Event.Command of
|
|
cmCalculatorPaste :
|
|
Message(@Self,evKeyDown,kbCtrlEnter,nil);
|
|
end;
|
|
evKeyDown :
|
|
case Event.KeyCode of
|
|
kbEnter :
|
|
begin
|
|
Event.KeyCode:=0;
|
|
Event.CharCode:='=';
|
|
end;
|
|
kbCtrlEnter :
|
|
begin
|
|
ClearEvent(Event);
|
|
CD^.GetDisplay(R); Re:=R;
|
|
Close;
|
|
CalcClipboard:=R;
|
|
Message(Application,evBroadcast,cmCalculatorPaste,nil);
|
|
end;
|
|
kbEsc :
|
|
begin
|
|
CD^.GetDisplay(R);
|
|
if R<>0 then begin
|
|
CD^.SetDisplay(0);
|
|
CD^.DrawView;
|
|
end
|
|
else Close;
|
|
ClearEvent(Event);
|
|
end;
|
|
end;
|
|
end;
|
|
inherited HandleEvent(Event);
|
|
if Event.What=evKeyDown then
|
|
Message(CD,Event.What,Event.KeyCode,Event.InfoPtr);
|
|
end;
|
|
|
|
procedure TCalculator.Show;
|
|
begin
|
|
{ if GetState(sfVisible)=false then CD^.Clear;}
|
|
inherited Show;
|
|
end;
|
|
|
|
procedure TCalculator.Close;
|
|
begin
|
|
Hide;
|
|
end;
|
|
|
|
procedure RegisterFPCalc;
|
|
begin
|
|
{$ifndef NOOBJREG}
|
|
RegisterType(RCalcButton);
|
|
RegisterType(RCalcDisplay);
|
|
RegisterType(RCalculator);
|
|
{$endif}
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.5 1999-06-28 19:25:35 peter
|
|
* fixes from gabor
|
|
|
|
Revision 1.4 1999/04/07 21:55:41 peter
|
|
+ object support for browser
|
|
* html help fixes
|
|
* more desktop saving things
|
|
* NODEBUG directive to exclude debugger
|
|
|
|
Revision 1.3 1999/03/01 15:41:49 peter
|
|
+ Added dummy entries for functions not yet implemented
|
|
* MenuBar didn't update itself automatically on command-set changes
|
|
* Fixed Debugging/Profiling options dialog
|
|
* TCodeEditor converts spaces to tabs at save only if efUseTabChars is
|
|
set
|
|
* efBackSpaceUnindents works correctly
|
|
+ 'Messages' window implemented
|
|
+ Added '$CAP MSG()' and '$CAP EDIT' to available tool-macros
|
|
+ Added TP message-filter support (for ex. you can call GREP thru
|
|
GREP2MSG and view the result in the messages window - just like in TP)
|
|
* A 'var' was missing from the param-list of THelpFacility.TopicSearch,
|
|
so topic search didn't work...
|
|
* In FPHELP.PAS there were still context-variables defined as word instead
|
|
of THelpCtx
|
|
* StdStatusKeys() was missing from the statusdef for help windows
|
|
+ Topic-title for index-table can be specified when adding a HTML-files
|
|
|
|
Revision 1.1 1998/12/22 14:27:54 peter
|
|
* moved
|
|
|
|
Revision 1.2 1998/12/22 10:39:39 peter
|
|
+ options are now written/read
|
|
+ find and replace routines
|
|
|
|
}
|