[Pythianproject-cvsmail] CVS: Prototypes/GUISystem vglEdits.pas,NONE,1.1

[Kamil K. <kkr...@us...>]

Update of /cvsroot/pythianproject/Prototypes/GUISystem
In directory slayer.i.sourceforge.net:/tmp/cvs-serv5898

Added Files:
	vglEdits.pas 
Log Message:
new unit 

--- NEW FILE ---
unit vglEdits;

{ VGL Standard Editing Controls (C) 2000- The Pythian Project

  - Kamil Krauspe (kr...@gm...)

}

// KEY MIKE: see at my GetQByC function: you should implement this into your
// QuadTextUnit - higher performance, though
// In the edit component may be many bugs.
// TODO: horiz. scrollbar.
//       Clipboard???
//       optimize...
//       mouse selecting

interface

uses
  Windows, GLCanvas, Classes, vglClasses, Graphics, QuadTextUnit;

type
  TvglEditNavigationAction =
    (venaPrev, venaNext, venaPrevLine, venaNextLine, venaTop, venaBottom,
     venaPageUp, venaPageDown);

  TvglNavigateEvent = procedure(var Action: TvglEditNavigationAction; var KBM: TVGLKBModifiers) of object;
  TvglWriteEvent = procedure(var Code: Char; var KBM: TVGLKBModifiers) of object;

  TvglSingleLineEdit = class(TvglComponent) // single line editor
  private
    FCharWidths: array of Integer;
    procedure RecalculateWidths; // recalculate FCharWidths
    procedure InsertChar(C: Char; Pos: Integer);
    procedure InsertString(S: string; Pos: Integer);
    procedure DeleteChar(Pos: Integer);
    procedure DeleteBlock(Start, Length: Integer);
    procedure ClearText;
    procedure InitializeWidths;
    procedure FinalizeWidths;
  protected
    FGLText: TGLText;
    FSelStart: Integer;
    FSelLength: Integer;
    FSelStarted: Integer;
    FTranslucency: Single;
    FSelTranslulency: Single;
    FFontName: string;
    FText: string;
    FSelTextColor: TColor;
    FFontColor: TColor;
    FSelColor: TColor;
    FColor: TColor;
    FCurX: Integer;
    FOnNavigate: TvglNavigateEvent;
    FOnWrite: TvglWriteEvent;

    FTimerDiff, FTimerLast: Cardinal;
    FTimerCursorVis: Boolean;
    FTimerInterval: Cardinal;
    function GetSelEnd: Integer;
    procedure SetSelEnd(const Value: Integer);
    procedure SetOnNavigate(const Value: TvglNavigateEvent);
    procedure SetOnWrite(const Value: TvglWriteEvent);
    procedure SetCurX(const Value: Integer);
    procedure SetColor(const Value: TColor);
    procedure SetFontColor(const Value: TColor);
    procedure SetFontName(const Value: string);
    procedure SetSelColor(const Value: TColor);
    procedure SetSelLength(const Value: Integer);
    procedure SetSelStart(const Value: Integer);
    procedure SetSelTextColor(const Value: TColor);
    procedure SetSelTranslulency(const Value: Single);
    procedure SetText(const Value: string);
    procedure SetTranslucency(const Value: Single);

    function GetComponentType: string; override;

    procedure DrawBackround(where: TRect); // background and selection background
    procedure DrawText(where: TRect);  // the text with selected text
    procedure DrawCursor(where: TRect);

    procedure DoOnMouseDown(button, x, y: Integer); override;
    procedure DoOnMouseUp(button, x, y: Integer); override;
    procedure DoOnGlobalMouseMove(x, y: Integer); override;
    procedure DoOnKeyDown(KeyCode, KeyDown: Integer; KBMOD: TVGLKBModifiers; var AllowHP: Boolean); override;
    function GetWidthBy(Start, Pos: Integer): Integer; // getwidth of text from Start to Pos inclusive

    procedure TriggerNavigation(Action: TvglEditNavigationAction; KBM: TVGLKBModifiers);
    procedure TriggerWritting(Code: Char; KBM: TVGLKBModifiers);

    procedure DoOnNavigate(var Action: TvglEditNavigationAction; var KBM: TVGLKBModifiers); virtual;
    procedure DoOnWrite(var Code: Char; var KBM: TVGLKBModifiers); virtual;

    procedure Update(const ElapsedTime: Cardinal); override;
    procedure UpdateCursor;
  public
    constructor Create(aName:string; AOwner:TvglComponent);
    destructor Destroy; override ;
    procedure DrawSelf(where:TRect); override;
    function GetPosAt(X, Y: Integer; where: TRect): Integer;
    procedure SetDefHeight;
  published
    property SelStart: Integer read FSelStart write SetSelStart;
    property SelLength: Integer read FSelLength write SetSelLength;
    property SelEnd: Integer read GetSelEnd write SetSelEnd;
    property FontName: string read FFontName write SetFontName;
    property CurX: Integer read FCurX write SetCurX;
    // this supports only quadtext - GLF not support by now!
    property FontColor: TColor read FFontColor write SetFontColor;
    property Color: TColor read FColor write SetColor;
    property Translucency: Single read FTranslucency write SetTranslucency;
    property SelTranslulency: Single read FSelTranslulency write SetSelTranslulency;
    property SelColor: TColor read FSelColor write SetSelColor;
    property SelTextColor: TColor read FSelTextColor write SetSelTextColor;
    property Text: string read FText write SetText;
    property OnNavigate: TvglNavigateEvent read FOnNavigate write SetOnNavigate;
    property OnWrite: TvglWriteEvent read FOnWrite write SetOnWrite;
  end;

