пятница, 31 октября 2014 г.

Ссылка. VCL Form and Frame Scale Fix

http://www.delphinotes.ru/2013/06/vcl-form-and-frame-scale-fix.html

"Многие Delphi-программисты знают, что в VCL происходит некорректное масштабирование форм. Само масштабирование применяется в случае, когда текущее логическое разрешение экрана (значение Screen.PixelsPerInch) не совпадает с тем, при котором разрабатывалась форма в дизайнере (значение PixelsPerInch, сохранённое в DFM-файле). Некорректность заключается в том, что в некоторых случаях масштабирование не применяется к размеру самой формы, но применяется ко всем дочерним контролам. Также не масштабируются констрейнты формы, что приводит к ещё более некрасивым результатам – сначала форма масштабируется, а потом её размер ограничивается старыми констрейнтами."

Мы тоже с этим боролись. Примерно такими же методами.

Ссылка. Организация памяти в текстовом редакторе

Организация памяти в текстовом редакторе

Gap buffer

Прикольно. Я ровно такое делал в начале 90-х.

Когда писал один из редакторов под DOS.

Вот тут может быть даже доступны исходники:

http://everesteditor.chat.ru/Resources/Editors/DOS/my/index.htm
https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/

Прикольно,что это всплыло в 2013-м году.

Видимо - "есть потребности".

"Я уже не первый раз сталкиваюсь с тем, что некоторые технологии, разработанные для старых компьютеров с ограниченными возможностями, оказываются в наше время забытыми, что приводит к распространению неэффективных решений. Надеюсь, что описанное в этой статье «тайное знание предков» поможет появлению на свет хороших текстовых редакторов."

Ну и это перекликается вот с чем - Рефакторинг. Преодоление "алгоритма маляра".

Всё так или иначе возвращается.

Из старых исходников особенно интересно вот это:

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/OLD/SSW.PAS

{$O+}
{$I-}

Unit SSw;

{$DEFINE FROM_SSW}

Interface

{$I DEFINES.INC} { - текущие директивы условной компиляции }
{$I USES.INC}

Const
 swOk              =  0;
 swBoxInvalid      = -1;
 swBoxNoBlock      = -2;
 swNonCorrectBlock = -3;
 swReadError       = -4;
 swWriteError      = -5;
 swCreateError     = -6;
 swStreamError     = -7;
 swMemoryError     = -8;

Type
 TBlockHeader = record
  NextPtr,PrevPtr : LongInt;
  LenContext : Word;
 end;

 TBoxHeader = record
  CurBlock,FirstBlock : LongInt;
 end;

 PBoxCollection = ^TBoxCollection;
 TBoxCollection = object(TCollection)
  Procedure FreeItem(Item : Pointer); virtual;
  Function DataSize : Integer; virtual;
 end;

const
 HdSize = SizeOf(TBlockHeader);

type
 PSwapper = ^TSwapper;
 TSwapper = object(TObject)

  BoxList    : PBoxCollection;
  {$IFDEF ENCRYPT}
  SwFile     : PEncryptFilter;
  {$ELSE}
  SwFile     : PLoFile;
  {$ENDIF}
  {$IFNDEF TEMP}
  FName      : String;
  {$ENDIF}
  HeadSwFile : PLoFile;
  MaxLenCount: Word;
  BlockHd    : TBlockHeader;
  FreeBox    : Integer;
  Status     : Integer;

  Constructor Init({$IFNDEF TEMP}Const aFName: PathStr;{$ENDIF}
                    aMaxLenCount: Word
   {$IFDEF ENCRYPT} ;aKey: LongInt {$ENDIF});
  Destructor Done; virtual;
  Procedure NewBlockBox(Var BoxNumber: Integer);
  Procedure FreeBlockBox(BoxNumber: Integer);
  Function  GetBlock(BoxNumber:Integer; Var Count: Word; Var Block) : Integer;
  Function  PutBlock(BoxNumber:Integer; Count: Word; Var Block) : Integer;
  Function  MoveBlock(SourceBoxNum,DestBoxNum:Integer) : Integer;
  Function  BoxValid(BoxNumber:Word) : Boolean;
  Function  EmptyBox(BoxNumber:Word) : Boolean;
  function  HasError : Boolean;
 end;

Implementation
var
 TmpCount : Word;
Function TBoxCollection.DataSize: Integer;
 Begin
  DataSize:=SizeOf(TBoxHeader);
 end;

Procedure TBoxCollection.FreeItem(Item : Pointer);
 Begin
  if Item <> Nil Then FreeMem(Item,DataSize);
 end;

 Constructor TSwapper.Init({$IFNDEF TEMP}Const aFName: PathStr;{$ENDIF}
  aMaxLenCount: Word
  {$IFDEF ENCRYPT} ;aKey: LongInt {$ENDIF});
  Begin
   inherited Init;
   Status := swOk;
   MaxLenCount:=aMaxLenCount;
   {$IFNDEF TEMP}
   FName := aFName;
   {$ENDIF}
   {$IFNDEF TEMP}
    {$IFDEF ENCRYPT}
     SwFile:=New(PEncryptFilter,Init(aKey,
                 New(PLoFile,Init(FName+'.sw',stCreate,cBlockSize))));
    {$ELSE}
     SwFile:=New(PLoFile,Init(FName+'.sw',stCreate,cBlockSize));
    {$ENDIF ENCRYPT}
    HeadSwFile:=New(PLoFile,Init(FName+'.hsw',stCreate,512));
   {$ELSE}
    {$IFDEF ENCRYPT}
     SwFile:=New(PEncryptFilter,Init(aKey,
                New(PTempBufStream,Init(cBlockSize))));
    {$ELSE}
     SwFile:=New(PTempBufStream,Init(cBlockSize));
    {$ENDIF ENCRYPT}
    HeadSwFile:=New(PTempBufStream,Init(512));
   {$ENDIF TEMP}
   if (SwFile = nil) or (HeadSwFile = nil) then
    begin
     Status := swStreamError;
     Exit;
    end;
   if (SwFile^.Status <> stOk) or (HeadSwFile^.Status <> stOk) then
    begin
     Status := swCreateError;
     Exit;
    end;
   BoxList:=New(PBoxCollection,Init(5,2));
   NewBlockBox(FreeBox);
  end;

 Destructor TSwapper.Done;
  {$IFNDEF TEMP}
   var F:File;
  {$ENDIF TEMP}
  Begin
   if (SwFile<>nil) then Dispose(SwFile,Done);
   if (HeadSwFile<>nil) then Dispose(HeadSwFile,Done);
   if (BoxList<>nil) Then Dispose(BoxList,Done);
   {$IFNDEF TEMP}
    Assign(F,FName+'.sw');
    Erase(F);
    Assign(F,FName+'.hsw');
    Erase(F);
   {$ENDIF}
   inherited Done;
  end;

 Procedure TSwapper.NewBlockBox(Var BoxNumber : Integer);
  Var
    P : Pointer;
    It : Integer;

  Function GetFreeElem(Item: Pointer) : Boolean; far;
   Begin
    GetFreeElem:=(Item=Nil);
   end;

  Begin
   P:=MemAlloc(BoxList^.DataSize);
   If P<>Nil
    then
     Begin
      With TBoxHeader(P^) do
       Begin
        CurBlock:=-1;
        FirstBlock:=-1;
       end;
     end
    else
     Begin
      BoxNumber:=-1;
      Status := swMemoryError;
      Exit;
     end;
   It:=BoxList^.IndexOf(Nil);
   If It>=0
    then
     Begin
      BoxList^.AtPut(It,P);
      BoxNumber:=It;
     end
    else
     Begin
      BoxNumber:=BoxList^.Count;
      BoxList^.Insert(P);
     end;
  end;

 Function  TSwapper.EmptyBox(BoxNumber:Word) : Boolean;
   Begin
    EmptyBox := not(TBoxHeader(BoxList^.At(BoxNumber)^).CurBlock>0);
   end; {TSwapper.EmptyBox}

 Procedure TSwapper.FreeBlockBox(BoxNumber : Integer);
   Begin
    if BoxValid(BoxNumber) Then
     begin
      if (BoxList^.At(BoxNumber)) <> Nil Then
       begin
        while(not EmptyBox(BoxNumber)) do
          MoveBlock(BoxNumber,FreeBox);
        BoxList^.FreeItem(BoxList^.At(BoxNumber));
        BoxList^.AtPut(BoxNumber,Nil);
        {Связать с пустыми (?!): }
       end;
     end
    else
     Status := swBoxInvalid;
   end;

 Function TSwapper.BoxValid(BoxNumber:Word) : Boolean;
   Begin
    If (BoxNumber>=0) and (BoxNumber<BoxList^.Count)
     then BoxValid:=True
     else BoxValid:=False;
   end;

 Function TSwapper.GetBlock(BoxNumber:Integer;
                             Var Count: Word;Var Block) : Integer;
   Var
    CurPtr   : LongInt;

   Begin
     If Not BoxValid(BoxNumber)
      then
       Begin
        Status := swBoxInvalid;
        GetBlock:=swBoxInvalid;
        Exit;
       end;
     CurPtr:=TBoxHeader(BoxList^.At(BoxNumber)^).CurBlock;

     If CurPtr=-1
      then
       Begin
        Status := swBoxNoBlock;
        GetBlock:=swBoxNoBlock;
        Exit;
       end;

     HeadSwFile^.Seek(CurPtr*HdSize);
     HeadSwFile^.Read(BlockHd,HdSize);
     Count:=BlockHd.LenContext;
     SwFile^.Seek(CurPtr*MaxLenCount);
     SwFile^.Read(Block,{MaxLen}Count);

     if (HeadSwFile^.Status <> stOk) or (SwFile^.Status <> stOk) then
      begin
       Status := swReadError;
       GetBlock:=swReadError;
       Exit;
      end;

     MoveBlock(BoxNumber,FreeBox);
     GetBlock:=swOk;
   end;

 Function TSwapper.PutBlock(BoxNumber:Integer;
                             Count: Word; Var Block) : Integer;
   Var
    SwLog  : Integer;
    CurPtr : LongInt;
    i      : Word;
   const
    NULL   : Byte = 0;
   Begin
    If Not BoxValid(BoxNumber)
      then
       Begin
        Status := swBoxInvalid;
        PutBlock:=swBoxInvalid;
        Exit;
       end;

    if (Count > MaxLenCount) then Count := MaxLenCount;
    BlockHd.LenContext:=Count;
    SwLog:=MoveBlock(FreeBox,BoxNumber);
    If (SwLog=swOk)
     then
      Begin
       CurPtr := TBoxHeader(BoxList^.At(BoxNumber)^).CurBlock;
       HeadSwFile^.Seek(CurPtr*HdSize);
       HeadSwFile^.Read(BlockHd,HdSize);
       if (HeadSwFile^.Status <> stOk) then
        begin
         Status := swReadError;
         PutBlock:=swReadError;
         Exit;
        end;
       BlockHd.LenContext:=Count;
       HeadSwFile^.Seek(CurPtr*HdSize);
       HeadSwFile^.Write(BlockHd,HdSize);
       if (HeadSwFile^.Status <> stOk) then
        begin
         Status := swWriteError;
         PutBlock:=swWriteError;
         Exit;
        end;
       SwFile^.Seek(CurPtr*MaxLenCount);
       SwFile^.Write(Block,{MaxLen}Count);
       if (MaxLenCount > Count) then
        for i := 1 to MaxLenCount - Count do
         SwFile^.Write(NULL,1);
       if (SwFile^.Status <> stOk) then
        begin
         Status := swWriteError;
         PutBlock:=swWriteError;
         Exit;
        end;
       PutBlock:=swOk;
      end
     else PutBlock:=SwLog;
   end;

 Function TSwapper.MoveBlock(SourceBoxNum,DestBoxNum:Integer) : Integer;
   Var
    BlockPtr : LongInt;

   Begin
     If Not (BoxValid(SourceBoxNum) and
             BoxValid(DestBoxNum))
      then
       Begin
        Status:=swBoxInvalid;
        MoveBlock:=swBoxInvalid;
        Exit;
       end;

     BlockPtr:=TBoxHeader(BoxList^.At(SourceBoxNum)^).CurBlock;
     If BlockPtr=-1
      then
       If SourceBoxNum=FreeBox
        then
         BlockPtr:=HeadSwFile^.GetSize div HdSize
        else
         Begin
          Status := swBoxNoBlock;
          MoveBlock:=swBoxNoBlock;
          Exit;
         end
      else
       Begin
        HeadSwFile^.Seek(BlockPtr*HdSize);
        HeadSwFile^.Read(BlockHd,HdSize);
        if (HeadSwFile^.Status <> stOk) then
         begin
          Status := swReadError;
          MoveBlock:=swReadError;
          Exit;
         end;
        TBoxHeader(BoxList^.At(SourceBoxNum)^).CurBlock:=BlockHd.NextPtr;
       end;

     {Пpисоед. блока BlockPtr к Dest}
     BlockHd.NextPtr:=TBoxHeader(BoxList^.At(DestBoxNum)^).CurBlock;
     HeadSwFile^.Seek(BlockPtr*HdSize);
     HeadSwFile^.Write(BlockHd,HdSize);
     if (HeadSwFile^.Status <> stOk) then
      begin
       Status := swWriteError;
       MoveBlock:=swWriteError;
       Exit;
      end;

     If TBoxHeader(BoxList^.At(DestBoxNum)^).CurBlock>=0
      then
       Begin
        HeadSwFile^.Seek(TBoxHeader(BoxList^.At(DestBoxNum)^).CurBlock*HdSize);
        HeadSwFile^.Read(BlockHd,HdSize);
        if (HeadSwFile^.Status <> stOk) then
         begin
          Status := swReadError;
          MoveBlock:=swReadError;
          Exit;
         end;
        BlockHd.PrevPtr:=BlockPtr;
        HeadSwFile^.Seek(TBoxHeader(BoxList^.At(DestBoxNum)^).CurBlock*HdSize);
        HeadSwFile^.Write(BlockHd,HdSize);
        if (HeadSwFile^.Status <> stOk) then
         begin
          Status := swWriteError;
          MoveBlock:=swWriteError;
          Exit;
         end;
       end
      else {Пеpвый блок};
     TBoxHeader(BoxList^.At(DestBoxNum)^).CurBlock:=BlockPtr;
     MoveBlock:=swOk;
   end;

