path: root/src/gui/fpg_editcombo.pas

{
    fpGUI  -  Free Pascal GUI Toolkit

    Copyright (C) 2006 - 2008 See the file AUTHORS.txt, included in this
    distribution, for details of the copyright.

    See the file COPYING.modifiedLGPL, included in this distribution,
    for details about redistributing fpGUI.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

    Description:
      Defines a edit ComboBox control with auto-complete feature.
}

unit fpg_editcombo;

{$mode objfpc}{$H+}

{.$Define DEBUG}

{
    ***********************************************************
    **********   This is still under development!   ***********
    ***********************************************************

    It needs lots of testing and debugging.
}


{ TODO: Needs a lot of refactoring to get rid of code duplication. }

{
This is an example of what we can aim for:
You need a mono font to see the correct layout.


               TfpgBaseComboBox
              _________|______________
             |                        |
   TfpgBaseStaticCombo        TfpgBaseEditCombo
       ______|_________               |
      |                |         TfpgEditCombo
      |                |
 TfpgComboBox   TfpgBaseColorCombo
                       |
                 TfpgColorComboBox
}

interface

uses
  Classes,
  SysUtils,
  fpg_base,
  fpg_main,
  fpg_widget,
  fpg_popupwindow,
  fpg_combobox;

type
  TAllowNew = (anNo, anYes, anAsk);


  { TfpgBaseEditCombo }

  TfpgBaseEditCombo = class(TfpgBaseComboBox)
  private
    FAutoCompletion: Boolean;
    FAllowNew: TAllowNew;
    FText: string;
    FSelectedItem: integer;
    FMaxLength: integer;
    FNewItem: boolean;
    procedure   SetAllowNew(const AValue: TAllowNew);
    procedure   InternalBtnClick(Sender: TObject);
    procedure   InternalListBoxSelect(Sender: TObject);
    procedure   InternalListBoxKeyPress(Sender: TObject; var keycode: word; var shiftstate: TShiftState;
                var consumed: Boolean);
  protected
    FMargin: integer;
    FDropDown: TfpgPopupWindow;
    FDrawOffset: integer;
    FSelStart: integer;
    FSelOffset: integer;
    FCursorPos: integer;
    procedure   DoDropDown; override;
    function    GetText: string; virtual;
    function    HasText: boolean; virtual;
    procedure   SetText(const AValue: string); virtual;
    procedure   HandleResize(AWidth, AHeight: TfpgCoord); override;
    procedure   HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override;
    procedure   HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: Boolean); override;
    procedure   HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override;
    procedure   HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override;
    procedure   HandlePaint; override;
    property    AutoCompletion: Boolean read FAutocompletion write FAutoCompletion default False;
    property    AllowNew: TAllowNew read FAllowNew write SetAllowNew default anNo;
    property    BackgroundColor default clBoxColor;
    property    TextColor default clText1;
    property    Text: string read GetText write SetText;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure   Clear;
    procedure   SetFocus;
    procedure   Update;
    property    NewText: boolean read FNewItem;
  end;


  TfpgEditCombo = class(TfpgBaseEditCombo)
  published
    property    AutoCompletion;
    property    AllowNew;
    property    BackgroundColor;
    property    DropDownCount;
    property    FocusItem;
    property    FontDesc;
    property    Height;
    property    Items;
    property    Text;
    property    TextColor;
    property    Width;
    property    OnChange;
    property    OnCloseUp;
    property    OnDropDown;
    property    OnEnter;
    property    OnExit;
    property    OnKeyPress;
  end;


function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False;
      ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo;


implementation

uses
  fpg_stringutils,
  fpg_constants,
  fpg_listbox,
  fpg_dialogs;

var
  OriginalFocusRoot: TfpgWidget;

type
  { This is the class representing the dropdown window of the combo box. }
  TDropDownWindow = class(TfpgPopupWindow)
  private
    FCallerWidget: TfpgWidget;
    ListBox:    TfpgListBox;
  protected
    procedure   HandlePaint; override;
    procedure   HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: Boolean); override;
    procedure   HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override;
    procedure   HandleShow; override;
    procedure   HandleHide; override;
  public
    constructor Create(AOwner: TComponent); override;
    property    CallerWidget: TfpgWidget read FCallerWidget write FCallerWidget;
  end;


{ TDropDownWindow }

procedure TDropDownWindow.HandlePaint;
begin
  Canvas.BeginDraw;