implementation

uses
  SysUtils, Math;

const
  vgl_CursorBlinkRate = 500;

function GetQByC(C: Char): Integer;
var
  i: Integer;
begin
  Result := -1;
  if (C >= 'a') and (C <= 'z') then
    Result := Ord(C) - 27
  else if (C >= 'A') and (C <= 'Z') then
    Result := Ord(C) - 64
  else if (C >= '1') and (C <= '9') then
    Result := Ord(C) + 4
  else
    for i := 62 to NUMCHARS do
      if TEX_CHARS[i] = C then
      begin
        Result := i;
        Exit;
      end;
end;

{ TvglSingleLineEdit }

procedure TvglSingleLineEdit.ClearText;
begin
  FText := '';
  SetLength(FCharWidths, 0);
  FSelStart := 1;
  FSelLength := 1;
end;

constructor TvglSingleLineEdit.Create(aName: string;
  AOwner: TvglComponent);
begin
  inherited Create(aName, aOwner);
  FFocusable := True;
  FAcceptsChildren := False;
  FGLText := TGLText.Create('Arial');
  FGLText.SetColor(FFontColor);
  InitializeWidths;
  FColor := clWhite;
  FTranslucency := 0;
  FSelStart := 1;
  FSelLength := 0;
  FSelTranslulency := 0;
  FSelColor := clNavy;
  FSelTextColor := clWhite;
  FFontColor := clBlack;
  FTimerInterval := vgl_CursorBlinkRate;
  FOnNavigate := nil;
  FOnWrite := nil;
  Text := 'SingleLineEdit';
  FCurX := 1;
  FTimerCursorVis := True;
end;

procedure TvglSingleLineEdit.DeleteBlock(Start, Length: Integer);
begin
  if (Start < 0) or (Start > System.Length(FText)) then
    Exit;
  System.Delete(FText, Start, Length);
  RecalculateWidths; // in future this will be changed to optimize the code
    // ...and will use Move(...) to reorganize the FCharWidths faster
end;

procedure TvglSingleLineEdit.DeleteChar(Pos: Integer);
begin
  DeleteBlock(Pos, 1);
end;

destructor TvglSingleLineEdit.Destroy;
begin
  FGLText := nil;
  FinalizeWidths;
  inherited;
end;

procedure TvglSingleLineEdit.DoOnGlobalMouseMove(x, y: Integer);
begin
  inherited;

end;

procedure TvglSingleLineEdit.DoOnKeyDown(KeyCode, KeyDown: Integer;
  KBMOD: TVGLKBModifiers; var AllowHP: Boolean);
var
  i: Integer; C: Char;
