{ *************************************************************************** }
{                                                                             }
{ EControl Syntax Editor SDK                                                  }
{                                                                             }
{ Copyright (c) 2004 - 2008 EControl Ltd., Zaharov Michael                    }
{     www.econtrol.ru                                                         }
{     support@econtrol.ru                                                     }
{                                                                             }
{ *************************************************************************** }
{$I ecSyntEdit.INC}

unit ecEmbObj;

interface

uses Windows, Classes, Controls, Graphics, ecSyntAnal, ecLists;

type
  TecEmbeddedObjects = class;

  TecEmbeddedObjectFlags = set of (efOpaque, efSizable, efControl);

  TecCustomEmbeddedObject = class
  private
    function GetIndex: integer;
  protected
    FPosition: integer;
    FHint: string;
    FFlags: TecEmbeddedObjectFlags;
    FOwner: TecEmbeddedObjects; // Assigned by the container
    function GetFlags: TecEmbeddedObjectFlags; virtual;
    function GetHint: string; virtual;
    function GetPosition: integer; virtual;
    procedure SetPosition(Value: integer); virtual;
    procedure SetFlags(const Value: TecEmbeddedObjectFlags); virtual;
    procedure SetHint(const Value: string); virtual;
    procedure SetOwner(AOwner: TecEmbeddedObjects); virtual;

    class function SupportFormat(Format: Word): Boolean; virtual;
    function LoadFromClipboardFormat(Format: Word): Boolean; virtual;
  public
    constructor Create; virtual;

    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromStream(Stream: TStream); virtual;

    procedure Draw(Target: TWinControl; Canvas: TCanvas; const R: TRect); virtual; abstract;
    function GetSize(Target: TWinControl; Canvas: TCanvas): TSize; virtual;
    procedure SetSize(Target: TWinControl; Canvas: TCanvas; Value: TSize); virtual;

    property Index: integer read GetIndex;
    property Owner: TecEmbeddedObjects read FOwner;

    property Flags: TecEmbeddedObjectFlags read GetFlags write SetFlags;
    property Hint: string read GetHint write SetHint;
    property Position: integer read GetPosition write SetPosition;
  end;

  TecEmbeddedObjectClass = class of TecCustomEmbeddedObject;

  TFormatRange = class(TRange)
  private
    FStyleIdx: integer;
  public
    constructor Create(AStartPos, AEndPos, AStyleIdx: integer);
    property StyleIdx: integer read FStyleIdx;
  end;

  TecEmbeddedObjects = class(TSyntTextSource, IecExternalFormatter, IecSyntMemoPlugIn2)
  private
    FList: TList;
    FInTextImageList: TImageList;
    FStyles: TStyleCache;
    FFormatRanges: TRangeList;
    FFormatEnabled: Boolean;
    FControlSite: TWinControl;
    FHasControls: Boolean;
    function GetCount: integer;
    function GetItem(Index: integer): TecCustomEmbeddedObject;
    function FindClassForFormat(Format: Word): TecEmbeddedObjectClass;
    function FindClassToPaste(var Format: Word): TecEmbeddedObjectClass;
    procedure SetInTextImageList(const Value: TImageList);

    function GetStyleList(CurPos: integer; List: TStyleEntries): integer;
    procedure AnalyzeToPos(APos: integer);
    procedure PackFormatting;
    procedure SetFormatEnabled(const Value: Boolean);
    procedure SetControlSite(const Value: TWinControl);
    procedure ScrollPosChanged; // IecSyntMemoPlugIn2
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ResetLineHeightAtPos(Pos: integer);
    procedure UpdateControls;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure AddClient(Client: TObject); override;
    procedure RemoveClient(Client: TObject); override;

    function CaretPosToStrPos(const p: TPoint): integer; override;
    function StrPosToCaretPos(p: integer): TPoint; override;
    function LineLength(Index: integer): integer; override;
    procedure TextChanged(Sender: TObject; Pos, Count, LineChange: integer); override;

    function PriorAt(Pos: integer; First: Boolean): Integer;
    function Add(const Obj: TecCustomEmbeddedObject): integer;
    procedure Delete(Index: integer);
    function Remove(const Obj: TecCustomEmbeddedObject): integer;
    function IndexOf(const Obj: TecCustomEmbeddedObject): integer;

    // Formatting
    procedure FormatRange(StartPos, EndPos: integer; Style: TSyntaxFormat);
    function RangeStyle(StartPos, EndPos: integer; var Style: TSyntaxFormat): Boolean;
    procedure ClearFormatting; overload;
    procedure ClearFormatting(StartPos, EndPos: integer); overload;
    procedure SaveFormatting(Stream: TStream); overload;
    procedure LoadFormatting(Stream: TStream); overload;
    procedure SaveFormatting(const FileName: string); overload;
    procedure LoadFormatting(const FileName: string); overload;
    function HasFormatting: Boolean;

    procedure ChangePosition(const Obj: TecCustomEmbeddedObject; NewPos: integer);
    function GetObjectsInRange(FromPos, ToPos: integer): TList;

    function CanPaste: Boolean;
    function Paste(Sender: TObject): Boolean;

    function ObjectsAtLine(Line: integer): TList;
    function ObjectAtCaret(cp: TPoint): integer;
    function ObjectCaretPos(Index: integer): TPoint;

    function InsertIcon(ImageIndex: integer; Position: integer): TecCustomEmbeddedObject;
    function InsertPicture(Graphic: TGraphic; Position: integer): TecCustomEmbeddedObject;
    function InsertControl(Control: TControl; Position: integer): TecCustomEmbeddedObject;

    property Count: integer read GetCount;
    property Items[Index: integer]: TecCustomEmbeddedObject read GetItem; default;
    property HasControls: Boolean read FHAsControls;
  published
    property ImageList: TImageList read FInTextImageList write SetInTextImageList;
    property FormatEnabled: Boolean read FFormatEnabled write SetFormatEnabled default True;
    property ControlSite: TWinControl read FControlSite write SetControlSite;
  end;

  TecEmbeddedImage = class(TecCustomEmbeddedObject)
  private
    FPicture: TPicture;
  protected
    class function SupportFormat(Format: Word): Boolean; override;
    function LoadFromClipboardFormat(Format: Word): Boolean; override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect); override;
    function GetSize(Target: TWinControl; Canvas: TCanvas): TSize; override;

    property Picture: TPicture read FPicture;
  end;

  TecEmbeddedImageIdx = class(TecCustomEmbeddedObject)
  private
    FImageIndex: integer;
    procedure SetImageIndex(const Value: integer);
  public
    constructor Create; override;
    procedure Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect); override;
    function GetSize(Target: TWinControl; Canvas: TCanvas): TSize; override;

    property ImageIndex: integer read FImageIndex write SetImageIndex;
  end;

  TecEmbeddedControl = class(TecCustomEmbeddedObject)
  private
    FControl: TControl;
  protected
    procedure SetOwner(AOwner: TecEmbeddedObjects); override;
  public
    constructor CreateCtrl(AControl: TControl);
    destructor Destroy; override;

    procedure Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect); override;
    function GetSize(Target: TWinControl; Canvas: TCanvas): TSize; override;

    property Control: TControl read FControl;
  end;

