C уважением дарю вам программу на турбо паскале!
Это графический редактор.
Вот код программы:
Program redator;
uses crt,graph,dos;
var aas,aad,zx,zy,ax,ay,n,x,y,m,err,h:integer;
var ddd:searchrec;
var a,buf:array[1..127,1..84] of byte;
var gif:array[1..2,1..5,1..5] of byte;
var ex,file1,filename,xstr,ystr,Atr:string[100];
var i:char;
var def:boolean;
var col,block,bget,get,cir,color,linereg,step,n1,x1,y1,x2,y2,m1,ff,dc:byte;
var f1,f2,f3:text;
label g,l1,l,l3;
procedure default;
begin;
assign(f3,''DEFAULT'');
def:=true;
reset(f3);
readln(f3,filename);
gotoxy(25,2);writeln(filename);
readln(f3,atr);
xstr:=copy(atr,1,pos(''x'',atr)-1);
ystr:=copy(atr,pos(''x'',atr)+1,length(atr)-1);
val(xstr,x,err);
val(ystr,y,err);
end;
procedure clear;
begin
setfillstyle(1,0);
bar(4+(zx-1)*step,4+(zy-1)*step,2+step+(zx-1)*step,2+step+(zy-1)*step);
setfillstyle(1,a[zx,zy]);
floodfill(4+(zx-1)*step,4+(zy-1)*step,15);
end;
procedure pixel;
begin
ff:=a[zx,zy];
if ff<15 then dc:=15;
if ff=15 then dc:=0;
setcolor(dc);
line(8+(zx-1)*step,5+(zy-1)*step,8+(zx-1)*step,11+(zy-1)*step);
line(5+(zx-1)*step,8+(zy-1)*step,11+(zx-1)*step,8+(zy-1)*step);
end;
procedure new;
begin
setfillstyle(1,0);
for m:=1 to ay do begin
for n:=1 to ax do begin
bar(4+(n-1)*step,4+(m-1)*step,2+step+(n-1)*step,2+step+(m-1)*step);
setfillstyle(1,a[n,m]);
floodfill(4+(n-1)*step,4+(m-1)*step,15);
putpixel(351+n,420+m,a[n,m]);
end;
end;
end;
procedure out;
begin;
setfillstyle(1,0);
for m:=1 to ay do begin
for n:=1 to ax do begin
bar(4+(n-1)*step,4+(m-1)*step,2+step+(n-1)*step,2+step+(m-1)*step);
setfillstyle(1,getpixel(351+n,420+m));
floodfill(4+(n-1)*step,4+(m-1)*step,15);
a[n,m]:=getpixel(351+n,420+m);
end;
end;
end;
procedure setcol(x:byte);
begin
setfillstyle(1,0);
bar(2,472,16*20+15,478);
setcolor(6);line(15+x*20,472,13+x*20,474);line(15+x*20,472,17+x*20,474);
col:=x;
end;
begin
def:=false;
assign(f1,''prog/file'');
reset(f1);
for h:=1 to 2 do begin
for m:=1 to 5 do begin
for n:=1 to 5 do begin
read(f1,i);
if i=''1'' then gif[h,n,m]:=1 else gif[h,n,m]:=0;
end;
readln(f1);
end;
readln(f1);
end;
aas:=detect;
initgraph(aas,aad,''bgi'');
clrscr;cleardevice;
setcolor(7);rectangle(1,1,639,479);
setcolor(2);
outtextxy(10,20,''Please,enter file name:'');
gotoxy(25,2);read(filename);
if filename='''' then default else begin
assign(f3,''DEFAULT'');
rewrite(f3);
writeln(f3,filename);
end;
findfirst(filename,$01,ddd);
err:=doserror;
assign(f2,filename);
if err<>0 then rewrite(f2) else append(f2);
outtextxy(10,38+16,''Please,enter file size:'');
setcolor(14);rectangle(60,60+16,148,148+16);
setcolor(13);rectangle(191,15,192+80,22+10);
setcolor(3);line(50,50+16,140,50+16);line(50,50+16,50,140+16);
line(140,50+16,137,47+16);line(140,50+16,137,53+16);
line(50,140+16,47,137+16);line(50,140+16,53,137+16);
setcolor(4);outtextxy(143,47+16,''X'');outtextxy(47,143+16,''Y'');
setfillstyle(7,8);floodfill(65,65+16,14);
textcolor(2);
if def=true then begin
ax:=x;
ay:=y;
goto l3;
end;
outtextxy(2,165+16,''X:'');gotoxy(3,12);read(ax);
outtextxy(2,181+16,''Y:'');gotoxy(3,13);read(ay);
str(ax,xstr);str(ay,ystr);
writeln(f3,xstr+''x''+ystr);
close(f3);
l3:cleardevice;
setcolor(7);rectangle(1,1,639,479);
for n:=0 to 15 do begin
setcolor(15);
rectangle(10+n*20,460,20+n*20,470);
setfillstyle(1,n);floodfill(12+n*20,462,15);
setcolor(4);
str(n,ex);
if n>9 then ex:=chr(87+n);
outtextxy(13+n*20,449,ex);
end;
setcolor(15);rectangle(1,420,16*20+16,479);
setcolor(2);
outtextxy(13,433,''Press shift+color to change color:'');
color:=1;
setcol(4);
setcolor(15);
step:=10;
rectangle(3,3,ax*step+3,ay*step+3);
rectangle(351,420,352+ax,421+ay);
for n:=1 to ay do begin
line(3,3+(n-1)*step,3+(ax)*step,3+(n-1)*step);
end;
for n:=1 to ax do begin
line(3+(n-1)*step,3,3+(n-1)*step,3+(ay)*step);
end;
zx:=1;zy:=1;
new;
pixel;
g:i:=readkey;
if (i=''6'') and (zx<ax) then begin
clear;zx:=zx+1;pixel;
end;
if (i=''4'') and (zx>1) then begin
clear;zx:=zx-1;pixel;
end;
if (i=''8'') and (zy>1) and (block=0) then begin
clear;zy:=zy-1;pixel;
end;
if (i=''2'') and (zy<ay) and (block=0) then begin
clear;zy:=zy+1;pixel;
end;
case i of
''!'':setcol(1);
''@'':setcol(2);
''#'':setcol(3);
''$'':setcol(4);
''%'':setcol(5);
''^'':setcol(6);
''&'':setcol(7);
''*'':setcol(8);
''('':setcol(9);
'')'':setcol(0);
''A'':setcol(10);
''B'':setcol(11);
''C'':setcol(12);
''D'':setcol(13);
''E'':setcol(14);
''F'':setcol(15);
end;
if i=''q'' then begin
for m:=1 to ay do begin
for n:=1 to ax do begin
a[n,m]:=0;
end;
end;
new;
end;
if i=''0'' then begin
a[zx,zy]:=0;
clear;pixel;putpixel(351+zx,420+zy,0);
goto l;
end;
if i='' '' then begin
a[zx,zy]:=col;
clear;pixel;putpixel(351+zx,420+zy,a[zx,zy]);
end;
l:if (i=''l'') and (linereg=1) then begin
setcolor(col);
line(351+x1,420+y1,351+zx,420+zy);
linereg:=0;i:='' '';
out;
end;
if (i=''r'') and (linereg=1) then begin
setcolor(col);
rectangle(351+x1,420+y1,351+zx,420+zy);
linereg:=0;i:='' '';a[zx,zy]:=col;
out;
end;
if ((i=''l'') or (i=''r'')) and (linereg=0) then begin
x1:=zx;y1:=zy;
a[zx,zy]:=4;pixel;
linereg:=1
end;
if (i=''c'') and (cir=1) then begin
setcolor(col);
circle(351+x2,420+y2,abs(zx-x2));
cir:=0;i:='' '';
out;
block:=0;
end;
if (i=''c'') and (cir=0) then begin
block:=1;
x2:=zx;y2:=zy;
a[zx,zy]:=14;pixel;
cir:=1;
end;
if (i=''w'') then begin
for m:=1 to ay do begin
for n:=1 to ax do begin
if a[n,m]<10 then write(f2,a[n,m]);
if a[n,m]=10 then write(f2,''A'');
if a[n,m]=11 then write(f2,''B'');
if a[n,m]=12 then write(f2,''C'');
if a[n,m]=13 then write(f2,''D'');
if a[n,m]=14 then write(f2,''E'');
if a[n,m]=15 then write(f2,''F'');
end;
writeln(f2);
end;
setcolor(1);
outtextxy(600,460,''Ok!'');
for n:=1 to 1000 do delay(100);
setfillstyle(1,0);
bar(580,440,637,478);
while keypressed do i:=readkey;
end;
if i=''e'' then goto l1;
goto g;
repeat until keypressed;
l1:close(f2);
end.
(Только место .". там не .".)
Управление:
2,4,8,6 на боковой клаве--движения курсора.
Shift+цыфра--Установить цвет.
"W"--записатьрисунок в файл.
"Е"--выход(Для нормальной записи это обязательно).
"L"--поставить начальные координаты линии(Будущей).
"L"--поставить конечные координаты линии.
"R"--тоже самое,но прямоугольник.
"С"--Круг(Центр-радиус).
"Spase"--поставить точку.
"0"--стереть точку.
Примечание:Caps lock должен быть выключен,а Num lock-включён.
После запуска набирается имя рисунка и его размер(В пикселях).
Рядом з программой надо создать файл без расширения с именем "Default".
то нужно для того,чтобы при вводе имени рисунка можно было нажать Enter и прога автоматически будет дописывать в прошлый рисунок.
Я думаю,с кодами рисунков вы разбиретесь.
Если нет,то обращайтесь по мылу.
ЗЫ:Плиз!Добавте эту прогу в список игрушек!