begin
  inherited;
  if (vkmAlt in KBMOD) or (vkmControl in KBMOD) then
    Exit;
  AllowHP := False;
  case KeyCode of
    VK_UP: TriggerNavigation(venaPrevLine, KBMOD);
    VK_DOWN: TriggerNavigation(venaNextLine, KBMOD);
    VK_LEFT: TriggerNavigation(venaPrev, KBMOD);
    VK_RIGHT: TriggerNavigation(venaNext, KBMOD);
    VK_HOME: TriggerNavigation(venaTop, KBMOD);
    VK_END: TriggerNavigation(venaBottom, KBMOD);
    VK_BACK:
      begin
        if SelLength = 0 then
        begin
          DeleteChar(CurX - 1);
          CurX := CurX - 1;
        end
        else begin
          DeleteBlock(SelStart, SelLength);
          SelLength := 0;
          CurX := SelStart;
        end;
        Text := FText;
      end;
    VK_DELETE:
      begin
        if SelLength = 0 then
          DeleteChar(CurX)
        else begin
          DeleteBlock(SelStart, SelLength);
          SelLength := 0;
          CurX := SelStart;
        end;
        Text := FText;
        UpdateCursor;
      end;
  else
    if (KeyCode >= VK_NUMPAD0) and (KeyCode <= VK_NUMPAD9) then
      KeyCode := KeyCode - 48;
    C := Chr(KeyCode);
    if not (vkmShift in KBMOD) then
      C := LowerCase(C)[1];
    i := GetQByC(C);
    if (i > 0) or (KeyCode = VK_SPACE) then
      TriggerWritting(C, KBMOD)
    else
      AllowHP := True;
  end;

end;

procedure TvglSingleLineEdit.DoOnMouseDown(button, x, y: Integer);
begin
  inherited;
  CurX := GetPosAt(X, Y, ScreenBounds);
end;

procedure TvglSingleLineEdit.DoOnMouseUp(button, x, y: Integer);
begin
  inherited;

end;

procedure TvglSingleLineEdit.DoOnNavigate(
  var Action: TvglEditNavigationAction; var KBM: TVGLKBModifiers);
begin
  if Assigned(FOnNavigate) then
    FOnNavigate(Action, KBM);
end;

procedure TvglSingleLineEdit.DoOnWrite(var Code: Char;
  var KBM: TVGLKBModifiers);
begin
  if Assigned(FOnWrite) then
    FOnWrite(Code, KBM);
end;

procedure TvglSingleLineEdit.DrawBackround(where: TRect);
begin
  FCanvas.CurrentColor := FColor;
  FCanvas.FillAlpha := 1 - FTranslucency;
  FCanvas.Solid := True;
  FCanvas.Rectangle(where.Left, where.Top, where.Right, where.Bottom);
  FCanvas.Solid := False;
  FCanvas.FillAlpha := 1;
  FCanvas.Rectangle(where.Left, where.Top, where.Right, where.Bottom);
end;

procedure TvglSingleLineEdit.DrawCursor(where: TRect);
var
  i, h: Integer;
begin
  FCanvas.SetClipping(where);
  i := GetWidthBy(1, CurX - 1);
  h := FGLText.QT.GridSquareHeight;
  FCanvas.CurrentRed := 1 - FCanvas.CurrentRed;
  FCanvas.CurrentGreen := 1 - FCanvas.CurrentGreen;
  FCanvas.CurrentBlue := 1 - FCanvas.CurrentBlue;
  FCanvas.FillAlpha := 1;
  FCanvas.Solid := True;
  FCanvas.Rectangle(where.Left + i, where.Top, where.Left + i + 1, where.Top + h);
  FCanvas.CancelClipping;
end;

procedure TvglSingleLineEdit.DrawSelf(where: TRect);
begin
  inherited;
  DrawBackround(where);
  DrawText(where);
  if Focused and FTimerCursorVis then DrawCursor(where);
end;

procedure TvglSingleLineEdit.DrawText(where: TRect);
var
  w: Integer;
  l1, l2, l3: Integer; // widths of blocks: before sel., selection, after selection
  r1: TRect;