{ TecEmbeddedOLE = class(TecCustomEmbeddedObject)
  private
    FOLECtrl: TOleContainer;
  protected
    function GetDevSize: TSize; override;
    class function SupportFormat(Format: Word): Boolean; override;
    function LoadFromClipboardFormat(Format: Word): Boolean; override;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect); override;

    property OLEContainer: TOleContainer read FOLECtrl;
  end;}

var
  PixelPerInch: TPoint;

procedure RegisterEmbeddedClass(AClass: TecEmbeddedObjectClass);
procedure UnregisterEmbeddedClass(AClass: TecEmbeddedObjectClass);

implementation

uses SysUtils, Contnrs, Clipbrd, ecSyntMemo, {$IFNDEF EC_VCL5}Types,{$ENDIF} Math;

var
  FEmbeddedClasses: TList = nil;
  NullSize: TSize;

procedure RegisterEmbeddedClass(AClass: TecEmbeddedObjectClass);
begin
  if not Assigned(FEmbeddedClasses) then
    FEmbeddedClasses := TList.Create;
  if FEmbeddedClasses.IndexOf(TObject(AClass)) = -1 then
    FEmbeddedClasses.Add(TObject(AClass));
end;

procedure UnregisterEmbeddedClass(AClass: TecEmbeddedObjectClass);
begin
  if Assigned(FEmbeddedClasses) then
    FEmbeddedClasses.Remove(TObject(AClass));
end;

procedure Initialize;
var DC: HDC;
begin
  DC := GetDC(0);
  PixelPerInch.X := GetDeviceCaps(DC, LOGPIXELSX);
  PixelPerInch.Y := GetDeviceCaps(DC, LOGPIXELSY);
  ReleaseDC(0, DC);
end;

{ TecEmbeddedObjects }

constructor TecEmbeddedObjects.Create(AOwner: TComponent);
begin
  inherited;
  FList := TObjectList.Create;
  FFormatRanges := TRangeList.Create(False);
  FStyles := TStyleCache.Create;
  FFormatEnabled := True;
end;

destructor TecEmbeddedObjects.Destroy;
begin
  inherited;
  FreeAndNil(FFormatRanges);
  FreeAndNil(FList);
  FreeAndNil(FStyles);
end;

procedure TecEmbeddedObjects.Delete(Index: integer);
var wasCtl: Boolean;
    i: integer;
begin
  wasCtl := TObject(FList[Index]) is TecEmbeddedControl;
  FList.Delete(Index);
  if wasCtl then
    begin
      FHasControls := False;
      for i := 0 to FList.Count - 1 do
        if TObject(FList[i]) is TecEmbeddedControl then
          begin
            FHasControls := True;
            Exit;
          end;
    end;
end;

function TecEmbeddedObjects.GetCount: integer;
begin
  Result := FList.Count;
end;

function TecEmbeddedObjects.GetItem(Index: integer): TecCustomEmbeddedObject;
begin
  Result := TecCustomEmbeddedObject(FList[Index]);
end;

function TecEmbeddedObjects.Remove(const Obj: TecCustomEmbeddedObject): integer;
begin
  Result := FList.Remove(Obj);
end;

function TecEmbeddedObjects.IndexOf(const Obj: TecCustomEmbeddedObject): integer;
begin
  Result := FList.IndexOf(Obj);
end;

function ObjCmp(const List: TList; Index: integer; Key: TObject): integer;
begin
  Result := TecCustomEmbeddedObject(List[Index]).Position - integer(Key);
end;