//  inherited HandlePaint;
  Canvas.Clear(clWhite);
  Canvas.EndDraw;
end;

procedure TDropDownWindow.HandleKeyChar(var AText: TfpgChar;
  var shiftstate: TShiftState; var consumed: Boolean);
begin
  if TfpgEditCombo(FCallerWidget).FAutoCompletion then
    TfpgEditCombo(FCallerWidget).HandleKeyChar(AText,shiftstate,consumed);
end;

procedure TDropDownWindow.HandleKeyPress(var keycode: word;
  var shiftstate: TShiftState; var consumed: boolean);
begin
  if TfpgEditCombo(FCallerWidget).FAutoCompletion then
  begin
    TfpgEditCombo(FCallerWidget).HandleKeyPress(keycode,shiftstate,consumed);
//    consumed:= True;
  end
  else
  begin
    inherited HandleKeyPress(keycode, shiftstate, consumed);
    if keycode = keyEscape then
    begin
      consumed := True;
      Close;
    end;
  end;
end;

procedure TDropDownWindow.HandleShow;
begin
  ListBox.SetPosition(0, 0, Width, Height);
  inherited HandleShow;
  ActiveWidget := ListBox;
end;

procedure TDropDownWindow.HandleHide;
begin
  // HandleHide also gets called in TfpgWidget.Destroy so we need a few
  // if Assigned() tests here. This should be improved on.
//  if Assigned(FocusRootWidget) then
//    FocusRootWidget.ReleaseMouse;  // for internal ListBox

  if Assigned(CallerWidget) then
    CallerWidget.SetFocus;
  inherited HandleHide;
end;

constructor TDropDownWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ListBox := TfpgListBox.Create(self);
  ListBox.PopupFrame := True;
end;

function CreateEditCombo(AOwner: TComponent; x, y, w: TfpgCoord; AList:TStringList; ACompletion: boolean = False;
      ANew: TAllowNew = anNo; h: TfpgCoord = 0): TfpgEditCombo;
begin
  Result           := TfpgEditCombo.Create(AOwner);
  Result.Left      := x;
  Result.Top       := y;
  Result.Width     := w;
  Result.Focusable := True;
  Result.AutoCompletion := ACompletion;
  Result.AllowNew       := ANew;
  if h < TfpgEditCombo(Result).Font.Height + 6 then
    Result.Height:= TfpgEditCombo(Result).Font.Height + 6
  else
    Result.Height:= h;

  if Assigned(AList) then
    Result.Items.Assign(AList);
end;

{ TfpgBaseEditCombo }

procedure TfpgBaseEditCombo.SetAllowNew(const AValue: TAllowNew);
begin
  if FAllowNew <> AValue then
    FAllowNew := AValue;
end;

function TfpgBaseEditCombo.GetText: string;
begin
  if FAutoCompletion then
    Result := FText
  else
    if (FocusItem >= 0) and (FocusItem <= FItems.Count-1) then
      Result := FItems.Strings[FocusItem]
    else
      Result := '';
end;

function TfpgBaseEditCombo.HasText: boolean;
begin
  Result := FFocusItem >= 0;
end;

procedure TfpgBaseEditCombo.DoDropDown;
var
  ddw: TDropDownWindow;
  rowcount, i: integer;
  r: TfpgRect;
begin
  if (not Assigned(FDropDown)) or (not FDropDown.HasHandle) then
  begin
    FreeAndNil(FDropDown);
    OriginalFocusRoot := FocusRootWidget;
    FDropDown := TDropDownWindow.Create(nil);
    ddw := TDropDownWindow(FDropDown);
    ddw.Width := Width;
    ddw.CallerWidget := self;
    ddw.ListBox.OnSelect := @InternalListBoxSelect;
    ddw.ListBox.OnKeyPress := @InternalListBoxKeyPress;

    // Assign combobox text items to internal listbox
    if FAutoCompletion then
    begin
      for i := 0 to FItems.Count-1 do
        if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then
          ddw.ListBox.Items.Add(FItems.Strings[i]);
    end
    else
      ddw.ListBox.Items.Assign(FItems);

    // adjust the height of the dropdown
    rowcount := ddw.ListBox.Items.Count;
    if rowcount > DropDownCount then
      rowcount := DropDownCount;
    if rowcount < 1 then
      rowcount := 1;
    ddw.Height := (ddw.ListBox.RowHeight * rowcount) + 4;
    ddw.ListBox.Height := ddw.Height;   // needed in follow focus, otherwise, the default value (80) is used

    // set default focusitem
    ddw.ListBox.FocusItem := FFocusItem;

    ddw.DontCloseWidget := self;  // now we can control when the popup window closes
    r := GetDropDownPos(Parent, self, ddw);
    ddw.Height := r.Height;

    if (FItems.Count > 0) then
      DoOnDropDown;
    ddw.OnClose := @InternalOnClose;

    ddw.ShowAt(Parent, r.Left, r.Top);
  end
  else
  begin
    FBtnPressed := False;
    ddw := TDropDownWindow(FDropDown);
    ddw.Close;
    FreeAndNil(FDropDown);
  end;