function TSwapper.HasError : Boolean;
var Msg : String;
begin
 if (Status=swOk) then
  HasError := False
 else
  begin
   HasError := True;
   Case Status of
    swBoxInvalid: Msg := 'Неправильный номер коробки временного файла.';
    swBoxNoBlock: Msg := 'Коробка временного файла пустая.';
    swNonCorrectBlock: Msg := 'Неверный блок временного файла.';
    swReadError: Msg := 'Ошибка чтения временного файла.';
    swWriteError: Msg := 'Ошибка записи временного файла.';
    swCreateError: Msg := 'Ошибка создания временного файла.';
    swStreamError: Msg := 'Ошибка открытия временного потока.';
    swMemoryError: Msg := 'Нехватка памяти для работы с временным файлом.';
   else
    Msg := 'Неизвестная ошибка временного файла.';
   end;
   MessageBox(^C+Msg,Nil,mfError+mfOkButton);
  end;
end;

{$UNDEF FROM_SSW}

end.

Это собственная реализация своппинга.

А используется своппинг тут:

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/OLD/LONGEDIT.PAS

Ну а GapBuffer используется например тут:

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/OLD/EDITOR.PAS

{$O+}

{$DEFINE FROM_EDITOR}

Unit Editor;

interface

{$I DEFINES.INC} { - текущие директивы условной компиляции }
{$I USES.INC}

{ интерфейс обьекта TEditor - простого редактора коротких файлов }
type
  PEditor = ^TEditor;
  {$IFNDEF SVISION}
  TEditor = object(TView)
  {$ELSE}
  TEditor = object(TView)
  {$ENDIF}
    UndoMode: Boolean;
    HScrollBar: PLongScrollBar;
    VScrollBar: PLongScrollBar;
    Indicator: PIndicator;
    Buffer: PEditBuffer;
    BufSize: Word;
    BufLen: Word;
    GapLen: Word;
    SelStart: Word;
    SelEnd: Word;
    OSelectMode : Byte;    { предыдущий режим выделения блока   }
    OSelStart   : Word;    { старое начало блока (до подкачки из коробки) }
    OSelEnd     : Word;    { старый конец блока  (до подкачки из коробки) }
    CurPtr: Word;
    CurPos: TLongPoint;
    Delta: TLongPoint;
    Limit: TLongPoint;
    edDrawLine: LongInt;
    DrawPtr: Word;
    IsValid: Boolean;
    Modified: Boolean;
    Selecting: Boolean;
    Overwrite: Boolean;
    LockCount: Byte;
    UpdateFlags: Byte;
    KeyState: Integer;
    {$IFDEF SVISION}
    ScrollNum   : LongInt; { количество строк скроллинга в графическом реж}
    VertScroll  : Word;    { шаг вертикального скроллирования }
    SCY         : Word;    { высота привязанного шрифта }
    OvSelectMode: Byte;    { предыдущий режим выделения блока   }
    {$ENDIF}

    constructor Init(var Bounds: TRect;
      AHScrollBar, AVScrollBar: PLongScrollBar;
      AIndicator: PIndicator; ABufSize: Word);
    constructor Load(var S: TStream);
    procedure   Store(var S: TStream);
    destructor  Done; virtual;

    { "стандартные" процедуры поддержки видимого обьекта }
    procedure ChangeBounds(var Bounds: TRect); virtual;
    function  GetPalette: Views.PPalette; virtual;
    function  CursorVisible: Boolean;
    function  Valid(Command: Word): Boolean; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure ConvertEvent(var Event: TEvent); virtual;
    procedure SetCmdState(Command: Word; Enable: Boolean);
    procedure UpdateCommands; virtual;
    function  GetMousePtr(Mouse: TPoint): Word;
    procedure SetState(AState: Word; Enable: Boolean); virtual;

    { работа с буфером редактора }
    procedure InitBuffer;                         virtual;
    procedure DoneBuffer;                         virtual;
    function  SetBufSize(NewSize: Word): Boolean; virtual;
    procedure SetBufLen(Length: Word);            virtual;

    { процедуры перемещения по тексту }
    procedure SetCurPtr(P: Word; SelectMode: Byte);virtual;
    procedure ScrollTo(X, Y: LongInt);             virtual;
    function  GoToBlockStart : Boolean;            virtual;
    function  GoToBlockEnd   : Boolean;            virtual;
    procedure GoToPos(P:TLongPoint);


    { базовые процедуры вставки/удаления }
    function  InsertBuffer(var P: PEditBuffer; Offset, Length: Word;
              AllowUndo, SelectText: Boolean): Boolean; virtual;
    function  InsertFrom(Editor: PEditor): Boolean;     virtual;
    function  InsertText(Text: Pointer; Length: Word;
                         SelectText: Boolean): Boolean; virtual;
    procedure DeleteRange(StartPtr, EndPtr: Word;
         DelSelect: Boolean);          virtual;

    { базовые процедуры вставки/удаления для Undo файла}
    procedure uInsertText(AText: Pointer; ALen: Integer;
              StartPtr: TLongPoint);
    procedure uOverwriteText(AText: Pointer; ALen: Integer;
              StartPtr: TLongPoint);
    procedure uDeleteRange(StartPtr, EndPtr: TLongPoint);
    function  PointLine(ALine: Integer; var ALineLen: Integer) : Pointer;

    { начало/конец транзакций для Undo-файла }
    procedure StartTransaction;
    procedure StopTransaction;

    { иммитация нажатия клавиш }
    procedure NewLine;
    procedure Tab;

    procedure Undo; virtual;
    function  IsClipboard: Boolean;
    procedure ToggleInsMode;

    { процедуры низкого уровня для работы с буфером }
    function  CharPos(P, Target: Word): Integer;       virtual;
    function  CharPtr(P: Word; Target: Integer): Word; virtual;
    function  BufChar(P: Word): Char;
    function  BufPtr(P: Word) : Word;
    function  LineMove(P: Word; Count: Integer): Word;
    function  LineStart(P: Word): Word;                virtual;
    function  LineEnd(P: Word):   Word;                virtual;
    function  NextChar(P: Word): Word;                 virtual;
    function  NextLine(P: Word): Word;
    function  NextWord(P: Word): Word;
    function  PrevChar(P: Word): Word;                 virtual;
    function  PrevLine(P: Word): Word;
    function  PrevWord(P: Word): Word;

    { процедуры работы с блоками }
    procedure SetSelect(NewStart, NewEnd: Word; CurStart: Boolean); virtual;
    function  ClipCopy: Boolean;                       virtual;
    procedure ClipCut;                                 virtual;
    procedure ClipPaste;                         virtual;
    procedure DeleteSelect;                            virtual;
    procedure DeleteBlock;                             virtual;
    function  HasSelection: Boolean;
    procedure HideSelect;                              virtual;
    procedure StartSelect(P : Word);                   virtual;
    procedure EndSelect(P : Word);                     virtual;

    { процедуры отрисовки редактора }
    procedure Draw; virtual;
    procedure DrawLines(Y, Count: Integer; LinePtr: Word); virtual;
    procedure FormatLine(var DrawBuf; LinePtr: Word;
                Width: Integer; Colors: Word);
    procedure TrackCursor(Center: Boolean);
    procedure Lock;
    procedure Unlock;
    procedure Update(AFlags: Byte);
    procedure DoUpdate; virtual;
    {$IFDEF SVISION}
    procedure DoScroll;
    function  CheckKeys(Key : Word) : Word;
    {$ENDIF}

    { процедуры поиска/замены       }
    function  Search(const FindStr: String; Opts: Word): Boolean;
    procedure DoSearchReplace; {!!!} virtual;
    procedure Find;
    procedure Replace;

    { Для форматирования блоков: }
    function  CorrectSpecial(P, Len : Word) : Integer; virtual;
    procedure FormatParagraph(cm : Integer);           virtual;
    { сжимает абзац в строку }
    function  ParagraphToLine(cm : Integer;Ind : Integer) : Boolean;
    Procedure LineToParagraph;
    Function  NextSpace(P : Word) : Word;
    { определяет левый отступ строки }
    Function  GetIndent(P:Word)   : Integer;
    { переносит слово }
    Procedure SplitWord(Const FullWord : String; Var SplitPos:Word); virtual;
    Procedure SplitStr;
    function  GetThisWord(P: Word): String;
    function  ThisWord(P: Word): Word;

  end;

function DefEditorDialog(Dialog: Integer; Info: Pointer): Word;
{$IFNDEF SVISION}
function CreateFindDialog: PDialog;
function CreateReplaceDialog: PDialog;
{$ELSE}
function CreateFindDialog: PsDialog;
function CreateReplaceDialog: PsDialog;
{$ENDIF}
function StdEditorDialog(Dialog: Integer; Info: Pointer): Word;

const LongEditWindowNum  : Word = 0;

const
    SetterInited : Boolean  = False;
var
    TheSetter  : TSetter;  { "настройщик" редактора }

{$IFDEF USE_UNDO}
const
    UndoFile   : PsUndoFile = nil;
{$ENDIF USE_UNDO}

const
    Clipboard  : PEditor    = nil;

const
  EditorDialog: TEditorDialog = StdEditorDialog;
{$Ifdef MOST }
  EditorFlags: Word = efPromptOnReplace;
{$Else }
  EditorFlags: Word = efBackupFiles + efPromptOnReplace;
{$EndIf}

const
  FindStr: String[80] = '';
  ReplaceStr: String[80] = '';

type
  TFindDialogRec = record
    Find: String[80];
    Options: Word;
  end;

type
  TReplaceDialogRec = record
    Find: String[80];
    Replace: String[80];
    Options: Word;
  end;

implementation

{$I MINMAX.INC}
{$I SCAN.INC  }
{$I COUNT.INC }

{ TEditor }

procedure TEditor.StartTransaction;
begin
{$IFDEF USE_UNDO}
  if not IsClipboard and (UndoFile <> nil) then
    UndoFile^.StartTransaction;
{$ENDIF USE_UNDO}
end;

procedure TEditor.StopTransaction;
begin
{$IFDEF USE_UNDO}
  if not IsClipboard and (UndoFile <> nil) then
    UndoFile^.StopTransaction;
{$ENDIF USE_UNDO}
end;

procedure TEditor.uInsertText(AText: Pointer; ALen: Integer;
                              StartPtr: TLongPoint);
begin
 UndoMode := True;
 GoToPos(StartPtr);
 InsertText(AText,ALen,False);
 UndoMode := False;
end;

procedure TEditor.uOverwriteText(AText: Pointer; ALen: Integer;
                              StartPtr: TLongPoint);
begin
 UndoMode := True;
 GoToPos(StartPtr);
 DeleteRange(CurPtr,CurPtr+ALen,False);
 GoToPos(StartPtr);
 InsertText(AText,ALen,False);
 UndoMode := False;
end;

procedure TEditor.uDeleteRange(StartPtr, EndPtr: TLongPoint);
var
 OB, OE, OP : TLongPoint;
begin
 UndoMode := True;

 HideSelect;

 GoToPos(StartPtr);
 StartSelect(CurPtr);
 GoToPos(EndPtr);
 EndSelect(CurPtr);
 DeleteBlock;

 UndoMode := False;
end;

function  TEditor.PointLine(ALine: Integer; var ALineLen: Integer) : Pointer;
var
 P : TLongPoint;
begin
 P.X := 0;  P.Y := ALine;
 GoToPos(P);
 SetCurPtr(LineEnd(CurPtr),0);
 ALineLen := LineEnd(CurPtr) - LineStart(CurPtr);
 PointLine := @(Buffer^[LineStart(CurPtr)]);
end;

constructor TEditor.Init(var Bounds: TRect;
  AHScrollBar, AVScrollBar: PLongScrollBar;
  AIndicator: PIndicator; ABufSize: Word);
{$IFDEF SVISION}
var
 SV : TsView absolute Self;
{$ENDIF}
begin
  inherited Init(Bounds);
  GrowMode := gfGrowHiX + gfGrowHiY;
  Options := Options or ofSelectable;
  {$IFDEF SVISION}
  Options := Options or ofClipping;
  {$ENDIF}
  EventMask := evMouseDown + evKeyDown + evCommand + evBroadcast;
  ShowCursor;
  HScrollBar := AHScrollBar;
  VScrollBar := AVScrollBar;
  Indicator := AIndicator;
  BufSize := ABufSize;
  {$IFDEF SVISION}
  VertScroll := 1;
  SCY := SV.LinkedFont^.CharHeight;
  OvSelectMode := 0;
  {$ENDIF}
  InitBuffer;
  if Buffer <> nil
   then IsValid := True
   else
    begin
     IsValid := False;
     EditorDialog(edOutOfMemory, nil);
     BufSize := 0;
     {!!!}
     SetBufLen(0);
     Exit;
    end;
  SetBufLen(0);
  if (LongEditWindowNum = 0) then
   if not(SetterInited) then
    begin
     SetterInited := True;
     if (SetterFileName='') then
      TheSetter.Init('')
     else
      TheSetter.Init(GetPathString+SetterFileName);
    end;
end;

constructor TEditor.Load(var S: TStream);
begin
  inherited Load(S);
  GetPeerViewPtr(S, HScrollBar);
  GetPeerViewPtr(S, VScrollBar);
  GetPeerViewPtr(S, Indicator);
  S.Read(BufSize, SizeOf(Word));
  S.Read(SCY,SizeOf(SCY));
  InitBuffer;
  if Buffer <> nil
   then IsValid := True
   else
    begin
     IsValid := False;
     EditorDialog(edOutOfMemory, nil);
     BufSize := 0;
    end;
  Lock;
  {$IFDEF SVISION}
  VertScroll := 1;
  {$ENDIF}
  UndoMode := False;
  SetBufLen(0);