function TecEmbeddedObjects.PriorAt(Pos: integer; First: Boolean): Integer;
begin
  QuickSearch(FList, ObjCmp, TObject(Pos), Result);
  if Result <> -1 then
    if First then
      while (Result > 0) and (Items[Result - 1].Position = Pos) do
        Dec(Result)
    else
      while (Result + 1 < FList.Count) and (Items[Result + 1].Position = Pos) do
        Inc(Result);
end;

function TecEmbeddedObjects.Add(const Obj: TecCustomEmbeddedObject): integer;
begin
  if Obj is TecEmbeddedControl then
    FHasControls := True;
  Result := PriorAt(Obj.Position, False);
  Inc(Result);
  if Result > FList.Count then
    Result := FList.Count;
  FList.Insert(Result, Obj);
  Obj.SetOwner(Self);
  ResetLineHeightAtPos(Obj.Position);
end;

procedure TecEmbeddedObjects.ChangePosition(const Obj: TecCustomEmbeddedObject;
  NewPos: integer);
var Idx: integer;
begin
  Idx := IndexOf(Obj);
  if Idx <> -1 then
    begin
      FList.Delete(Idx);
      Obj.Position := NewPos;
      Add(Obj);
    end;
end;

function TecEmbeddedObjects.GetObjectsInRange(FromPos, ToPos: integer): TList;
var idx: integer;
begin
  Result := nil;
  Idx := PriorAt(FromPos, True);
  if (Idx = -1) or (Items[Idx].Position < FromPos) then Inc(Idx);
  while (Idx < FList.Count) and (Items[Idx].Position <= ToPos) and
        (Items[Idx].Position >= FromPos) do
    begin
      if Result = nil then
        Result := TList.Create;
      Result.Add(Items[Idx]);
      Inc(Idx);
    end;
end;

function TecEmbeddedObjects.CanPaste: Boolean;
var Format: Word;
begin
  Result := FindClassToPaste(Format) <> nil;
end;

function TecEmbeddedObjects.Paste(Sender: TObject): Boolean;
var cls: TecEmbeddedObjectClass;
    obj: TecCustomEmbeddedObject;
    Format: Word;
begin
  cls := FindClassToPaste(Format);
  Result := Assigned(cls);
  if Result then
    begin
      obj := cls.Create;
      Clipboard.Open;
      try
        Result := obj.LoadFromClipboardFormat(Format);
      finally
        ClipBoard.Close;
      end;
      if Result then
        begin
          if Assigned(Sender) and (Sender is TCustomSyntaxMemo) then
            obj.Position := TCustomSyntaxMemo(Sender).CaretStrPos;
          Add(obj);
        end
      else
        obj.Free;
    end;
end;

function TecEmbeddedObjects.FindClassForFormat(
  Format: Word): TecEmbeddedObjectClass;
var i: integer;
begin
  if Assigned(FEmbeddedClasses) then
    for i := 0 to FEmbeddedClasses.Count - 1 do
      if TecEmbeddedObjectClass(FEmbeddedClasses[i]).SupportFormat(Format) then
        begin
          Result := TecEmbeddedObjectClass(FEmbeddedClasses[i]);
          Exit;
        end;
  Result := nil;
end;

function TecEmbeddedObjects.FindClassToPaste(var Format: Word): TecEmbeddedObjectClass;
begin
  Result := nil;
  try
    Clipboard.Open;
    try
      Format := EnumClipboardFormats(0);
      while Format <> 0 do
        begin
          Result := FindClassForFormat(Format);
          if Result <> nil then Exit
            else Format := EnumClipboardFormats(Format);
        end;
    finally
      Clipboard.Close;
    end;
  except
  end;
end;

procedure TecEmbeddedObjects.SetInTextImageList(const Value: TImageList);
begin
  if FInTextImageList = Value then Exit;
  FInTextImageList := Value;
end;

procedure TecEmbeddedObjects.Notification(AComponent: TComponent;
  Operation: TOperation);
var i: integer;
begin
  inherited;
  if Operation = opRemove then
    for i := Count - 1 downto 0 do
      if (Items[i] is TecEmbeddedControl) and
         (TecEmbeddedControl(Items[i]).FControl = AComponent) then
        begin
          TecEmbeddedControl(Items[i]).FControl := nil;
          Exit;
        end;
end;

function TecEmbeddedObjects.InsertControl(Control: TControl;
  Position: integer): TecCustomEmbeddedObject;
begin
  Result := TecEmbeddedControl.CreateCtrl(Control);
  Result.Position := Position;
  Add(Result);
  UpdateControls;
  ResetLineHeightAtPos(Position);
end;

function TecEmbeddedObjects.InsertIcon(ImageIndex,
  Position: integer): TecCustomEmbeddedObject;
begin
  Result := TecEmbeddedImageIdx.Create;
  TecEmbeddedImageIdx(Result).ImageIndex := ImageIndex;
  Result.Position := Position;
  Add(Result);
  ResetLineHeightAtPos(Position);
end;

function TecEmbeddedObjects.InsertPicture(Graphic: TGraphic;
  Position: integer): TecCustomEmbeddedObject;
begin
  Result := TecEmbeddedImage.Create;
  TecEmbeddedImage(Result).Picture.Assign(Graphic);
  Result.Position := Position;
  Add(Result);
  ResetLineHeightAtPos(Position);
end;