end;

procedure TfpgBaseEditCombo.InternalBtnClick(Sender: TObject);
begin
  DoDropDown;
end;

procedure TfpgBaseEditCombo.InternalListBoxSelect(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to Items.Count-1 do
  begin
    if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then
    begin
      FocusItem := i;
      FSelectedItem:= i;
      FText:= Items[i];
      Break;
    end;
  end;
  FDropDown.Close;
  //Repaint will check if Handle is created
  Repaint;
end;

procedure TfpgBaseEditCombo.InternalListBoxKeyPress(Sender: TObject; var keycode: word;
          var shiftstate: TShiftState; var consumed: Boolean);
var
  i: Integer;
begin
  if ((keycode = keyUp) or (keycode = keyDown)) and (TDropDownWindow(FDropDown).ListBox.FocusItem > -1) then
    for i := 0 to Items.Count-1 do
    begin
      if Items[i]= TDropDownWindow(FDropDown).ListBox.Items[TDropDownWindow(FDropDown).ListBox.FocusItem] then
      begin
        FSelectedItem:= i;
        Break;
      end;
    end;

  //Repaint will check if Handle is created
  Repaint;
end;

procedure TfpgBaseEditCombo.SetText(const AValue: string);
var
  i: integer;
begin
  if AValue = '' then
  begin
    FText:= '';
    FocusItem := -1;  // nothing selected
  end
  else
  begin
    for i := 0 to Items.Count-1 do
    begin
      if SameText(UTF8Copy(Items.Strings[i], 1, UTF8Length(AVAlue)), AValue) then
      begin
        FocusItem := i;
        FText:= AValue;
        Repaint;
        Exit; //==>
      end;
    end;
    // if we get here, we didn't find a match
    FocusItem := -1;
  end;
end;

procedure TfpgBaseEditCombo.HandleResize(AWidth, AHeight: TfpgCoord);
begin
  inherited HandleResize(AWidth, AHeight);
  if FSizeIsDirty then
    CalculateInternalButtonRect;
end;

procedure TfpgBaseEditCombo.HandleKeyChar(var AText: TfpgChar;
    var shiftstate: TShiftState; var consumed: Boolean);
var
  s: TfpgChar;
  prevval: string;
  i: integer;
begin
  prevval   := FText;
  s         := AText;
  consumed  := False;
  if FText = '' then
    FNewItem := False;

  // Handle only printable characters
  // Note: This is now UTF-8 compliant!
  if Enabled and (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then
  begin
    if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then
    begin
      UTF8Insert(s, FText, FCursorPos + UTF8Length(s));
      Inc(FCursorPos);
      FSelStart := FCursorPos;
      if Assigned(FDropDown) then
        FDropDown.Close;
      FSelectedItem := -1;
      for i := 0 to FItems.Count-1 do
        if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then
        begin
          FSelectedItem:= i;
          DoDropDown;
          Break;
        end;
      if FSelectedItem = -1 then
        if FAllowNew = anNo then
        begin
          UTF8Delete(FText, FCursorPos, 1);
          Dec(FCursorPos);
          FSelStart := FCursorPos;
          for i := 0 to FItems.Count-1 do
            if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then
            begin
              FSelectedItem:= i;
              DoDropDown;
              Break;
            end;
        end
        else
          FNewItem:= True;
    end;
    consumed := True;
  end;

  if prevval <> FText then
    DoOnChange;

  if consumed then
    RePaint;
//  else
    inherited HandleKeyChar(AText, shiftstate, consumed);
end;

procedure TfpgBaseEditCombo.HandleKeyPress(var keycode: word;
    var shiftstate: TShiftState; var consumed: boolean);
var
  hasChanged: boolean;
  i: integer;
begin
  hasChanged := False;

  if not Enabled then
    consumed := False
  else
  begin
    consumed := True;

    case keycode of
      keyBackSpace:
          begin
            if FCursorPos > 0 then
            begin
              UTF8Delete(FText, FCursorPos, 1);
              Dec(FCursorPos);
              FSelStart := FCursorPos;
            if Assigned(FDropDown) then
              FDropDown.Close;
            FSelectedItem := -1;
            for i := 0 to FItems.Count-1 do
              if SameText(UTF8Copy(FItems.Strings[i], 1, UTF8Length(FText)), FText) then
              begin
                FSelectedItem:= i;
                if FNewItem then
                  FNewItem:= False;
                DoDropDown;
                Break;
              end;
            hasChanged := True;
            end;
          end;
      keyDelete:
          begin
            if FAllowNew <> anNo then
            begin
              FocusItem := -1;
              FSelectedItem := -1;
              FNewItem:= True;
              hasChanged := True;
            end;
          end;

      keyReturn,
      keyPEnter:
          begin
            if FSelectedItem > -1 then
              SetText(Items[FSelectedItem])
            else
              FocusItem:= -1;
            if FNewItem then
              case FAllowNew of
                anYes:
                  begin
                    FItems.Add(FText);
                    FocusItem := Pred(FItems.Count);
                  end;
                anAsk:
                  begin
                    if TfpgMessageDialog.Question(rsNewItemDetected, Format(rsAddNewItem, [FText])) = mbYes then
                    begin
                      FItems.Add(FText);
                      FFocusItem := Pred(FItems.Count);
                    end
                    else
                    begin
                      FNewItem:= False;
                      FFocusItem := -1;
                      FText:= '';
                    end;  { if/else }
                    Parent.ActivateWindow;
                  end;
                end;
            hasChanged := True;
            if Assigned(FDropDown) then
              FDropDown.Close;
          end;
      else
      begin
        Consumed := False;
      end;
    end;
  end;

  if Consumed then
  begin
    FSelStart  := FCursorPos;
    FSelOffset := 0;
  end;

  if consumed and hasChanged then
    RePaint;

  if hasChanged then
    DoOnChange;
  inherited HandleKeyPress(keycode, shiftstate, consumed);
end;

procedure TfpgBaseEditCombo.HandleLMouseDown(x, y: integer;
    shiftstate: TShiftState);
begin
  inherited HandleLMouseDown(x, y, shiftstate);
  // button state is down only if user clicked in the button rectangle.
  FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y));
  if not FAutoCompletion then
  begin
    PaintInternalButton;
    DoDropDown;
  end
  else if FBtnPressed then
    begin
      PaintInternalButton;
      DoDropDown;
    end;