begin
  w := FGLText.QT.GridSquareHeight;
  r1 := where;
  r1.Bottom := r1.Top + W;
  if FSelLength > 0 then
  begin
    l1 := 0;
    l3 := 0;
    if FSelStart > 1 then
      l1 := GetWidthBy(1, FSelStart - 1);
    l2 := GetWidthBy(FSelStart, FSelStart + FSelLength - 1);
    if FSelStart + FSelLength <= System.Length(FText) then
      l3 := GetWidthBy(FSelStart + FSelLength, System.Length(FText));
    if l1 > 0 then
    begin
      FGLText.SetColor(FFontColor);
      r1.Right := r1.Left + l1;
      r1 := FitRectToRect(r1, where);
      FCanvas.SetClipping(r1);
      FCanvas.DrawText(where.Left, where.Top, FGLText);
      FCanvas.CancelClipping;
      r1.Left := r1.Right;
    end;
    FGLText.SetColor(FSelTextColor);
    r1.Right := r1.Left + l2;
    r1 := FitRectToRect(r1, where);
    FCanvas.SetClipping(r1);
    FCanvas.FillAlpha := 1 - FSelTranslulency;
    FCanvas.CurrentColor := FSelColor;
    FCanvas.Solid := True;
    FCanvas.Rectangle(r1.Left, r1.Top, r1.Right, r1.Bottom);
    FCanvas.DrawText(where.Left, where.Top, FGLText);
    FCanvas.CancelClipping;
    r1.Left := r1.Right;
    if l3 > 0 then
    begin
      FGLText.SetColor(FFontColor);
      r1.Right := r1.Left + l3;
      r1 := FitRectToRect(r1, where);
      FCanvas.SetClipping(r1);
      FCanvas.DrawText(where.Left, where.Top, FGLText);
      FCanvas.CancelClipping;
    end;
  end
  else begin
    FGLText.SetColor(FFontColor);
    FCanvas.SetClipping(where);
    FCanvas.DrawText(where.Left, where.Top, FGLText);
    FCanvas.CancelClipping;
  end
end;

procedure TvglSingleLineEdit.FinalizeWidths;
begin
  ClearText;
end;

function TvglSingleLineEdit.GetComponentType: string;
begin
  Result := 'SingleLineEdit';
end;

function TvglSingleLineEdit.GetPosAt(X, Y: Integer; where: TRect): Integer;
var
  Cnt, a, i: Integer;
begin
  if not PointInRect(where, X, Y) then
    Exit;
  a := where.Left;
  Cnt := System.Length(FCharWidths);
  Result := 0;
  for i := 0 to Cnt - 1 do
  begin
    a := a + FCharWidths[i] + FGLText.QT.GridCharSpacing;
    if X < a then
    begin
      Result := i + 1;
      Exit;
    end;
  end;
  Result := Cnt + 1;
end;

function TvglSingleLineEdit.GetSelEnd: Integer;
begin
  Result := SelStart + SelLength;
end;

function TvglSingleLineEdit.GetWidthBy(Start, Pos: Integer): Integer;
var
  i, j: Integer; s: string;
begin
  if (Start <= 0) or (Pos <= 0) then
  begin
    Result := 0;
    Exit;
  end;
  Start := Math.Max(Math.Min(Start, System.Length(FCharWidths)), 1);
  Pos := Math.Max(Math.Min(Pos, System.Length(FCharWidths)), 1);
 { j := 0;
  for i := Start to Pos do
    Inc(j, FCharWidths[i - 1] + FGLText.QT.GridCharSpacing);
  Result := j;                                              }
  j := Pos - Start + 1;
  s := Copy(FText, Start, j);
  Result := qtGetStringWidth(FGLText.QT, s);
end;

procedure TvglSingleLineEdit.InitializeWidths;
begin
  SetLength(FCharWidths, 0);
  FText := '';
  FSelLength := 0;
  FSelStart := 0;
end;

procedure TvglSingleLineEdit.InsertChar(C: Char; Pos: Integer);
begin
  InsertString(C, Pos);
end;

procedure TvglSingleLineEdit.InsertString(S: string; Pos: Integer);
begin
  if (Pos < 0) then
    Exit;

  if Pos > Length(FText) then
    FText := FText + S
  else
    System.Insert(S, FText, Pos);
  RecalculateWidths;
end;

procedure TvglSingleLineEdit.RecalculateWidths;
var
  i, j, k: Integer;
begin
  j := Length(FText);
  if j = 0 then
    Exit;

  SetLength(FCharWidths, j);
  for i := 0 to j - 1 do
  begin
    k := GetQByC(FText[i + 1]);
    if k = -1 then
      k := FGLText.QT.SpaceWidth
    else
      k := FGLText.QT.TexWidths[k];
    FCharWidths[i] := k;
  end;
end;

procedure TvglSingleLineEdit.SetColor(const Value: TColor);
begin
  FColor := Value;
end;

procedure TvglSingleLineEdit.SetCurX(const Value: Integer);
begin
  FCurX := Value;
  UpdateCursor;
end;

procedure TvglSingleLineEdit.SetDefHeight;
begin
  Height := FGLText.QT.GridSquareHeight + 1;
end;

procedure TvglSingleLineEdit.SetFontColor(const Value: TColor);
begin
  FFontColor := Value;
end;

procedure TvglSingleLineEdit.SetFontName(const Value: string);
begin
  FFontName := Value;
  FGLText.FontName := FFontName;
  RecalculateWidths;
end;