function TecEmbeddedObjects.ObjectsAtLine(Line: integer): TList;
var Idx: integer;
begin
  if Line < Lines.Count then
    begin
      Idx := Lines.LineIndex(Line) - 1;
      Result := GetObjectsInRange(Idx, Idx + Lines.LineSpace(Line));
    end else
      Result := nil;
end;

function TecEmbeddedObjects.CaretPosToStrPos(const p: TPoint): integer;
var Objs: TList;
    i: integer;
    x: integer;
begin
  if p.Y >= Lines.Count then Result := Lines.TextLength else
    if p.Y < 0 then Result := 0 else
      begin
        Objs := ObjectsAtLine(p.Y);
        try
          Result := Lines.LineIndex(p.Y) - 1;
          x := p.X;
          if Assigned(Objs) then
            for i := 0 to Objs.Count - 1 do
              if TecCustomEmbeddedObject(Objs[i]).Position < Result + x then
                Dec(x);
          if x > Lines.LineLength(p.Y) then
            Inc(Result, Lines.LineLength(p.Y))
          else
            Inc(Result, x);
        finally
          FreeAndNil(Objs);
        end;
      end;
end;

function TecEmbeddedObjects.LineLength(Index: integer): integer;
var Objs: TList;
begin
  if (Index >= 0) and (Index < Lines.Count) then
    begin
      Result := Lines.LineLength(Index);
      Objs := ObjectsAtLine(Index);
      if Assigned(Objs) then
        begin
          Inc(Result, Objs.Count);
          Objs.Free;
        end;
    end
  else
    Result := 0;
end;

function TecEmbeddedObjects.StrPosToCaretPos(p: integer): TPoint;
var Objs: TList;
    i: integer;
begin
  Result := inherited StrPosToCaretPos(p);
  Objs := ObjectsAtLine(Result.Y);
  if Assigned(Objs) then
   try
    for i := 0 to Objs.Count - 1 do
      if TecCustomEmbeddedObject(Objs[i]).Position < p then
        Inc(Result.X);
   finally
     Objs.Free;
   end;
end;


function TecEmbeddedObjects.ObjectAtCaret(cp: TPoint): integer;
var Objs: TList;
    i, p, p1: integer;
begin
  Objs := ObjectsAtLine(cp.Y);
  if Assigned(Objs) then
    begin
      i := 0;
      p := CaretPosToStrPos(Point(0, cp.Y)) + cp.X;
      while i < Objs.Count do
        begin
          p1 := TecCustomEmbeddedObject(Objs[i]).Position;
          if p1 > p then Break else
           if p1 = p then
             begin
               Result := IndexOf(TecCustomEmbeddedObject(Objs[i]));
               Exit;
             end else
               Dec(p);
          Inc(i);
        end;
    end;
  Result := -1;
end;

function TecEmbeddedObjects.ObjectCaretPos(Index: integer): TPoint;
var i: integer;
    Objs: TList;
begin
  Result := StrPosToCaretPos(Items[Index].Position);
  Objs := ObjectsAtLine(Result.Y);
  if Assigned(Objs) then
    try
      for i := 0 to Objs.Count do
        if Objs[i] = Items[Index] then Exit
          else Inc(Result.X);
    finally
      Objs.Free;
    end;
end;

procedure TecEmbeddedObjects.TextChanged(Sender: TObject; Pos, Count,
  LineChange: integer);
var i, N: integer;
begin
   inherited;
   N := 0;
   for i := 0 to FClients.Count - 1 do
     if (TObject(FClients[i]) is TCustomSyntaxMemo) and
        (TCustomSyntaxMemo(FClients[i]).CaretStrPos = Pos) then
       begin
         N := ObjectAtCaret(TCustomSyntaxMemo(FClients[i]).CaretPos);
         if N = -1 then N := 0;
       end;

   if N = 0 then
     N := PriorAt(Pos, True);
   if N = -1 then N := 0 else
     if Items[N].Position < Pos then Inc(N);

   for i := FList.Count - 1 downto N do
     with Items[i] do
       begin
         if (Count < 0) and (Position < Pos - Count) and (Position > Pos) then
           Delete(i)
         else
           Position := Position + Count;
       end;

   // Updating format ranges
   if Pos = -1 then ClearFormatting else
     begin
       N := FFormatRanges.NextAt(Pos - 1);
       if N <> -1 then
         for i := FFormatRanges.Count - 1 downto N do
           if (Count < 0) and (FFormatRanges[i].StartPos < Pos - Count) then
             begin
               if (FFormatRanges[i].EndPos <= Pos - Count) and
                  (FFormatRanges[i].StartPos >= Pos) then
                 FFormatRanges.Delete(i)
               else
                with TFormatRange(FFormatRanges[i]) do
                 begin
                   if FStartPos > Pos then
                     FStartPos := Pos;
                   FEndPos := FEndPos + Count;
                 end;
             end else
           with TFormatRange(FFormatRanges[i]) do
             begin
               if FStartPos >= Pos then
                 FStartPos := FStartPos + Count;
               FEndPos := FEndPos + Count;
             end;
       PackFormatting;
     end;
  UpdateControls;
end;

procedure TecEmbeddedObjects.ResetLineHeightAtPos(Pos: integer);
var Line, i: integer;
begin
  Line := StrPosToCaretPos(Pos).Y;
  for i := 0 to FClients.Count - 1 do
    if TObject(FClients[i]) is TCustomSyntaxMemo then
      with TCustomSyntaxMemo(FClients[i]) do
        InvalidateLines(Line, Line, True);