end;

procedure TfpgBaseEditCombo.HandleLMouseUp(x, y: integer;
    shiftstate: TShiftState);
begin
  inherited HandleLMouseUp(x, y, shiftstate);
  FBtnPressed := False;
  PaintInternalButton;
end;

procedure TfpgBaseEditCombo.HandlePaint;
var
  r: TfpgRect;
  tw, tw2, st, len: integer;
  Texte: string;

  // paint selection rectangle
  procedure DrawSelection;
  var
    lcolor: TfpgColor;
  begin
    if Focused then
    begin
      lcolor := clSelection;
      Canvas.SetTextColor(clSelectionText);
    end
    else
    begin
      lcolor := clInactiveSel;
      Canvas.SetTextColor(clText1);
    end;

    len := FSelOffset;
    st  := FSelStart;
    if len < 0 then
    begin
      st  := st + len;
      len := -len;
    end;
    tw  := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st));
    tw2 := Font.TextWidth(UTF8Copy(Items[FSelectedItem], 1, st + len));

    // XOR on Anti-aliased text doesn't look to good. Lets try standard
    // Blue & White like what was doen in TfpgEdit.
{   Canvas.SetColor(lcolor);
    Canvas.FillRectangle(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height);
    r.SetRect(-FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height);
    Canvas.AddClipRect(r);
    Canvas.SetTextColor(clWhite);
    fpgStyle.DrawString(Canvas, -FDrawOffset + FMargin, 3, Text, Enabled);
    Canvas.ClearClipRect;
}
    Canvas.XORFillRectangle(fpgColorToRGB(lcolor) xor $FFFFFF,
      -FDrawOffset + FMargin + tw, 3, tw2 - tw, Font.Height);
  end;