procedure TvglSingleLineEdit.SetOnNavigate(const Value: TvglNavigateEvent);
begin
  FOnNavigate := Value;
end;

procedure TvglSingleLineEdit.SetOnWrite(const Value: TvglWriteEvent);
begin
  FOnWrite := Value;
end;

procedure TvglSingleLineEdit.SetSelColor(const Value: TColor);
begin
  FSelColor := Value;
end;

procedure TvglSingleLineEdit.SetSelEnd(const Value: Integer);
var
  i: Integer;
begin
  i := Value - SelStart;
  SelLength := i;
  if i < 0 then
    SelStart := Value;
end;

procedure TvglSingleLineEdit.SetSelLength(const Value: Integer);
begin
  FSelLength := Value;
end;

procedure TvglSingleLineEdit.SetSelStart(const Value: Integer);
begin
  FSelStart := Max(Value, 1);
end;

procedure TvglSingleLineEdit.SetSelTextColor(const Value: TColor);
begin
  FSelTextColor := Value;
end;

procedure TvglSingleLineEdit.SetSelTranslulency(const Value: Single);
begin
  FSelTranslulency := Value;
end;

procedure TvglSingleLineEdit.SetText(const Value: string);
begin
  SelLength := 0;
  SelStart := 1;
  FText := Value;
  FGLText.Text := Text;
  RecalculateWidths;
end;

procedure TvglSingleLineEdit.SetTranslucency(const Value: Single);
begin
  FTranslucency := Value;
end;

procedure TvglSingleLineEdit.TriggerNavigation(
  Action: TvglEditNavigationAction; KBM: TVGLKBModifiers);
var
  Sel: Boolean;
  i, j: Integer;
  OldSelStart, OldSelEnd, OldCurX, ASelEnd: Integer;
begin
  DoOnNavigate(Action, KBM);
  Sel := vkmShift in KBM;

  if not Sel then
  begin
    SelStart := CurX;
    SelLength := 0;
  end;

  OldSelStart := SelStart;
  OldSelEnd := OldSelStart + SelLength;
  OldCurX := CurX;

  case Action of
    venaPrev: CurX := CurX - 1;
    venaNext: CurX := CurX + 1;
    venaPrevLine: CurX := CurX - 1;
    venaNextLine: CurX := CurX + 1;
    venaTop: CurX := 1;
    venaBottom: CurX := System.Length(FText) + 1;
  end;
  if Sel then
  begin
    i := CurX - OldCurX; // indicates direction
    if SelLength = 0 then
    begin
      FSelStarted := OldCurX; // anchor starting selection point
      SelStart := OldCurX;
    end;
    ASelEnd := SelEnd;
    if i = 1 then
    begin
      if (CurX > FSelStarted) and (FSelStarted = SelStart) then
        SelEnd := SelEnd + 1
      else begin
        SelStart := SelStart + 1;
        SelEnd := ASelEnd;
      end;
    end
    else if i = -1 then
    begin
      if (CurX < FSelStarted) and (FSelStarted >= SelStart) then
      begin
        SelStart := SelStart - 1;
        SelEnd := ASelEnd;
      end
      else begin
        SelLength := SelLength - 1;
      end;
    end
    else if CurX = System.Length(FText) + 1 then // END
    begin
      SelStart := FSelStarted;
      SelEnd := CurX;
    end
    else if CurX = 1 then // HOME
    begin
      SelStart := 1;
      SelEnd := FSelStarted;
    end;
  end;
end;

procedure TvglSingleLineEdit.TriggerWritting(Code: Char;
  KBM: TVGLKBModifiers);
begin
  DoOnWrite(Code, KBM);
  if FSelLength > 0 then
  begin
    DeleteBlock(FSelStart, FSelLength);
    FSelLength := 0;
    CurX := FSelStart;
  end;
  InsertChar(Code, CurX);
  CurX := CurX + 1;
  Text := FText;
end;

procedure TvglSingleLineEdit.Update(const ElapsedTime: Cardinal);
begin
  inherited;
  FTimerDiff := ElapsedTime - FTimerLast;
  if FTimerDiff >= FTimerInterval then
  begin
    FTimerLast := ElapsedTime;
    FTimerCursorVis := not FTimerCursorVis;
  end;
end;


procedure TvglSingleLineEdit.UpdateCursor;
begin
  FCurX := Max(Min(FCurX, System.Length(FText) + 1), 1);
  if SelLength = 0 then
    SelStart := FCurX;
end;

end.