end;

procedure TecEmbeddedObjects.FormatRange(StartPos, EndPos: integer;
  Style: TSyntaxFormat);
var FstlIdx, idx, p: integer;

  function GetMergedStyle(frm_idx: integer): integer;
  var Stl: TSyntaxFormat;
  begin
    Stl := TSyntaxFormat.Create(nil);
    Stl.Assign(FStyles[frm_idx]);
    Stl.Merge(Style);
    Result := FStyles.AddStyle(Stl);
  end;

  procedure AddRng(sp, ep, frm_idx: integer);
  var fR: TFormatRange;
      Stl: TSyntaxFormat;
  begin
    if ep > EndPos then
      ep := EndPos;
    if ep <= sp then Exit;
    fR := TFormatRange.Create(sp, ep, -1);
    if frm_idx <> -1 then
      begin
        fR.FStyleIdx := GetMergedStyle(frm_idx);
      end
    else
      begin
        if FstlIdx = -1 then
          begin
            Stl := TSyntaxFormat.Create(nil);
            Stl.Assign(Style);
            FstlIdx := FStyles.AddStyle(Stl);
          end;
        fR.FStyleIdx := FstlIdx;
      end;
    FFormatRanges.Add(fR);
  end;

  procedure AddRngSt(sp, ep, stl_idx: integer);
  begin
    if ep <= sp then Exit;
    FFormatRanges.Add(TFormatRange.Create(sp, ep, stl_idx));
  end;

var fR: TFormatRange;
begin
  FstlIdx := -1;
  idx := FFormatRanges.PriorAt(EndPos);
  while (idx >= 0) and (EndPos > StartPos) and (FFormatRanges[idx].EndPos > StartPos) do
    begin
      fR := TFormatRange(FFormatRanges[idx]);
      // intersection with right bound
      if fR.EndPos > EndPos then
        begin
          p := fR.EndPos;
          fR.FEndPos := EndPos;
          AddRngSt(EndPos, p, fR.StyleIdx);
        end else
      if fR.EndPos < EndPos then
        begin
          p := max(fR.EndPos, StartPos);
          AddRng(p, EndPos, -1);
          EndPos := p;
        end;
      // intersection with left bound
      if fR.StartPos < StartPos then
        begin
          p := fR.StartPos;
          fR.FStartPos := StartPos;
          AddRngSt(p, StartPos, fR.StyleIdx);
        end;

      if fR.StartPos >= fR.EndPos then
        FFormatRanges.Delete(idx)
      else
        begin
          fR.FStyleIdx := GetMergedStyle(fR.StyleIdx);
          EndPos := fR.StartPos;
        end;

      Dec(Idx);
    end;
  AddRng(StartPos, EndPos, -1);
  PackFormatting;
end;

procedure TecEmbeddedObjects.PackFormatting;
var L: array of integer;
    i, k: integer;
    r, r1: TFormatRange;
    was_del: Boolean;
begin
  if FStyles.Count = 0 then Exit;
  SetLength(L, FStyles.Count);
  // Union ranges and style using calculation
  for i := FFormatRanges.Count - 1 downto 0 do
    begin
      r := TFormatRange(FFormatRanges[i]);
      if r.StartPos = r.EndPos then
        begin
          FFormatRanges.Delete(i);
          Continue;
        end;
      if i > 0 then
        begin
          r1 := TFormatRange(FFormatRanges[i - 1]);
          if (r.StartPos = r1.EndPos) and (r.StyleIdx = r1.StyleIdx) then
            begin
              r1.FEndPos := r.EndPos;
              FFormatRanges.Delete(i);
              Continue;
            end;
        end;
      Inc(L[r.StyleIdx]);
    end;

  // Deleting not used styles
  was_del := False;
  for i := FStyles.Count - 1 downto 0 do
    if L[i] = 0 then
      begin
        was_del := True;
        FStyles.Delete(i);
      end;
  if not was_del then Exit;

  // Creating index map
  k := 0;
  for i := 0 to Length(L) - 1 do
    if L[i] = 0 then L[i] := -1 else
      begin
        L[i] := k;
        Inc(k);
      end;

  // Changing indexes
  for i := 0 to FFormatRanges.Count - 1 do
    with TFormatRange(FFormatRanges[i]) do
      FStyleIdx := L[FStyleIdx];
end;

procedure TecEmbeddedObjects.AnalyzeToPos(APos: integer);
begin
end;

function TecEmbeddedObjects.GetStyleList(CurPos: integer;
  List: TStyleEntries): integer;
var idx: integer;
begin
  if not FFormatEnabled then
    begin
      Result := -1;
      Exit;
    end;

  idx := FFormatRanges.NextAt(CurPos);
  if idx = -1 then Result := -1 else
   with TFormatRange(FFormatRanges[idx]) do
    if StartPos > CurPos then Result := StartPos else
    begin
      List.Add(FStyles[StyleIdx], StartPos, EndPos, False);
      Result := EndPos;
    end;
end;

function TecEmbeddedObjects.RangeStyle(StartPos, EndPos: integer; var Style: TSyntaxFormat): Boolean;
var idx: integer;
    Stl: TSyntaxFormat;
