Editor bitmapových obrázků pro programy Saloky
Delphi & Pascal (česká wiki)
Kategórie: KMP (Programy mladých programátorů)
Program: Bitmapy.pas
Soubor exe: Bitmapy.exe
Potřebné: Prechod.mf
Program: Bitmapy.pas
Soubor exe: Bitmapy.exe
Potřebné: Prechod.mf
Editor bitmapových obrázků pro programy Saloky.
{ BITMAPY.PAS } { Editor bitmapovych obrazkov pre programy Saloky. } { } { Author: Ľuboš Saloky } { Datum: 01.01.1996 http://www.trsek.com } {$G+} program Editor_bitmapovych_obrazkov; uses MukoGr,MukoUtil,Myska,Crt,Dos; {$DEFINE _______MAPEDIT} const PrikX=205;PrikY=10; MiniX=205;MiniY=140; {160,0} Font='prechod.mf'; RozPaleta=4; RozBitmapa=4; PocetOP=10; Aktiv:array[1..PocetOP,1..4] of word=( (0,0,0,0), {bitmapa - spracovane zvlast} (PrikX,PrikY,PrikX+16,PrikY+16), {<} (PrikX+20,PrikY,PrikX+36,PrikY+16), {>} (PrikX+40,PrikY,PrikX+80,PrikY+16), {novy} (PrikX,PrikY+20,PrikX+40,PrikY+36), {zmaz} (PrikX+45,PrikY+20,PrikX+109,PrikY+36), {odstran} (PrikX,PrikY+40,PrikX+56,PrikY+56), {koniec} (PrikX,PrikY+60,PrikX+16*RozPaleta,PrikY+60+16*RozPaleta), (PrikX+16*RozPaleta+2,PrikY+60,PrikX+22+RozPaleta*16,PrikY+60+16*RozPaleta), (PrikX+64,PrikY+40,PrikX+48+64,PrikY+56)); {subor} OLH:array[0..PocetOP]of string[40]=( '','Kliknutim poloz bod.','Predosla bitmapa.','Dalsia bitmapa.', 'Pridaj novu bitmapu.','Zmazanie bitmapy.','Odstranenie bitmapy.', 'Koniec programu.','Vyber si farbu.','Aktualna farba.','Subor s bitmapami'); Texty:array[2..10] of string[7]=('<','>','NOVA','ZMAZ','ODSTRAN','KONIEC','','','SUBOR'); var Udalost,UStara:integer; x,y,z,PomX,PomY,Kolko,Err:word; {kolko bajtov bolo nacitanych pri odstranovani} RozX,RozY,Color:byte; {rozmery aktualnej bitmapy a aktualna farba} AktBMP,Tlacidla:byte; {pocet a aktualna bitmapa} BMP:array[0..3601] of byte; {bitmapy max. 40*40} ASubor:SearchRec; {$IFDEF MAPEDIT} VsetkyBMP:array[0..28*24*24] of byte;{vsetky bitmapy} {$ENDIF} s,Subor:string; f:file; Odstr:longint; {pozicia 1. odstranovaneho bajtu} {$IFDEF MAPEDIT} procedure ZobrazSusedneBitmapy; const PosAktX=40;PosAktY=150; begin Nastav(PosAktX-16,PosAktY-16,0); VyplnPlochu(56,56); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+19) mod 24)*576); Nastav(PosAktX,PosAktY-16,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+20) mod 24)*576); Nastav(PosAktX+16,PosAktY-16,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+21) mod 24)*576); Nastav(PosAktX-16,PosAktY,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+22) mod 24)*576); Nastav(PosAktX,PosAktY,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+23) mod 24)*576); Nastav(PosAktX+16,PosAktY,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+24) mod 24)*576); Nastav(PosAktX-16,PosAktY+16,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+25) mod 24)*576); Nastav(PosAktX,PosAktY+16,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+26) mod 24)*576); Nastav(PosAktX+16,PosAktY+16,0); PrilepPriehladnuBitmapu(24,24,Ofs(VsetkyBMP)+((AktBMP+27) mod 24)*576); end; {$ENDIF} procedure NacitajBitmapu; begin BlockRead(f,RozX,1); BlockRead(f,RozY,1); BlockRead(f,BMP,RozX*RozY); end; procedure ZobrazBitmapu; var px,py:word; begin Nastav(0,0,0); VyplnPlochu(202,200); Nastav(MiniX-1,MiniY-1,0); VyplnPlochu(42,42); Nastav(MiniX-1,MiniY-1,15); Ramcek(RozX+2,RozY+2,0); for px:=0 to RozX-1 do for py:=0 to RozY-1 do begin Nastav(RozBitmapa*px,RozBitmapa*py,BMP[py*RozX+px]); VyplnPlochu(RozBitmapa,RozBitmapa); PolozBod(MiniX+px,MiniY+py,BMP[px+RozX*py]); end; for px:=0 to RozX do PolozBod(RozBitmapa*px,RozBitmapa*RozY+1,15); for py:=0 to RozY do PolozBod(RozBitmapa*RozX+1,RozBitmapa*py,15); Nastav(0,RozY*RozBitmapa,15); if RozY<>40 then CiaraVodorovna(RozX*RozBitmapa+1); Nastav(RozX*RozBitmapa,0,15); CiaraZvisla(RozY*RozBitmapa+1); end; procedure NovaBitmapa; begin VypniKurzorMysi; if Subor='' then begin Nastav(0,0,0); VyplnPlochu(201,200); VypisPriehladne('Nebol zvoleny subor.'#13'Bude vytvoreny novy.'#13#13'Meno suboru:',Hneda); Nastav(0,32,0); Citaj(12,Hneda); Subor:=Ret; Assign(f,Subor); ReWrite(f,1); BlockWrite(f,paleta,768); AktBMP:=0;RozX:=0;RozY:=0; BlockWrite(f,AktBMP,1); ZapniKurzorMysi; end; Seek(f,FilePos(f)-RozY*RozX); BlockWrite(f,BMP,RozY*RozX); Seek(f,768); BlockRead(f,AktBMP,1); Seek(f,768); Inc(AktBMP); BlockWrite(f,AktBMP,1); Seek(f,FileSize(f)); Nastav(0,0,0); {vyber rozmerov bitmapy} VyplnPlochu(201,200); VypisPriehladne('Zvol si velkost bitmapy.',SvetloModra); Nastav(0,16,0); VypisPriehladne('X-ova:',Hneda); Nastav(48,16,0); Citaj(3,Bordova); Val(Ret,RozX,Err); Nastav(0,24,0); VypisPriehladne('Y-ova:',Hneda); Nastav(48,24,0); Citaj(3,Bordova); Val(Ret,RozY,Err); BlockWrite(f,RozX,1); BlockWrite(f,RozY,1); for PomX:=0 to 3599 do BMP[PomX]:=0; BlockWrite(f,BMP,RozX*RozY); ZobrazBitmapu; ZapniKurzorMysi; end; procedure InicializujSubor; begin if Subor<>'' then begin Assign(f,Subor); {inicializacia suboru} {$I-} Reset(f,1); {$I+} if IOResult<>0 then begin ReWrite(f,1); BlockWrite(f,paleta,768); AktBMP:=0;RozX:=0;RozY:=0; BlockWrite(f,AktBMP,1); ZapniKurzorMysi; NovaBitmapa; end; {$IFDEF MAPEDIT} Seek(f,771); for x:=0 to 24 do begin BlockRead(f,VsetkyBMP[x*576],24*24); Seek(f,Filepos(f)+2); end; ZobrazSusedneBitmapy; {$ENDIF} Seek(f,769); NacitajBitmapu; ZobrazBitmapu; end; end; procedure InicializujPracovnuPlochu; begin VypniKurzorMysi; ZmazObrazovku; Nastav(Aktiv[8,1]-1,Aktiv[8,2]-1,15);{kreslenie obvodovych ciar okolo palety} Ramcek(16*RozPaleta+23,16*RozPaleta+2,0); Nastav(Aktiv[8,3],Aktiv[8,2],15); CiaraZvisla(16*RozPaleta+1); for x:=0 to 15 do {vykreslenie palety} for y:=0 to 15 do begin Nastav(PrikX+x*RozPaleta,PrikY+60+y*RozPaleta,x+16*y); VyplnPlochu(RozPaleta,RozPaleta); end; for x:=2 to 7 do begin {vykreslenie tlacidiel} Nastav(Aktiv[x,1],Aktiv[x,2],14); Ramcek(Aktiv[x,3]-Aktiv[x,1],Aktiv[x,4]-Aktiv[x,2],0); Nastav(Aktiv[x,1]+4,Aktiv[x,2]+4,0); VypisPriehladne(Texty[x],SvetloModra); end; Nastav(Aktiv[10,1],Aktiv[10,2],14); Ramcek(Aktiv[10,3]-Aktiv[10,1],Aktiv[10,4]-Aktiv[10,2],0); Nastav(Aktiv[10,1]+4,Aktiv[10,2]+4,0); VypisPriehladne(Texty[10],SvetloModra); AktBMP:=1;Color:=25; Nastav(Aktiv[8,3]+1,Aktiv[8,2],Color); VyplnPlochu(20,16*RozPaleta); ZapniKurzorMysi; end; BEGIN { ----- inicializacia ----- } Subor:=''; InicializujGrafiku; NacitajFontAPaletu(Font); InicializujPracovnuPlochu; InicializujSubor; ZapniKurzorMysi; { ----- cakanie na udalost ----- } UStara:=0; repeat repeat ZistiPoziciu(x,y,Tlacidla); x:=x div 2; Udalost:=0; for z:=1 to PocetOP do if (x>=Aktiv[z,1]) and (x<=Aktiv[z,3]) and (y>=Aktiv[z,2]) and (y<=Aktiv[z,4]) then Udalost:=z; if (x<RozBitmapa*RozX) and (y<RozBitmapa*RozY) then Udalost:=1; if (Udalost<>UStara) and (RozY<38) then begin VypniKurzorMysi; Nastav(0,192,0); VyplnPlochu(201,8); VypisPriehladne(OLH[Udalost],SvetloModra); UStara:=Udalost; ZapniKurzorMysi; end; until Tlacidla>0; if (Udalost<>8) and (Udalost<>1) then repeat ZistiPoziciu(PomX,PomY,Tlacidla); until Tlacidla=0; { ----- spracovanie udalosti ----- } case Udalost of 1:begin{kreslenie bitmapy} PomX:=x div RozBitmapa; PomY:=y div RozBitmapa; if BMP[PomX+PomY*RozX]<>Color then begin VypniKurzorMysi; Nastav(PomX*RozBitmapa,PomY*RozBitmapa,Color); VyplnPlochu(RozBitmapa,RozBitmapa); BMP[PomX+PomY*RozX]:=Color; PolozBod(MiniX+PomX,MiniY+PomY,Color); {$IFDEF MAPEDIT} VsetkyBMP[AktBMP*576+PomY*24+PomX]:=Color; PolozBod(40+PomX,150+PomY,Color); {$ENDIF} ZapniKurzorMysi; end; end; 2:begin{predosla bitmapa} Seek(f,FilePos(f)-RozY*RozX); BlockWrite(f,BMP,RozY*RozX); if AktBMP>1 then begin Seek(f,769); for PomX:=1 to AktBMP-1 do NacitajBitmapu; Dec(AktBMP); ZobrazBitmapu; UStara:=0; end; end; 3:begin{dalsia bitmapa} Seek(f,FilePos(f)-RozY*RozX); BlockWrite(f,BMP,RozY*RozX); if not EOF(f) then begin NacitajBitmapu; ZobrazBitmapu; UStara:=0; Inc(AktBMP); end; end; 4:NovaBitmapa;{nova bitmapa} 5:begin{zmazanie bitmapy} for PomX:=0 to 3599 do BMP[PomX]:=Color; ZobrazBitmapu; end; 6:begin{odstranenie bitmapy} Odstr:=FilePos(f)-RozX*RozY-2; Seek(f,Odstr); while not EOF(f) do begin Seek(f,Odstr+RozX*RozY+2); BlockRead(f,BMP,RozX*RozY+2,Kolko); Seek(f,Odstr); BlockWrite(f,BMP,Kolko); Odstr:=Odstr+RozX*RozY+2; end; Seek(f,FileSize(f)-RozX*RozY-2); Truncate(f); Seek(f,768); BlockRead(f,AktBMP,1); Dec(AktBMP); Seek(f,768); BlockWrite(f,AktBMP,1); AktBMP:=1; NacitajBitmapu; ZobrazBitmapu; end; 8:begin{vyber farby} PomX:=(x-Aktiv[8,1]) div RozPaleta; PomY:=(y-Aktiv[8,2]) div RozPaleta; if 16*PomY+PomX<>Color then begin Color:=16*PomY+PomX; VypniKurzorMysi; Nastav(Aktiv[8,3]+1,Aktiv[8,2],Color); VyplnPlochu(20,16*RozPaleta); ZapniKurzorMysi; end; end; 10:begin SuboroveOkno(80,20,'Subory:','mb',ASubor); CakajNaPustenie; Subor:=ASubor.Name; VypniKurzorMysi; InicializujPracovnuPlochu; if Subor<>'' then begin InicializujSubor; end else if RozX>0 then ZobrazBitmapu; ZapniKurzorMysi; end; end; {$IFDEF MAPEDIT} if (Udalost<>8) and (Udalost<>1) then ZobrazSusedneBitmapy; {$ENDIF} until Udalost=7; { ----- ukoncenie programu ----- } if Subor<>'' then begin Seek(f,FilePos(f)-RozY*RozX); BlockWrite(f,BMP,RozY*RozX); Close(f); end; VypniKurzorMysi; END.