Editor animácií
Delphi & Pascal (česká wiki)
Kategória: KMP (Klub mladých programátorov)
Autor: Ľuboš Saloky
Program: Animacie.pas
Súbor exe: Animacie.exe
Potrebné: Mukogr.pas, Mukoutil.pas, Myska.pas
Autor: Ľuboš Saloky
Program: Animacie.pas
Súbor exe: Animacie.exe
Potrebné: Mukogr.pas, Mukoutil.pas, Myska.pas
Editor animácií.
{ MUKOGR.PAS } { Základné utility pre prácu s grafickým režimom. } { } { Author: Ľuboš Saloky } { Datum: 01.01.1996 http://www.trsek.com } unit MukoGr; INTERFACE type TKurzor=array[0..33] of word; { ----- farby, premenne pristupne uzivatelovi ----- } const Cierna=0;Cervena=1;Oranzova=2;Zlta=3;Zelena=4;Svetlomodra=5;Modra=6; Ruzova=7;Bordova=8;Hneda=9;Hnedocervena=10; Hodiny:TKurzor=(0,0,61455,57351,49155,32769,0,0,0,0,0,0,32769,49155,57351, 61455,33153,33729,0,4080,4104,8452,19746,17730,16770,16642,16386,18450,10212,4104,4080,1632,15420,0); SipkaDole:TKurzor=(8,13,65535,65535,63519,63519,63519,63519,0,0,32769,49155,57351,61455,63519, 64575,65151,65535,0,0,0,960,960,960,960,32766,16380,8184,4080,2016,960,384,0,0); SipkaHore:TKurzor=(8,2,65535,65151,64575,63519,61455,57351,49155,32769,0,0,63519,63519,63519, 63519,65535,65535,0,0,384,960,2016,4080,8184,16380,32766,960,960,960,960,0,0,0); SipkaVlavo:TKurzor=(2,8,65343,65087,64575,63551,61503,57347,49155,32771,32771,49155,57347,61503,63551, 64575,65087,65343,0,128,384,896,1920,3968,8184,16376,16376,8184,3968,1920,896,384,128,0); SipkaVpravo:TKurzor=(13,8,64767,64639,64575,64543,64527,49159,49155,49153,49153,49155,49159,64527,64543, 64575,64639,64767,0,256,384,448,480,496,8184,8188,8188,8184,496,480,448,384,256,0); Otaznik:TKurzor=(7,14,63519,61455,57351,49603,50115,59331,65415,65295,65055,64575,63615,63615,64767, 63615,63615,64767,0,2016,3120,6168,6168,24,48,96,192,384,768,768,0,768,768,0); Obycajny:TKurzor=(0,0,16383,8191,4095,2047,1023,511,255,127,63,31,511,4351,12543, 63615,63615,63615,0,16384,24576,28672,30720,31744,32256,32512,32640,31744,27648,17920,1536,768,768,0); Terc:TKurzor=(8,8,65535,64543,61447,57347,49281,50145,34800,34352,36408,34352,34800,50145,49281, 57347,61447,64543,0,0,448,1584,2056,4100,4100,8194,8322,8194,4100,4100,2056,1584,448,0); Ruka:TKurzor=(8,0,64543,63503,61447,53251,32769,1,1,32769,49153,57345,61441,61443,63491,63495,63495, 63495,128,864,1360,1368,9556,21844,19460,9220,4100,2052,1028,1032,520,528,1008,0); Paleta:array[0..767] of byte=( 0,0,0,4,4,4,8,8,8,13,13,13,17,17,17,21,21,21,25,25,25,29,29,29,34,34,34,38,38,38,42,42, 42,46,46,46,50,50,50,55,55,55,59,59,59,63,63,63,16,0,0,21,0,0,26,0,0,32,0,0,37,0,0,42, 0,0,47,0,0,53,0,0,58,0,0,63,0,0,63,16,16,63,23,23,63,30,30,63,36,36,63,43,43,63,50,50, 16,9,0,21,12,0,26,15,0,32,19,0,37,22,0,42,25,0,47,28,0,53,32,0,58,35,0,63,38,0,63,40, 6,63,43,13,63,46,19,63,48,25,63,50,32,63,53,38,16,16,0,20,20,0,25,25,0,29,29,0,33,33,0,37, 37,0,42,42,0,46,46,0,50,50,0,54,54,0,59,59,0,63,63,0,63,63,10,63,63,20,63,63,29,63,63,39, 0,15,0,0,20,0,0,26,0,0,31,0,0,36,0,0,42,0,0,47,0,0,52,0,0,58,0,0,63,0,8,63, 8,16,63,16,24,63,24,31,63,31,39,63,39,47,63,47,0,15,15,0,19,19,0,24,24,0,28,28,0,32,32,0, 37,37,0,41,41,0,46,46,0,50,50,0,54,54,0,59,59,0,63,63,10,63,63,20,63,63,30,63,63,40,63,63, 0,0,20,0,0,24,0,0,28,0,0,32,0,0,36,0,0,40,0,0,43,0,0,47,0,0,51,0,0,55,0,0, 59,0,0,63,10,10,63,20,20,63,30,30,63,40,40,63,17,0,17,21,0,21,25,0,25,30,0,30,34,0,34,38, 0,38,42,0,42,46,0,46,50,0,50,55,0,55,59,0,59,63,0,63,63,11,63,63,22,63,63,34,63,63,45,63, 12,0,17,15,0,22,19,0,26,22,0,31,26,0,35,29,0,40,32,0,45,36,0,49,39,0,54,43,0,58,46,0, 63,49,8,63,52,16,63,54,24,63,57,32,63,60,40,63,17,12,3,20,15,5,23,17,8,26,20,10,29,23,13,32, 26,15,35,28,17,38,31,20,41,34,22,44,36,25,47,39,27,49,42,30,51,44,33,53,47,37,55,49,40,57,52,43, 16,8,16,19,11,19,22,13,22,25,16,25,28,19,28,30,22,30,33,24,33,36,27,36,39,30,39,42,32,42,45,35, 45,47,38,47,49,41,49,52,45,52,54,48,54,56,51,56,63,63,63,0,62,17,0,61,17,0,61,18,0,60,18,0, 59,19,0,58,20,0,57,20,0,57,21,0,56,21,0,55,22,0,54,23,0,53,23,0,52,24,0,52,24,0,51,25, 0,50,26,0,49,26,0,48,27,0,48,27,0,47,28,0,46,29,0,45,29,0,44,30,0,44,30,0,43,31,0,42, 32,0,41,32,0,40,33,0,40,33,0,39,34,0,38,35,0,37,35,0,36,36,0,36,36,0,35,37,0,34,38,0, 33,38,0,32,39,0,32,40,0,31,40,0,30,41,0,29,41,0,28,42,0,27,43,0,27,43,0,26,44,0,25,44, 0,24,45,0,23,46,0,23,46,0,22,47,0,21,47,0,20,48,0,19,49,0,19,49,0,18,50,0,17,50,0,16, 51,0,15,52,0,15,52,0,14,53,0,13,53,0,12,54,0,11,55,0,10,55,0,10,56,0,9,56,0,8,57,0, 7,58,0,6,58,0,6,59,0,5,59,0,4,60,0,3,61,0,2,61,0,2,62,0,1,62,0,0,63,63,63,63); var kx,ky:integer; Adresa,Posun:word; {aktualny offset, posun pri vypise textov} Color:byte; {farba} Ret:string; {tu je retazec po nacitani cez Kurzor} OknoXMin,OknoXMax,OknoYMin,OknoYMax:word;{okraje okna pre proceduru PrilepBitmapu} VSeg:word; {segment VideoRAM} Font:array[0..16383] of byte; { ----- zakladne procedury ----- } procedure InicializujGrafiku; procedure ZavriGrafiku; { ----- procedury pre pracu s farbami ----- } procedure NastavFarbu(cislo,r,g,b:byte); procedure ZistiFarbu(cislo:byte;var r,g,b:byte); { ----- elementarne graficke procedury ----- } procedure ZmazObrazovku; procedure Nastav(px,py:integer;pColor:byte); {nastavi kurzor a farbu} procedure PolozBod(px,py:word;pColor:byte);{polozi bod v pozicii kurzora aktualnej farby} function ZistiBod(px,py:word):byte; {do premennej Color ulozi farbu na mieste kurzora} procedure CiaraVodorovna(Dlzka:word); {ciara z miesta kurzora} procedure CiaraZvisla(Dlzka:word); procedure VyplnPlochu(DeltaX,DeltaY:word); {vyplni ju zadanou farbou} { ----- dalsie procedury ----- } procedure Obdlznik(DeltaX,DeltaY:word); {ramcek bez vyplne} procedure Ramcek(DeltaX,DeltaY,FarbaVnutra:word);{lavy horny roh na mieste kurzora, vyfarbi znutra} procedure CakajNaVOI; {caka na ukoncenie zobrazovania} procedure NacitajFontAPaletu(FontStr:string); procedure VypisPriehladne(s:string;Odtien:byte); {40.000 zn./s, "prilepuje" retazec na aktualnu poziciu} procedure NastavTvarKurzora(Zdroj:word); { ----- procedury pre pracu s bitmapami ----- } procedure PrilepBitmapu(DeltaX,DeltaY,Zdroj:word);{zdroj je offset bitmapy} procedure PrilepPriehladnuBitmapu(DeltaX,DeltaY,Zdroj:word); procedure StiahniBitmapu(DeltaX,DeltaY,Ciel:word);{Ciel je offset bitmapy} procedure KopirujObrazovku(VSeg1,VSeg2:word); procedure PrilepDynamickuBitmapu(DeltaX,DeltaY:word;Zdroj:pointer);{nerespektuje Okno____} IMPLEMENTATION var KonY:word; procedure InicializujGrafiku; begin asm mov ax,13h int 10h end; end; procedure ZavriGrafiku;assembler; asm mov ax,3 int 10h end; procedure NastavFarbu(cislo,r,g,b:byte); begin port[$3C8]:=cislo; port[$3C9]:=r; port[$3C9]:=g; port[$3C9]:=b; end; procedure ZistiFarbu(cislo:byte;var r,g,b:byte); var x:byte; begin port[$3C7]:=cislo; r:=port[$3C9]; g:=port[$3C9]; b:=port[$3C9]; end; procedure ZmazObrazovku;assembler; asm cld mov es,VSeg db 66h; mov cx,16000; dw 0 db 66h; xor di,di; dw 0 db 66h; xor ax,ax; dw 0 db 66h; rep stosw; dw 0 end; procedure Nastav(px,py:integer;pColor:byte);assembler; asm mov al,pColor mov Color,al mov cx,320 mov ax,py mov ky,ax imul cx mov bx,px mov kx,bx add ax,bx mov Adresa,ax {nastav offset ciela} end; procedure PolozBod(px,py:word;pColor:byte);assembler; asm mov es,VSeg mov cx,320 mov ax,py mul cx add ax,px mov di,ax mov al,pColor stosb end; function ZistiBod(px,py:word):byte; var pColor:byte; begin asm mov es,VSeg mov cx,320 mov ax,py mul cx add ax,px mov di,ax mov al,byte[es:di] mov pColor,al end; ZistiBod:=pColor; end; procedure CiaraVodorovna(Dlzka:word);assembler; asm cld mov es,VSeg mov di,Adresa mov al,Color mov cx,Dlzka jcxz @Koniec rep stosb @Koniec: end; procedure CiaraZvisla(Dlzka:word);assembler; asm mov es,VSeg mov di,Adresa mov al,Color mov cx,Dlzka jcxz @Koniec @DalsiBod: mov [es:di],al add di,320 loop @DalsiBod @Koniec: end; procedure VyplnPlochu(DeltaX,DeltaY:word);assembler; asm cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec cld mov es,VSeg mov di,Adresa mov bx,DeltaY mov dx,320 sub dx,DeltaX {v DX je 320-DeltaX} mov al,Color @DalsiRiadok:mov cx,DeltaX rep stosb add di,dx dec bx jnz @DalsiRiadok @Koniec: end; procedure Obdlznik(DeltaX,DeltaY:word); begin CiaraZvisla(DeltaY); CiaraVodorovna(DeltaX); Adresa:=Adresa+DeltaX-1; CiaraZvisla(DeltaY); Adresa:=Adresa+320*DeltaY-DeltaX-319; CiaraVodorovna(DeltaX); Adresa:=Adresa-320*DeltaY; end; procedure Ramcek(DeltaX,DeltaY,FarbaVnutra:word);assembler; asm cld cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec mov es,VSeg mov di,Adresa mov bp,sp mov bx,DeltaY sub bx,2 {v BX pocet riadkov vnutra} mov cx,DeltaX mov dx,320 sub dx,cx {v DX je 320-DeltaX} mov al,Color rep stosb {1. riadok} @DalsiRiadok:add di,dx stosb {1. bod} mov ax,FarbaVnutra mov cx,DeltaX sub cx,2 rep stosb {vnutro} mov al,Color stosb {posledny bod} dec bx jnz @DalsiRiadok add di,dx mov al,Color mov cx,DeltaX rep stosb @Koniec: end; procedure CakajNaVOI;assembler; asm mov dx,03DAh @vz1: in al,dx and al,08h jnz @vz1 @vz2: in al,dx and al,08h jz @vz2 end; procedure NacitajFontAPaletu(FontStr:string); var f:file; pX:word; begin Assign(f,FontStr); Reset(f,16384); BlockRead(f,Font,1); Close(f); for px:=0 to 255 do NastavFarbu(px,Paleta[3*px],Paleta[3*px+1],Paleta[3*px+2]); end; procedure VypisPriehladne(s:string;Odtien:byte); var c1,c2:word; DDiak:boolean; begin c2:=0; Odtien:=Odtien*16; for c1:=1 to Ord(s[0]) do begin c2:=c2+1; {kvoli Enter a vypocitavaniu offsetu ciela} DDiak:=False; asm mov es,VSeg mov dx,Posun lea si,Font {data pre pismeno} @Dalsie: lea bx,s add bx,c1 {pismeno} mov ah,0 mov al,byte[ss:bx] cmp al,13 {spracovanie Enter} jne @Normalne add Adresa,dx mov c2,1 inc c1 jmp @Dalsie { ----- vypocet offsetov zdroja a ciela ----- } @Normalne: mov di,Adresa mov bx,c2 shl bx,3 sub bx,8 add di,bx {offset ciela} mov cx,0 cmp al,'`' {dlzen} je @Diak cmp al,'~' {makcen} je @Diak cmp al,'^' {vokan} je @Diak cmp al,'|' {dve bodky} je @Diak jmp @Dalej @Diak: sub di,320 mov DDiak,True @Dalej: shl ax,6 {offset zdroja} add si,ax {ukazuje na aktualne pismeno} { ----- vypisovanie pismena ----- } @DalsiBod: mov al,byte[si] and al,$0F jz @Nekresli mov al,byte[si] add al,Odtien mov [es:di],al @Nekresli: inc si inc di inc cx test cl,00000111b jnz @Pokracuj add di,312 @Pokracuj: cmp cx,63 jbe @DalsiBod cmp DDiak,True {spracovanie diakritiky} jne @Koniec @Diak2: dec c2 @Koniec: end; end; end; procedure NastavTvarKurzora(Zdroj:word); begin asm mov ax,ds mov es,ax mov si,Zdroj mov dx,si add dx,4 mov ax,9 mov bx,word[si] mov cx,word[si+2] int 33h end; end; procedure PrilepBitmapu(DeltaX,DeltaY,Zdroj:word);assembler; asm cld cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec mov ax,DeltaY add ax,ky mov KonY,ax mov es,VSeg mov si,Zdroj { Zdroj -> ... } mov di,Adresa { ... -> Adresa} mov bx,kx { x-ova sur. } mov dx,ky { y-ova sur. } @DalsiRiadok:mov cx,DeltaX @DalsiBod: lodsb cmp bx,OknoXMin {kontrola rozsahu} jl @Nekresli cmp bx,OknoXMax jg @Nekresli cmp dx,OknoYMin jl @Nekresli cmp dx,OknoYMax jg @Nekresli mov byte[es:di],al @Nekresli: inc di {offset na dalsi bod, aj ked predosly nebol polozeny} inc bx {zvys x-ovu sur.} loop @DalsiBod {potial kreslenie 1 riadka} mov bx,kx {vrat x-ovu sur. na zaciatok} inc dx {dalsi riadok} add di,320 sub di,DeltaX {uprav DI} cmp dx,KonY jl @DalsiRiadok @Koniec: end; procedure PrilepPriehladnuBitmapu(DeltaX,DeltaY,Zdroj:word);assembler; asm cld cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec mov ax,DeltaY add ax,ky mov KonY,ax mov es,VSeg mov si,Zdroj { Zdroj -> ... } mov di,Adresa { ... -> Adresa} mov bx,kx { x-ova sur. } mov dx,ky { y-ova sur. } @DalsiRiadok:mov cx,DeltaX @DalsiBod: lodsb cmp al,0 {nova podmienka oproti PrilepBitmapu} je @Nekresli cmp bx,OknoXMin {kontrola rozsahu} jl @Nekresli cmp bx,OknoXMax jg @Nekresli cmp dx,OknoYMin jl @Nekresli cmp dx,OknoYMax jg @Nekresli mov byte[es:di],al @Nekresli: inc di {offset na dalsi bod, aj ked predosly nebol polozeny} inc bx {zvys x-ovu sur.} loop @DalsiBod {potial kreslenie 1 riadka} mov bx,kx {vrat x-ovu sur. na zaciatok} inc dx {dalsi riadok} add di,320 sub di,DeltaX {uprav DI} cmp dx,KonY jl @DalsiRiadok @Koniec: end; procedure PrilepDynamickuBitmapu(DeltaX,DeltaY:word;Zdroj:pointer);assembler; asm cld cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec mov es,VSeg mov dx,DeltaY mov bx,DeltaX mov di,Adresa { ... -> Adresa} push ds lds si,Zdroj {Zdroj -> .... } add si,16 @DalsiRiadok:mov cx,DeltaX rep movsb add di,320 sub di,bx {uprav DI} dec dx jnz @DalsiRiadok pop ds @Koniec: end; procedure StiahniBitmapu(DeltaX,DeltaY,Ciel:word);assembler; asm cld cmp DeltaX,0 je @Koniec cmp DeltaY,0 je @Koniec mov si,Adresa push ds mov ax,ds mov es,ax mov ax,VSeg mov ds,ax mov di,Ciel {nastavene su DS:SI -> ES:DI} mov dx,320 sub dx,DeltaX {v DX je posun zdrojoveho offsetu} mov bx,DeltaY @DalsiRiadok:mov cx,DeltaX rep movsb add si,dx dec bx jnz @DalsiRiadok pop ds @Koniec: end; procedure KopirujObrazovku(VSeg1,VSeg2:word);assembler; asm cld push ds mov ds,VSeg1 mov es,VSeg2 db 66h; mov si,0; dw 0 db 66h; mov di,0; dw 0 db 66h; mov cx,16000; dw 0 db 66h; rep movsw pop ds end; BEGIN OknoXMin:=0; OknoXMax:=319; OknoYMin:=0; OknoYMax:=199; VSeg:=$A000; Posun:=8*320; END.