VPF::Проблемы с памятью - Форум программистов

ALeXandrK

Дата 16.7.2007, 22:21 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 342
Регистрация: 31.1.2007
Где: Санкт-Петербург

Репутация: 3
Всего: 6

Задача в общем: Есть объект "TExercise = class(TImage)" - олицетворяет одно занятие в учебном учреждении,
есть список всех занятий "TExercisesList = class", в котором соответственно "Exercise:PExercise" - указатель на текущее
активное занятие.
Список и объекты создаются нормально (проверено в debug-ере), но как только я пытаюсь нарисовать текущее занятие,
вылетает ошибка знакомая пожалуй всем: "Access vialation ...".
По дебагеру отследил где происходит метаморфоз: при заходе в процедуру "procedure TExercisesList.Draw(const FromIndex: integer);",
а точнее, когда выделяется память под переменные, объявленные в var, т.е. "var AlsoWidth,AlsoHeight:integer;".
Я следил в дебагере, когда эти переменные инициализуруются, то весь текущий Exercise толи сдвигается, то ли
затирается, вообщем указатель начинает указывать на полный бред.
Что у меня тут не так??? Вот в чём вопрос =)

Вот код:

Код


type PExercise = ^TExercise;
 TExercise = class(TImage)
 private
   FidExercise:integer;
   FMove:boolean;
 protected
   procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
   procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
 public
   Hours:byte;
   Next:PExercise;
   Prior:PExercise;
   BorderColor:TColor;
   Color:TColor;
   Caption:TText;
   ExtraCaption:TExtraCaption;
   constructor Create(AOwner:TComponent;const idExercise:integer;
     const Text:string; const Amount:byte;
     const Color:TColor); reintroduce; overload;
   destructor Destroy; override;
   procedure Draw(const Left,Top,Width,Height:integer);
   procedure Hide;
 published
   property IdExersice:Integer read FidExercise write FidExercise;
 end;

type TExercisesList = class
  private
    FEmpty:boolean;
    FFirst:PExercise;
    FLast:PExercise;
    FVisibleCount:integer;
    FFirstVisibleIndex:integer;
    FCount:integer;
    function MoveTo(Index:integer):boolean;
    function CanDraw:integer;
  protected
  public
    Parent:TWinControl;
    Exercise:PExercise;
    IntervalHeight:integer;
    IntervalWidth:integer;
    Width:integer;
    Height:Integer;
    constructor Create(AOwner: TWinControl);
    destructor Destroy; override;
    procedure Next;
    procedure Prior;
    procedure Last;
    procedure First;
    procedure Add(const idExercise:integer; const Text:string;
                  Amount:byte; const Color:TColor);
    procedure Delete(const Index:integer);
    procedure Draw(const FromIndex:integer);
    procedure DrawNext;
    procedure DrawPrior;
    procedure HideAll;
    procedure Clear;
  published
    property Count:integer read FCount;
end;

Вот реализация классов:

Код


{ TExercise }
{$REGION 'TExercise'}
constructor TExercise.Create(AOwner:TComponent; const idExercise: integer;
              const Text:string; const Amount: byte;const Color:TColor);
begin
  inherited Create(AOwner);
  FidExercise := idExercise;
  FMove := False;
  Visible := False;
  Transparent := False;
  Next := nil;
  Prior := nil;
  Caption.Text := Text;
  Self.Color := Color;
  Hours := Amount;
  if Hours > 0 then
  begin
    ExtraCaption.Caption.Text := inttostr(Hours);
    ExtraCaption.Visible := true;
  end
  else ExtraCaption.Visible := false;
end;

destructor TExercise.Destroy;
begin
  inherited;
end;

