Модератор: Модераторы
unit wordsUnits;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,Types, Dialogs;
Type
PList=^List;
List=record
PForwards, PNext:PList;
Words:String;
end;
{ TListWords}
TListWords = class
private
Start,PosList, Finish:PList;
procedure SetItems(value:PList);virtual;
protected
public
property first:PList read start; // нет смысла в изменении данного указателя,
// если только не удаляется первый элемент
property Item:PList read PosList write SetItems; // указывает на текущий элемент списка
property Last:PList read Finish;// write SetFinish;
function next(value:Plist):PList;
function next:PList; // перегружено для удобства использования
function pred (value:Plist):Plist;
function pred:Plist; // перегружено для удобства использования
procedure Add (Str:String); //добавляет в конец списка
procedure Insert (Str:String);virtual; //добавляет в середину списка
procedure Del (index:PList); virtual;
function Cut (index:PList):Plist; virtual;
function CopyWords (index:PList):PList; virtual;
Procedure Clear; //очищает строку
procedure readString (Str:String);virtual; //преобразование строки во внутренний формат
Function WriteString:String;virtual;
procedure writeWords(index:PList; Str:String);virtual; //работа с отдельными словами
Function readWords (index:PList): String; virtual;
constructor Create;
destructor Destroy; override;
published
end;
TArrayWords=array of TListWords;// для вставки создания рабочей копии текста.
//
implementation
{ TListWords }
procedure TListWords.SetItems(value: PList);
begin
PosList:=Value;
end;
function TListWords.next(value:Plist): PList;
begin
Result:=value^.PNext;
end;
function TListWords.next: PList;
begin
Result:=PosList^.PNext;
end;
function TListWords.pred (value:Plist): Plist;
begin
Result:=value^.PForwards;
end;
function TListWords.pred: Plist;
begin
Result:=PosList^.PForwards;
end;
procedure TListWords.Add(Str: String);
begin
PosList:=Finish;
Insert(Str);
end;
procedure TListWords.Insert(Str: String);
var
point:PList;
begin
New (Point);
//проверка на пустоту списка
//(в этом случае указатели нельзя просто перенести)
if Start=nil then
begin
Start:=Point;
Finish:=Point;
PosList:=Point;
//с заполнением полей немного неудобно, но думаю обойдется
PosList^.Words:=Str;
PosList^.PForwards:=nil; //можно start, но пока не буду
PosList^.PNext:=nil; //можно Finish, но пока не буду
end
else // что делать когда элемент один?
//стандартная вставка
Begin
Point^.PNext:=PosList^.PNext; //переносим ссылки Start=PosList!
PosList^.PNext:=Point;
PosList:=Point^.PNext;//"шагаем" на следующий после Point элемент
Point^.PForwards:=PosList^.PForwards; //переносим ссылки
PosList^.PForwards:=Point;
PosList:=Point; // указатель должен стоять на вставляемом элементе
PosList^.Words:=Str;
end;
end;
procedure TListWords.Del(index: PList);
begin
if index=PosList then PosList:= next(PosList);//сдвигаем текущую позицию указателя чтобы он не повис
Index^.PForwards^.PNext:=Index^.PForwards^.PNext^.PNext; //обходим элемент
Index^.PNext^.PForwards:=Index^.PNext^.PForwards^.PForwards;
Dispose(Index);
end;
function TListWords.Cut(index: PList): Plist;
begin
Result:=CopyWords(Index);
Del (index);
end;
function TListWords.CopyWords(index: PList): PList; //по идее, это должна быть функцияч, но((
begin
Result^.PForwards:=nil; // нас не интересуют адреса
Result^.PNext:=nil;
Result^.Words:=index^.Words;
end;
procedure TListWords.Clear;
begin
while Start=finish do del(Start); //проверить условие
Start:=nil;
PosList:=nil;
Finish:=nil;
end;
//{
procedure TListWords.readString(Str: String); //строка преобразуется в набор слов
var
// tmpStr:String;
count:integer;
begin
//здесь потребуется создать элементы строки
if Str='' then exit //на выход
else
begin
if pos(' ',Str)=0 then
begin //пробел не найден все в результат
add (Str);
end
else
begin
//добавить проверку на пустоту строки
count:=pos(' ',Str);
if count=1 then begin end // пробел на первой позиции
else begin
Add(System.Copy(Str,1,count-1)); //-1 чтобы не копировать пробел
System.Delete(Str,1,count);
end;
end;
end;
end;
function TListWords.WriteString: String;
begin
PosList:=Start;
Result:='';
while PosList=Finish do result:=Result+''+PosList^.Words; //при использовании readString пробелы убираются.
end;
procedure TListWords.writeWords(index: PList; Str: String);
begin
index^.Words:=Str;
end;
function TListWords.readWords (index:PList): String;
begin
result:=index^.Words; //реально в "слове" могут быть пробелы и др. сисмволы
end;
constructor TListWords.Create;
begin
inherited Create;
ShowMessage('Ave!!!'); // окно не показывается!!!
Start:=nil;
PosList:=nil;
Finish:=nil;
end;
destructor TListWords.Destroy;
begin
Clear;
inherited Destroy;
end;
//}
end.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
WordsUnits;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
Lisp:TListWords;//проверяемый класс
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
Lisp.Create;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Lisp.Add(Form1.Edit1.Caption);//.Destroy; здесь выбрасывает ошибку.
end;
end.
var
MouseIsDown: boolean;
PX, PY: integer;
procedure TForm1.<Component>MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
MouseIsDown := True;
PX := X;
PY := Y;
end;
end;
procedure TForm1.<Component>MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if MouseIsDown then
begin
SetBounds(Form1.Left + (X - PX), Form1.Top + (Y - PY), Form1.Width, Form1.Height);
end;
end;
procedure TForm1.<Component>MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseIsDown:=False;
end;
zub писал(а):Настраивайте стек\кучу наздоровье - они тут совершенно непричем.
zub писал(а):Если писать нормально - никто никому ничего не должен, просто программа работает максимально быстро
Я сейчас проверил, ... . А значит, ... К сожалению, ..., что, для ... , практически сводит на нет возможность ...
Вернуться в Разработки на нашем сайте
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 10