begin
  idx := FFormatRanges.NextAt(StartPos);
  Result := True;
  if (idx = -1) or (FFormatRanges[idx].StartPos > StartPos) then
    Result := False else
  while idx < FFormatRanges.Count do
    begin
      Stl := FStyles[TFormatRange(FFormatRanges[idx]).StyleIdx];
      if Style = nil then
        begin
          Style := TSyntaxFormat.Create(nil);
          Style.Assign(Stl);
        end
      else
          Style.Intersect(Stl);

      if FFormatRanges[idx].EndPos >= EndPos then Exit else
      if (idx = FFormatRanges.Count - 1) or
         (FFormatRanges[idx].EndPos <> FFormatRanges[idx + 1].StartPos) then
        begin
          Result := False;
          FreeAndNil(Style);
          Exit;
        end;

      Inc(Idx);
    end;
end;

procedure TecEmbeddedObjects.ClearFormatting;
begin
  FFormatRanges.Clear;
  FStyles.Clear;
end;

procedure TecEmbeddedObjects.ClearFormatting(StartPos, EndPos: integer);
var idx, p: integer;
begin
  idx := FFormatRanges.PriorAt(EndPos);
  if (idx <> -1) and (FFormatRanges[idx].EndPos > EndPos) then
    begin
      p := FFormatRanges[idx].StartPos;
      TFormatRange(FFormatRanges[idx]).FStartPos := EndPos;
      if p < StartPos then
        begin
          FFormatRanges.Add(TFormatRange.Create(p, StartPos, TFormatRange(FFormatRanges[idx]).StyleIdx));
          Exit;
        end;
      Dec(Idx);
    end;
  while (idx >= 0) and (FFormatRanges[idx].StartPos >= StartPos) do
    begin
      FFormatRanges.Delete(idx);
      Dec(Idx);
    end;

  if (Idx >= 0) and (FFormatRanges[idx].EndPos > StartPos) then
    TFormatRange(FFormatRanges[idx]).FEndPos := StartPos;

  PackFormatting;
end;

procedure TecEmbeddedObjects.SetFormatEnabled(const Value: Boolean);
begin
  if FFormatEnabled <> Value then
    begin
      FFormatEnabled := Value;
      FormatChanged;
    end;
end;

const FM_SIGNATURE: integer = $00ECECEC;

type
  TWriterAccess = class(TWriter)
  public
    procedure WriteProperties(Instance: TPersistent);
  end;

  TReaderAccess = class(TReader)
  protected
    function Error(const Message: string): Boolean; override;
  public
    procedure ReadProperty(AInstance: TPersistent);
  end;

procedure TWriterAccess.WriteProperties(Instance: TPersistent);
begin
  inherited WriteProperties(Instance); // .Net support
end;

function TReaderAccess.Error(const Message: string): Boolean;
begin
  Result := True;
end;

procedure TReaderAccess.ReadProperty(AInstance: TPersistent);
begin
  inherited ReadProperty(AInstance);   // .Net support
end;

procedure TecEmbeddedObjects.LoadFormatting(Stream: TStream);
  function ReadInt: integer;
  begin
    Stream.Read(Result, sizeof(integer));
  end;
var Stl: TSyntaxFormat;
    i, N, S,E,F: integer;
begin
  if ReadInt <> FM_SIGNATURE then
    raise Exception.Create('Invalid stream format');

  FFormatRanges.Clear;
  FStyles.Clear;

  // Reading styles
  with TReaderAccess.Create(Stream, 4096) do
  try
    ReadListBegin;
    while not EndOfList do
      begin
        Stl := TSyntaxFormat.Create(nil);
        ReadListBegin;
        while not EndOfList do ReadProperty(Stl);
        ReadListEnd;
        FStyles.AddNoCheck(Stl);
      end;
    ReadListEnd;  
  finally
    Free;
  end;

  // Reading ranges
  N := ReadInt;
  for i := 0 to N - 1 do
    begin
      S := ReadInt;
      E := ReadInt;
      F := ReadInt;
      FFormatRanges.Add(TFormatRange.Create(S, E, F));
    end;
end;

procedure TecEmbeddedObjects.SaveFormatting(Stream: TStream);
  procedure WriteInt(V: integer);
  begin
    Stream.Write(V, sizeof(integer));
  end;
var i: integer;
begin
  WriteInt(FM_SIGNATURE);
  // Writting styles
  with TWriterAccess.Create(Stream, 4096) do
  try
    WriteListBegin;
    for i := 0 to FStyles.Count - 1 do
      begin
        WriteListBegin;
        WriteProperties(FStyles[i]);
        WriteListEnd;
      end;
    WriteListEnd;
  finally
    Free;
  end;
  // Writting ranges
  WriteInt(FFormatRanges.Count);
  for i := 0 to FFormatRanges.Count - 1 do
    with TFormatRange(FFormatRanges[i]) do
      begin
        WriteInt(StartPos);
        WriteInt(EndPos);
        WriteInt(StyleIdx);
      end;
end;

procedure TecEmbeddedObjects.LoadFormatting(const FileName: string);
var FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFormatting(FS);
  finally
    FS.Free;
  end;
end;

procedure TecEmbeddedObjects.SaveFormatting(const FileName: string);
var FS: TFileStream;
begin
  FS := TFileStream.Create(FileName, fmCreate);
  try
    SaveFormatting(FS);
  finally
    FS.Free;
  end;
end;

function TecEmbeddedObjects.HasFormatting: Boolean;
begin
  Result := FFormatRanges.Count > 0;
end;

