Нужна помощь для работы с файлом Опции

[BRS]

Вобщем так, если кому не лень - помогите с программой.
Пишу данный проэкт исключительно из любопытства и для себя )))

Вобщем так. Вот код программы:

Код

program Paint;

uses
  screen, myunit, crt, graph;

var
  x, y,color, size  : integer;
  key               : char;
  brush             : boolean;

begin
IG;
logo;
userscreen;
brush := false;x := (getmaxx + 120) div 2; y := getmaxy div 2; size := 1; color := 15;
repeat
  cursor(x,y);
  key := readkey;
  case ord(key) of
     72: begin
   if (brush = true) and (y <> 16) then
      begin
      y := y - 1;
      putpoint(x,y,size,color);
      end;
   if (brush <> true) and (y <> 16) then
      y := y - 1;
   end;
     75: begin
   if (brush = true) and (x <> 131) then
      begin
      x := x - 1;
      putpoint(x,y,size,color);
      end;
   if (brush <> true) and (x <> 131) then
      x := x - 1;
   end;
     80: begin
   if (brush = true) and (y <> getmaxy  - 16) then
      begin
      y := y + 1;
      putpoint(x,y,size,color);
      end;
   if (brush <> true) and (y <> getmaxy  - 16) then
      y := y + 1;
   end;
     77: begin
   if (brush = true) and (x <> getmaxx - 16) then
      begin
      x := x + 1;
      putpoint(x,y,size,color);
      end;
   if (brush <> true) and (x <> getmaxx  - 16) then
      x := x + 1;
   end;
     49: color :=  1;
     50: color :=  9;
     51: color :=  2;
     52: color :=  4;
     53: color :=  5;
     54: color :=  6;
     55: color := 14;
     56: color := 15;
     57: color :=  0;
     99: begin
   cleardevice;
   userscreen;
   brush := false;x := (getmaxx + 120) div 2; y := getmaxy div 2; size := 1; color := 15;
   end;
     9: begin
   brush := not brush;
   if brush = true then putpoint(x,y,size,color);
   end;
     61: if size < 10 then size := size + 1;
     45: if size > 1 then size := size - 1;
  end;
until ord(key) = 27;
closeGraph;
end.

Вот модули:

Код

unit screen;

interface
  uses crt, graph;
  var x, y : integer;
  procedure logo;
  procedure userscreen;
  procedure cursor(x,y : integer);

implementation

procedure logo;
     var i : integer;
  begin
  settextstyle(0,0,3);
  outtextxy(125,200, 'Turbo Brush v 1.0');
  repeat
  for i := 1 to 10 do
     begin
     arc(getmaxx div 2,460,360,180,i*20);
     delay(2000);
     end;
  setcolor(0);
  for i := 1 to 10 do
     begin
     arc(getmaxx div 2,460,360,180,i*20);
     delay(2000);
     end;
  setcolor(15);
  until keypressed;
  cleardevice;
  settextstyle(0,0,0);
  end;

procedure userscreen;
  begin
  y := 25; x := 15;
  line(120,5,120,getmaxy-5);
  line(120,5,getmaxx-5,5);
  line(getmaxx-5,5,getmaxx-5,getmaxy-5);
  line(getmaxx-5,getmaxy-5,120,getmaxy-5);
  setfillstyle(1,7);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Brush  TAB');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Left    <=');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Right   =>');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Up      /\');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Down    \/');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Size   +/-');y := y + 25;setcolor(15);
  bar3d(10,y-15,90,y,4,true);setcolor(0);outtextxy(x,y-10,'SetColor:');y := y + 25;setcolor(15);
   bar3d(10,y-15,20,y,4,true);
   bar3d(10+20,y-15,20+20,y,4,true);
   bar3d(10+40,y-15,20+40,y,4,true);
   setcolor(1);outtextxy(x-3,y-10, '1');
   setcolor(9);outtextxy(x+17,y-10, '2');
   setcolor(2);outtextxy(x+37,y-10, '3');
   y := y + 25;setcolor(15);
   bar3d(10,y-15,20,y,4,true);
   bar3d(10+20,y-15,20+20,y,4,true);
   bar3d(10+40,y-15,20+40,y,4,true);
   setcolor(4);outtextxy(x-3,y-10, '4');
   setcolor(5);outtextxy(x+17,y-10, '5');
   setcolor(6);outtextxy(x+37,y-10, '6');
   y := y + 25;setcolor(15);
   bar3d(10,y-15,20,y,4,true);
   bar3d(10+20,y-15,20+20,y,4,true);
   bar3d(10+40,y-15,20+40,y,4,true);
   setcolor(14);outtextxy(x-3,y-10, '7');
   setcolor(15);outtextxy(x+17,y-10, '8');
   setcolor(0);outtextxy(x+37,y-10, '9');
   y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Clear    C');y := y + 25;setcolor(15);
  bar3d(10,y-15,100,y,4,true);setcolor(0);outtextxy(x,y-10,'Quit   ESC');y := y + 25;setcolor(15);
  end;