procedure TExercise.Draw(const Left,Top,Width,Height:integer);
var Text:string;
begin
Self.Left := Left;
Self.Top := Top;
Self.Width := Width;
Self.Height := Height;
  with Canvas do
   begin
     Brush.Color := Color;
     //Печатаем основной текст по центру
     FillRect(ClientRect);
     Canvas.Font := Caption.Font;
     Text := Caption.Text;
     TextOut((Width-TextWidth(Text)) div 2,
      (Height-TextHeight(Text)) div 2,Text);
     //Печатаем дополнительный текст внизу справа,
     //если нужно
     if ExtraCaption.Visible
     then
      begin
        Canvas.Font := ExtraCaption.Caption.Font;
        Text:= ExtraCaption.Caption.Text;
        TextOut(Width-TextWidth(Text)-1,
                Height-TextHeight(Text)-1, Text);
      end;
   end;
Visible := True;
end;

procedure TExercise.Hide;
begin
  Visible := False;
end;

procedure TExercise.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
end;

procedure TExercise.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
end;

procedure TExercise.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
 inherited;
  if Button=mbLeft then FMove := not(FMove);
  if Button=mbRight then FMove := false;
  if FMove then Screen.Cursor := crDrag else Screen.Cursor := crDefault;
end;

{$ENDREGION}

{ TExercisesList }
{$REGION 'TExercisesList'}
procedure TExercisesList.Add(const idExercise:integer;const Text:string;
                              Amount:byte; const Color:TColor);
var New : TExercise;
begin
inc(FCount);
New := TExercise.Create(Parent,idExercise,Text,Amount,Color);
New.Parent := Parent;
//Если список пуст
if (FEmpty)
then
 begin
  FFirst := @New;
  FEmpty := false;
 end
// Если список не пуст
else
 begin
  FLast := @New;
  Exercise.Next := @New;
  Exercise.Prior := Exercise;
 end;
FLast  := @New;
Exercise := @New;
end;

function TExercisesList.CanDraw: integer;
var AmountByHoriz,AmountByVert:integer;
begin
//Кол-во занятий по горизонтали
AmountByHoriz:=Ceil(Parent.Width / (1.5*IntervalWidth+Width));
//Кол-во занятий по вертикали
AmountByVert:=Ceil(Parent.Height /(1.5*IntervalHeight+Height));
Result := AmountByHoriz*AmountByVert;
end;

procedure TExercisesList.Clear;
var i:integer;
begin
if FEmpty then Exit;
for I := 0 to Count - 1 do
Delete(i);
end;

constructor TExercisesList.Create(AOwner: TWinControl);
begin
  inherited Create;
  Parent := AOwner;
  FEmpty := True;
  FVisibleCount:=0;
  FFirstVisibleIndex := -1;
  FFirst := nil;
  FLast := nil;
  FCount := 0;
  Height := 24;
  Width := 64;
  IntervalHeight := 5;
  IntervalWidth := 5;
end;

procedure TExercisesList.Delete(const Index: integer);
var Visible:boolean;
begin
if not(MoveTo(Index))then exit;

dec(FCount);

if Exercise.Visible then dec(FVisibleCount);
Visible := Exercise.Visible;
Exercise.Visible := False;
if FLast=FFirst then
begin
  FFirst.Destroy;
  FFirst := nil;
  FLast := nil;
  FFirstVisibleIndex := -1;
  FEmpty := true;
  exit;
end;
if Exercise=FLast then
begin
  FLast := FLast.Prior;
  FLast.Next := nil;
  Exercise.Destroy;
  if Visible then Draw(FFirstVisibleIndex);
  exit;
end;
if Exercise=FFirst then
begin
  FFirst := FFirst.Next;
  FFirst.Prior := nil;
  Exercise.Destroy;
  if Visible then Draw(0);
  exit;
end;
Exercise.Next.Prior := Exercise.Prior;
Exercise.Prior.Next := Exercise.Next;
Exercise.Destroy;
if Visible then Draw(FFirstVisibleIndex);
end;

destructor TExercisesList.Destroy;
begin
  Clear;
  inherited;
end;

procedure TExercisesList.Draw(const FromIndex: integer);
var AlsoWidth,AlsoHeight:integer;//ВОТ ТУТ НАЧИНАЕТСЯ НЕЛАДНОЕ!!!!!!!!!!!!!
begin
  HideAll;
  FFirstVisibleIndex := -1;
  FVisibleCount:=0;
