PC World Komputer 1998 April A/Pcwk4a98.iso/PROGRAM/DELPHI16/Calc/CALC.PAS

Pascal/Delphi Source File | 1995-06-01 | 9.1 KB | 416 lines

unit Calc;

{$F+,O+,S-}

{     Calculator object.
    Modified from the Borland Demo by Sanford Aranoff. }

interface

uses Drivers, Objects, Views, Dialogs, general;


type

  TCalcState = (csFirst, csValid, csError);

  PCalcDisplay = ^TCalcDisplay;
  TCalcDisplay = object(TView)
    Status    : TCalcState;
    Num1,
    Num2,
    Number    : string[79];
    Sign        : Char;
    Operator: Char;
    PriorOp,
    Operand    : Double;
    constructor Init (var Bounds: TRect);
    constructor Load (var S: TStream);
    procedure CalcKey (Key: Char);
    procedure Clear;
    procedure Draw; virtual;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent (var Event: TEvent); virtual;
    procedure Store (var S: TStream);
  end;

  PCalculator = ^TCalculator;
  TCalculator = object(TDialog)
    constructor Init;
  end;

const
  RCalcDisplay: TStreamRec = (
     ObjType: 10040;
     VmtLink: Ofs (TypeOf (TCalcDisplay)^);
     Load:    @TCalcDisplay.Load;
     Store:   @TCalcDisplay.Store
  );
  RCalculator: TStreamRec = (
     ObjType: 10041;
     VmtLink: Ofs (TypeOf (TCalculator)^);
     Load:    @TCalculator.Load;
     Store:   @TCalculator.Store
  );