begin
  Canvas.BeginDraw;
//  inherited HandlePaint;
  Canvas.ClearClipRect;
  r.SetRect(0, 0, Width, Height);
  Canvas.DrawControlFrame(r);

  // internal background rectangle (without frame)
  InflateRect(r, -2, -2);
  Canvas.SetClipRect(r);

  if Enabled then
    Canvas.SetColor(FBackgroundColor)
  else
    Canvas.SetColor(clWindowBackground);

  Canvas.FillRectangle(r);

  // paint the fake dropdown button
  PaintInternalButton;

  Dec(r.Width, FInternalBtnRect.Width);
  Canvas.SetClipRect(r);
  Canvas.SetFont(Font);

  if not AutoCompletion then
    if Focused then
    begin
      Canvas.SetColor(clSelection);
      Canvas.SetTextColor(clSelectionText);
      InflateRect(r, -1, -1);
    end
    else
    begin
      if Enabled then
        Canvas.SetColor(FBackgroundColor)
      else
        Canvas.SetColor(clWindowBackground);
      Canvas.SetTextColor(FTextColor);
    end
  else
  begin
    if Enabled then
      Canvas.SetColor(FBackgroundColor)
    else
      Canvas.SetColor(clWindowBackground);
    Canvas.SetTextColor(FTextColor);
  end;
  Canvas.FillRectangle(r);

  // Draw select item's text
  if not AutoCompletion then
  begin
    if HasText then
      fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled);
  end
  else
  begin
    if HasText then
    begin
      FSelOffset := 0;
      fpgStyle.DrawString(Canvas, FMargin+1, FMargin, Text, Enabled);
    end
    else
    begin
      Texte := Text;
      if Texte <> '' then
        if FSelectedItem > -1 then
        begin
          FSelOffset := Font.TextWidth(UTF8Copy(Items[FSelectedItem], UTF8Length(FText) + 1,
            UTF8Length(Items[FSelectedItem]) - UTF8Length(FText)));
          fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText + UTF8Copy(Items[FSelectedItem],
            UTF8Length(FText) + 1, UTF8Length(Items[FSelectedItem]) - UTF8Length(FText)), Enabled);
        end
        else
        begin
          FSelOffset := 0;
          fpgStyle.DrawString(Canvas, FMargin+1, FMargin, FText, Enabled);
        end;
    end;

    if Focused then
    begin
      // drawing selection
      if FSelOffset <> 0 then
        DrawSelection;

      // drawing cursor
      FCursorPos:= UTF8Length(FText);
      tw := Font.TextWidth(UTF8Copy(FText, 1, FCursorPos));
      fpgCaret.SetCaret(Canvas, -FDrawOffset + FMargin + tw, 3, fpgCaret.Width, Font.Height);
    end
    else
      fpgCaret.UnSetCaret(Canvas);
  end;

  Canvas.EndDraw;
end;

constructor TfpgBaseEditCombo.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBackgroundColor  := clBoxColor;
  FTextColor        := Parent.TextColor;
  FWidth            := 120;
  FHeight           := Font.Height + 6;
  FMargin           := 3;
  FFocusable        := True;
  FAutocompletion   := False;
  FAllowNew         := anNo;

  FText             := '';
  FCursorPos        := UTF8Length(FText);
  FSelStart         := FCursorPos;
  FSelOffset        := 0;
  FDrawOffset       := 0;
  FSelectedItem     := -1;       // to allow typing if list is empty
  FNewItem          := False;

  CalculateInternalButtonRect;
end;

destructor TfpgBaseEditCombo.Destroy;
begin
  FDropDown.Free;
  inherited Destroy;
end;

procedure TfpgBaseEditCombo.Clear;
begin
  Text := '';
  Items.Clear;
end;

procedure TfpgBaseEditCombo.SetFocus;
var
  i: integer;
begin
  HandleSetFocus;
  if FText > '' then
    for i := 0 to Items.Count-1 do
      if SameText(UTF8Copy(Items.Strings[i], 1, UTF8Length(FText)), FText) then
      begin
        FSelectedItem := i;
        FNewItem := False;
        Exit; //==>
      end;
end;

procedure TfpgBaseEditCombo.Update;
begin
  FFocusItem := -1;
  Repaint;
end;

end.