if not(MoveTo(FromIndex)) then exit;
  AlsoWidth:=IntervalWidth;
  AlsoHeight:=IntervalHeight;
  while Height+AlsoHeight+IntervalHeight<Parent.Height do
  begin
    if Width+AlsoWidth+IntervalWidth>Parent.Width
    then AlsoHeight:=AlsoHeight+Height+IntervalHeight
    else
      begin
        Exercise.Draw(AlsoWidth,AlsoHeight,Width,Height);
        inc(FVisibleCount);
        AlsoWidth:=AlsoWidth+Width+IntervalWidth;
      end;
  end;    
  if FVisibleCount>0 then FFirstVisibleIndex:=FromIndex;  
end;

procedure TExercisesList.DrawNext;
var FromIndex:integer;
begin
//Определяем индекс первого прорисовываемого занятия
  FromIndex:=FFirstVisibleIndex+CanDraw;
//Если следующий индекс занятия превосходит
//кол-во всех занятий, то выходим
  if FromIndex>Count-1 then exit;
  Draw(FromIndex);
end;

procedure TExercisesList.DrawPrior;
var FromIndex:integer;
begin
//Определяем индекс первого прорисовываемого занятия
  FromIndex:=FFirstVisibleIndex-CanDraw;
//Если индекс меньше первого, то выходим
  if FromIndex<0 then exit;
  Draw(FromIndex);
end;

procedure TExercisesList.First;
begin
  Exercise := FFirst;
  Draw(0);
end;

procedure TExercisesList.HideAll;
var i,a:integer;
begin
if FFirstVisibleIndex = -1 then exit;
//Переходим на первое видимое занятие
  if FFirstVisibleIndex = 0
  then Exercise := FFirst
  else for a := 0 to FFirstVisibleIndex do Next;
//Прячем все видимые занятия
  for I := FFirstVisibleIndex to FVisibleCount +FFirstVisibleIndex do
  begin
    Exercise.Hide;
    Next;
  end;
//Переходим на первое занятие в списке
Exercise := FFirst;
end;

procedure TExercisesList.Last;
begin
  Exercise := FLast;
end;

function TExercisesList.MoveTo(Index: integer):boolean;
var i:integer;
begin
//Проверка на границы диапозона
if (Index<0) or FEmpty or (Index>=Count)
then
  begin
    Result := False;
    exit;
  end;
Exercise:=FFirst;

for I := 0 to Index-1 do
begin
  Exercise:=Exercise.Next;
end;
Result := True;
end;

procedure TExercisesList.Next;
begin
  Exercise :=  Exercise.Next;
end;

procedure TExercisesList.Prior;
begin
  Exercise :=  Exercise.Prior;
end;
{$ENDREGION}

Модули, необходимые для компиляции:

Код


uses Forms, Math, SysUtils, Graphics, ExtCtrls, Classes, Types, Messages, Controls;

Вот, что я делаю:

Код


...
var List:TExercisesList;
...
//Ну и по нажатью кнопки, например:
List := TExercisesList.Create(Panel1);
List.Add(13,'MyText',5,clRed);
List.Draw(0);

Это сообщение отредактировал(а) ALeXandrK - 16.7.2007, 23:08

Присоединённый файл ( Кол-во скачиваний: 7 )

experiments.rar 8,04 Kb

--------------------

Богат не/ни тот, у кого много, а тот, кому хватает

MetalFan

Дата 16.7.2007, 22:45 (ссылка)

(голосов:1)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

сорь, но ЖЭСТЬ...
зачем нужны указатели на указатели? (переменные классовых типов - те же указатели).
избавься везде от PExercise и будет тебе счастие

Добавлено через 1 минуту и 52 секунды
p.s. круто конечно, но как-то чего-то в архиве в аттаче для компиляции нехватает ;)

Добавлено через 2 минуты и 47 секунд
ну и в догонку

Цитата(ALeXandrK @ 16.7.2007, 22:21

)

  FMove := False;
  Visible := False;
  Transparent := False;
  Next := nil;
  Prior := nil;