end;

destructor TEditor.Done;
begin
  DoneBuffer;
  if (LongEditWindowNum = 0)
   then
     TheSetter.Done;
  inherited Done;
end;

function TEditor.BufChar(P: Word): Char; assembler;
asm
        LES     DI,Self
        MOV     BX,P
        CMP     BX,ES:[DI].TEditor.CurPtr
        JB      @@1
        ADD     BX,ES:[DI].TEditor.GapLen
@@1:
        CMP     BX,ES:[DI].TEditor.BufSize
        JB      @@2
        MOV     BX,ES:[DI].TEditor.BufSize
        DEC     BX

@@2:    LES     DI,ES:[DI].TEditor.Buffer
        MOV     AL,ES:[DI+BX]
end;

function TEditor.BufPtr(P: Word): Word; assembler;
asm
        LES     DI,Self
        MOV     AX,P
        CMP     AX,ES:[DI].TEditor.CurPtr
        JB      @@1
        ADD     AX,ES:[DI].TEditor.GapLen
@@1:
end;

procedure TEditor.ChangeBounds(var Bounds: TRect);
begin
  SetBounds(Bounds);
  Delta.X := MaxLong(0, MinLong(Delta.X, Limit.X - Size.X div SCX));
  Delta.Y := MaxLong(0, MinLong(Delta.Y, Limit.Y - Size.Y div SCY));
  Update(ufView);
end;

function TEditor.CharPos(P, Target: Word): Integer;
var
  Pos: Integer;
begin
  Pos := 0;
  while P < Target do
  begin
    if BufChar(P) = #9 then Pos := Pos or 7;
    Inc(Pos);
    Inc(P);
  end;
  CharPos := Pos;
end;

function TEditor.CharPtr(P: Word; Target: Integer): Word;
var
  Pos: Integer;
begin
  Pos := 0;
  while (Pos < Target) and (P < BufLen) and (BufChar(P) <> #13) do
  begin
    if BufChar(P) = #9 then Pos := Pos or 7;
    Inc(Pos);
    Inc(P);
  end;
  if Pos > Target then Dec(P);
  CharPtr := P;
end;

function TEditor.ClipCopy: Boolean;
begin
  ClipCopy := False;
  if (Clipboard <> nil) and (Clipboard <> @Self) then
  begin
    ClipCopy := Clipboard^.InsertFrom(@Self);
    Selecting := False;
    Update(ufUpdate);
    {$IFDEF SVISION}
    OvSelectMode := smExtend
    {$ENDIF SVISION}
  end;
end;

procedure TEditor.ClipCut;
begin
  if ClipCopy then DeleteSelect;
end;

procedure TEditor.ClipPaste;
begin
  if (Clipboard <> nil) and (Clipboard <> @Self) then
    InsertFrom(Clipboard);
end;

procedure TEditor.ConvertEvent(var Event: TEvent);
var
  ShiftState: Byte absolute $40:$17;
  Key: Word;
begin
  if Event.What = evKeyDown then
  begin
    if (ShiftState and $03 <> 0) and
      (Event.ScanCode >= $47) and (Event.ScanCode <= $51) then
      Event.CharCode := #0;
    Key := Event.KeyCode;
    if KeyState <> 0 then
    begin
      if (Lo(Key) >= $01) and (Lo(Key) <= $1A) then Inc(Key, $40);
      if (Lo(Key) >= $61) and (Lo(Key) <= $7A) then Dec(Key, $20);
    end;
    Key := ScanKeyMap(KeyMap[KeyState], Key);
    KeyState := 0;
    if Key <> 0 then
      if Hi(Key) = $FF then
      begin
        KeyState := Lo(Key);
        ClearEvent(Event);
      end else
      begin
        Event.What := evCommand;
        Event.Command := Key;
      end;
  end;
end;

function TEditor.CursorVisible: Boolean;
begin
  CursorVisible := (CurPos.Y >= Delta.Y) and (CurPos.Y < Delta.Y + Size.Y div SCY);
end;

procedure TEditor.DeleteRange(StartPtr, EndPtr: Word; DelSelect: Boolean);
begin
  if HasSelection and DelSelect then DeleteSelect else
  begin
    SetSelect(StartPtr, EndPtr, True);
    DeleteSelect;
  end;
end;

procedure TEditor.DeleteSelect;
var
 OPos  : TLongPoint;
 SPos  : TLongPoint;
 EPos    : TLongPoint;
 OSS,OSE : Word;
 SS,SE   : Word;
begin
  {$IFDEF USE_UNDO}
  if not(IsClipBoard) AND (UndoFile<>nil) AND not(UndoMode) then
   begin
    OSS := OSelStart; OSE := OSelEnd;
    SS := SelStart; SE := SelEnd;
    OPos := CurPos;
    SetCurPtr(SelStart,0); SPos := CurPos;
    SetCurPtr(SelEnd,0);   EPos := CurPos;
    UndoFile^.InsertText(@Self,SPos,EPos);
    if (OPos.X<>SPos.X) OR (OPos.Y<>SPos.Y) then
     begin
      GoToPos(OPos);
      SelStart := SS; SelEnd := SE;
     end
    else
     begin
      SetSelect(SS,SE,True);
     end;
    OSelStart := OSS; OSelEnd := OSE;
   end;
  {$ENDIF USE_UNDO}
  InsertText(nil, 0, False);
end;

procedure TEditor.DeleteBlock;
begin
 DeleteSelect;
end;

procedure TEditor.DoneBuffer;
begin
  if Buffer <> nil then
  begin
    FreeMem(Buffer, BufSize);
    Buffer := nil;
  end;
end;

procedure TEditor.DoSearchReplace;
var
  I: Word;
  C: TPoint;
begin
  repeat
    I := cmCancel;
    if not Search(FindStr, EditorFlags) then
    begin
      if EditorFlags and (efReplaceAll + efDoReplace) <>
          (efReplaceAll + efDoReplace) then
        EditorDialog(edSearchFailed, nil)
    end
    else if EditorFlags and efDoReplace <> 0 then
    begin
      I := cmYes;
      if EditorFlags and efPromptOnReplace <> 0 then
      begin
        MakeGlobal(Cursor, C);
        I := EditorDialog(edReplacePrompt, Pointer(C));
      end;
      if I = cmYes then
      begin
        Lock;
        InsertText(@ReplaceStr[1], Length(ReplaceStr), False);
        TrackCursor(False);
        Unlock;
      end;
    end;
  until (I = cmCancel) or (EditorFlags and efReplaceAll = 0);
end;

{$IFNDEF SVISION}
procedure TEditor.DoUpdate;
begin
  if UpdateFlags <> 0 then
  begin
    if CursorVisible then SetCursor(CurPos.X - Delta.X, CurPos.Y - Delta.Y);
    if UpdateFlags and ufView <> 0 then DrawView else
      if UpdateFlags and ufLine <> 0 then
        DrawLines((CurPos.Y - Delta.Y), 1, LineStart(CurPtr));
    if HScrollBar <> nil then
      HScrollBar^.SetParams(Delta.X, 0, Limit.X - Size.X, Size.X div 2, 1);
    if VScrollBar <> nil then
       VScrollBar^.SetParams(Delta.Y, 0, Limit.Y - Size.Y, Size.Y - 1, 1);
    if Indicator <> nil then Indicator^.SetValue(CurPos, Modified);
    if State and sfActive <> 0 then UpdateCommands;
    UpdateFlags := 0;
  end;
end;
{$ELSE}
procedure TEditor.DoUpdate;
var R : TRect;
    P : TLongPoint;
    OSM : Word;
begin
  if UpdateFlags <> 0 then
  begin
    if (UpdateFlags and ufScroll <> 0)
       AND (UpdateFlags and ufBlock = 0)
       AND (abs(ScrollNum)<(Size.Y div SCY)-1)
    then
     DoScroll
    else
     if (UpdateFlags and ufScroll <> 0)
        and (ScrollNum <> 0)
        {AND (UpdateFlags and ufBlock = 0)} then
     begin
      OSM := OSelectMode;
      OSelectMode := 0;
      P := CurPos; Dec(P.Y,ScrollNum); ScrollNum := 0;
      GotoPos(P);
      OSelectMode := OSM;
     end;
    ScrollNum := 0;
    if CursorVisible then SetCursor((CurPos.X - Delta.X)*SCX,(CurPos.Y - Delta.Y)*SCY);
    if (UpdateFlags and ufView <> 0) or (UpdateFlags and ufBlock <> 0)
     then DrawView else
      if UpdateFlags and ufLine <> 0 then
        begin
         R.Assign(0,(CurPos.Y-Delta.Y)*SCY,Size.X,(CurPos.Y-Delta.Y+1)*SCY);
         DrawLines((CurPos.Y - Delta.Y)*SCY, SCY, LineStart(CurPtr));
        end;
    if HScrollBar <> nil then
      HScrollBar^.SetParams(Delta.X, 0, Limit.X - Size.X div SCX, (Size.X div SCX) div 2, 1);
    if VScrollBar <> nil then
       VScrollBar^.SetParams(Delta.Y, 0, Limit.Y - Size.Y div SCY, (Size.Y div SCY) - 1, 1);
    if Indicator <> nil then Indicator^.SetValue(CurPos, Modified);
    if State and sfActive <> 0 then UpdateCommands;
    UpdateFlags := 0;
  end;
end;
{$ENDIF SVISION}

{$IFDEF SVISION}
procedure TEditor.DoScroll;
var R  : TRect;
    DY : Integer;
    OPos,P : TLongPoint;
    SV : TsView absolute Self;
    CursorOn : Boolean;

 procedure DrawProc(var R1 : TRect); far;
  begin
   OPos := CurPos;
   if (ScrollNum > 0) then
    begin
     Inc(R1.B.Y,DY);
     GoToPos(Delta);
    end
   else
    begin
     Inc(R1.A.Y,DY);
     P:=Delta; Inc(P.Y,(Size.Y div SCY)); Inc(P.Y,ScrollNum);
     GoToPos(P);
    end;
   CopyImage(ActivePage,
            R1.A.X, R1.A.Y - DY,
            R1.B.X-1, R1.B.Y-DY-1,
            ActivePage,
            R1.A.X, R1.A.Y);
  end;

var
 OSM : Word;

begin
 OSM := OSelectMode;
 OSelectMode := 0;
 CursorOn := State and sfCursorVis <> 0;
 if CursorOn then HideCursor;
 HideMouse;
 DY := ScrollNum * SCY;
 GetExtent(R);
 if (ScrollNum > 0) then
  R.A.Y := R.A.Y + SCY * ScrollNum
 else
  R.B.Y := R.A.Y + ((Size.Y div SCY) + ScrollNum) * SCY;
 SV.DrawFigure(R,@DrawProc);
 DrawLines((CurPos.Y - Delta.Y)*SCY, abs(DY), LineStart(CurPtr));
 GetExtent(R);
 R.A.Y := R.B.Y - (Size.Y - (Size.Y div SCY) * SCY);
 SV.DrawRect(R,True,Lo(GetColor($0301)));
 if (OPos.Y >= Delta.Y) and (OPos.Y < Delta.Y + Size.Y div SCY)
  then GoToPos(OPos);
 UpdateFlags := ufScroll;
 ShowMouse;
 if CursorOn then ShowCursor;
 OSelectMode := OSM;
end;

function TEditor.CheckKeys(Key : Word) : Word; assembler;
asm
        PUSH    CX
        XOR     CX,CX
@@LP: MOV AH,1
 INT 16H
        JE      @@1
        CMP     AX,Key
        JNE     @@1
        MOV     AH,0
        INT     16H
        INC     CX
        JMP     @@LP
@@1:    MOV     AX,CX
        POP     CX
end;

{$ENDIF SVISION}

{$IFNDEF SVISION}
procedure TEditor.Draw;
begin
  if edDrawLine <> Delta.Y then
  begin
    DrawPtr := LineMove(DrawPtr, Delta.Y - edDrawLine);
    edDrawLine := Delta.Y;
  end;
  DrawLines(0, Size.Y, DrawPtr);
end;
{$ELSE}
procedure TEditor.Draw;
var
 R : Trect;
 SV : TsView absolute Self;
begin
  if edDrawLine <> Delta.Y then
  begin
    DrawPtr := LineMove(DrawPtr, Delta.Y - edDrawLine);
    edDrawLine := Delta.Y;
  end;
  DrawLines(0, Size.Y, DrawPtr);
  GetExtent(R);
  R.A.Y := R.B.Y - (Size.Y - (Size.Y div SCY) * SCY);
  SV.DrawRect(R,True,Lo(GetColor($0301)));
end;
{$ENDIF SVISION}

procedure TEditor.DrawLines(Y, Count: Integer; LinePtr: Word);
var
  Color: Word;
{$IFDEF SVISION}
  bkColor  : Word;
  SV       : TsView absolute Self;
  B        : array [0..MaxLineLength-1] of Word;
  SzX      : Word;
  S        : String;
  P        : TPoint;
  R        : TRect;
  S1,S2,S3 : String;
  C1,C2,C3 : Byte;
  B1,B2,B3 : Byte;

procedure BufferToStr(var Buf; var S1, S2, S3: String;
                      var C1, C2, C3 : Byte;
                      var B1, B2, B3 : Byte;
                      Len: Word); near;{assembler;}
var     C : Byte;
        B : array [0..(MaxLineLength-1)*2] of Byte absolute Buf;
        i : Word;
        L : Byte;
begin

 C := B[1];
 L := 0;
 S1 := ''; S2 := ''; S3 := '';

 for i:=0 to Len*2 do
  begin
   if (C <> B[i+1]) then
     begin
      C1 := C;
      if (C1 = Lo(Color)) then B1:=Lo(bkColor) else B1:=Hi(bkColor);
      C  := B[i+1];
      break;
     end;
   Inc(i);
   Inc(L);
   S1[L] := Char(B[i-1]);
  end;
  S1[0] := Char(L);

 L := 0;

 if (i < Len*2) then
 for i:=i to Len*2 do
  begin
   if (C <> B[i+1]) then
     begin
      C2 := C;
      if (C2 = Lo(Color)) then B2:=Lo(bkColor) else B2:=Hi(bkColor);
      C  := B[i+1];
      break;
     end;
   Inc(i);
   Inc(L);
   S2[L] := Char(B[i-1]);
  end;
  S2[0] := Char(L);

 L := 0;

 if (i < Len*2) then
   for i:=i to Len*2 do
    begin
     if (C <> B[i+1]) then
       begin
        C3 := C;
        if (C3 = Lo(Color)) then B3:=Lo(bkColor) else B3:=Hi(bkColor);
        C  := B[i+1];
        break;
       end;
     Inc(i);
     Inc(L);
     S3[L] := Char(B[i-1]);
    end;
    S3[0] := Char(L);
end;

{asm
        PUSH    DS
        LDS     SI,Buf
        LES     DI,S1
        CLD
        MOV     CX,Len
        INC     DI
        XOR     BL,BL
        MOV     C,0

@@1:    LODSB
        CMP     C,0
        JE      @@2
        CMP     C,AL
        JNE     @@3

@@2:    INC     BL
        LODSB
        STOSB
        LOOP    @@1

@@3:
        LES     DI,S1
        MOV     AL,BL
        STOSB

        POP     DS
end;}

{$ELSE}
  B: array[0..MaxLineLength - 1] of Word;
{$ENDIF}
begin
  {$IFDEF SVISION}
   SzX := Size.X div SCX + 1;
   P.X := 0;
   P.Y := Y;
   Color := GetColor($0402);
   bkColor:= GetColor($0301);
  {$ELSE}
   Color := GetColor($0201);
  {$ENDIF}
  while Count {$IFNDEF SVISION} >0 {$ELSE} >=SCY {$ENDIF} do
  begin
   {$IFNDEF SVISION}
    FormatLine(B, LinePtr, Delta.X + Size.X, Color);
    WriteBuf(0, Y, Size.X, 1, B[Delta.X]);
    LinePtr := NextLine(LinePtr);
    Inc(Y);
    Dec(Count);
   {$ELSE}
    FormatLine(B, LinePtr, Delta.X+SzX, Color);

    BufferToStr(B[Delta.X],S1,S2,S3,C1,C2,C3,B1,B2,B3,SzX);
    R.A.X := P.X; R.A.Y := P.Y;
    R.B := R.A; Inc(R.B.X,Size.X); Inc(R.B.Y,SCY);

      SV.DrawSysStr(R,S1,False,C1,B1);

    if (S2<>'') then
     begin
      Inc(R.A.X,Length(S1)*SCX); Inc(R.B.X,Length(S1)*SCX);
      SV.DrawSysStr(R,S2,False,C2,B2);
     end;

     if (S3<>'') then
     begin
      Inc(R.A.X,Length(S2)*SCX); Inc(R.B.X,Length(S2)*SCX);
      SV.DrawSysStr(R,S3,False,C3,B3);
     end;

    LinePtr := NextLine(LinePtr);
    Inc(P.Y,SCY);
    Dec(Count,SCY);
   {$ENDIF}
  end;
end;

procedure TEditor.Find;
var
  FindRec: TFindDialogRec;
begin
  with FindRec do
  begin
    Find := FindStr;
    Options := EditorFlags;
    if EditorDialog(edFind, @FindRec) <> cmCancel then
    begin
      FindStr := Find;
      EditorFlags := Options and not efDoReplace;
      DoSearchReplace;
    end;
  end;
end;

procedure TEditor.FormatLine(var DrawBuf; LinePtr: Word;
  Width: Integer; Colors: Word); assembler;
asm
{!!! - Изменена для работы с "нормальными" блоками }
        PUSH    DS
        LDS     BX,Self
        LES     DI,DrawBuf
        MOV     SI,LinePtr
        XOR     DX,DX
        CLD
        MOV     AH,Colors.Byte[0]
        MOV CX,DS:[BX].TEditor.CurPtr
        CMP CX,DS:[BX].TEditor.SelStart
        JA @@100
        CALL @@10
        JMP @@200
@@100: MOV CX,DS:[BX].TEditor.SelStart
 CALL @@10
        MOV AH,Colors.Byte[1]
        MOV CX,DS:[BX].TEditor.CurPtr
        CMP CX,DS:[BX].TEditor.SelEnd
        JA @@300
        CALL @@10
        ADD SI,DS:[BX].TEditor.GapLen
        JMP @@400
@@300: MOV CX,DS:[BX].TEditor.SelEnd
 CALL @@10
        MOV AH,Colors.Byte[0]
        MOV CX,DS:[BX].TEditor.CurPtr
        CALL @@10
        ADD SI,DS:[BX].TEditor.GapLen
        JMP @@500
@@200: ADD SI,DS:[BX].TEditor.GapLen
 MOV CX,DS:[BX].TEditor.SelStart
        ADD CX,DS:[BX].TEditor.GapLen
        CALL @@10
@@400: MOV AH,Colors.Byte[1]
 MOV CX,DS:[BX].TEditor.SelEnd
        ADD CX,DS:[BX].TEditor.GapLen
        CALL @@10
@@500:  MOV     AH,Colors.Byte[0]
        MOV     CX,DS:[BX].TEditor.BufSize
        CALL    @@10
        JMP     @@31
@@10:   SUB     CX,SI
        JA      @@11
        RETN
@@11:   LDS     BX,DS:[BX].TEditor.Buffer
        ADD     SI,BX
        MOV     BX,Width
@@12:   LODSB
        CMP     AL,' '
        JB      @@20
{ $IFNDEF SVISION}
@@13:   STOSW
(*{$ELSE}
@@13:   STOSB
{$ENDIF}*)
        INC     DX
@@14:   CMP     DX,BX
        JAE     @@30
        LOOP    @@12
        LDS     BX,Self
        SUB     SI,DS:[BX].TEditor.Buffer.Word[0]
        RETN
@@20:   CMP     AL,0DH
        JE      @@30
        CMP     AL,09H
        JNE     @@13
        MOV     AL,' '
{ $IFNDEF SVISION}
@@21:   STOSW
(*{$ELSE}
@@21:   STOSB
{$ENDIF}*)
        INC     DX
        TEST    DL,7
        JNE     @@21
        JMP     @@14
@@30:   POP     CX
{$IFNDEF SVISION}
@@31:   MOV     AL,' '
{$ELSE}
@@31:   MOV     AL,00
{$ENDIF}
        MOV     CX,Width
        SUB     CX,DX
        JBE     @@32
        REP     STOSW
@@32:   POP     DS
end;

function TEditor.GetMousePtr(Mouse: TPoint): Word;
begin
  MakeLocal(Mouse, Mouse);
  Mouse.X:=Mouse.X div SCX; Mouse.Y:=Mouse.Y div SCY;
  Mouse.X := Max(0, Min(Mouse.X, Size.X div SCX - 1));
  Mouse.Y := Max(0, Min(Mouse.Y, Size.Y div SCY - 1));
  GetMousePtr := CharPtr(LineMove(DrawPtr, Mouse.Y + Delta.Y - edDrawLine),
    Mouse.X + Delta.X);
end;

function TEditor.GetPalette:Views.PPalette;
const
  P: String[Length(CEditor)] = CEditor;
begin
  GetPalette := @P;
end;

function TEditor.ThisWord(P: Word): Word;
 Begin
  If (P > 0) then
   While (P > 0) and (BufChar(PrevChar(P)) in WordChars)
    do P := PrevChar(P);
  ThisWord:=P;
 end;

function TEditor.GetThisWord(P: Word): String;
 Var
  AThisWord : String;
 Begin
  AThisWord:='';
  P:=ThisWord(P);
  While (P < BufLen) and (BufChar(P) in WordChars) do
   Begin
    AThisWord:=AThisWord+BufChar(P);
    P := NextChar(P);
   end;
  GetThisWord:=AThisWord;
 end;

function  TEditor.GoToBlockStart : Boolean;
begin
 GoToBlockStart := True;
 SetCurPtr(SelStart,0);
end;

function  TEditor.GoToBlockEnd : Boolean;
begin
 GoToBlockEnd := True;
 SetCurPtr(SelEnd,0);
end;

procedure TEditor.GoToPos(P:TLongPoint);
var
 i   : LongInt;
 Lim : LongInt;
begin
 if (P.X=CurPos.X) AND (P.Y=CurPos.Y) then Exit;
 {$IFDEF SVISION} Inc(LockCount); {$ENDIF}
 if P.Y <> CurPos.Y then
  begin
   Lim := P.Y - CurPos.Y;
   for i:=1 To abs(Lim) do
    SetCurPtr(LineMove(CurPtr,Lim div abs(Lim)),0);
  end;
 SetCurPtr(LineStart(CurPtr),0);
 if (P.X<=CharPos(CurPtr,LineEnd(CurPtr))) then
  for i:=1 To P.X do
   SetCurPtr(NextChar(CurPtr),0);
 {$IFDEF SVISION} Dec(LockCount); {$ENDIF}
end;

procedure TEditor.HandleEvent(var Event: TEvent);

var
  ShiftState  : Byte absolute $40:$17;
  CenterCursor: Boolean;
  SelectMode  : Byte;
  i           : Integer;
  NewPtr      : Word;
  D           : TLongPoint;
  Mouse       : TPoint;
{$IFDEF SVISION}
  ODelta      : TLongPoint;
  SV          : TsView absolute Self;
{$ENDIF}

procedure CheckScrollBar(P: PLongScrollBar; var D: {$IFNDEF SVISION}
                                                    LongInt
                                                   {$ELSE}
                                                    Integer
                                                   {$ENDIF});
{$IFDEF SVISION}
var ODelta : TLongPoint;
{$ENDIF}
begin
  if (Event.InfoPtr = P) and (P^.Value <> D) then
  begin
    {$IFDEF SVISION}
    ODelta := Delta;
    {$ENDIF}
    D := P^.Value;
    {$IFDEF SVISION}
     if (ODelta.Y<>Delta.Y) then
      Message(@Self,evCommand,cmSetScroll,Pointer(ODelta.Y-Delta.Y))
     else
      Update(ufView);
    {$ELSE}
     Update(ufView);
    {$ENDIF}
  end;
end;

begin
  {$IFDEF SVISION}
   ScrollNum := 0;
   SCY := SV.LinkedFont^.CharHeight;
  {$ENDIF}
  inherited HandleEvent(Event);
  ConvertEvent(Event);
  CenterCursor := not CursorVisible;
  SelectMode := 0;
  if Selecting or (ShiftState and $03 <> 0) then SelectMode := smExtend;
  {$IFDEF SVISION}
  if (SelectMode = smExtend) then UpdateFlags := ufView or ufBlock
   else if (OvSelectMode = smExtend) OR (OvSelectMode = smDrag)
    then UpdateFlags := ufView or ufBlock;
  OvSelectMode := SelectMode;
  {$ENDIF}
  case Event.What of
    evMouseDown:
      begin
        if Event.Double then SelectMode := SelectMode or smDouble;
        repeat
          Lock;
          if Event.What = evMouseAuto then
          begin
            MakeLocal(Event.Where, Mouse);
            D := Delta;
            if Mouse.X < 0 then Dec(D.X);
            if Mouse.X >= Size.X then Inc(D.X);
            if Mouse.Y < 0 then Dec(D.Y);
            if Mouse.Y >= Size.Y then Inc(D.Y);
            ScrollTo(D.X, D.Y);
          end;
          SetCurPtr(GetMousePtr(Event.Where), SelectMode);
          SelectMode := SelectMode or smExtend;
          UpdateFlags := ufView {$IFDEF SVISION} {or ufBlock} {$ENDIF};
          {$IFDEF SVISION}
          OvSelectMode := smDrag;
          {$ENDIF}
          Unlock;
        until not MouseEvent(Event, evMouseMove + evMouseAuto);
      end;
    evKeyDown:
      case Event.CharCode of
        #32..#255:
          begin
            Lock;
            if Overwrite
               {and not HasSelection}
               and (CurPtr <> LineEnd(CurPtr))
             then
              begin
               DeleteRange(CurPtr,CurPtr+1,False);
              end; {SelEnd := NextChar(CurPtr)};
            If (Event.CharCode in [#32])
               and (CurPtr >= LineStart(CurPtr)+TheSetter._R.StrLen-1)
             then NewLine
             else InsertText(@Event.CharCode, 1, False);
            TrackCursor(False);
            Unlock;
          end;
      else
        Exit;
      end;
    evCommand:
      case Event.Command of
        cmFind: Find;
        cmReplace: Replace;
        cmSearchAgain: DoSearchReplace;
      else
        begin
          Lock;
          case Event.Command of
            cmTab: Tab;
            cmCut: ClipCut;
            cmCopy: ClipCopy;
            cmPaste: ClipPaste;
            cmUndo: Undo;
            cmClear: DeleteSelect;
            cmCharLeft: {$IFNDEF SVISION}
                         SetCurPtr(PrevChar(CurPtr), SelectMode);
                        {$ELSE}
                         for i:= 1 to CheckKeys(kbLeft)+1 do
                          begin
                           SetCurPtr(PrevChar(CurPtr), SelectMode);
                          end;
                        {$ENDIF SVISION}
            cmCharRight:{$IFNDEF SVISION}
                         SetCurPtr(NextChar(CurPtr), SelectMode);
                        {$ELSE}
                         for i:= 1 to CheckKeys(kbRight)+1 do
                          begin
                           SetCurPtr(NextChar(CurPtr), SelectMode);
                          end;
                        {$ENDIF}
            cmWordLeft: SetCurPtr(PrevWord(CurPtr), SelectMode);
            cmWordRight: SetCurPtr(NextWord(CurPtr), SelectMode);
            cmLineStart: SetCurPtr(LineStart(CurPtr), SelectMode);
            cmLineEnd: SetCurPtr(LineEnd(CurPtr), SelectMode);
            cmLineUp:  {$IFNDEF SVISION}
                        SetCurPtr(LineMove(CurPtr, -1), SelectMode);
                       {$ELSE}
                        begin
                         ScrollNum := VertScroll * (CheckKeys(kbUp)+1);
                         if (ScrollNum > (CurPos.Y)) then
                          ScrollNum := CurPos.Y;
                         SetCurPtr(LineMove(CurPtr, -ScrollNum), SelectMode);
                        end;
                       {$ENDIF}
            cmLineDown:{$IFNDEF SVISION}
                        SetCurPtr(LineMove(CurPtr, 1), SelectMode);
                       {$ELSE}
                        begin
                         ScrollNum := -VertScroll * (CheckKeys(kbDown)+1);
                         if (-ScrollNum > (Limit.Y-CurPos.Y)) then
                          ScrollNum := CurPos.Y - Limit.Y;
                         SetCurPtr(LineMove(CurPtr, -ScrollNum), SelectMode);
                        end;
                       {$ENDIF}
            cmPageUp: {$IFNDEF SVISION}
                      SetCurPtr(LineMove(CurPtr, -(Size.Y div SCY - 1)), SelectMode);
                      {$ELSE}
                      SetCurPtr(LineMove(CurPtr, -(Size.Y div SCY - 1)*(CheckKeys(kbPgUp)+1)), SelectMode);
                      {$ENDIF}
            cmPageDown:{$IFNDEF SVISION}
                       SetCurPtr(LineMove(CurPtr, (Size.Y div SCY - 1)), SelectMode);
                       {$ELSE}
                       SetCurPtr(LineMove(CurPtr, (Size.Y div SCY - 1)*(CheckKeys(kbPgDn)+1)), SelectMode);
                       {$ENDIF}
            cmTextStart: SetCurPtr(0, SelectMode);
            cmTextEnd:   SetCurPtr(BufLen, SelectMode);
            cmNewLine: NewLine;
            cmBackSpace: DeleteRange(PrevChar(CurPtr), CurPtr, False);
            cmDelChar: DeleteRange(CurPtr, NextChar(CurPtr), False);
            cmDelWord: DeleteRange(CurPtr, NextWord(CurPtr), False);
            cmDelStart: DeleteRange(LineStart(CurPtr), CurPtr, False);
            cmDelEnd: DeleteRange(CurPtr, LineEnd(CurPtr), False);
            cmDelLine: DeleteRange(LineStart(CurPtr), NextLine(CurPtr), False);
            cmInsMode: ToggleInsMode;
            cmStartSelect: StartSelect(CurPtr);
            cmHideSelect: HideSelect;
            cmIndentMode: TheSetter._R.AutoIndent := not TheSetter._R.AutoIndent;
            {$IFDEF SVISION}
            cmSetScroll     : begin
                               ScrollNum := Integer(Event.InfoPtr);
                               if (ScrollNum <> 0) then
                                UpdateFlags := (UpdateFlags and ufBlock)
                                               or ufView or ufScroll;
                               UnLock;
                               ClearEvent(Event);
                               Exit;
                              end;
            {$ENDIF}
          else
            Unlock;
            Exit;
          end;
          {$IFDEF SVISION}
           ODelta := Delta;
           TrackCursor(False);
           if (ScrollNum <> 0) AND (ODelta.Y<>Delta.Y) then
            begin
             Dec(LockCount);
             Message(@Self,evCommand,cmSetScroll,Pointer(ScrollNum));
             ClearEvent(Event);
             Exit;
            end;
          {$ELSE}
           TrackCursor(False);
          {$ENDIF SVISION}
          Unlock;
        end;
      end;
    evBroadcast:
      case Event.Command of
        cmScrollBarChanged:
          if (Event.InfoPtr = HScrollBar) or
            (Event.InfoPtr = VScrollBar) then
          begin
            CheckScrollBar(HScrollBar, Delta.X);
            CheckScrollBar(VScrollBar, Delta.Y);
          end
          else
            Exit;
      else
        Exit;
      end;
  end;
  ClearEvent(Event);
end;

function TEditor.HasSelection: Boolean;
begin
  HasSelection := SelStart <> SelEnd;
end;

procedure TEditor.HideSelect;
begin
  Selecting := False;
  SetSelect(CurPtr, CurPtr, False);
  {$IFDEF SVISION}
  UpdateFlags := ufView or ufBlock;
  {$ENDIF SVISION}
end;

procedure TEditor.InitBuffer;
begin
  Buffer := MemAlloc(BufSize);
end;

function TEditor.InsertBuffer(var P: PEditBuffer; Offset, Length: Word;
  AllowUndo, SelectText: Boolean): Boolean;
var
  SelLen, DelLen, SelLines, Lines: Word;
  NewSize,Dum: Longint;
  OCurPos : TLongPoint;
begin
  OCurPos := CurPos;
  InsertBuffer := True;
  Selecting := False;
  SelLen := SelEnd - SelStart;
  if (SelLen = 0) and (Length = 0) then Exit;
  DelLen := 0;
  if (SelLen > 0) then DelLen := SelLen;
  NewSize := Longint(BufLen - SelLen + DelLen) + Length;
  if (NewSize > $FFF0) then
   NewSize := $FFF1;
  if (NewSize > BufSize) then
    if not SetBufSize(NewSize) then
    begin
      EditorDialog(edOutOfMemory, nil);
      InsertBuffer := False;
      SelEnd := SelStart;
      Exit;
    end;
  if (SelLen > 0) then
   SelLines := CountLines(Buffer^[BufPtr(SelStart)], SelLen)
  else
   SelLines := 0;
  if (CurPtr = SelEnd) AND (SelLen > 0) then
  begin
    CurPtr := SelStart;
    Dec(CurPos.Y, SelLines);
  end;
  if Delta.Y > CurPos.Y then
  begin
    Dec(Delta.Y, SelLines);
    if Delta.Y < CurPos.Y then Delta.Y := CurPos.Y;
  end;
  if Length > 0 then Move(P^[Offset], Buffer^[CurPtr], Length);
  Lines := CountLines(Buffer^[CurPtr], Length);
  Inc(CurPtr, Length);
  Inc(CurPos.Y, Lines);
  edDrawLine := CurPos.Y;
  DrawPtr := LineStart(CurPtr);
  CurPos.X := CharPos(DrawPtr, CurPtr);
  if not SelectText then SelStart := CurPtr;
  SelEnd := CurPtr;
  Dum:=Length; Dum:=Dum-SelLen;
  Inc(BufLen,Dum);
  Dec(GapLen,Dum);
  Dum:=Lines; Dum:=Dum-SelLines;
  Inc(Limit.Y,Dum);
  Delta.Y := MaxLong(0, MinLong(Delta.Y, Limit.Y - Size.Y div SCY));
  if not(IsClipboard) then Modified := True;
  {$IFDEF USE_UNDO}
  if (UndoFile<>nil) AND not(IsClipBoard) AND not(UndoMode) then
   UndoFile^.DeleteRange(OCurPos,CurPos);
  {$ENDIF USE_UNDO}
  SetBufSize(BufLen);
  if (SelLines = 0) and (Lines = 0) then Update(ufLine) else Update(ufView);
end;

function TEditor.InsertFrom(Editor: PEditor): Boolean;
begin
  InsertFrom := InsertBuffer(Editor^.Buffer,
    Editor^.BufPtr(Editor^.SelStart),
    Editor^.SelEnd - Editor^.SelStart, False, IsClipboard);
end;

function TEditor.InsertText(Text: Pointer; Length: Word;
  SelectText: Boolean): Boolean;
begin
  InsertText:=InsertBuffer(PEditBuffer(Text),
                           0, Length, False, SelectText);
end;

function TEditor.IsClipboard: Boolean;
begin
  IsClipboard := (Clipboard = @Self);
end;

function TEditor.LineEnd(P: Word): Word; assembler;
asm
        PUSH    DS
        LDS     SI,Self
        LES     BX,DS:[SI].TEditor.Buffer
        MOV     DI,P
        MOV     AL,0DH
        CLD
        MOV     CX,DS:[SI].TEditor.CurPtr
        SUB     CX,DI
        JBE     @@1
        ADD     DI,BX
        REPNE   SCASB
        JE      @@2
        MOV     DI,DS:[SI].TEditor.CurPtr
@@1:    MOV     CX,DS:[SI].TEditor.BufLen
        SUB     CX,DI
        JCXZ    @@4
        ADD     BX,DS:[SI].TEditor.GapLen
        ADD     DI,BX
        REPNE   SCASB
        JNE     @@3
@@2:    DEC     DI
@@3:    SUB     DI,BX
@@4:    MOV     AX,DI
        POP     DS
end;

function TEditor.LineMove(P: Word; Count: Integer): Word;
var
  Pos: Integer;
  I: Word;
begin
  I := P;
  P := LineStart(P);
  Pos := CharPos(P, I);
  while Count <> 0 do
  begin
    I := P;
    if Count < 0 then
    begin
      P := PrevLine(P);
      Inc(Count);
    end else
    begin
      P := NextLine(P);
      Dec(Count);
    end;
  end;
  if P <> I then P := CharPtr(P, Pos);
  LineMove := P;
end;

function TEditor.LineStart(P: Word): Word; assembler;
asm
        PUSH    DS
        LDS     SI,Self
        LES     BX,DS:[SI].TEditor.Buffer
        MOV     DI,P
        MOV     AL,0DH
        STD
        MOV     CX,DI
        SUB     CX,DS:[SI].TEditor.CurPtr
        JBE     @@1
        ADD     BX,DS:[SI].TEditor.GapLen
        ADD     DI,BX
        DEC     DI
        REPNE   SCASB
        JE      @@2
        SUB     BX,DS:[SI].TEditor.GapLen
        MOV     DI,DS:[SI].TEditor.CurPtr
@@1:    MOV     CX,DI
        JCXZ    @@4
        ADD     DI,BX
        DEC     DI
        REPNE   SCASB
        JNE     @@3
@@2:    INC     DI
        INC     DI
        SUB     DI,BX
        CMP     DI,DS:[SI].TEditor.CurPtr
        JE      @@4
        CMP     DI,DS:[SI].TEditor.BufLen
        JE      @@4
        CMP     ES:[BX+DI].Byte,0AH
        JNE     @@4
        INC     DI
        JMP     @@4
@@3:    XOR     DI,DI
@@4:    MOV     AX,DI
        POP     DS
end;

procedure TEditor.Lock;
begin
  Inc(LockCount);
end;

procedure TEditor.NewLine;
const
  CrLf: array[1..2] of Char = #13#10;
  InChar : Char =' ';
var
  I,B,ILen: Word;

begin
  B := LineStart(CurPtr);
  InsertText(@CrLf, 2, False);
  if TheSetter._R.AutoIndent
   then
    If TheSetter._R.IndentLen<0 data-blogger-escaped-:="B;" data-blogger-escaped-and="" data-blogger-escaped-begin="" data-blogger-escaped-curptr="" data-blogger-escaped-do="" data-blogger-escaped-else="" data-blogger-escaped-end="" data-blogger-escaped-false="" data-blogger-escaped-i="" data-blogger-escaped-if="" data-blogger-escaped-inc="" data-blogger-escaped-inserttext="" data-blogger-escaped-or="" data-blogger-escaped-then="" data-blogger-escaped-thesetter._r.indentlen="" data-blogger-escaped-uffer="" data-blogger-escaped-while="">0 then
       For i:=0 to TheSetter._R.IndentLen-1 do
        InsertText(@InChar,1, False);
end;

function TEditor.NextChar(P: Word): Word; assembler;
asm
        PUSH    DS
        LDS     SI,Self
        MOV     DI,P
        CMP     DI,DS:[SI].TEditor.BufLen
        JE      @@3
        INC     DI
        CMP     DI,DS:[SI].TEditor.BufLen
        JE      @@3
        LES     BX,DS:[SI].TEditor.Buffer
        CMP     DI,DS:[SI].TEditor.CurPtr
        JB      @@1
        ADD     BX,DS:[SI].TEditor.GapLen
@@1:    CMP     ES:[BX+DI-1].Word,0A0DH
        JNE     @@2
        INC     DI
@@2:    {!!!}
@@3:
        CMP     DI,DS:[SI].TEditor.BufSize
        JB      @@4
        MOV     DI,DS:[SI].TEditor.BufSize
        DEC     DI
@@4:
 MOV     AX,DI
        POP     DS
end;

function TEditor.NextLine(P: Word): Word;
begin
  NextLine := NextChar(LineEnd(P));
end;

function TEditor.NextWord(P: Word): Word;
begin
  while (P < BufLen) and (BufChar(P) in WordChars) do
    P := NextChar(P);
  while (P < BufLen) and not (BufChar(P) in WordChars) do
    P := NextChar(P);
  NextWord := P;
end;

function TEditor.PrevChar(P: Word): Word; assembler;
asm
        PUSH    DS
        LDS     SI,Self
        MOV     DI,P
        OR      DI,DI
        JE      @@3
        DEC     DI
        JE      @@3
        LES     BX,DS:[SI].TEditor.Buffer
        CMP     DI,DS:[SI].TEditor.CurPtr
        JB      @@1
        ADD     BX,DS:[SI].TEditor.GapLen
@@1:    CMP     ES:[BX+DI-1].Word,0A0DH
        JNE     @@2
        DEC     DI
@@2:    {!!!}
@@3:
 MOV     AX,DI
        POP     DS
end;

function TEditor.PrevLine(P: Word): Word;
begin
  PrevLine := LineStart(PrevChar(P));
end;

function TEditor.PrevWord(P: Word): Word;
begin
  while (P > 0) and not (BufChar(PrevChar(P)) in WordChars) do
    P := PrevChar(P);
  while (P > 0) and (BufChar(PrevChar(P)) in WordChars) do
    P := PrevChar(P);
  PrevWord := P;
end;

procedure TEditor.Replace;
var
  ReplaceRec: TReplaceDialogRec;
begin
  with ReplaceRec do
  begin
    Find := FindStr;
    Replace := ReplaceStr;
    Options := EditorFlags;
    if EditorDialog(edReplace, @ReplaceRec) <> cmCancel then
    begin
      FindStr := Find;
      ReplaceStr := Replace;
      EditorFlags := Options or efDoReplace;
      DoSearchReplace;
    end;
  end;
end;

procedure TEditor.ScrollTo(X, Y: LongInt);
begin
  X := MaxLong(0, MinLong(X, Limit.X - Size.X div SCX));
  Y := MaxLong(0, MinLong(Y, Limit.Y - Size.Y div SCY));
{!!!}
  if (X <> Delta.X) or (Y <> Delta.Y) then
  begin
    Delta.X := X;
    Delta.Y := Y;
    Update(ufView);
  end;
end;

function TEditor.Search(const FindStr: String; Opts: Word): Boolean;
var
  I, Pos: Word;
begin
  Search := False;
  Pos := CurPtr;
  repeat
    if Opts and efCaseSensitive <> 0 then
      I := Scan(Buffer^[BufPtr(Pos)], BufLen - Pos, FindStr,0)
    else I := IScan(Buffer^[BufPtr(Pos)], BufLen - Pos, FindStr);
    if (I <> sfSearchFailed) then
    begin
      Inc(I, Pos);
      if (Opts and efWholeWordsOnly = 0) or
         not (((I <> 0) and (BufChar(I - 1) in WordChars)) or
              ((I + Length(FindStr) <> BufLen) and
               (BufChar(I + Length(FindStr)) in WordChars))) then
      begin
        Lock;
        SetCurPtr(I,0);
        StartSelect(CurPtr);
        EndSelect(CurPtr + Length(FindStr));
        Selecting := False;
        {$IFDEF SVISION}
        OvSelectMode := smExtend;
        {$ENDIF}
        TrackCursor(not CursorVisible);
        Unlock;
        Search := True;
        Exit;
      end else Pos := I + 1;
    end;
  until I = sfSearchFailed;
end;

procedure TEditor.SetBufLen(Length: Word);
begin
  BufLen := Length;
  GapLen := BufSize - Length;
  SelStart := 0;
  SelEnd := 0;
  CurPtr := 0;
  CurPos.X := 0; CurPos.Y := 0;
  Delta.X := 0; Delta.Y := 0;
  Limit.X := MaxLineLength;
  Limit.Y := CountLines(Buffer^[GapLen], BufLen) + 1;
  edDrawLine := 0;
  DrawPtr := 0;
  Modified := False;
  Update(ufView);
end;

function TEditor.SetBufSize(NewSize: Word): Boolean;
begin
  SetBufSize := NewSize <= BufSize;
end;

procedure TEditor.SetCmdState(Command: Word; Enable: Boolean);
var
  S: TCommandSet;
begin
  S := [Command];
  if Enable and (State and sfActive <> 0) then
    EnableCommands(S) else DisableCommands(S);
end;

procedure TEditor.SetCurPtr(P: Word; SelectMode: Byte);
var
  Anchor: Word;
begin
  if SelectMode and smExtend = 0
   then Anchor := P
   else
    if CurPtr = SelStart
     then Anchor := SelEnd
     else Anchor := SelStart;
  if P < Anchor
   then
    begin
     if SelectMode and smDouble <> 0 then
      begin
       P:=PrevLine(NextLine(P));
       Anchor:=NextLine(PrevLine(Anchor));
      end;
     SetSelect(P, Anchor, True);
    end
   else
    begin
     if SelectMode and smDouble <> 0 then
      begin
       P:=NextLine(P);
       Anchor:=PrevLine(NextLine(Anchor));
      end;
     SetSelect(Anchor, P, False);
    end;
end;

procedure TEditor.SetSelect(NewStart, NewEnd: Word; CurStart: Boolean);
var
  Flags: Byte;
  P, L: Word;
begin
  if CurStart then P := NewStart else P := NewEnd;
  Flags := ufUpdate;
  {$IFNDEF SVISION}
  if (NewStart <> SelStart) or (NewEnd <> SelEnd) then
    if (NewStart <> NewEnd) or (SelStart <> SelEnd) then
      Flags := ufView;
  {$ENDIF}
  if P <> CurPtr then
  begin
    if P > CurPtr then
    begin
      L := P - CurPtr;
      Move(Buffer^[CurPtr + GapLen], Buffer^[CurPtr], L);
      Inc(CurPos.Y, CountLines(Buffer^[CurPtr], L));
      CurPtr := P;
    end else
    begin
      L := CurPtr - P;
      CurPtr := P;
      Dec(CurPos.Y, CountLines(Buffer^[CurPtr], L));
      Move(Buffer^[CurPtr], Buffer^[CurPtr + GapLen], L);
    end;
    edDrawLine := CurPos.Y;
    DrawPtr := LineStart(P);
    CurPos.X := CharPos(DrawPtr, P);
    SetBufSize(BufLen);
  end;
  SelStart := NewStart;
  SelEnd := NewEnd;
  Update(Flags);
end;

procedure TEditor.SetState(AState: Word; Enable: Boolean);
begin
  inherited SetState(AState, Enable);
  case AState of
    sfActive:
      begin
        if HScrollBar <> nil then HScrollBar^.SetState(sfVisible, Enable);
        if VScrollBar <> nil then VScrollBar^.SetState(sfVisible, Enable);
        if Indicator  <> nil then Indicator^.SetState(sfVisible, Enable);
        {$IFDEF USE_UNDO}
        if Enable AND (UndoFile <> nil) then UndoFile^.Clear;
        {$ENDIF USE_UNDO}
        UpdateCommands;
      end;
    sfExposed:
      if Enable then Unlock;
  end;
end;

Procedure TEditor.SplitWord(Const FullWord : String; Var SplitPos:Word);
 Var
  I   : Byte;
  Len : Byte;

 Function GlasnPresent(Const Slog : String) : Boolean;
  Var
   I : Byte;
  Begin
   GlasnPresent:=False;
   For I:=1 to Length(Slog) do
    If Slog[I] in Glasn
     then
      Begin
       GlasnPresent:=True;
       Break;
      end;
  end;

 Function ValidSlog(Const Slog : String;SlogNum : Byte) : Boolean;
  Begin
   If (Length(Slog)>1) and
      GlasnPresent(Slog) and
      ((SlogNum=1) or Not (Slog[1] in Znaks))
    then ValidSlog:=True
    else ValidSlog:=False;
  end;

Begin
  if TheSetter._R.MaySplit then
   begin
    Len := Length(FullWord);
    While SplitPos>1 do
     Begin
      If ValidSlog(Copy(FullWord,1,SplitPos),1) and
         ValidSlog(Copy(FullWord,SplitPos+1,Len),2) and
         ((FullWord[SplitPos] in Glasn+Znaks) or
          Not (FullWord[SplitPos+1] in Glasn))
       then Exit
       else Dec(SplitPos);
     end;
     SplitPos:=0;
   end
  else
   SplitPos := 0;
end;

Function TEditor.GetIndent(P:Word) : Integer;
 Var
  I : Integer;
 Begin
  P:=LineStart(P);
  I:=0;
  if (BufChar(P)=#13) then I:=-1
   else
    While (P<BufLen) AND (BufChar(P)=#32) do
      Begin
       Inc(I);
{       Inc(P);}
       P:=NextChar(P);
      end;
  GetIndent:=I;
 end;

Function TEditor.NextSpace(P : Word) : Word;
 const SP : Char = #32;
 Begin
  Repeat
   P:=NextChar(P);
   if BufChar(P)=#9 then
    begin
     DeleteRange(P,NextChar(P),False);
     InsertText(@SP,1,False);
    end;
  until (BufChar(P)=#32) or (P+1 >= BufLen);
  NextSpace:=P;
 end;


function TEditor.ParagraphToLine(cm : Integer; Ind : Integer) : Boolean;
 Var
  P    : Word;
  OP   : TLongPoint;
  Cnt  : LongInt;
  SCnt : String;
 Begin
  Cnt := 0; SCnt := '';
  CtrlBreakHit := False;
  ParagraphToLine := True;
  OP := CurPos;
  P  := LineStart(CurPtr);
  {!!!}
  if ((cm = cmFormatInt) AND (GetIndent(P)<>TheSetter._R.FirstLineIndent)) then
   Ind:=GetIndent(P);
  If (BufChar(LineStart(CurPtr)) = #32)
   then
    If (NextWord(P)<=LineEnd(CurPtr))
     then P:=NextWord(P)
     else
      Begin
       SetCurPtr(LineStart(NextLine(P)),0);
       EXIT;
      end;

  Repeat
   Inc(Cnt);
   Str(Cnt,SCnt);
   SCnt := 'Просмотрено: ' + SCnt + ' строк.';
   DecStatusCount;
   SetNewStatus(SCnt);
   While (NextSpace(P)<LineEnd(P)) do
    Begin
     P:=NextSpace(P);
     SetCurPtr(P,0);
     If (BufChar(NextChar(P))=#32)
      then
       Begin
        While (P<BufLen) AND (BufChar(NextChar(P))=#32) do P:=NextChar(P);
        DeleteRange(CurPtr,P,False);
       end;
     P:=CurPtr;
    end;
   If (P >= BufLen) then exit;
   {!!!}
   If (Ind = -1) then Ind:=GetIndent(NextLine(P));
   If (Ind >=0) AND
      ((cm = cmFormatInt) AND (GetIndent(NextLine(P))=Ind)) XOR
      ((cm = cmFormatNew) AND (GetIndent(NextLine(P))=Ind)) XOR
      ((cm = cmFormat) AND (GetIndent(NextLine(P))=TheSetter._R.IndentLen))
    then
     Begin
      {!!!}
      SetCurPtr(LineEnd(P),0);
      P:=NextLine(P);
      If P >= BufLen then exit;
      P:=LineStart(P);
      While (P<BufLen) AND (BufChar(P)=#32) do P:=NextChar(P);
      DeleteRange(CurPtr,P,False);
      P:=PrevChar(CurPtr);
      If (BufChar(P)=CarrySign) and
         (BufChar(PrevChar(P)) in WordChars) and
         (BufChar(NextChar(P)) in WordChars)
       then
        DeleteRange(P,NextChar(P),False)
       else
        If (BufChar(P)<>#32)
         then
          Begin
           SetCurPtr(NextChar(P),0);
           InsertText(@SpaceCh,1,False);
          end;
     end
    else
     Begin
      Break;
     end;
  until CtrlBreakHit {и не конец файла};
  if CtrlBreakHit then
   begin
    CtrlBreakHit := False;
    ParagraphToLine := False;
   end;
  GoToPos(OP);
  CtrlBreakHit := False;
 end;

Procedure TEditor.LineToParagraph;
var
 Cnt  : LongInt;
 SCnt : String;
 Begin
  Cnt := 0; SCnt := '';
  While (LineEnd(CurPtr)-LineStart(CurPtr)>TheSetter._R.StrLen) do
   begin
    Inc(Cnt);
    Str(Cnt,SCnt);
    SCnt := 'Отформатировано: ' + SCnt + ' строк.';
    DecStatusCount;
    SetNewStatus(SCnt);
    Splitstr;
   end;
 end;

procedure TEditor.FormatParagraph(cm : Integer);
 var
  LS : Word;
  Ind: Integer;
  S  : String;
  i  : integer;
 Begin
  SetNewStatus('Форматирование абзаца...');
  StartTransaction;
  Ind := -1;
  if (cm = cmFormatNew) then
   begin
     LS := LineStart(CurPtr);
     Ind := GetIndent(CurPtr);
     if (Ind>0) then DeleteRange(LS,LS+Ind,False);
     if (TheSetter._R.FirstLineIndent > 0) then
      begin
       S := '';
       for i:=1 to TheSetter._R.FirstLineIndent do
        S := S + #32;
       SetCurPtr(LineStart(CurPtr),0);
       InsertText(@S[1],Length(S),False);
       SetCurPtr(LineStart(CurPtr),0);
      end;
   end;
  if ParagraphToLine(cm,-1) then
   LineToParagraph;
  SetCurPtr(NextLine(CurPtr),0);
  StopTransaction;
  SetOldStatus;
 end;

function  TEditor.CorrectSpecial(P, Len : Word) : Integer;
begin
 CorrectSpecial := 0;
end;

Procedure TEditor.SplitStr;
  Var
   SpWord       : String;
   SplitNum : Word;
   DecSpNum : Integer;
   SaveCurPtr : Word;
   P   : Word;
   IncrCh : Integer;
   SLen         : Word;
  Begin
   IncrCh:=0;
   DecSpNum:=0;
   SaveCurPtr:=CurPtr;
   SLen := TheSetter._R.StrLen;
   SLen := SLen+CorrectSpecial(LineStart(CurPtr),SLen);
   P:=LineStart(CurPtr)+SLen;
   SpWord:=GetThisWord(P);
   If SpWord=''
    then While BufChar(PrevChar(P))=#32 do P:=PrevChar(P)
    else
     If (ThisWord(P)>=P-1)
      then
       Begin
        P:=ThisWord(P);
        While BufChar(PrevChar(P))=#32 do P:=PrevChar(P)
       end
      else
       Begin
        P:=ThisWord(P);
        SplitNum:=LineStart(P)+SLen-1;
        SplitNum:=SplitNum-P;
        SplitWord(SpWord,SplitNum);
        If SplitNum>0
         then
          Begin
           SetCurPtr(P+SplitNum,0);
           InsertText(@CarrySign, 1, False);
           P:=CurPtr;
          end
         else
           While BufChar(PrevChar(P))=' ' do P:=PrevChar(P);
       end;

   if TheSetter._R.MaySmooth then
    begin
     IncrCh:=LineStart(CurPtr)+SLen-P;
     If (IncrCh>0)
        and (LineStart(P)<PrevWord(P))
        and (LineStart(P)<PrevWord(PrevWord(P)))
      then
       Begin
        While IncrCh>0 do
         Begin
          While (LineStart(P)<PrevWord(PrevWord(P)))
           and (IncrCh>0) do
           Begin
            P:=PrevWord(P);
            SetCurPtr(P,0);
            InsertText(@SpaceCh, 1, False);
            Dec(IncrCh);
           end;
          P:=LineStart(P)+SLen-IncrCh;
         end;
       P:=LineStart(P)+SLen;
       end;
    end;{if MaySmooth ...}
   SetCurPtr(P,0);
   NewLine;
   P:=LineStart(CurPtr)+TheSetter._R.IndentLen;
   If BufChar(P)=#32
    then DeleteRange(P,NextChar(P),False);
 end;

procedure TEditor.StartSelect(P : Word);
begin
  Selecting := True;
  SetSelect(P,SelEnd,True);
  {$IFDEF SVISION}
  UpdateFlags := UpdateFlags or ufBlock;
  {$ENDIF}
end;

procedure TEditor.EndSelect(P : Word);
begin
  Selecting := True;
  SetSelect(SelStart,P,False);
  {$IFDEF SVISION}
  UpdateFlags := UpdateFlags or ufBlock;
  {$ENDIF}
end;

procedure TEditor.Store(var S: TStream);
begin
  inherited Store(S);
  PutPeerViewPtr(S, HScrollBar);
  PutPeerViewPtr(S, VScrollBar);
  PutPeerViewPtr(S, Indicator);
  S.Write(BufSize, SizeOf(Word));
  S.Write(SCY,SizeOf(SCY));
end;

procedure TEditor.ToggleInsMode;
begin
  Overwrite := not Overwrite;
  SetState(sfCursorIns, not GetState(sfCursorIns));
end;

procedure TEditor.Tab;
var i : Byte;
    S : String;
Begin
 Lock;
 S := '';
 for i := 1 to (TheSetter._R.TabLen-(CurPos.X mod TheSetter._R.TabLen)) do
  S := S + #32;
 if (Ord(S[0])<>0) then
  InsertText(@S[1],i,False);
 TrackCursor(not CursorVisible);
 UnLock;
end;

procedure TEditor.TrackCursor(Center: Boolean);
begin
  if Center then
    ScrollTo(CurPos.X - Size.X div SCX + 1, CurPos.Y - (Size.Y div SCY) div 2) else
    ScrollTo(MaxLong(CurPos.X - Size.X  div SCX + 1, MinLong(Delta.X, CurPos.X)),
      MaxLong(CurPos.Y - Size.Y div SCY + 1, MinLong(Delta.Y, CurPos.Y)));
end;

procedure TEditor.Undo;
begin
{$IFDEF USE_UNDO}
 SetNewStatus('Идет откат предыдущей операции...');
 if UndoFile <> nil then begin
   UndoFile^.Undo(@Self);
   UpdateCommands;
 end;
 SetOldStatus;
{$ENDIF USE_UNDO}
end;

procedure TEditor.Unlock;
begin
  if LockCount > 0 then
  begin
    Dec(LockCount);
    if LockCount = 0 then DoUpdate;
  end;
end;

procedure TEditor.Update(AFlags: Byte);
begin
  UpdateFlags := UpdateFlags or AFlags;
  if LockCount = 0 then DoUpdate;
end;

procedure TEditor.UpdateCommands;
begin
  if not(IsClipboard) then
  begin
    SetCmdState(cmCut, HasSelection);
    SetCmdState(cmCopy, HasSelection);
    SetCmdState(cmPaste, (Clipboard <> nil) and (Clipboard^.HasSelection));
  end;
  SetCmdState(cmClear, HasSelection);
  SetCmdState(cmPrint, True);
  SetCmdState(cmFind, True);
  SetCmdState(cmReplace, True);
  SetCmdState(cmSearchAgain, True);
  SetCmdState(cmSettings, True);
  SetCmdState(cmFormat, True);
  SetCmdState(cmFormatNew, True);
  SetCmdState(cmFormatInt, True);
end;

function TEditor.Valid(Command: Word): Boolean;
begin
  Valid := IsValid;
end;

{$I DIALOG.INC}

{$UNDEF FROM_EDITOR}

end. {Editor}

Там кстати и про SuperVision упоминания есть.

А ещё была "штука" -"редактор шаблонных документов". До сих пор мной не повторённая.

Это когда часть текста - ReadOnly а часть - "поля для заполнения".

Типа "формы ввода".

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/OLD/LONGEDIT.PAS

Ну и "длинный буфер":
https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/NEW/LONGBUF.PAS

Исходники иногда "рвут крышу" - типа "данные обращаются к View". Зато они сильно документированы. Я сейчас столько комментариев - не пишу. Даже удивительно, что уогда-то писал.

А вот тут:

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/wEditor/Editor/OE/ALTABLER.PAS

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/wEditor/Editor/OE/ALTABLER.INC

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/wEditor/Editor/OE/ALTABLEC.PAS

https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/DOSEditors/wEditor/Editor/OE/ALTABLEC.INC

Ещё смешнее - реализация таблиц для Plain-Text редактора.


unit alTableR;

interface

uses
  OvcBase,
  alEditN,
  alPara,
  alUndo,
  alTableC,
  alEditCo,
  cChars;

type
  TColumnArray = array [1..MaxColumnCount] of TTableColumn;

{=========================================================================}

type
  TTableRow = class(TParaNode)

   protected
    {---------------------------------------------------------------------}
    { добавленные поля }
    FColumnArray  : TColumnArray;
    FColumnCount  : Integer;
    FTableWidth   : Integer;
    FLeftDelta    : Integer;
    FTree         : TParaList;

   protected
    {---------------------------------------------------------------------}
    { методы для работы со свойствами }
    function  GetColumnWidth(i: Integer) : Integer;
      { - возвращает ширину i-й колонки }
    procedure SetColumnWidth(i: Integer; Value: Integer);
      { - устанавливает ширину i-й колонки }
    procedure SetLeftDelta(Value: Integer);
      { - устанавливает отступ таблицы }
    function  GetColumn(i : Integer) : TTableColumn;
      { - возвращает i-ю колонку }
    procedure SetColumn(i: Integer; Value: TTableColumn);
      { - присваивает i-ю колонку }

   public
    {---------------------------------------------------------------------}
    { переопределенные методы }
    function  NthLine(N : Integer; var Len : Word) : PChar;
      override;
      {-return a pointer to the Nth line of this paragraph; Len is its length}
    procedure Recalc;
      override;
      {-calculate the number of lines in this paragraph given the specified
        wrap column}
    function  PosToLine(Pos : Integer; var Col : Integer) : Integer;
      override;
      {-given a position in the paragraph, return the line and Col}
    function PEQ(PN: TParaNode): Boolean;
      override;
      {-сравнивает параметры двух параграфов на идентичность}
    function GetHIndent(L : Integer) : Integer;
      override;
      {-}

    {---------------------------------------------------------------------}
    { переопределенные методы для записи/чтения строки таблицы }
    procedure StoreParas(OnWrite: TalEditorReadWriteEvent; var Res: LongInt);
      override;
      {-сохраняет параметры строки таблицы}
    constructor LoadParas(OnRead: TalEditorReadWriteEvent; var Res: LongInt);
      override;
      {-читает параметры строки таблицы}
    procedure StoreText(Editor: TOvcBase; OnWrite: TalEditorReadWriteEvent; var Res : LongInt);
      override;
      {-сохраняет текст параграфа}
    procedure LoadText(Editor: TOvcBase; OnRead: TalEditorReadWriteEvent; Count: LongInt;
                       var Res: LongInt);
      override;
      {-читает текст параграфа}

    {---------------------------------------------------------------------}
    { добавленные методы }
    constructor Create(aTree: TParaList; aColumnCount,
                       aLeftDelta, aTableWidth,aColumnWidth: Integer);
      virtual;
      {-создает новую строку таблицы не заполняя ее ячейками}
    constructor CreateSame(aTree: TParaList; TR: TTableRow);
      virtual;
      {-создает строку таблицы с параметрами как у TR}
    constructor CreateEmpty(aTree: TParaList; aColumnCount, aTableWidth: Integer);
      virtual;
      {-создает пустую строку таблицы заполнив ее ячейками}
    destructor  Destroy;
      override;
      {-}
    function    ScreenPosToTable(P : Integer; var TP: TTablePoint): TTableColumn;
      {-из позиции на экране находит позицию в таблице }
    function    GlobalPosToTable(C: Integer; P : Integer) : Integer;
      { - из позиции на экране находит позицию в таблице }
    procedure   CorrectScreenPos(var CurLine : LongInt;
                                 var CurCol  : Integer;
                                 var LinePos : Integer);
      {-поправляет позицию на экране так
        чтобы она правильно попадала в ячейку таблицы }
    procedure   MoveCaretToPP(C: Integer;
                              Para: LongInt; var Pos: Integer);
      { - из позиции в таблице - делает позицию на экране }
    procedure   MoveCaretTo(C: Integer;
                            Line: LongInt; var Col: Integer);
      {-из позиции в таблице - делает позицию на экране }
    function    GetHighlightBorder(BC, EC: Integer;
                                   var HBC, HEC: Integer) : Boolean;
      {-определяет границы колонок которыми ограничено выделение }
    procedure   GetHighlightColumns(Left,Right: Integer;
                                    var LeftColumn, RightColumn: Integer);
      {-возвращает номера колонок выделенных в данной строке таблицы}
    procedure   InsertColumn(C: Integer);
      {-вставляет новую колонку по номеру C}
    procedure   PlaceColumn(C: Integer; TC: TTableColumn);
      {-вставляет новую колонку TC по номеру C}
    procedure   DeleteColumn(C: Integer);
      {-удаляет колонку по номеру C}
    procedure   SwapColumns(C1,C2: Integer);
      {-меняет колонки местами}

    {---------------------------------------------------------------------}
    { свойства }
    property Tree : TParaList
      read FTree
      write FTree;
      {-дерево параграфов-владелец данной строки таблицы}

    property Column [i : Integer] : TTableColumn
      read GetColumn
      write SetColumn;
      default;
      {- i-я ячеека }

    property ColumnWidth [i : Integer] : Integer
      read GetColumnWidth
      write SetColumnWidth;
      {-ширина i-й колонки }

    property ColumnCount : Integer
      read FColumnCount
      write FColumnCount;
      {-число колонок }

    property TableWidth : Integer
      read FTableWidth
      write FTableWidth;
      {-ширина таблицы }

    property LeftDelta : Integer
      read FLeftDelta
      write SetLeftDelta;
      {-левый отступ таблицы }

  end; { TTableRow }

{=========================================================================}

implementation

uses
  alEdit,
  alParaT,
  MinMax;

{$I altableR.inc }

end.

Я уж и забыл, что "такое было".

 Под каким-нибудь Lazarus'ом или Delphi1 это даже наверное соберётся.

Ссылки. Про "векторную графику" и диаграммы

Контейнер визуальных объектов:


Библиотека EasyCAD library, или контейнер визуальных объектов для практикующих:


Я их уже когда-то видел и нахожу полезными, но тут мне их напомнили, посему - считаю поводом поделиться.

четверг, 30 октября 2014 г.

Самокритика. Об УЖАСНЫХ интерфейсах

Собственно вот:

 Im3IndexedStorage = interface(IStorage)
  {* Хранилище с возможностью доступа по индексу. }
   ['{1962E532-4615-4D4A-9FAC-0F1E3402F097}']
   function SetIndexParam(aBits: byte;
    aMaxBits: byte): Boolean;
     {* устанавливает параметры "размазывания" индекса. }
   function DeleteStore(anIndex: Integer): hResult;
     {* удаляет элемент хранилища. }
   function CreateStore(anIndex: Integer;
    anAccess: Tm3StoreAccess;
    aStoreType: Tm3StoreType;
    out aStore: IUnknown;
    aUseCompression: Boolean = true): hResult; overload; 
     {* создает элемент хранилища. }
   function OpenStore(anIndex: Integer;
    anAccess: Tm3StoreAccess;
    aStoreType: Tm3StoreType;
    out aStore: IUnknown;
    aUseCompression: Boolean = true): hResult; overload; 
     {* открывает элемент хранилища. }
   function CreateStore(const aName: Tl3PCharLen;
    anAccess: Tm3StoreAccess;
    aStoreType: Tm3StoreType;
    out aStore: IUnknown;
    aUseCompression: Boolean = true): hResult; overload; 
     {* создает элемент хранилища }
   function OpenStore(const aName: Tl3PCharLen;
    anAccess: Tm3StoreAccess;
    aStoreType: Tm3StoreType;
    out aStore: IUnknown;
    aUseCompression: Boolean = true): hResult; overload; 
     {* открывает элемент хранилища }
   function OpenStore(aPosition: Int64;
    anAccess: Tm3StoreAccess;
    const aName: Tl3PCharLen;
    aStoreType: Tm3StoreType;
    aUseCompression: Boolean = true): IUnknown; overload; 
     {* открывает элемент хранилища. }
   function OpenStore(aPosition: Int64;
    anAccess: Tm3StoreAccess;
    anIndex: Integer;
    aStoreType: Tm3StoreType;
    aUseCompression: Boolean = true): IUnknown; overload; 
     {* открывает элемент хранилища }
   function OpenStore(const aStoreInfo: Tm3StoreInfo;
    const aName: Tl3PCharLen;
    anAccess: Tm3StoreAccess = m3_saRead;
    aUseCompression: Boolean = true): IUnknown; overload; 
     {* открывает элемент хранилища. }
   procedure Iterate(anAction: Tm3StorageElementAction); overload; 
     {* перебирает элементы хранилища по именам. }
   procedure Iterate(anAction: Tm3StoreAction); overload; 
     {* перебирает элементы хранилища по индексам. }
   procedure IterateF(anAction: Tm3StorageElementAction); overload; 
     {* перебирает элементы хранилища, потом освобождает заглушку. }
   procedure IterateF(anAction: Tm3StoreAction); overload; 
     {* перебирает элементы хранилища, потом освобождает заглушку. }
   function RenameElementA(const aOldName: Tl3WString;
    const aNewName: Tl3WString): hResult;
     {* Переименовывает элемент хранилища }
   function ElementExists(const aName: Tl3WString): Boolean;
     {* Проверяет существование элемента с указанным именем }
 end;//Im3IndexedStorage

Такие "интерфейсы" делать - НЕЛЬЗЯ.

Множество схожих методов с одинаковыми названиями.

Не говоря уж о том, что "одни через другие выводятся".

Я кстати долго думал - как "интерфейсы минимизировать". Через утилитные классы.

Если кому-то интересно - расскажу.

Если не интересно - "оставлю для себя".

Часть вещей были сделаны "в угоду оптимизации", но это всё равно - не является "оправданием".

Полный код тут - https://sourceforge.net/p/rumtmarc/code-0/HEAD/tree/trunk/Blogger/RealWork/m3/m3StorageInterfaces.pas

P.S. Переделал я кстати этот "интерфейс".Получше. Скоро напишу - как.

Рендеринг форматированного текста для iOS

http://18delphi.blogspot.ru/2013/10/coretext_30.html

На следующей неделе придётся к этому вернуться. Что-то недоделал там. Надеюсь - быстро доделаю.

Рефакторинг. Преодоление "алгоритма маляра".

По мотивам - ToDo. Написать как замена "ассемблера" на нормальное ООП привело к отказу от "алгоритма маляра"

Было:

procedure   Tm3StorageStream.Seek(AOffset     : Int64;
                                  AOrigin     : TSeekOrigin;
                                  var AResult : Int64;
                                  var AReturn : HRESULT
                                 );
 
 procedure    __Seek(const APosition: Int64;
                     var   AResult: Int64
                    );
 var
       LCount:                   Int64;
       LPosition1:               Int64;
       LPosition2:               Int64;
       LPosition3:               Int64;
 begin
 
  with f_StreamHeader.TOCItemDataPtr^.RBody do
   begin
 
    if ((APosition >= 0) and (APosition <= RRealSize))
     then
      begin
 
       if (APosition = FPosition)
        then
        else
         begin
 
          LPosition1:=FPosition-FTOCBuffBodyOffset;
 
          if ((APosition >= LPosition1) and (APosition < (LPosition1+TOCBuffBodySize)))
           then
            begin
 
             FTOCBuffBodyOffset:=APosition-LPosition1;
 
            end
           else
            begin
 
             with f_StreamHeader.FRootStreamManager do
              begin
 
               SaveTOCBuffData(RTOCBuffRootPosition, f_CurFilePos,
                               FTOCBuffData^, FTOCBuffDataCompare^,
                               FTOCBuffDataModifed, ReadOnly);
 
               LPosition2:=Int64(-1);
               LPosition3:=RTOCBuffRootPosition;
 
               LCount:=APosition div FTOCBuffBodySize;
 
               while (LCount <> 0) do
                begin
 
                 LoadTOCBuffData(LPosition2,LPosition3,LPosition2,
                                 FTOCBuffData^,FTOCBuffDataCompare^,
                                 FTOCBuffDataModifed,False);
 
                 LPosition3:=FTOCBuffData^.RNextPosition;
 
                 Dec(LCount);
 
                end;
 
               LoadTOCBuffData(LPosition2,LPosition3, f_CurFilePos,
                               FTOCBuffData^,FTOCBuffDataCompare^,
                               FTOCBuffDataModifed,True);
 
               FTOCBuffBodyOffset:=APosition mod FTOCBuffBodySize;
 
              end;
 
            end;
 
          FPosition:=APosition;
 
         end;
 
      end
     else
      begin
 
       Exit;
 
      end;
 
   end;
 
  AResult:=APosition;
 
 end;
 
begin
 
 if SUCCEEDED(AReturn)
  then
   begin
 
    case AOrigin of
 
     soBeginning: begin
 
                       __Seek(AOffset,AResult);
 
                      end;
 
     soCurrent: begin
 
                       __Seek(AOffset+FPosition,AResult);
 
                      end;
 
     soEnd: begin
 
                       __Seek(AOffset + f_StreamHeader.TOCItemDataPtr^.RBody.RRealSize, aResult);
 
                      end;
 
     else             begin
 
                       OleError(E_UNEXPECTED);
 
                      end;
 
    end;
     
   end;
 
end;

Стало:

procedure Tm3NewStorageStreamPrim.Seek(anOffset: Int64;
  anOrigin: TSeekOrigin;
  var theResult: Int64;
  var theReturn: hResult);
//#UC START# *4FA27D5302C5_5448F0A40180_var*

 procedure __Seek(const aPosition: Int64;
                  var   theResult: Int64);
 var
  l_Next : Tm3StorageBlock;
  l_BlockIndex : Int64;
 begin//__Seek
  if ((APosition >= 0) and (APosition <= f_HeaderData.RRealSize)) then
  begin
   if (APosition <> f_Position) then
   begin
    l_BlockIndex := APosition div f_HeaderData.Stream.ClusterBodySize;

    if (l_BlockIndex <> f_Block.Index) then
    begin
     if (l_BlockIndex = 0) then
     begin
      FreeAndNil(f_Block);
      f_Block := Tm3StorageBlock.Create(f_HeaderData);
     end//l_BlockIndex = 0
     else
     if (l_BlockIndex > f_Block.Index) then
     begin
      while (l_BlockIndex <> f_Block.Index) do
      begin
       l_Next := f_Block.CreateNext;
       try
        l_Next.SetRefTo(f_Block);
       finally
        FreeAndNil(l_Next);
       end;//try..finally
      end;//l_BlockIndex <> f_Block.Index
     end//l_BlockIndex > f_Block.Index
     else
     if (l_BlockIndex < f_Block.Index) then
     begin
      while (l_BlockIndex <> f_Block.Index) do
      begin
       l_Next := f_Block.CreatePrev;
       try
        l_Next.SetRefTo(f_Block);
       finally
        FreeAndNil(l_Next);
       end;//try..finally
      end;//l_BlockIndex <> f_Block.Index
     end;//l_BlockIndex > f_Block.Index
    end;//l_BlockIndex <> f_Block.Index

    Assert(l_BlockIndex = f_Block.Index);

    f_Block.SetPositionInStream(aPosition);
    f_Position := aPosition;
   end;//APosition <> FPosition
  end//((APosition >= 0) and (APosition <= RRealSize))
  else
   Assert(false, 'Смещаемся за границу потока');
  theResult := f_Position;
 end;//__Seek

//#UC END# *4FA27D5302C5_5448F0A40180_var*
begin
//#UC START# *4FA27D5302C5_5448F0A40180_impl*
 if SUCCEEDED(theReturn) then
 begin
  case anOrigin of
   soBeginning:
    __Seek(anOffset, theResult);
   soCurrent:
    __Seek(anOffset + f_Position, theResult);
   soEnd:
    __Seek(anOffset + f_HeaderData.RRealSize, theResult);
   else
   begin
    Assert(false, 'Неверный anOrigin');
    OleError(E_UNEXPECTED);
   end;//else
  end;//case anOrigin
 end;//SUCCEEDED(theReturn)
//#UC END# *4FA27D5302C5_5448F0A40180_impl*
end;//Tm3NewStorageStreamPrim.Seek

Или в "самом актуальном прочтении":

procedure Tm3NewStorageStreamPrim.Seek(anOffset: Int64;
  anOrigin: TSeekOrigin;
  var theResult: Int64;
  var theReturn: hResult);
//#UC START# *4FA27D5302C5_5448F0A40180_var*

 procedure __Seek(const aPosition: Int64;
                  var   theResult: Int64);
 var
  l_Next : Tm3StorageBlock;
  l_BlockIndex : Int64;
 begin//__Seek
  if ((APosition >= 0) and (APosition <= f_HeaderData.RRealSize)) then
  begin
   if (APosition <> f_Position) then
   begin
    Assert(f_Block <> nil);
    f_Block.MoveTo(aPosition, f_Block);
   end;//APosition <> FPosition
  end//((APosition >= 0) and (APosition <= RRealSize))
  else
   Assert(false, 'Смещаемся за границу потока');
  theResult := f_Position;
 end;//__Seek

//#UC END# *4FA27D5302C5_5448F0A40180_var*
begin
//#UC START# *4FA27D5302C5_5448F0A40180_impl*
 if SUCCEEDED(theReturn) then
 begin
  case anOrigin of
   soBeginning:
    __Seek(anOffset, theResult);
   soCurrent:
    __Seek(anOffset + f_Position, theResult);
   soEnd:
    __Seek(anOffset + f_HeaderData.RRealSize, theResult);
   else
   begin
    Assert(false, 'Неверный anOrigin');
    // - это "предусловие", оно НЕ ДОЛЖНО нарушаться
    OleError(E_UNEXPECTED);
   end;//else
  end;//case anOrigin
 end;//SUCCEEDED(theReturn)
//#UC END# *4FA27D5302C5_5448F0A40180_impl*
end;//Tm3NewStorageStreamPrim.Seek

среда, 29 октября 2014 г.

Коротко. Про DUnit и Delphi XE7

Офигенскую тут штуку "нашёл".

Открываем файл с классом:

unit msLine;

interface

uses
 msShape,
 FMX.Graphics,
 System.Types
 ;

type
 TmsLine = class(TmsShape)
 private
  FFinishPoint: TPointF;
 protected
  procedure DoDrawTo(const aCtx: TmsDrawContext); override;
  constructor CreateInner(const aStartPoint: TPointF); override;
  property FinishPoint : TPointF Read FFinishPoint write FFinishPoint;
 public
  function IsNeedsSecondClick : Boolean; override;
  procedure EndTo(const aCtx: TmsEndShapeContext); override;
  procedure MoveTo(const aFinishPoint: TPointF); override;
 end;

implementation

uses
 SysUtils,
 msPointCircle
 ;

constructor TmsLine.CreateInner(const aStartPoint: TPointF);
begin
 inherited;
 FinishPoint := aStartPoint;
end;

procedure TmsLine.EndTo(const aCtx: TmsEndShapeContext);
begin
 FinishPoint := aCtx.rStartPoint;
end;

procedure TmsLine.MoveTo(const aFinishPoint: TPointF);
begin
 Assert(false, 'Примитив ' + ClassName + ' не может быть перемещён');
end;

procedure TmsLine.DoDrawTo(const aCtx: TmsDrawContext);
var
 l_Proxy : TmsShape;
begin
 if (StartPoint = FinishPoint) then
 begin
  l_Proxy := TmsPointCircle.CreateInner(StartPoint);
  try
   l_Proxy.DrawTo(aCtx);
  finally
   FreeAndNil(l_Proxy);
  end;//try..finally
 end//StartPoint = FinishPoint
 else
  aCtx.rCanvas.DrawLine(StartPoint,
                   FinishPoint, 1);
end;

function TmsLine.IsNeedsSecondClick: Boolean;
begin
 Result := true;
end;

end.

Нажимаем Alt-F-N-O.

(File-New-Other)

Получаем:



Выбираем - Test Case.

Получаем:


Нажимаем "Next":

Получаем:

Нажимаем "Finish":

Получаем:

unit TestMsLine;
{

  Delphi DUnit Test Case
  ----------------------
  This unit contains a skeleton test case class generated by the Test Case Wizard.
  Modify the generated code to correctly setup and call the methods from the unit 
  being tested.

}

interface

uses
  TestFramework, msLine, FMX.Graphics, System.Types, msShape;

type
  // Test methods for class TmsLine

  TestTmsLine = class(TTestCase)
  strict private
    FmsLine: TmsLine;
  public
    procedure SetUp; override;
    procedure TearDown; override;
  published
    procedure TestIsNeedsSecondClick;
    procedure TestEndTo;
    procedure TestMoveTo;
  end;

implementation

procedure TestTmsLine.SetUp;
begin
  FmsLine := TmsLine.Create;
end;

procedure TestTmsLine.TearDown;
begin
  FmsLine.Free;
  FmsLine := nil;
end;

procedure TestTmsLine.TestIsNeedsSecondClick;
var
  ReturnValue: Boolean;
begin
  ReturnValue := FmsLine.IsNeedsSecondClick;
  // TODO: Validate method results
end;

procedure TestTmsLine.TestEndTo;
var
  aCtx: msShape.TmsMakeShapeContext;
begin
  // TODO: Setup method call parameters
  FmsLine.EndTo(aCtx);
  // TODO: Validate method results
end;

procedure TestTmsLine.TestMoveTo;
var
  aFinishPoint: TPointF;
begin
  // TODO: Setup method call parameters
  FmsLine.MoveTo(aFinishPoint);
  // TODO: Validate method results
end;

initialization
  // Register any test cases with the test runner
  RegisterTest(TestTmsLine.Suite);
end.

Вуаля!

Мы получили "каркас тестов" нашего класса.

Скажем так...Для меня ЛИЧНО - Embarcadero - "открыли Америку". От них - не ожидал.

Приятно :-) Хотя и "требует доработки".

Смежная тема - Коротко. Добавляем "банальные" тесты к нашему приложению