1 {
2 This file is part of the Free Pascal Integrated Development Environment
3 Copyright (c) 1998 by Berczi Gabor
4
5 Calculator object for the IDE
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15 {$I globdir.inc}
16 unit FPCalc;
17
18 interface
19
20 uses
21 Drivers,Objects,Views,Dialogs,App,
22 FVConsts,
23 WViews,
24 FPViews;
25
26 const
27 MaxDecimals = 10;
28 MaxDigits = 30;
29
30 type
31
32 TCalcState = (csFirst, csValid, csError);
33
34 PCalcButton = ^TCalcButton;
35 TCalcButton = object(TButton)
36 procedure HandleEvent(var Event: TEvent); virtual;
37 end;
38
39 PCalcDisplay = ^TCalcDisplay;
40 TCalcDisplay = object(TView)
41 Status: TCalcState;
42 Number: string[MaxDigits];
43 Sign: Char;
44 LastOperator,
45 _Operator: Char;
46 LastR,
47 Operand: extended;
48 Memory: extended;
49 DispNumber: extended;
50 HexShown : boolean;
51 constructor Init(var Bounds: TRect);
52 constructor Load(var S: TStream);
CalcKeynull53 function CalcKey(Key: string): boolean;
54 procedure Clear;
55 procedure Draw; virtual;
GetPalettenull56 function GetPalette: PPalette; virtual;
57 procedure HandleEvent(var Event: TEvent); virtual;
58 procedure Store(var S: TStream);
59 private
60 procedure GetDisplay(var R: extended);
61 procedure SetDisplay(R: extended;ShouldKeepZeroes : boolean);
62 procedure Error;
63 end;
64
65 PCalculator = ^TCalculator;
66 TCalculator = object(TCenterDialog)
67 CD : PCalcDisplay;
68 constructor Init;
69 procedure HandleEvent(var Event: TEvent); virtual;
70 procedure Show; {virtual;}
71 procedure Close; virtual;
72 constructor Load(var S: TStream);
73 procedure Store(var S: TStream);
74 end;
75
76 {$ifndef NOOBJREG}
77 const
78 RCalcButton: TStreamRec = (
79 ObjType: 10139;
80 VmtLink: Ofs(TypeOf(TCalcButton)^);
81 Load: @TCalcButton.Load;
82 Store: @TCalcButton.Store
83 );
84 RCalcDisplay: TStreamRec = (
85 ObjType: 10140;
86 VmtLink: Ofs(TypeOf(TCalcDisplay)^);
87 Load: @TCalcDisplay.Load;
88 Store: @TCalcDisplay.Store
89 );
90 RCalculator: TStreamRec = (
91 ObjType: 10141;
92 VmtLink: Ofs(TypeOf(TCalculator)^);
93 Load: @TCalculator.Load;
94 Store: @TCalculator.Store
95 );
96 {$endif}
97
98 procedure RegisterFPCalc;
99
100 implementation
101
102 uses
103 {$ifdef Unix}
104 baseunix,
105 unix,
106 {$endif}
107 {$ifdef go32v2}
108 dpmiexcp,
109 {$endif}
110 {$ifdef windows}
111 {$ifdef HasSignal}
112 signals,
113 {$endif}
114 {$endif windows}
115 FPUtils,FPConst,WUtils;
116
117 const
118 cmCalcButton = 100;
119 cmPressButton = 101;
120
121 {$ifdef useresstrings}
122 resourcestring
123 {$else}
124 const
125 {$endif}
126 dialog_calculator = 'Calculator';
127
128
129 procedure TCalcButton.HandleEvent(var Event: TEvent);
130 var
131 Call : boolean;
132 i : Sw_Word;
133 begin
134 Call:=true;
135 case Event.What of
136 evKeyDown :
137 case Event.KeyCode of
138 kbEnter : Call:=false;
139 end;
140 evBroadcast :
141 case Event.Command of
142 cmDefault : Call:=false;
143 cmPressButton :
144 begin
145 if (PString(Event.InfoPtr)^=Title^) or
146 ((PString(Event.InfoPtr)^='^') and (Title^='x^y')) then
147 begin
148 Select;
149 DrawState(true);
150 i:=GetDosTicks+2;
151 repeat
152 until GetDosTicks>i;
153 DrawState(false);
154 ClearEvent(Event);
155 end;
156 end;
157 end;
158 end;
159 if Call then
160 inherited HandleEvent(Event);
161 end;
162
163 constructor TCalcDisplay.Init(var Bounds: TRect);
164 begin
165 inherited Init(Bounds);
166 Options := Options or ofSelectable;
167 EventMask := evKeyDown + evBroadcast;
168 Clear;
169 HelpCtx:={hcCalculatorLine}0;
170 HexShown:=false;
171 end;
172
173 constructor TCalcDisplay.Load(var S: TStream);
174 begin
175 inherited Load(S);
176 S.Read(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
177 SizeOf(_Operator) + SizeOf(Operand));
178 HexShown:=false;
179 end;
180
181 procedure TCalcDisplay.GetDisplay(var R: extended);
182 begin
183 { Val(Sign + Number, R, E);}
184 R:=DispNumber;
185 end;
186
187 procedure TCalcDisplay.SetDisplay(R: extended;ShouldKeepZeroes : boolean);
188 var
189 S: string[MaxDigits];
190 i,KeepZeroes : byte;
191 begin
192 DispNumber:=R;
193 KeepZeroes:=0;
194 if ShouldKeepZeroes and (pos('.',Number)>0) then
195 for i:=length(Number) downto pos('.',Number)+1 do
196 if Number[i]='0' then
197 inc(KeepZeroes)
198 else
199 break;
200
201 Str(R: 0: MaxDecimals, S);
202 if Pos('.',S)<>0 then
203 while (length(S)>1) and (S[length(S)]='0') do Dec(S[0]);
204 if KeepZeroes>0 then
205 for i:=1 to KeepZeroes do
206 S:=S+'0';
207 if S[1] <> '-' then Sign := ' ' else
208 begin
209 Delete(S, 1, 1);
210 Sign := '-';
211 end;
212 if Length(S) > MaxDigits + 1 + MaxDecimals then Error
213 else
214 begin
215 if S[Length(S)] = '.' then Dec(S[0]);
216 Number := S;
217 end;
218 end;
219
220 procedure TCalcDisplay.Error;
221 begin
222 Status := csError;
223 Number := 'Error';
224 Sign := ' ';
225 DrawView;
226 end;
227
228 {$ifdef HasSignal}
229 var
230 {$ifndef go32v2}
231 CalcSigJmp : Jmp_Buf;
232 {$else : go32v2}
233 CalcSigJmp : dpmi_jmp_buf;
234 {$endif go32v2}
235 const
236 fpucw : word = $1332;
237 {$ifdef Unix}
238 Procedure CalcSigFPE(sig : longint);cdecl;
239 {$else}
CalcSigFPEnull240 function CalcSigFPE(sig : longint) : longint;cdecl;
241 {$endif}
242 {$ifdef CPUI386}
243 var
244 { Use a local variable to avoid problems with PIC code }
245 local_fpucw : word;
246 {$endif CPUI386}
247 begin
248 {$ifdef CPUI386}
249 asm
250 fninit
251 fldcw local_fpucw
252 end;
253 fpucw := local_fpucw;
254 {$endif}
255 { ErrorBox('Error while computing math expression',nil);
256 was only there for debugging PM }
257 {$ifdef go32v2}
258 Dpmi_LongJmp(CalcSigJmp,1);
259 {$else : not go32v2}
260 LongJmp(CalcSigJmp,1);
261 {$endif go32v2}
262 {$ifndef Unix}
263 { Just here to avoid compiler warnings PM }
264 CalcSigFPE:=0;
265 {$endif}
266 end;
267 {$endif HasSignal}
268
TCalcDisplay.CalcKeynull269 function TCalcDisplay.CalcKey(Key: string): boolean;
270 var
271 R,D: extended;
272 X : cardinal;
273 procedure CheckFirst;
274 begin
275 if Status = csFirst then
276 begin
277 Status := csValid;
278 SetDisplay(0,false);
279 end;
280 end;
281 {$ifdef HasSignal}
282 var
283 StoreSigFPE : SignalHandler;
284 {$endif HasSignal}
285 {$ifdef CPUI386}
286 var
287 { Use a local variable to avoid problems with PIC code }
288 local_fpucw : word;
289 {$endif CPUI386}
290 begin
291 CalcKey:=true;
292 Key := UpCaseStr(Key);
293 {$ifdef HasSignal}
294 {$ifdef CPUI386}
295 local_fpucw:=fpucw;
296 asm
297 fstcw local_fpucw
298 end;
299 {$endif}
300 {$ifdef go32v2}
301 if Dpmi_SetJmp(CalcSigJmp)=0 then
302 {$else : not go32v2}
303 if SetJmp(CalcSigJmp)=0 then
304 {$endif go32v2}
305 {$endif HasSignal}
306 begin
307 {$ifdef HasSignal}
308 StoreSigFPE:={$ifdef unix}fpSignal{$else}Signal{$endif}(SIGFPE,@CalcSigFPE);
309 {$endif HasSignal}
310 if (Status = csError) and (Key <> 'C') then Key := ' ';
311 if HexShown then
312 begin
313 GetDisplay(R);
314 SetDisplay(R,false);
315 HexShown := false;
316 if Key = 'H' then
317 Key := ' ';
318 end;
319 if Key='X^Y' then Key:='^';
320 if length(Key)>1 then
321 begin
322 { if Status = csFirst then}
323 begin
324 { Status := csValid;}
325 GetDisplay(R);
326 if Key='1/X' then begin if R=0 then Error else SetDisplay(1/R,false) end else
327 if Key='SQRT' then begin if R<0 then Error else SetDisplay(sqrt(R),false) end else
328 if Key='LOG' then begin if R<=0 then Error else SetDisplay(ln(R),false) end else
329 if Key='X^2' then SetDisplay(R*R,false) else
330 if Key='M+' then Memory:=Memory+R else
331 if Key='M-' then Memory:=Memory-R else
332 if Key='M'#26 then SetDisplay(Memory,false) else
333 if Key='M'#27 then Memory:=R else
334 if Key='M'#29 then begin D:=Memory; Memory:=R; SetDisplay(D,false); end;
335 end;
336 end
337 else
338 case Key[1] of
339 '0'..'9':
340 if Length(Number)<MaxDigits then
341 begin
342 CheckFirst;
343 if Number = '0' then Number := '';
344 Number := Number + Key;
345 SetDisplay(StrToExtended(Number),true);
346 end;
347 '.':
348 begin
349 CheckFirst;
350 if Pos('.', Number) = 0 then Number := Number + '.';
351 end;
352 #8, #27:
353 begin
354 CheckFirst;
355 if Length(Number) = 1 then Number := '0' else Dec(Number[0]);
356 SetDisplay(StrToExtended(Number),true); { !!! }
357 end;
358 'H':
359 begin
360 GetDisplay(R);
361 X:=trunc(abs(R));
362 Number:=HexStr(longint(X),8);
363 HexShown:=true;
364 end;
365 '_', #241:
366 begin
367 if Sign = ' ' then Sign := '-' else Sign := ' ';
368 GetDisplay(R);
369 SetDisplay(-R,true);
370 end;
371 '+', '-', '*', '/', '=', '%', #13, '^':
372 begin
373 if (Key[1]='=') and (Status=csFirst) then
374 begin
375 Status:=csValid;
376 R:=LastR;
377 _Operator:=LastOperator;
378 end
379 else
380 GetDisplay(R);
381 if (Status = csValid) then
382 begin
383 Status := csFirst;
384 LastR:=R;
385 LastOperator:=_Operator;
386 if Key = '%' then
387 case _Operator of
388 '+', '-': R := Operand * R / 100;
389 '*', '/': R := R / 100;
390 end;
391 case _Operator of
392 '^': if (Operand = 0)and(R <= 0) then Error else SetDisplay(Power(Operand,R),false);
393 '+': SetDisplay(Operand + R,false);
394 '-': SetDisplay(Operand - R,false);
395 '*': SetDisplay(Operand * R,false);
396 '/': if R = 0 then Error else SetDisplay(Operand / R,false);
397 end;
398 end;
399 _Operator := Key[1];
400 GetDisplay(Operand);
401 end;
402 'C':
403 Clear;
404 else CalcKey:=false;
405 end;
406 {$ifdef HasSignal}
407 {$ifdef unix}fpSignal{$else}Signal{$endif}(SIGFPE,StoreSigFPE);
408 {$endif HasSignal}
409 DrawView;
410 {$ifdef HasSignal}
411 end
412 else { LongJmp called }
413 begin
414 ErrorBox('Error while computing '+Key,nil);
415 CalcKey:=true;
416 {$endif HasSignal}
417 end;
418 end;
419
420 procedure TCalcDisplay.Clear;
421 begin
422 Status := csFirst;
423 Number := '0';
424 Sign := ' ';
425 _Operator := '=';
426 end;
427
428 procedure TCalcDisplay.Draw;
429 var
430 Color: Byte;
431 I: Integer;
432 B: TDrawBuffer;
433 begin
434 Color := GetColor(1);
435 I := Size.X - Length(Number) - 2;
436 MoveChar(B, ' ', Color, Size.X);
437 MoveChar(B[I], Sign, Color, 1);
438 MoveStr(B[I + 1], Number, Color);
439 WriteBuf(0, 0, Size.X, 1, B);
440 end;
441
GetPalettenull442 function TCalcDisplay.GetPalette: PPalette;
443 const
444 P: string[1] = #19;
445 begin
446 GetPalette := @P;
447 end;
448
449 procedure TCalcDisplay.HandleEvent(var Event: TEvent);
450 var S: string[3];
451 begin
452 inherited HandleEvent(Event);
453 case Event.What of
454 evKeyDown:
455 if Owner<>nil then
456 if (Owner^.State and sfSelected)<>0 then
457 begin
458 S:=Event.CharCode;
459 Message(Owner,evBroadcast,cmPressButton,@S);
460 if CalcKey(Event.CharCode) then
461 ClearEvent(Event);
462 end;
463 evBroadcast:
464 if Event.Command = cmCalcButton then
465 begin
466 CalcKey(PButton(Event.InfoPtr)^.Title^);
467 ClearEvent(Event);
468 end;
469 end;
470 end;
471
472 procedure TCalcDisplay.Store(var S: TStream);
473 begin
474 TView.Store(S);
475 S.Write(Status, SizeOf(Status) + SizeOf(Number) + SizeOf(Sign) +
476 SizeOf(_Operator) + SizeOf(Operand));
477 end;
478
479 { TCalculator }
480
481 constructor TCalculator.Init;
482 const
483 Keys: array[0..29] of string[4] =
484 ('M+', 'x^y','C' ,#27 ,'%' ,#241 ,
485 'M-', 'x^2','7' ,'8' ,'9' ,'/' ,
486 'M'#26,'1/x','4' ,'5' ,'6' ,'*' ,
487 'M'#27,'sqrt','1' ,'2' ,'3' ,'-' ,
488 'M'#29,'log','0' ,'.' ,'=' ,'+' );
489 var
490 I: Integer;
491 P: PView;
492 R: TRect;
493 begin
494 R.Assign(5, 3, 43, 18);
495 inherited Init(R, dialog_Calculator);
496 Options := Options or ofFirstClick or ofTopSelect;
497 HelpCtx:=hcCalcWindow;
498
499 for I := 0 to 29 do
500 begin
501 R.A.X := (I mod 6) * 5 + 2;
502 R.A.Y := (I div 6) * 2 + 4;
503 R.B.X := R.A.X + 5;
504 R.B.Y := R.A.Y + 2;
505 if (I mod 6)=0 then Inc(R.B.X,1) else
506 if (I mod 6)=1 then begin R.Move(1,0); Inc(R.B.X,2) end else
507 R.Move(3,0);
508 P := New(PCalcButton, Init(R, Keys[I], cmCalcButton,
509 bfNormal + bfBroadcast+bfGrabFocus));
510 P^.Options := P^.Options {and not ofSelectable};
511 Insert(P);
512 end;
513 R.Assign(3, 2, 35, 3);
514 New(CD, Init(R));
515 CD^.Options:=CD^.Options or ofSelectable;
516 Insert(CD);
517 end;
518
519 procedure TCalculator.HandleEvent(var Event: TEvent);
520 var R: extended;
521 { Re: real;}
522 begin
523 if (State and sfSelected)<>0 then
524 case Event.What of
525 evCommand :
526 case Event.Command of
527 cmCalculatorPaste :
528 Message(@Self,evKeyDown,kbCtrlEnter,nil);
529 end;
530 evKeyDown :
531 case Event.KeyCode of
532 kbEnter :
533 begin
534 Event.KeyCode:=0;
535 Event.CharCode:='=';
536 end;
537 kbCtrlEnter :
538 begin
539 ClearEvent(Event);
540 CD^.GetDisplay(R); {Re:=R;}
541 Close;
542 CalcClipboard:=R;
543 Message(Application,evBroadcast,cmCalculatorPaste,nil);
544 end;
545 kbEsc :
546 begin
547 CD^.GetDisplay(R);
548 if R<>0 then begin
549 CD^.SetDisplay(0,false);
550 CD^.DrawView;
551 end
552 else Close;
553 ClearEvent(Event);
554 end;
555 end;
556 end;
557 { lets CD try to handle this }
558 if Event.What=evKeyDown then
559 Message(CD,Event.What,Event.KeyCode,Event.InfoPtr);
560 inherited HandleEvent(Event);
561 end;
562
563 procedure TCalculator.Show;
564 begin
565 { if GetState(sfVisible)=false then CD^.Clear;}
566 inherited Show;
567 end;
568
569 procedure TCalculator.Close;
570 begin
571 Hide;
572 end;
573
574 constructor TCalculator.Load(var S: TStream);
575 begin
576 inherited Load(S);
577 GetSubViewPtr(S,CD);
578 end;
579
580 procedure TCalculator.Store(var S: TStream);
581 begin
582 inherited Store(S);
583 PutSubViewPtr(S,CD);
584 end;
585
586
587 procedure RegisterFPCalc;
588 begin
589 {$ifndef NOOBJREG}
590 RegisterType(RCalcButton);
591 RegisterType(RCalcDisplay);
592 RegisterType(RCalculator);
593 {$endif}
594 end;
595
596 end.
597