PROCEDURE NuAdd(VAR s : String; const source : String);
PROCEDURE NuAdd1(VAR s : String; const let: char);
PROCEDURE NuAdd2(VAR s : String; const source : String;

procedure RegisterCalc;

implementation

const
    plus                = '+';
   minus             = '-';
   equals         = '=';
      cmCalcButton     = 100;
   equals13       = [equals, #13];

var
    R1,R2        : double;
    n            : integer;
   lin_calc,
   Ln            : string[80];



constructor TCalcDisplay.Init (var Bounds: TRect);
begin
   inherited Init (Bounds);
   Options:= Options or ofSelectable;
   EventMask:= evKeyDown + evBroadcast;
   Clear;
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 NuAdd;
var
    i,j    : word;
begin
    i:= byte(source[0]);
   j:= byte(s[0]);
   if i+j >= $FF then
       exit;
   move(source[1],s[succ(j)],i);
   inc(s[0],i)
   {Move(source[1], s[succ(length(s))], length(source));
   Inc(s[0], length(source))}
END;

procedure nuadd1;
begin
    {s + let}
   inc(s[0]);
    s[byte(s[0])]:= let
end;

procedure NuAdd2;
begin
    {s + source + let}
    if byte(source[0]) + byte(s[0]) >= $ff then
       exit;
   inc(s[0]);
   Move(source[1], s[byte(s[0])], byte(source[0]));
   Inc(s[0], byte(source[0]));
    s[byte(s[0])]:= let
END;

procedure TCalcDisplay.CalcKey (Key: Char);
var
      R        : Double;
   E,
     i,j,k    : integer;

procedure Error;
begin
   Status:= csError;
   Num1:= '0';
   Num2:= '0';
   Number:= 'Error';
   R1:= 0;
   R2:= 0;
   Sign:= blank
end;

procedure SetDisplay (R: Double);
var
  S: string[63];
begin
   Str (R:0:10, S);
   if  S[1] <> minus  then
        Sign:= blank
   else begin
      Delete (S, 1, 1);
      Sign:= minus
   end;
   if  byte(S[0]) > 79  then
      Error
      {15 + 1 + 10 then Error}
   else begin
      while  S[byte(S[0])] = '0'  do
            Dec (S[0]);
      if  S[byte(S[0])] = period  then
            Dec (S[0]);
      Number:= S
   end
end;

procedure GetDisplay (var R: Double);
begin
   Val (Sign + Number, R, E)
end;

procedure GetPriorDisplay (var R: Double);
begin
   Val (Num1, R, E)
end;

procedure CheckFirst;
begin
   if  Status = csFirst  then
   begin
      Status:= csValid;
       Num1:= '0';
      Num2:= '0';
      Number:= '0';
      Sign:= blank
   end
end;

begin
   Key:= UpCase (Key);
   if  (Status = csError) and not (Key in ['C',esc]) then
        Key:= blank;
   case  Key  of
      '0'..'9':
      begin
         CheckFirst;
         if  Number = '0'  then
                Number:= '';
         nuadd1(number,key);
         if  Num2 = '0'  then
                Num2:= '';
         nuadd1(Num2,key);

         if byte(lin_calc[0]) >= 72 then
             Nudelete(lin_calc,1,1);
         nuadd1(lin_calc,key)
      end;
      period:
      begin
         CheckFirst;
         if  Pos (period, Number) = 0  then
         begin
             nuadd1(number,period);
            nuadd1(num2,period);
            if byte(lin_calc[0]) >= 72 then
                delete(lin_calc,1,1);
            nuadd1(lin_calc,period)
         end
      end;
      #8:
      begin
         CheckFirst;
         dec(lin_calc[0]);
         if  byte(Number[0]) = 1  then
                Number:= '0'
         else
                Dec (Number[0])
      end;
      '_', #241: begin  {+-}
         if  Sign = blank  then
                Sign:= minus
         else
                Sign:= blank;
         if byte(lin_calc[0]) >= 72 then
             delete(lin_calc,1,1);
         i:= 0;
         k:= byte(lin_calc[0]);
         if k > 0 then
         for j:= 1 to k do
             if lin_calc[j] = blank then
                i:= j;
         NuInsert(sign,lin_calc,succ(i))
      end;
      plus, minus, star, slash, equals, '%', #13:
      begin
          if (key in [star,slash]) and not (Operator in [star,slash]) then
         begin
                Num1:= Sign + Num2;
             val(Num1,R1,E);
             if operator = minus then
                 R1:= -R1
         end;
         if byte(lin_calc[0]) >= 72 then
             delete(lin_calc,1,1);
         if not (key in equals13) then
             nuadd1(lin_calc,key);
         if  Status = csValid  then
         begin
            Status:= csFirst;
            GetDisplay (R);
            if Operator in [star,slash] then
               val(Num2,R2,E);
            if  Key = '%'  then
            begin
               case  Operator  of
                  plus, minus: R:= Operand * R / 100;
                  star, slash: R:= R / 100
               end;
               R2:= R2/100
            end;
            if Operator in [plus,minus] then
                PriorOp:= Operand;
            case  Operator  of
               plus    : SetDisplay (Operand + R);
               minus    : SetDisplay (Operand - R);
               star    : begin
                   R1:= R1*R2;
                        SetDisplay (PriorOp + R1)
                        {(Operand * R);}
               end;
               slash    :
                  if  R2 = 0  then
                            Error
                  else begin
                      R1:= R1/R2;
                            SetDisplay(PriorOp + R1)
                  end
                                {(Operand / R);}
            end
         end;
         if key in equals13 then
         begin
             PriorOp:= 0;
             ln:= equals;
                if sign = minus then
                    nuadd1(ln,minus);
                nuadd2(ln,number,blank);
            n:= byte(ln[0]);
            if byte(lin_calc[0]) + n >= 72 then
                delete(lin_calc,1, (byte(lin_calc[0])+n-80));
            nuadd(lin_calc,ln)
         end;
         Operator:= Key;
         GetDisplay (Operand)
      end;
      'C', esc: Clear;
      else begin
         if byte(lin_calc[0]) >= 72 then
             delete(lin_calc,1,1);
         nuadd1(lin_calc,blank);
         PriorOp:= 0;
         number:= '0'
      end
   end;
   DrawView
end;

procedure TCalcDisplay.Clear;
begin
   Status:= csFirst;
   Num1:= '0';
   Num2:= '0';
   Number:= '0';
   R1:= 0;
   R2:= 0;
   lin_calc:= '';
   PriorOp:= 0;
   Sign:= blank;
   Operator:= equals
end;

procedure TCalcDisplay.Draw;
var
  Color: Byte;
  I: Integer;
  B: TDrawBuffer;
begin
     i:= byte(lin_calc[0]);
   if i >= 72 then
       delete(lin_calc,1,i-72);
   Color:= GetColor (1);
   I:= Size.X - byte(lin_calc[0]) - 2;
   MoveChar (B, blank, Color, Size.X);
   {MoveChar (B[I], Sign, Color, 1);}
   MoveStr (B[I + 1], lin_calc, 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);
begin
   inherited HandleEvent (Event);
   case  Event.What  of
      evKeyDown:
      begin
         CalcKey (Event.CharCode);
         ClearEvent (Event)
      end;
      evBroadcast:
         if  Event.Command = cmCalcButton  then
         begin
            CalcKey (PButton (Event.InfoPtr)^.Title^[1]);
            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
  KeyChar: array[0..19] of Char = 'C'#27'%'#241'789/456*123-0.=+';
var
  I: Integer;
  P: PView;
  R: TRect;
begin
   lin_calc:= blank;
   R.Assign (0, 3, 79, 18);
   inherited Init (R, 'Calculator');
   Options:= Options or ofFirstClick;
   for  I:= 0 to 19  do
   begin
      R.A.X:= (I mod 4) * 5 + 2;
      R.A.Y:= (I div 4) * 2 + 4;
      R.B.X:= R.A.X + 5;
      R.B.Y:= R.A.Y + 2;
      P:= New (PButton, Init (R, KeyChar[I], cmCalcButton,
         bfNormal + bfBroadcast));
      P^.Options:= P^.Options and not ofSelectable;
      Insert (P);
   end;
   R.Assign (1, 2, 78, 3);
   Insert (New (PCalcDisplay, Init (R)));
end;

procedure RegisterCalc;
begin
   RegisterType (RCalcDisplay);
   RegisterType (RCalculator)
end;

end.