абсолютно ненужные в конструкторе телодвижения...

--------------------

There are always someone smarter than you...

ALeXandrK

Дата 16.7.2007, 22:53 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 342
Регистрация: 31.1.2007
Где: Санкт-Петербург

Репутация: 3
Всего: 6

Убрал все PExercise, но всё осталось так же smile

Цитата

ну и в догонкуЦитата(ALeXandrK @  16.7.2007,  22:21 )
  FMove := False;
  Visible := False;
  Transparent := False;
  Next := nil;
  Prior := nil;

абсолютно ненужные в конструкторе телодвижения...

Это я уже от безысходности начал ерунду городить smile

Спасибо за поправку!

Это сообщение отредактировал(а) ALeXandrK - 16.7.2007, 22:54

--------------------

Богат не/ни тот, у кого много, а тот, кому хватает

Snowy

Дата 16.7.2007, 22:58 (ссылка)

(голосов:1)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

1. Объект уже есть указатель.
2. Зачем придумывать свой список, когда есть уже готовые классы?
3. В приложенном файле нет проекта, а смотреть весь код на глаз лениво...
Чую... Чую паскаль...

ALeXandrK

Дата 16.7.2007, 23:01 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 342
Регистрация: 31.1.2007
Где: Санкт-Петербург

Репутация: 3
Всего: 6

Цитата

p.s. круто конечно, но как-то чего-то в архиве в аттаче для компиляции нехватает ;)

Там все есть, просто лишнее было в Uses... (Unit2). Подправил smile

Цитата

1. Объект уже есть указатель.

Это я знал, но почему то при первых попытках ссылаться в класе на себя не получалось:
Delphi ругалась. Вот и пришлось правой рукой да левое ухо, а сейчас всё нормально smile

Цитата

2. Зачем придумывать свой список, когда есть уже готовые классы?

Думал, что так будет проще (ничего лишнего), но видимо зря пошел таким путем smile

Цитата

3. В приложенном файле нет проекта, а смотреть весь код на глаз лениво...

А как же я всё запускаю?? smile

из этого же аттача...

Это сообщение отредактировал(а) ALeXandrK - 16.7.2007, 23:07

--------------------

Богат не/ни тот, у кого много, а тот, кому хватает

Snowy

Дата 16.7.2007, 23:06 (ссылка)

(голосов:1)

Загрузка ...

Эксперт

Профиль
Группа: Модератор
Сообщений: 11363
Регистрация: 13.10.2004
Где: Питер

Репутация: 192
Всего: 484

Цитата(ALeXandrK @ 16.7.2007, 23:01

)

Там все есть, просто лишнее было в Uses... (Unit2). Подправил

Забыл саму суть - uExercises smile

ALeXandrK

Дата 16.7.2007, 23:08 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 342
Регистрация: 31.1.2007
Где: Санкт-Петербург

Репутация: 3
Всего: 6

АААА болбес smile

Подправил

Это сообщение отредактировал(а) ALeXandrK - 16.7.2007, 23:09

--------------------

Богат не/ни тот, у кого много, а тот, кому хватает

MetalFan

Дата 16.7.2007, 23:15 (ссылка)

(голосов:2)

Загрузка ...

Аццкий Сотона

Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128

Цитата(ALeXandrK @ 16.7.2007, 22:53

)

Убрал все PExercise

убери еще собак

Добавлено через 2 минуты и 29 секунд
да проверку на assigned(Caption.Font) при установке шрифта в 166 строке сделай

Это сообщение отредактировал(а) MetalFan - 16.7.2007, 23:15

--------------------

There are always someone smarter than you...

ALeXandrK

Дата 16.7.2007, 23:20 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 342
Регистрация: 31.1.2007
Где: Санкт-Петербург

Репутация: 3
Всего: 6

MetalFan : КРАСАВЕЦ!

Спасибо тебе! Все работает!

Snowy: Тоже спасибо!!!

--------------------

Богат не/ни тот, у кого много, а тот, кому хватает

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »