lazarus-ccr/components/orpheus/ovccaret.pas

{*********************************************************}
{*                   OVCCARET.PAS 4.06                   *}
{*********************************************************}

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is TurboPower Orpheus                                    *}
{*                                                                            *}
{* The Initial Developer of the Original Code is TurboPower Software          *}
{*                                                                            *}
{* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002    *}
{* TurboPower Software Inc. All Rights Reserved.                              *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

{$I OVC.INC}

{$B-} {Short-circuit Boolean Evaluation}
{$I+} {Input/Output-Checking}
{$P+} {Open Parameters}
{$T-} {Typed @ Operator}
{.W-} {Windows Stack Frame}
{$X+} {Extended Syntax}

unit ovccaret;
  {-Caret handling class}

interface

uses
  {$IFNDEF LCL} Windows, {$ELSE} LclIntf, MyMisc, {$ENDIF} 
  Graphics, Classes, Controls, Forms;

type
  TOvcCaretShape = (                 {Predefined caret shapes..}
                    csBlock,         {..block over whole cell}
                    csHalfBlock,     {..block over bottom part of cell}
                    csVertLine,      {..vertical line to left of cell}
                    csHorzLine,      {..horizontal line on bottom of cell}
                    csCustom,        {..custom width/height}
                    csBitmap);       {..bitmap caret, custom width/height}

  TOvcCaretAlign = (                 {Alignment of caret in cell..}
                    caLeft,          {..left side, centered vertically}
                    caTop,           {..top side, centered horizontally}
                    caRight,         {..right side, centered vertically}
                    caBottom,        {..bottom side, centered horizontally}
                    caCenter);       {..centered vertically and horizontally}

type
  {Class defining a caret shape}
  TOvcCaret = class(TPersistent)
  {.Z+}
  protected
    {property fields}
    FAlign     : TOvcCaretAlign;      {Caret alignment in cell}
    FBitmap    : TBitmap;             {Bitmap for a bitmapped caret}
    FBitmapX   : Integer;             {Bitmap's hotspot X}
    FBitmapY   : Integer;             {Bitmap's hotspot Y}
    FBlinkTime : word;                {Blink time}
    FCaretHt   : Integer;             {Height: autosized for some shapes}
    FCaretWd   : Integer;             {Width: autosized for some shapes}
    FIsGray    : boolean;             {True if a 'gray' caret}
    FShape     : TOvcCaretShape;      {Shape}

    FOnChange  : TNotifyEvent;        {Owner's change notification}

    {internal fields}
    RefCount      : word;             {Reference count}

    {property access methods}
    procedure SetAlign(A : TOvcCaretAlign);
    procedure SetBitmap(BM : TBitMap);
    procedure SetBitmapX(X : Integer);
    procedure SetBitmapY(Y : Integer);
    procedure SetBlinkTime(BT : word);
    procedure SetCaretHeight(CH : Integer);
    procedure SetCaretWidth(CW : Integer);
    procedure SetIsGray(IG : boolean);
    procedure SetShape(S : TOvcCaretShape);

    {general methods}
    procedure NotifyChange;

  public
    {VCL methods}
    constructor Create;
    destructor Destroy; override;

    {other methods}
    procedure Register;
    procedure Deregister;

    {properties}
    property OnChange : TNotifyEvent
        read FOnChange
        write FOnChange;
  {.Z-}

  published
    {properties}
    property Bitmap : TBitmap
        read FBitmap write SetBitmap;
    property BitmapHotSpotX : Integer
        read FBitmapX write SetBitmapX
        default 0;
    property BitmapHotSpotY : Integer
        read FBitmapY write SetBitmapY
        default 0;
    property Shape : TOvcCaretShape
        read FShape write SetShape
        default csVertLine;
    property Align : TOvcCaretAlign
        read FAlign write SetAlign
        default caLeft;
    property BlinkTime : word
        read FBlinkTime write SetBlinkTime
        default 0;
    property CaretHeight : Integer
        read FCaretHt write SetCaretHeight
        default 10;
    property CaretWidth : Integer
        read FCaretWd write SetCaretWidth
        default 2;
    property IsGray : boolean
        read FIsGray write SetIsGray
        default False;
  end;

{.Z+}
type
  TOvcSingleCaret = class(TPersistent)
  {Class defining a Single caret}
  protected
    {property fields}
    FCaretType : TOvcCaret;           {Current caret type}
    FHeight    : Integer;             {Cell height}
    FLinked    : boolean;             {True if linked to owner}
    FPos       : TPoint;              {Position within owner}
    FVisible   : boolean;             {True if visible}
    FWidth     : Integer;             {Cell width}

    {other fields}
    OrigBlinkTime : word;             {Blink time before linking}
    Owner   : TWinControl;            {Owning control}
    XOffset : Integer;                {X Offset of caret in cell}
    YOffset : Integer;                {Y Offset of caret in cell}

    {property access methods}
    procedure SetCaretType(CT : TOvcCaret);
    procedure SetCellHeight(CH : Integer);
    procedure SetCellWidth(CW : Integer);
    procedure SetLinked(L : boolean);
    procedure SetPos(P : TPoint);
    procedure SetVisible(V : boolean);

    {general methods}
    procedure MakeShape;
    procedure Reinit;
    procedure ResetPos;

  public
    {VCL methods}
    constructor Create(AOwner : TWinControl);
    destructor Destroy; override;

    {general methods}
    procedure CaretTypeHasChanged(Sender : TObject);

    {properties}
    property CaretType : TOvcCaret
        read FCaretType
        write SetCaretType;

    property CellHeight : Integer
        read FHeight
        write SetCellHeight;

    property CellWidth : Integer
        read FWidth
        write SetCellWidth;

    property Linked : boolean
        read FLinked
        write SetLinked
        stored false;

    property Position : TPoint
        read FPos
        write SetPos;

    property Visible : boolean
        read FVisible
        write SetVisible;
  end;

type
  TOvcCaretPair = class(TOvcSingleCaret)
  {Class defining a pair of carets, one each for insert/overwrite modes}
  protected
    {property fields}
    FInsMode  : boolean;
    FInsCaretType : TOvcCaret;
    FOvrCaretType : TOvcCaret;

    {property access methods}
    procedure SetInsMode(IM : boolean);
    procedure SetInsCaretType(ICT : TOvcCaret);
    procedure SetOvrCaretType(OCT : TOvcCaret);

  public
    {VCL methods}
    constructor Create(AOwner : TWinControl);
    destructor Destroy; override;

    {properties}
    property InsertMode : boolean
        read FInsMode
        write SetInsMode;

    property InsCaretType : TOvcCaret
        read FInsCaretType
        write SetInsCaretType;

    property OvrCaretType : TOvcCaret
        read FOvrCaretType
        write SetOvrCaretType;
  end;
{.Z-}


implementation



{---TOvcCaret----------------------------------------------------}
constructor TOvcCaret.Create;
  begin
    inherited Create;

    FShape     := csVertLine;
    FAlign     := caLeft;
    FBlinkTime := 0;
    FIsGray    := False;
    FBitMap    := TBitMap.Create;
    FCaretHt   := 10;
    FCaretWd   := 2;
  end;
{--------}
destructor TOvcCaret.Destroy;
  begin
    FBitMap.Free;
    inherited Destroy;
  end;
{--------}
procedure TOvcCaret.Deregister;
  begin
    {decrement the reference count, if no one references us
     any more, kill ourselves}
    dec(RefCount);
    if (RefCount = 0) then
      Free;
  end;
{--------}
procedure TOvcCaret.NotifyChange;
  begin
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
{--------}
procedure TOvcCaret.Register;
  begin
    inc(RefCount);
  end;
{--------}
procedure TOvcCaret.SetAlign(A : TOvcCaretAlign);
  begin
    if (A <> FAlign) then
      begin
        FAlign := A;
        NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetBitmap(BM : TBitmap);
  begin
    if not Assigned(BM) then
      Exit;
    FBitMap.Assign(BM);
    NotifyChange;
  end;
{--------}
procedure TOvcCaret.SetBitmapX(X : Integer);
  begin
    if (X <> FBitMapX) then
      begin
        FBitMapX := X;
        if (Shape = csBitMap) then
          NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetBitmapY(Y : Integer);
  begin
    if (Y <> FBitMapY) then
      begin
        FBitMapY := Y;
        if (Shape = csBitMap) then
          NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetBlinkTime(BT : word);
  begin
    if (BT <> FBlinkTime) then
      begin
        FBlinkTime := BT;
        NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetCaretHeight(CH : Integer);
  begin
    if (CH <> FCaretHt) and (CH > 0) then
      begin
        FCaretHt := CH;
        NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetCaretWidth(CW : Integer);
  begin
    if (CW <> FCaretWd) and (CW > 0) then
      begin
        FCaretWd := CW;
        NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetIsGray(IG : boolean);
  begin
    if (IG <> FIsGray) then
      begin
        FIsGray := IG;
        NotifyChange;
      end;
  end;
{--------}
procedure TOvcCaret.SetShape(S : TOvcCaretShape);
  begin
    if (S <> FShape) then
      begin
        FShape := S;
        case FShape of
          csBlock:
            FAlign := caLeft;
          csVertLine :
            begin
              FAlign := caLeft;
              FCaretWd := 2;
            end;
          csHalfBlock:
            FAlign := caBottom;
          csHorzLine :
            begin
              FAlign := caBottom;
              FCaretHt := 2;
            end;
          csBitmap :
            begin
              FCaretHt := FBitMap.Height;
              FCaretWd := FBitMap.Width;
            end;
        end;{case}
        NotifyChange;
      end;
  end;
{--------------------------------------------------------------------}


{---TOvcSingleCaret--------------------------------------------------}
constructor TOvcSingleCaret.Create(AOwner : TWinControl);
  begin
    inherited Create;
    Owner := AOwner;

    FHeight := 10;
    FWidth := 10;

    {make our default caret type}
    FCaretType := TOvcCaret.Create;
    FCaretType.Register;
    Reinit;
  end;
{--------}
destructor TOvcSingleCaret.Destroy;
  begin
    Visible := false;
    Linked := false;
    FCaretType.Deregister;

    inherited Destroy;
  end;
{--------}
procedure TOvcSingleCaret.CaretTypeHasChanged(Sender : TObject);
  var
    WasLinked : boolean;
  begin
    {if something has changed about the caret, unlink from
     our owner, recalc our values, relink}
    WasLinked := Linked;
    Linked := false;
    Reinit;
    Linked := WasLinked;
  end;
{--------}
procedure TOvcSingleCaret.MakeShape;
  begin
    {don't bother if we aren't linked to anything or if we
     don't have a caret type}
    if (not Linked) or (not Assigned(FCaretType)) then
      Exit;

    {create the caret, and if necessary show it}
    with FCaretType do
      if (Shape = csBitmap) then
           CreateCaret(Owner.Handle, Bitmap.Handle, 0, 0)
      else CreateCaret(Owner.Handle, ord(IsGray), CaretWidth, CaretHeight);
    if Visible then
      ShowCaret(Owner.Handle);
  end;
{--------}
procedure TOvcSingleCaret.Reinit;
  var
    NewXOfs : Integer;
    NewYOfs : Integer;
  begin
    {don't bother if we don't have a caret type}
    if (not Assigned(FCaretType)) then
      Exit;

    {inits}
    NewXOfs := 0;
    NewYOfs := 0;

    with FCaretType do
      begin
        {stop recursion}
        OnChange := nil;

        {recalc the caret type's height and width}
        if (Shape <> csBitmap) and (Shape <> csCustom) then
          begin
            case Shape of
              csBlock    :
                begin
                  CaretHeight := FHeight;
                  CaretWidth := FWidth;
                end;
              csHalfBlock:
                begin
                  CaretHeight := FHeight div 2;
                  CaretWidth := FWidth;
                end;
              csVertLine : CaretHeight := FHeight;
              csHorzLine : CaretWidth := FWidth;
            end;{case}
          end;

        {allow changes to percolate through again}
        OnChange := CaretTypeHasChanged;

        {recalc the X and Y offsets}
        case Align of
          caLeft   : begin
                       NewXOfs := 0;
                       NewYOfs := (FHeight - CaretHeight) div 2;
                     end;
          caTop    : begin
                       NewXOfs := (FWidth - CaretWidth) div 2;
                       NewYOfs := 0;
                     end;
          caRight  : begin
                       NewXOfs := FWidth - CaretWidth;
                       NewYOfs := (FHeight - CaretHeight) div 2;;
                     end;
          caBottom : begin
                       NewXOfs := (FWidth - CaretWidth) div 2;
                       NewYOfs := FHeight - CaretHeight;
                     end;
          caCenter : begin
                       NewXOfs := (FWidth - CaretWidth) div 2;
                       NewYOfs := (FHeight - CaretHeight) div 2;
                     end;
        end;{case}
        if (Shape = csBitMap) then
          begin
            dec(NewXOfs, BitMapHotSpotX);
            dec(NewYOfs, BitMapHotSpotY);
          end;
        if (NewXOfs <> XOffset) or (NewYOfs <> YOffset) then
          begin
            XOffset := NewXOfs;
            YOffset := NewYOfs;
            if Linked then
              ResetPos;
          end;
      end;
  end;
{--------}
procedure TOvcSingleCaret.ResetPos;
  var
    NewX, NewY : Integer;
  begin
    if (FPos.X = MaxInt) then
         NewX := MaxInt
    else NewX := FPos.X + XOffset;
    if (FPos.Y = MaxInt) then
         NewY := MaxInt
    else NewY := FPos.Y + YOffset;
    SetCaretPos(NewX, NewY);
  end;
{--------}
procedure TOvcSingleCaret.SetCaretType(CT : TOvcCaret);
  begin
    if (CT <> FCaretType) then
      begin
        FCaretType.Deregister;
        FCaretType := CT;
        FCaretType.Register;
        FCaretType.OnChange := CaretTypeHasChanged;
        CaretTypeHasChanged(Self);
      end;
  end;
{--------}
procedure TOvcSingleCaret.SetCellHeight(CH : Integer);
  begin
    if (CH <> FHeight) and (CH > 0) then
      begin
        FHeight := CH;
        CaretTypeHasChanged(Self);
      end;
  end;
{--------}
procedure TOvcSingleCaret.SetCellWidth(CW : Integer);
  begin
    if (CW <> FWidth) and (CW > 0) then
      begin
        FWidth := CW;
        CaretTypeHasChanged(Self);
      end;
  end;
{--------}
procedure TOvcSingleCaret.SetLinked(L : boolean);
  begin
    if (L <> FLinked) then
      begin
        FLinked := L;
        if Assigned(Owner) and Owner.HandleAllocated then
          if FLinked then
            begin
              OrigBlinkTime := GetCaretBlinkTime;
              MakeShape;
              ResetPos;
              if (OrigBlinkTime <> CaretType.BlinkTime) then
                if (CaretType.BlinkTime <> 0) then
                  SetCaretBlinkTime(CaretType.BlinkTime);
            end
          else
            begin
              SetCaretBlinkTime(OrigBlinkTime);
{$IFNDEF LCL}
              DestroyCaret;
{$ELSE}
              DestroyCaret(Owner.Handle);
{$ENDIF}
            end
        else
          FLinked := false;
      end;
  end;
{--------}
procedure TOvcSingleCaret.SetPos(P : TPoint);
  begin
    if (P.X < 0) then
      P.X := MaxInt;
    if (P.Y < 0) then
      P.Y := MaxInt;
    if (P.X <> FPos.X) or (P.Y <> FPos.Y) then
      begin
        FPos := P;
        if Linked then
          ResetPos;
      end;
  end;
{--------}
procedure TOvcSingleCaret.SetVisible(V : boolean);
  begin
    if (V <> FVisible) then
      begin
        FVisible := V;
        if Linked then
          if Owner.HandleAllocated then
            if FVisible then
              ShowCaret(Owner.Handle)
            else
              HideCaret(Owner.Handle);
      end;
  end;


{---TOvcCaretPair----------------------------------------------------}
constructor TOvcCaretPair.Create(AOwner : TWinControl);
  begin
    inherited Create(AOwner);

    FInsCaretType := TOvcCaret.Create;
    FInsCaretType.Register;

    FOvrCaretType := TOvcCaret.Create;
    FOvrCaretType.Register;
    FOvrCaretType.Shape := csBlock;

    FInsMode := True;

    if FInsMode then
      CaretType := FInsCaretType
    else
      CaretType := FOvrCaretType
  end;

destructor TOvcCaretPair.Destroy;
begin
  FInsCaretType.Deregister;
  FOvrCaretType.Deregister;

  inherited Destroy;
end;

procedure TOvcCaretPair.SetInsMode(IM : boolean);
  begin
    if (IM <> FInsMode) then
      begin
        FInsMode := IM;
        if FInsMode then
             CaretType := FInsCaretType
        else CaretType := FOvrCaretType;
      end;
  end;
{--------}
procedure TOvcCaretPair.SetInsCaretType(ICT : TOvcCaret);
  begin
    if (ICT <> FInsCaretType) then
      begin
        FInsCaretType.Deregister;
        FInsCaretType := ICT;
        FInsCaretType.Register;
        if InsertMode then
          CaretType := FInsCaretType;
      end;
  end;
{--------}
procedure TOvcCaretPair.SetOvrCaretType(OCT : TOvcCaret);
  begin
    if (OCT <> FOvrCaretType) then
      begin
        FOvrCaretType.Deregister;
        FOvrCaretType := OCT;
        FOvrCaretType.Register;
        if not InsertMode then
          CaretType := FOvrCaretType;
      end;
  end;
{--------------------------------------------------------------------}


end.