StackViewClass.pas

   1 unit StackViewClass;
   2
   3 interface
   4
   5 uses
   6   ConstantsClass, FloatEditClass, FunctionsClass, HardwareClass, ResourcesClass,
   7   TagEditClass, TypesClass,
   8   Classes, Controls, Graphics, Grids, Menus, Types;
   9
  10 type
  11
  12   { TStackView }
  13
  14   TStackView = class(TStringGrid)
  15   private
  16     pChanges: array [0..2] of array [0..7] of Boolean;
  17     pColorTheme: TViewTheme;
  18     pFloatEdit: TFLoatEdit;
  19     pHardware: THardware;
  20     pOldOnState: TChangeEvent;
  21     pTagEdit: TTagEdit;
  22     function pGetChanges(ACol, ARow: Integer): Boolean; virtual;
  23     function pGetWidth: Integer; virtual;
  24     procedure pCustomDblClick(Sender: TObject); virtual;
  25     procedure pCustomDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); virtual;
  26     procedure pCustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
  27     procedure pCustomMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;
  28     procedure pDrawSingleCell(Canvas: TCanvas; ACol, ARow: Integer; Rect: TRect; Colors: TColors); virtual;
  29     procedure pOnSelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); virtual;
  30     procedure pOnState(Sender: TObject); virtual;
  31     procedure pSetChanges(ACol, ARow: Integer; Change: Boolean); virtual;
  32     procedure pSetColorTheme(ColorTheme: TViewTheme); virtual;
  33     procedure pSetHardware(Input: THardware); virtual;
  34     procedure pSetWidth(Width: Integer); virtual;
  35   public
  36     constructor CreateStackView(AOwner: TComponent; Hw: THardware); virtual;
  37     procedure ChangeStack(Line: Integer); virtual;
  38     procedure ChangeTag(Line: Integer); virtual;
  39     property Changes[ACol, ARow: Integer]: Boolean read pGetChanges write pSetChanges;
  40     property ColorTheme: TViewTheme read pColorTheme write pSetColorTheme;
  41     property FloatEdit: TFLoatEdit read pFloatEdit write pFloatEdit;
  42     property TagEdit: TTagEdit read pTagEdit write pTagEdit;
  43     property Hardware: THardware read pHardware write pSetHardware;
  44     property Width: Integer read pGetWidth write pSetWidth;
  45   end;
  46
  47 implementation
  48
  49 // ************************************************************************** //
  50 // *                       TStackView implementation                        * //
  51 // ************************************************************************** //
  52
  53   function TStackView.pGetChanges(ACol, ARow: Integer): Boolean;
  54   begin
  55     Result := False;
  56     if (ACol < 0) or (ACol > 2) or (ARow < 0) or (ARow > 7) then Exit;
  57     Result := pChanges[ACol, ARow];
  58   end;
  59
  60   function TStackView.pGetWidth: Integer;
  61   begin
  62     Result := TStringGrid(Self).Width;
  63   end;
  64
  65   procedure TStackView.pCustomDblClick(Sender: TObject);
  66   var
  67     lkey: Word;
  68   begin
  69     lkey := KEY_RETURN;
  70     pCustomKeyDown(Self, lkey, []);
  71   end;
  72
  73   procedure TStackView.pCustomDrawCell(Sender: TObject; ACol, ARow: Integer;
  74     Rect: TRect; State: TGridDrawState);
  75   begin
  76     if (gdSelected in State) then
  77       pDrawSingleCell(Canvas, ACol, ARow, Rect, ColorTheme.Line.Selected)
  78     else
  79       pDrawSingleCell(Canvas, ACol, ARow, Rect, ColorTheme.Line.None)
  80   end;
  81
  82   procedure TStackView.pCustomKeyDown(Sender: TObject; var Key: Word;
  83     Shift: TShiftState);
  84   var
  85     lselect: TGridCoord;
  86   begin
  87     lselect := Selection.TopLeft;
  88     case Key of
  89       KEY_RETURN, KEY_SPACE:
  90         case lselect.X of
  91           1: ChangeTag(lselect.Y);
  92           2: ChangeStack(lselect.Y);
  93         end;
  94     end;
  95   end;
  96
  97   procedure TStackView.pCustomMouseDown(Sender: TObject; Button: TMouseButton;
  98     Shift: TShiftState; X, Y: Integer);
  99   var
 100     lcol, lrow: Integer;
 101     lselect: TGridRect;
 102   begin
 103     MouseToCell(X, Y, lcol, lrow);
 104     if SelectCell(lcol, lrow) then
 105     {$IFDEF UNIX}
 106       SetColRow(1, 0);
 107     // Lazarus is really nice, by having incompatible calls :-(
 108     {$ELSE}
 109     begin
 110       lselect.Top := lrow;
 111       lselect.Bottom := lrow;
 112       lselect.Left := lcol;
 113       lselect.Right := lcol;
 114       Selection := lselect;
 115     end;
 116     {$ENDIF}
 117   end;
 118
 119   procedure TStackView.pDrawSingleCell(Canvas: TCanvas; ACol, ARow: Integer;
 120     Rect: TRect; Colors: TColors);
 121   var
 122     lsize: TSize;
 123     lx, ly: Integer;
 124   begin
 125     with Rect do
 126     begin
 127       Canvas.Brush.Color := Colors.BG;
 128       if Changes[ACol, ARow] then Canvas.Font.Color := ColorTheme.Change
 129       else Canvas.Font.Color := Colors.FG;
 130       lsize := Canvas.TextExtent(Cells[ACol, ARow]);
 131       lx := (Right - Left - lsize.cx) div 2 + Left;
 132       ly := (Bottom - Top - lsize.cy) div 2 + Top;
 133       Canvas.FillRect(Rect);
 134       Canvas.TextOut(lx, ly, Cells[ACol, ARow]);
 135     end;
 136   end;
 137
 138   procedure TStackView.pOnSelectCell(Sender: TObject; ACol, ARow: Integer;
 139     var CanSelect: Boolean);
 140   begin
 141     CanSelect := not(ACol = 0);
 142   end;
 143
 144   procedure TStackView.pOnState(Sender: TObject);
 145   var
 146     i: Integer;
 147   begin
 148     with Hardware.State.FPUState do
 149       for i := 0 to 7 do
 150       begin
 151         Changes[1, i] := not CompareStateTag(Hardware, i);
 152         Changes[2, i] := not CompareStateStack(Hardware, i);
 153         Changes[0, i] := Changes[1, i] or Changes[2, i];
 154         Cells[0, i] := DESC_STACKS[i];
 155         Cells[1, i] := DESC_TAG[GetTag(Hardware.State, i)];
 156         Cells[2, i] := CustomFloatToStr(@ST[i], SizeOf(ST[i]));
 157       end;
 158     Repaint;
 159     if not(@pOldOnState = nil) then pOldOnState(Sender);
 160   end;
 161
 162   procedure TStackView.pSetChanges(ACol, ARow: Integer; Change: Boolean);
 163   begin
 164     if (ACol < 0) or (ACol > 2) or (ARow < 0) or (ARow > 7) then Exit;
 165     pChanges[ACol, ARow] := Change;
 166   end;
 167
 168   procedure TStackView.pSetColorTheme(ColorTheme: TViewTheme);
 169   begin
 170     pColorTheme := ColorTheme;
 171     Color := ColorTheme.Line.None.BG;
 172   end;
 173
 174   procedure TStackView.pSetHardware(Input: THardware);
 175   begin
 176     pHardware := Input;
 177     if not(Input = nil) then
 178     begin
 179       pOldOnState := Input.OnState;
 180       Input.OnState := pOnState;
 181     end;
 182   end;
 183
 184   procedure TStackView.pSetWidth(Width: Integer);
 185   begin
 186     TStringGrid(Self).Width := Width;
 187     ColWidths[0] := Canvas.TextWidth(Cells[0, 0] + ' ');
 188     ColWidths[1] := Canvas.TextWidth(DESC_TAG[DESC_TAG_LONGEST] + ' ');
 189     ColWidths[2] := ClientWidth - ColWidths[1] - ColWidths[0];
 190   end;
 191
 192   constructor TStackView.CreateStackView(AOwner: TComponent; Hw: THardware);
 193   var
 194     lselect: TGridRect;
 195   begin
 196     inherited Create(AOwner);
 197     DoubleBuffered := True;
 198     ColorTheme := THEME_VIEW_DEFAULT;
 199     FixedCols := 0;
 200     FixedRows := 0;
 201     RowCount := 8;
 202     ColCount := 3;
 203     {$IFDEF UNIX}
 204     Options := [goRangeSelect, goThumbTracking];
 205     // Behavior of goRangeSelect differ in Lazarus :-(
 206     {$ELSE}
 207     Options := [goThumbTracking];
 208     {$ENDIF}
 209     DefaultDrawing := False;
 210     OnDrawCell := pCustomDrawCell;
 211     OnDblClick := pCustomDblClick;
 212     OnKeyDown := pCustomKeyDown;
 213     OnMouseDown := pCustomMouseDown;
 214     OnSelectCell := pOnSelectCell;
 215     Canvas.Font.Name := FONT_DEFAULT_NAME;
 216     Canvas.Font.Size := FONT_DEFAULT_SIZE;
 217     DefaultRowHeight := FONT_DEFAULT_HEIGHT;
 218     FloatEdit := TFLoatEdit.Create(AOwner);
 219     TagEdit := TTagEdit.Create(AOwner);
 220     PopupMenu := TPopupMenu.Create(Self);
 221     with PopupMenu do
 222     begin
 223       Items.Add(TMenuItem.Create(PopupMenu));
 224       with Items[Items.Count - 1] do
 225       begin
 226         Caption := FL_EDIT_MODIFY;
 227         OnClick := pCustomDblClick;
 228         Default := True;
 229       end;
 230     end;
 231     Hardware := Hw;
 232     pOnState(Self);
 233     {$IFDEF UNIX}
 234     SetColRow(1, 0);
 235     // Lazarus is really nice, by having incompatible calls :-(
 236     {$ELSE}
 237     lselect.Top := 0;
 238     lselect.Bottom := 0;
 239     lselect.Left := 1;
 240     lselect.Right := 1;
 241     Selection := lselect;
 242     {$ENDIF}
 243   end;
 244
 245   procedure TStackView.ChangeStack(Line: Integer);
 246   var
 247     lcheck: Boolean;
 248     lstate: THardwareState;
 249   begin
 250     lcheck := True;
 251     lstate := Hardware.State;
 252     FloatEdit.Caption := FL_EDIT_MODIFY + DESC_STACKS[Line];
 253     with lstate.FPUState do
 254       if FloatEdit.ShowBox(@ST[Line], SizeOf(ST[Line]), lcheck) then
 255       begin
 256         if lcheck then
 257           case FloatType(@ST[Line], SizeOf(ST[Line])) of
 258             -1: SetTag(lstate, Line, 2);
 259             0: SetTag(lstate, Line, 1);
 260             1: SetTag(lstate, Line, 0);
 261           end;
 262         Hardware.State := lstate;
 263       end;
 264   end;
 265
 266   procedure TStackView.ChangeTag(Line: Integer);
 267   var
 268     ltag: Integer;
 269     lstate: THardwareState;
 270   begin
 271     lstate := Hardware.State;
 272     TagEdit.Caption := FL_EDIT_MODIFY + DESC_STACKS[Line] + ' Tag';
 273     ltag := GetTag(lstate, Line);
 274     if TagEdit.ShowBox(ltag) then SetTag(lstate, Line, ltag);
 275     Hardware.State := lstate;
 276   end;
 277
 278 end.