ExceptionViewClass.pas

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