procedure TecEmbeddedObjects.UpdateControls;
var FDest: TCustomSyntaxMemo;
    i, SartPos, CHeight, LH: integer;
    isVis, BeforeEndSrc: Boolean;
    R: TRect;
    CP: TPoint;
    sz: TSize;
begin
  FDest := TCustomSyntaxMemo(ControlSite);
  if FDest = nil then Exit;

  BeforeEndSrc := True;
  SartPos := FDest.CaretPosToStrPos(Point(0, FDest.TopLine));
  with FDest.TextArea do
    CHeight := Bottom - Top;

  for i := 0 to Count - 1 do
    if Items[i] is TecEmbeddedControl then
      with TecEmbeddedControl(Items[i]) do
        begin
          Control.Parent := FDest;
          isVis := (Position >= SartPos) and BeforeEndSrc;
          if isVis then
            begin
              CP := StrPosToCaretPos(Position);
              R.TopLeft := FDest.CaretToMouse(CP.X, CP.Y);
              BeforeEndSrc := R.TopLeft.Y < CHeight;
              isVis := BeforeEndSrc;
              if isVis then
                begin
                  LH := FDest.LineHeight(CP);
                  sz := GetSize(FDest, FDest.Canvas);
                  R.Top := R.Top + (LH - sz.cy) div 2;
                  R.Bottom := R.Top + sz.cy;
                  R.Right := R.Left + sz.cx;
                end;
            end;
          if isVis then
            begin
              Control.BoundsRect := R;
              Control.Visible := True;
              Control.Refresh;
            end else
            begin
              Control.Visible := False;
            end;
        end;
end;

procedure TecEmbeddedObjects.ScrollPosChanged;
begin
  UpdateControls;
end;

procedure TecEmbeddedObjects.SetControlSite(const Value: TWinControl);
begin
  if (FControlSite <> Value) and
    (not Assigned(Value) or
     (FClients.IndexOf(Value) <> -1) and (Value is TCustomSyntaxMemo)) then
    begin
      FControlSite := Value;
      UpdateControls;
    end;
end;

procedure TecEmbeddedObjects.AddClient(Client: TObject);
begin
  inherited;
  if (csDesigning in ComponentState) and not Assigned(FControlSite) and (Client is TCustomSyntaxMemo) then
    ControlSite := TCustomSyntaxMemo(Client);
end;

procedure TecEmbeddedObjects.RemoveClient(Client: TObject);
begin
  inherited;
  if Client = ControlSite then
    ControlSite := nil;
end;

{ TecEmbeddedImage }

constructor TecEmbeddedImage.Create;
begin
  inherited;
  FPicture := TPicture.Create;
  Flags := [efOpaque, efSizable];
end;

destructor TecEmbeddedImage.Destroy;
begin
  FreeAndNil(FPicture);
  inherited;
end;

procedure TecEmbeddedImage.Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect);
begin
  Canvas.StretchDraw(R, FPicture.Graphic);
end;

function TecEmbeddedImage.GetSize(Target: TWinControl; Canvas: TCanvas): TSize;
begin
  if Assigned(Canvas) then
    begin
      Result.cx := MulDiv(FPicture.Width, Canvas.Font.PixelsPerInch, PixelPerInch.X);
      Result.cy := MulDiv(FPicture.Height, Canvas.Font.PixelsPerInch, PixelPerInch.Y);
    end else
      Result := NullSize;
end;

function TecEmbeddedImage.LoadFromClipboardFormat(Format: Word): Boolean;
var Data: THandle;
    Palette: HPALETTE;
begin
  Data := 0;
  Palette := 0;
  FPicture.LoadFromClipboardFormat(Format, Data, Palette);
  Result := True;
end;

class function TecEmbeddedImage.SupportFormat(Format: Word): Boolean;
begin
  Result := TPicture.SupportsClipboardFormat(Format);
end;

{ TecCustomEmbeddedObject }

constructor TecCustomEmbeddedObject.Create;
begin
  inherited Create;
end;

function TecCustomEmbeddedObject.GetFlags: TecEmbeddedObjectFlags;
begin
  Result := FFlags;
end;

function TecCustomEmbeddedObject.GetHint: string;
begin
  Result := FHint;
end;

function TecCustomEmbeddedObject.GetIndex: integer;
begin
  if Assigned(FOwner) then
    Result := FOwner.IndexOf(Self)
  else
    Result := -1;
end;

function TecCustomEmbeddedObject.GetPosition: integer;
begin
  Result := FPosition;
end;

function TecCustomEmbeddedObject.GetSize(Target: TWinControl; Canvas: TCanvas): TSize;
begin

end;

function TecCustomEmbeddedObject.LoadFromClipboardFormat(
  Format: Word): Boolean;
begin
  Result := False;
end;

procedure TecCustomEmbeddedObject.LoadFromStream(Stream: TStream);
begin

end;

procedure TecCustomEmbeddedObject.SaveToStream(Stream: TStream);
begin

end;

procedure TecCustomEmbeddedObject.SetFlags(const Value: TecEmbeddedObjectFlags);
begin
  FFlags := Value;
end;

procedure TecCustomEmbeddedObject.SetHint(const Value: string);
begin
  FHint := Value;
end;

procedure TecCustomEmbeddedObject.SetOwner(AOwner: TecEmbeddedObjects);
begin
  FOwner := AOwner;
end;