procedure cursor(x,y : integer);
     var pix_0,pix_11,pix_12,pix_21,pix_22,pix_31,pix_32,pix_41,pix_42 : word;
  begin
  pix_0  := getpixel(x,y);
  pix_11 := getpixel(x-1,y);pix_12 := getpixel(x-2,y);
  pix_21 := getpixel(x+1,y);pix_22 := getpixel(x+2,y);
  pix_31 := getpixel(x,y-1);pix_32 := getpixel(x,y-2);
  pix_41 := getpixel(x,y+1);pix_42 := getpixel(x,y+2);
  repeat
  putpixel(x,y,8);
  putpixel(x-1,y,8);putpixel(x,y+2,8);
  putpixel(x+1,y,8);putpixel(x,y-2,8);
  putpixel(x,y-1,8);putpixel(x,y+2,8);
  putpixel(x,y+1,8);putpixel(x,y-2,8);
  until keypressed;
  putpixel(x,y, pix_0);
  putpixel(x-1,y, pix_11);putpixel(x-2,y, pix_12);
  putpixel(x+1,y, pix_21);putpixel(x+2,y, pix_22);
  putpixel(x,y-1, pix_31);putpixel(x,y-2, pix_32);
  putpixel(x,y+1, pix_41);putpixel(x,y+2, pix_42);
  end;

end.

Код

unit
  MyUnit;

interface
  uses graph,crt;
  procedure IG;
  procedure PutPoint(x,y,size,color : integer);
  function Grade(a,x : real) : real;

implementation

procedure IG;
     var GD, GM, Error : integer;
  begin
  GD := Detect;
  InitGraph(GD, GM,'');
  Error := GraphResult;
  if Error <> grOk then
     begin
     writeln('Graphics error:', GraphErrorMsg(Error));
     writeln('Press any key...');
     readkey;
     clrscr;
     halt;
     end;
  end;

procedure PutPoint(x,y,size,color : integer);
     var i,j,k, center : integer;
  begin
  if size > 10 then size := 10;
  if size < 1 then size := 1;
  j := 1;
  for i := 1 to size do
     begin
     k := j;
     j := j + 2;
     end;
  size := k; center := size div 2 + 1;
  for i := 1 to size do
     for j := 1 to size do
        putpixel(i + x - center, j + y - center, color);
  end;

function Grade(a, x: real): real;
  begin
  grade := Exp(a*Ln(x));
  end;

end.

Пока что мне собственно необходима помощь вот в чем...

Мне необходимо написать модуль работы с файлами.
Процедура SaveIM(name) должна сохранять рабочую область (диагональ (120,5,getmaxx-5,getmaxy-5)) в файл name.
Процедура OpenIm(name) дожна заполнять ту же рабочую область ранее сохраненным изображением в файле name.

[volvo]

Должно работать - проверь...

Код

unit FileUnit;

Interface

{ Функция вернет False если не сможет создать файл с изображением }
Function SaveImage( name: String;
        xSt, ySt, xFn, yFn: Integer ): Boolean;
Procedure LoadImage( name: String;
         xSt, ySt: Integer );

Implementation
Uses Graph;

Function SaveImage( name: String;
        xSt, ySt, xFn, yFn: Integer ): Boolean;
 Var
   Size: Integer;
   p: Pointer;
   f: File;
 Begin
   size := ImageSize(xSt, ySt, xFn, yFn);
   GetMem(p, size);
   GetImage(xSt, ySt, xFn, yFn, p^);

   SaveImage := False;
   Assign(f, name);
   {$I-} ReWrite(f, size); {$I+}
   If IOResult <> 0 Then Exit;

   BlockWrite(f, p^, 1);
   Close(f);
   { !!! Маленькое исправление !!! }
   FreeMem(p, size);
   SaveImage := True;
 End;

Procedure LoadImage( name: String;
         xSt, ySt: Integer );
 Var
   f: File;
   size: LongInt;
   p: Pointer;
 Begin
   Assign(f, name);
   {$I-} Reset(f, 1); {$I+}
   If IOResult <> 0 Then Exit;

   size := FileSize(f);
   Reset(f, size);
   GetMem(p, size);
   BlockRead(f, p^, 1);

   PutImage(xSt, ySt, p^, CopyPut);
   FreeMem(p, size);
 End;

END.

Вызов -

Код

...
SaveImage(120,5,getmaxx-5,getmaxy-5);
...
LoadImage(120,5);
...

Маленькое исправление -
Добавлен вызов FreeMem для освобождения динамической памяти...

Сообщение отредактировано: volvo - 4.11.2004 17:34

[volvo]

BRS

Кстати, у тебя код в главной программе можно сократить, если вместо:

Код

  case ord(key) of
    ...
    49: color :=  1;
    50: color :=  9;
    51: color :=  2;
    52: color :=  4;
    53: color :=  5;
    54: color :=  6;
    55: color := 14;
    56: color := 15;
    57: color :=  0;
    ...
  end;

написАть так:

Код

{ Перед основной программой }
const
 colors: array[49 .. 57] of byte =
   (1, 9, 2, 4, 5, 6, 14, 15, 0);

...
Begin
...
  case ord(key) of
    ...
    49..57: color := colors[Ord(key)];
    ...
  end;
...
End.

А условия типа :

Код

   if (brush = true) and (y <> 16) then
     begin
     y := y - 1;
     putpoint(x,y,size,color);
     end;
  if (brush <> true) and (y <> 16) then
     y := y - 1;

переписать так:

Код

 if y <> 16 then
   begin
     dec(y);
     if brush then putpoint(x, y, size, color);
   end;

Сообщение отредактировано: volvo - 4.11.2004 17:28

[BRS]

Сенькс. Щас проверю

[BRS]

Не сохраняет...
Проверьте еще кто нить...

[volvo]

BRS

Только что проверил... Процедуры работают, но есть одна проблема: ты передаешь слишком большую область для сохранения, и функция ImageSize возвращает 0... попробуй изменить процедуру так, что она будет делить заданную тобой область на 4 (например) части и сохранять их в файле одну за другой ...

[BRS]

Попробуем