{************************************************}
{                                                }
{   WINDOWS CALCULATOR - nicked from example demos}
{                                                }
{************************************************}
{$I compflgs}
{ Simple four function calculator }

unit WinCalc;

{$B-}
{$R CALC.RES}

INTERFACE

uses WinTypes, WinProcs, Strings, OWindows, ODialogs;

const

	WinName : PChar = 'Kameleon Calculator';

{ Number of digits in calculator display }

	DisplayDigits = 15;

{ Control ID of display static text }

	id_Display = 400;

{ Color constants }

	rgb_Yellow = $0000FFFF;
	rgb_Blue   = $00FF0000;
	rgb_Red    = $000000FF;


type

{ Calculator state }

	TCalcState = (cs_First, cs_Valid, cs_Error);

{ Calculator dialog window object }

	PCalc = ^TCalc;
	TCalc = object(TDlgWindow)
		CalcStatus: TCalcState;
		Number: array[0..DisplayDigits] of Char;
		Negative: Boolean;
		Operator: Char;
		Operand: Real;
		BlueBrush: HBrush;
		constructor Init;
		destructor Done; virtual;
		function GetClassName: PChar; virtual;
		procedure GetWindowClass(var AWndClass: TWndClass); virtual;
		procedure WMControlColor(var Msg: TMessage);
			virtual wm_First + wm_CtlColor;
		procedure WMPaint(var Msg: TMessage);
			virtual wm_First + wm_Paint;
		procedure DefChildProc(var Msg: TMessage); virtual;
		procedure DefCommandProc(var Msg: TMessage); virtual;
		procedure FlashButton(Key: Char);
		procedure CalcKey(Key: Char);
		procedure Clear;
		procedure UpdateDisplay; virtual;
	end;

IMPLEMENTATION

uses wincrt, winapp, tasks, global;

{ Calculator constructor.  Create blue brush for calculator background,
	and do a clear command. }

constructor TCalc.Init;
begin
	write('TCalc.Init...');
	inherited Init(Application^.MainWindow, 'Kameleon Calculator');
	BlueBrush := CreateSolidBrush(rgb_Blue);
	Clear;
	writeln('done');
end;

{ Calculator destructor.  Dispose the background brush. }

destructor TCalc.Done;
begin
	write('TCalc.done...');
	DeleteObject(BlueBrush);
	inherited Done;
end;

{ We're changing the window class so we must supply a new class name. }

function TCalc.GetClassName: PChar;
begin
	write('TCalc.Getclassname...');
	GetClassName := WinName;
end;

{ The calculator has its own icon which is installed here. }

procedure TCalc.GetWindowClass(var AWndClass: TWndClass);
begin
	write('TCalc.getwindowclass...');
	inherited GetWindowClass(AWndClass);
	AWndClass.hIcon := LoadIcon(HInstance, WinName);
end;

{ Colorize the calculator.  Allows background to show through corners of
	buttons, uses yellow text on black background in the display, and sets
	the dialog background to blue. }

procedure TCalc.WMControlColor(var Msg: TMessage);
begin
	write('TCalc.wmgetcontrolcolor...');
	case Msg.LParamHi of
		ctlColor_Btn:
			Msg.Result := GetStockObject(null_Brush);
		ctlColor_Static:
			begin
				SetTextColor(Msg.WParam, rgb_Yellow);
				SetBkMode(Msg.WParam, transparent);
				Msg.Result := GetStockObject(black_Brush);
			end;
		ctlcolor_Dlg:
			begin
				SetBkMode(Msg.WParam, Transparent);
				Msg.Result := BlueBrush;
			end;
	else
		DefWndProc(Msg);
	end;
end;

{ Even dialogs can have their background's painted on.  This creates
	a red ellipse over the blue background. }

procedure TCalc.WMPaint(var Msg: TMessage);
var
	OldBrush: HBrush;
	OldPen: HPen;
	R: TRect;
	PS: TPaintStruct;
begin
	write('TCalc.wmpaint...');
	BeginPaint(HWindow, PS);
	OldBrush := SelectObject(PS.hdc, CreateSolidBrush(rgb_Red));
	OldPen := SelectObject(PS.hdc, GetStockObject(null_Pen));
	GetClientRect(HWindow, R);
	R.bottom := R.right;
	OffsetRect(R, -R.right div 4, -R.right div 4);
	Ellipse(PS.hdc, R.left, R.top, R.right, R.bottom);
	SelectObject(PS.hdc, OldPen);
	DeleteObject(SelectObject(PS.hdc, OldBrush));
	EndPaint(HWindow, PS);
end;

{ Flash a button with the value of Key.  Looks exactly like a
	click of the button with the mouse. }

procedure TCalc.FlashButton(Key: Char);
var
	Button: HWnd;
	Delay: Word;
begin
	write('TCalc.flashbutton...');
	if Key = #13 then Key := '=';
	Button := GetDlgItem(HWindow, Integer(UpCase(Key)));
	if Button <> 0 then
	begin
		SendMessage(Button, bm_SetState, 1, 0);
		for Delay := 1 to 30000 do;
		SendMessage(Button, bm_SetState, 0, 0);
	end;
end;

{ Rather then handle each button individually with child ID
	response methods, it is possible to handle them all at
	once with the default child procedure. }

procedure TCalc.DefChildProc(var Msg: TMessage);
begin
	write('TCalc.defchildproc...');
	if (Msg.WParamHi = 0) and (Msg.LParamHi = bn_Clicked) then
		CalcKey(Char(Msg.WParamLo));
	inherited DefChildProc(Msg);
end;

{ Rather then handle each accelerator individually with
	command ID response methods, it is possible to handle them
	all at once with the default command procedure. }

procedure TCalc.DefCommandProc(var Msg: TMessage);
begin
	write('TCalc.defcommandproc...');
	if Msg.WParamHi = 0 then
	begin
		FlashButton(Char(Msg.WParamLo)); { flash button as if it were pushed }
		CalcKey(Char(Msg.WParamLo));
	end;
	inherited DefCommandProc(Msg);
end;

{ Set Display text to the current value. }

procedure TCalc.UpdateDisplay;
var
	S: array[0..DisplayDigits + 1] of Char;
begin
	write('TCalc.updatedisplay...');
	if Negative then StrCopy(S, '-') else S[0] := #0;
	SetWindowText(GetDlgItem(HWindow, id_Display), StrCat(S, Number));
end;

{ Clear the calculator. }

procedure TCalc.Clear;
begin
	write('TCalc.clear...');
	CalcStatus := cs_First;
	StrCopy(Number, '0');
	Negative := False;
	Operator := '=';
end;

{ Process calculator key. }

procedure TCalc.CalcKey(Key: Char);
var
	R: Real;

  procedure Error;
  begin
    CalcStatus := cs_Error;
    StrCopy(Number, 'Error');
    Negative := False;
  end;

  procedure SetDisplay(R: Real);
	var
		First, Last: PChar;
    S: array[0..63] of Char;
	begin
    Str(R: 0: 10, S);
    First := S;
		Negative := False;
    if S[0] = '-' then
    begin
      Inc(First);
      Negative := True;
    end;
		if StrLen(First) > DisplayDigits + 1 + 10 then Error else
		begin
			Last := StrEnd(First);
			while Last[Word(-1)] = '0' do Dec(Last);
      if Last[Word(-1)] = '.' then Dec(Last);
      StrLCopy(Number, First, Last - First);
		end;
	end;

	procedure GetDisplay(var R: Real);
  var
    E: Integer;
	begin
		Val(Number, R, E);
    if Negative then R := -R;
  end;

	procedure CheckFirst;
	begin
    if CalcStatus = cs_First then
    begin
      CalcStatus := cs_Valid;
      StrCopy(Number, '0');
      Negative := False;
    end;
  end;

  procedure InsertKey;
  var
		L: Integer;
	begin
		L := StrLen(Number);
		if L < DisplayDigits then
		begin
			Number[L] := Key;
			Number[L + 1] := #0;
		end;
	end;

begin
	write('TCalc.calckey...');
	Key := UpCase(Key);
	if (CalcStatus = cs_Error) and (Key <> 'C') then Key := ' ';
	case Key of
		'0'..'9':
			begin
				CheckFirst;
				if StrComp(Number, '0') = 0 then Number[0] := #0;
				InsertKey;
      end;
    '.':
      begin
				CheckFirst;
        if StrPos(Number, '.') = nil then InsertKey;
      end;
		#8:
      begin
        CheckFirst;
        if StrLen(Number) = 1 then StrCopy(Number, '0')
				else Number[StrLen(Number) - 1] := #0;
      end;
		'_':
			Negative := not Negative;
		'+', '-', '*', '/', '=', '%', #13:
      begin
        if CalcStatus = cs_Valid then
        begin
					CalcStatus := cs_First;
					GetDisplay(R);
          if Key = '%' then
            case Operator of
              '+', '-': R := Operand * R / 100;
              '*', '/': R := R / 100;
						end;
          case Operator of
						'+': SetDisplay(Operand + R);
						'-': SetDisplay(Operand - R);
            '*': SetDisplay(Operand * R);
            '/': if R = 0 then Error else SetDisplay(Operand / R);
          end;
        end;
        Operator := Key;
        GetDisplay(Operand);
      end;
    'C':
      Clear;
  end;
	UpdateDisplay;
end;

procedure DoCalculator; far;
var Calc : PCalc;
begin
	write('DoCalculator...');
	New(Calc, init);
	write('Executing');

	Application^.ExecDialog(Calc);
	writeln('...done');
end;


begin
	RegisterTask(DesktopTasks, cmCalculator, @DoCalculator);
end.