procedure TecCustomEmbeddedObject.SetPosition(Value: integer);
begin
  FPosition := Value;
end;

procedure TecCustomEmbeddedObject.SetSize(Target: TWinControl; Canvas: TCanvas; Value: TSize);
begin
end;

class function TecCustomEmbeddedObject.SupportFormat(
  Format: Word): Boolean;
begin
  Result := False;
end;

{ TecEmbeddedImageIdx }

constructor TecEmbeddedImageIdx.Create;
begin
  inherited;
  Flags := [efSizable];
end;

procedure TecEmbeddedImageIdx.Draw(Wnd: TWinControl; Canvas: TCanvas;
  const R: TRect);
begin
  inherited;
  if Assigned(FOwner) and Assigned(FOwner.ImageList) and
     (FImageIndex >= 0) and (FImageIndex < FOwner.ImageList.Count) then
    begin
      FOwner.ImageList.Draw(Canvas, R.Left, R.Top, FImageIndex);
    end;
end;

function TecEmbeddedImageIdx.GetSize(Target: TWinControl;
  Canvas: TCanvas): TSize;
begin
  if Assigned(FOwner) and Assigned(FOwner.ImageList) and Assigned(Canvas) then
    begin
      Result.cx := MulDiv(FOwner.ImageList.Width, Canvas.Font.PixelsPerInch, PixelPerInch.X);
      Result.cy := MulDiv(FOwner.ImageList.Height, Canvas.Font.PixelsPerInch, PixelPerInch.Y);
    end else
      Result := NullSize;
end;

procedure TecEmbeddedImageIdx.SetImageIndex(const Value: integer);
begin
  FImageIndex := Value;
end;

{ TecEmbeddedControl }

constructor TecEmbeddedControl.CreateCtrl(AControl: TControl);
begin
  inherited Create;
  FControl := AControl;
  Flags := [efOpaque, efControl];
end;

destructor TecEmbeddedControl.Destroy;
begin
  FreeAndNil(FControl);
  inherited;
end;

procedure TecEmbeddedControl.Draw(Wnd: TWinControl; Canvas: TCanvas; const R: TRect);
var br: TRect;
begin
  br := Control.BoundsRect;
  if (br.Left <> R.Left) or (br.Top <> R.Top) then
    Control.BoundsRect := R;
  Control.Refresh;
end;

function TecEmbeddedControl.GetSize(Target: TWinControl; Canvas: TCanvas): TSize;
begin
  if Target = Control.Parent then
    begin
      Result.cx := Control.Width;
      Result.cy := Control.Height;
    end else
      Result := NullSize;
end;

procedure TecEmbeddedControl.SetOwner(AOwner: TecEmbeddedObjects);
begin
  inherited;
  if Assigned(FControl) and Assigned(FOwner) then
    FOwner.FreeNotification(FControl);
end;

{ TecEmbeddedOLE }
{function HimetricToPixels(const P: TPoint): TSize;
begin
  Result.cx := MulDiv(P.X, PixelPerInch.X, 2540);
  Result.cy := MulDiv(P.Y, PixelPerInch.Y, 2540);
end;

constructor TecEmbeddedOLE.Create;
begin
  inherited;
  FOLECtrl := TOleContainer.Create(nil);
end;

destructor TecEmbeddedOLE.Destroy;
begin
  FreeAndNil(FOLECtrl);
  inherited;
end;

procedure TecEmbeddedOLE.Draw(Wnd: TWinControl; Canvas: TCanvas;
  const R: TRect);
begin
  OleDraw(FOLECtrl.OleObjectInterface, DVASPECT_CONTENT, Canvas.Handle, R);
end;

function TecEmbeddedOLE.GetDevSize: TSize;
var ViewObject2: IViewObject2;
    Size: TPoint;
begin
  try
    if FOLECtrl.State <> osEmpty then
      begin
        if Succeeded(FOLECtrl.OleObjectInterface.QueryInterface(IViewObject2, ViewObject2)) then
        begin
          ViewObject2.GetExtent(DVASPECT_CONTENT, -1, nil, Size);
          Result := HimetricToPixels(Size);
        end;
      end;
  except
  end;
end;

function TecEmbeddedOLE.LoadFromClipboardFormat(Format: Word): Boolean;
begin
  Clipboard.Close;
  FOLECtrl.PasteSpecialDialog;
  Clipboard.Open;
  Result := True;
end;

class function TecEmbeddedOLE.SupportFormat(Format: Word): Boolean;
var
  DataObject: IDataObject;
begin
  Clipboard.Close;
  Result := Succeeded(OleGetClipboard(DataObject));
  Result := Result and
    ((OleQueryCreateFromData(DataObject) = 0) or
     (OleQueryLinkFromData(DataObject) = 0));
  Clipboard.Open;
end;}

{ TFormatRange }

constructor TFormatRange.Create(AStartPos, AEndPos, AStyleIdx: integer);
begin
  inherited Create(AStartPos, AEndPos);
  FStyleIdx := AStyleIdx;
end;

initialization
  NullSize.cx := 0;
  NullSize.cy := 0;
  Initialize;
  RegisterEmbeddedClass(TecEmbeddedImage);
  RegisterEmbeddedClass(TecEmbeddedImageIdx);
  RegisterEmbeddedClass(TecEmbeddedControl);
//  RegisterEmbeddedClass(TecEmbeddedOLE);

finalization
  FreeAndNil(FEmbeddedClasses);

end.
