Program editor umoznuje vytvaret, ukladat i nacitat z disku graficke soubory s priponou gra

Kategórie: KMP (Programy mladých programátorů)

Program: Graeditor.pas
Soubor exe: Graeditor.exe
Program editor umoznuje vytvaret, ukladat i nacitat z disku graficke soubory s priponou gra. Jedna se o muj vlastni format ve kterem je zakodovana grafika 160x200 pixelu s barevnou hloubkou 16 barev vybranych ze 65535ti. Vysledny graficky soubor zabira 9048 bajtu takze je vhodny pro prilinkovavani napr. do her v assembleru.

prvnich 8000 bajtu je grafika 160x200 (viz rozkodovani) obsahuje same hodnoty 0 1 2 3

dalsich 1000 bajtu obsahuje ctverice bajtu pro kazdy ctverecek 8x8 pixelu - zde uz jsou nahrany barvy 0-15

poslednich 48 bajtu obsahuje barevnou paletu pro prvnich 16 barev.

V programu je pouzito zakodovani a rozkodovani. Po rozkodovani zabira stranka 160x200x16 32KB zakodovana 9KB.

K zakodovani je pouzito prevodu decadickych cisel na binarni . Takze 4 pixely zabiraji presne jeden bajt. 00 01 10 11 b

Program obsahuje napovedu ve ktere je ovladani editoru. Vse je na klavesnici.

Zname chyby: kdyz se otevira soubor a zada se jmeno neexistujuciho souboru nebo nejak spatne dojde k padu programu (chybi File not found funkce) druha znama chyba: v casti editoru kde se pracuje se schrankou se obsah schranky napravo zobrazuje spatne ale jinak schranka funguje
{ GRAEDITOR.PAS                        Copyright (c) Martin Kolecek }
{ Program editor umoznuje vytvaret, ukladat i nacitat z disku       }
{ graficke soubory s priponou gra. Jedna se o muj vlastni format    }
{ ve kterem je zakodovana grafika 160x200 pixelu s barevnou hloubkou}
{ 16 barev vybranych ze 65535ti. Vysledny graficky soubor zabira    }
{ 9048 bajtu takze je vhodny pro prilinkovavani napr. do her v      }
{ assembleru.                                                       }
{                                                                   }
{ prvnich 8000 bajtu je grafika 160x200 (viz rozkodovani)           }
{ obsahuje same hodnoty 0 1 2 3                                     }
{                                                                   }
{ dalsich 1000 bajtu obsahuje ctverice bajtu pro kazdy ctverecek 8x8}
{ pixelu - zde uz jsou nahrany barvy 0-15                           }
{                                                                   }
{ poslednich 48 bajtu obsahuje barevnou paletu pro prvnich 16 barev.}
{                                                                   }
{ V programu je pouzito zakodovani a rozkodovani. Po rozkodovani    }
{ zabira stranka 160x200x16 32KB zakodovana 9KB.                    }
{                                                                   }
{ K zakodovani je pouzito prevodu decadickych cisel na binarni.     }
{ Takze 4 pixely zabiraji presne jeden bajt. 00 01 10 11 b          }
{                                                                   }
{ Program obsahuje napovedu ve ktere je ovladani editoru.           }
{ Vse je na klavesnici.                                             }
{                                                                   }
{ Zname chyby: kdyz se otevira soubor a zada se jmeno neexistujuciho}
{ souboru nebo nejak spatne dojde k padu programu (chybi File not   }
{ found funkce)                                                     }
{ druha znama chyba: v casti editoru kde se pracuje se schrankou se }
{ obsah schranky napravo zobrazuje spatne ale jinak schranka funguje}
{                                                                   }
{ Author: Martin Kolecek                                            }
{ Datum: 12.05.2009                           http://www.trsek.com  }
 
Program Editor;
Uses CRT,DOS;
 
Type
 TRGB= Record
         R: Byte;
         G: Byte;
         B: Byte;
       End;
 
Const
  FileNamePripona: string[4] = '.gra';
 
Var
  MMSelect: Byte;
  PalSelect: Byte;
 
  B4X,B4Y: Byte;
  B4X2,B4Y2: Byte;
  B4X3,B4Y3: Integer;
 
  EX,EY: Byte;
  EX2,EY2: Byte;
  Xs,Ys: Integer;
  Color: array[0..3] of Byte;
 
  F: File;
  DirInfo: SearchRec;
  FileName: string[12];
  FileNameJmeno: string[8];
  FileNameDialogOK:Boolean;
  CisloStranky: Byte;
 
  Clipboard: array[0..63] of Byte; {64B 8x8} {0..3}
  Clipboard2: array[0..3] of Byte; {barvy 4} {0..15}
 
  Grafika: array[0..7999] of Byte;
  Barvy4: array[0..999] of Byte;
  Paleta: array[0..47] of Byte;
  Barva: array[0..15] of TRGB;
 
  Buffer32,Buffer2: Pointer;
  BufferSeg32,BufferSeg2: Word;
 
  a7,a6,a5,a4,a3,a2,a1,a0: Byte;
  b7,b6,b5,b4,b3,b2,b1,b0: Byte;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure NoBeep;
Begin
  While KeyPressed do ReadKey;
End;
 
 
Procedure Init320x200; Assembler;
Asm
  Mov AH, 00h
  Mov AL, 13h
  Int 10h
End;
 
 
Procedure Init80x25; Assembler;
Asm
  Mov AH, 00h
  Mov AL, 03h
  Int 10h
End;
 
 
Procedure WaitRetrace; Assembler;
Asm
    Mov dx,3DAh
@l1:
    In al,dx
    And al,08h
    Jnz @l1
@l2:
    In al,dx
    And al,08h
    Jz  @l2
End;
 
 
Procedure WritePixel (X:Word;Y,Barva:Byte);
Begin
  Mem[$A000:Y*320+X]:=Barva;
End;
 
 
Procedure Blok(x1,y1,x2,y2,Barva:Word);
Var x,y: Word;
Begin
   For y:=y1 to y2 do
   For x:=x1 to x2 do WritePixel(x,y,Barva);
End;
 
 
Procedure Ramecek (X1,Y1,X2,Y2,Barva: Word);
Var DelkaX,DelkaY,I: Word;
Begin
 DelkaX := X2-X1; DelkaY := Y2-Y1;
 For I := 0 to DelkaX do WritePixel (X1+I,Y1,Barva);
 For I := 0 to DelkaX do WritePixel (X1+I,Y2,Barva);
 For I := 0 to DelkaY do WritePixel (X1,Y1+I,Barva);
 For I := 0 to DelkaY do WritePixel (X2,Y1+I,Barva);
End;
 
 
Procedure GetPal(Color:Byte; Var R,G,B:Byte);
Begin
   Port[$3c7]:=Color;
   R:=Port[$3c9];
   G:=Port[$3c9];
   B:=Port[$3c9];
End;
 
 
Function GetPalR(Color:Byte): Byte;
Var R,G,B: Byte;
Begin
   Port[$3c7]:=Color;
   R:=Port[$3c9];
   G:=Port[$3c9];
   B:=Port[$3c9];
   GetPalR:=R;
End;
 
 
Function GetPalG(Color:Byte): Byte;
Var R,G,B: Byte;
Begin
   Port[$3c7]:=Color;
   R:=Port[$3c9];
   G:=Port[$3c9];
   B:=Port[$3c9];
   GetPalG:=G;
End;
 
 
Function GetPalB(Color:Byte): Byte;
Var R,G,B: Byte;
Begin
   Port[$3c7]:=Color;
   R:=Port[$3c9];
   G:=Port[$3c9];
   B:=Port[$3c9];
   GetPalB:=B;
End;
 
 
Procedure SetPal(Color:Byte; R,G,B:Byte);
Begin
   Port[$3c8]:=Color;
   Port[$3c9]:=R;
   Port[$3c9]:=G;
   Port[$3c9]:=B;
End;
 
 
Procedure SoundStorno;
Var I,I2:Word;
Begin
  I2:=350;
  For I:=0 to 3 do
  Begin
    Sound(I2);
    Delay(20);
    NoSound;
    Dec(I2,50);
  End;
End;
 
 
Procedure SoundDone;
Var I,I2:Word;
Begin
  I2:=200;
  For I:=0 to 5 do
  Begin
    Sound(I2);
    Delay(20);
    NoSound;
    Inc(I2,50);
  End;
End;
 
 
Procedure InitBuffers;
Var I: Word;
Begin
  GetMem(Buffer32,32000); BufferSeg32:=Seg(Buffer32^);
  GetMem(Buffer2,2000); BufferSeg2:=Seg(Buffer2^);
  For I:=0 to 31999 do mem[BufferSeg32:I]:=0; {vymaz bufferu}
  For I:=0 to 1999 do mem[BufferSeg2:I]:=0;   {vymaz bufferu}
End;
 
 
Procedure ShutdownBuffers;
Begin
  FreeMem(Buffer32,32000);
  FreeMem(Buffer2,2000);
End;
 
 
Function Bin2Dec(b7,b6,b5,b4,b3,b2,b1,b0: Byte): Byte;
Var I: Byte;
Begin
  I:=0;
  If b7=1 then Inc(I,128);
  If b6=1 then Inc(I,64);
  If b5=1 then Inc(I,32);
  If b4=1 then Inc(I,16);
  If b3=1 then Inc(I,8);
  If b2=1 then Inc(I,4);
  If b1=1 then Inc(I,2);
  If b0=1 then Inc(I,1);
  Bin2Dec:=I;
End;
 
 
Procedure Dec2Bin(DCnum:Byte);
Begin
  If DCnum>=128 then Begin b7:=1; Dec(DCnum,128); End else b7:=0;
  If DCnum>=64  then Begin b6:=1; Dec(DCnum,64);  End else b6:=0;
  If DCnum>=32  then Begin b5:=1; Dec(DCnum,32);  End else b5:=0;
  If DCnum>=16  then Begin b4:=1; Dec(DCnum,16);  End else b4:=0;
  If DCnum>=8   then Begin b3:=1; Dec(DCnum,8);   End else b3:=0;
  If DCnum>=4   then Begin b2:=1; Dec(DCnum,4);   End else b2:=0;
  If DCnum>=2   then Begin b1:=1; Dec(DCnum,2);   End else b1:=0;
  If DCnum>=1   then Begin b0:=1; Dec(DCnum,1);   End else b0:=0;
End;
 
 
Procedure Zakodovat;
Var A,I: Word;
Begin
  A:=0; I:=0;
  Repeat
    Dec2Bin(mem[BufferSeg32:A+0]); a0:=b0; a1:=b1;
    Dec2Bin(mem[BufferSeg32:A+1]); a2:=b0; a3:=b1;
    Dec2Bin(mem[BufferSeg32:A+2]); a4:=b0; a5:=b1;
    Dec2Bin(mem[BufferSeg32:A+3]); a6:=b0; a7:=b1;
    Grafika[I]:=Bin2Dec(a7,a6,a5,a4,a3,a2,a1,a0);
    Inc(A,4);
    Inc(I);
  Until I=8000;
  A:=0; I:=0;
  Repeat
    Dec2Bin(mem[BufferSeg2:A+0]); a0:=b0; a1:=b1; a2:=b2; a3:=b3;
    Dec2Bin(mem[BufferSeg2:A+1]); a4:=b0; a5:=b1; a6:=b2; a7:=b3;
    Barvy4[I]:=Bin2Dec(a7,a6,a5,a4,a3,a2,a1,a0);
    Inc(A,2);
    Inc(I);
  Until I=1000;
  A:=0;
  For I:=0 to 15 do
  Begin
    Paleta[A+0]:=Barva[I].R;
    Paleta[A+1]:=Barva[I].G;
    Paleta[A+2]:=Barva[I].B;
    Inc(A,3);
  End;
End;
 
 
Procedure Rozkodovat;
Var A,I: Word;
Begin
  A:=0; I:=0;
  Repeat
    Dec2Bin(Grafika[I]);
    mem[BufferSeg32:A+0]:=Bin2Dec(0,0,0,0,0,0,b1,b0);
    mem[BufferSeg32:A+1]:=Bin2Dec(0,0,0,0,0,0,b3,b2);
    mem[BufferSeg32:A+2]:=Bin2Dec(0,0,0,0,0,0,b5,b4);
    mem[BufferSeg32:A+3]:=Bin2Dec(0,0,0,0,0,0,b7,b6);
    Inc(A,4);
    Inc(I);
  Until I=8000;
  A:=0; I:=0;
  Repeat
    Dec2Bin(Barvy4[I]);
    mem[BufferSeg2:A+0]:=Bin2Dec(0,0,0,0,b3,b2,b1,b0);
    mem[BufferSeg2:A+1]:=Bin2Dec(0,0,0,0,b7,b6,b5,b4);
    Inc(A,2);
    Inc(I);
  Until I=1000;
  A:=0;
  For I:=0 to 15 do
  Begin
    Barva[I].R:=Paleta[A+0];
    Barva[I].G:=Paleta[A+1];
    Barva[I].B:=Paleta[A+2];
    Inc(A,3);
  End;
End;
 
 
Procedure FnSave;
Begin
  Assign(F,Filename);
  Reset(F,1);
  Zakodovat;
  BlockWrite(F,Grafika,8000);
  BlockWrite(F,Barvy4,1000);
  BlockWrite(F,Paleta,48);
  BlockWrite(F,CisloStranky,1);
  Close(F);
  SoundDone;
End;
 
 
Procedure PrepareColors;
Var I: Byte;
Begin
  SetPal(251,0,0,0);     {Black}
  SetPal(252,63,63,63);  {White}
  SetPal(253,63,0,0);    {Red}
  SetPal(254,0,63,0);    {Green}
  SetPal(255,0,0,63);    {Blue}
  For I:=0 to 15 do
  SetPal(I,Barva[I].R,Barva[I].G,Barva[I].B);
End;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure WriteEPScreen;
Var x,y,I: Word;
Begin
  {Nastaveni palety}
  For I:=0 to 15 do SetPal(I,Barva[I].R,Barva[I].G,Barva[I].B);
 
  {Oramovani}
  x:=0; y:=0; Ramecek(x,y,x+319,y+199,252);
 
  {Editovana barva}
  x:=140; y:=50; Ramecek(x,y,x+100,y+100,252);
  Blok(x+2,y+2,x+98,y+98,PalSelect);
 
  {Barvy + mazani kurzoru}
  x:=12; y:=10;
  For I:=0 to 15 do
  Begin
    Blok(x,y,x+7,y+7,I);
    Ramecek(x-2,y-2,x+9,y+9,252);
    Ramecek(x-4,y-4,x+11,y+11,251);
    Ramecek(x-6,y-6,x+13,y+13,251);
    Inc(x,19);
  End;
 
  {Kurzor}
  x:=12; y:=10; I:=0;
  While I<PalSelect do Begin Inc(x,19); Inc(I); End;
  Ramecek(x-4,y-4,x+11,y+11,252);
  Ramecek(x-6,y-6,x+13,y+13,252);
 
  x:=10; y:=30; Ramecek(x,y,x+62,y+138,252);
 
  {Editor palety + mazani policek RGB}
  x:=12; y:=32; Ramecek(x,y,x+18,y+8,253); Blok(x+2,y+2,x+16,y+6,253);
  x:=32; y:=32; Ramecek(x,y,x+18,y+8,254); Blok(x+2,y+2,x+16,y+6,254);
  x:=52; y:=32; Ramecek(x,y,x+18,y+8,255); Blok(x+2,y+2,x+16,y+6,255);
  x:=12; y:=42; For I:=0 to 62 do Begin Blok(x,y,x+18,y,251); Inc(y,2); End;
  x:=32; y:=42; For I:=0 to 62 do Begin Blok(x,y,x+18,y,251); Inc(y,2); End;
  x:=52; y:=42; For I:=0 to 62 do Begin Blok(x,y,x+18,y,251); Inc(y,2); End;
 
  {Policka s hodnotami RGB}
  x:=12; y:=42; I:=0;
  While I< Barva[PalSelect].R do
  Begin Blok(x,y,x+18,y,253); Inc(y,2); Inc(I); End;
  x:=32; y:=42; I:=0;
  While I< Barva[PalSelect].G do
  Begin Blok(x,y,x+18,y,254); Inc(y,2); Inc(I); End;
  x:=52; y:=42; I:=0;
  While I< Barva[PalSelect].B do
  Begin Blok(x,y,x+18,y,255); Inc(y,2); Inc(I); End;
End;
 
 
Procedure EditorPalety;
Var Ending: Boolean;
Begin
  PalSelect:=1;
  Ending:=False;
  Blok(0,0,319,199,251);
  Repeat
    WaitRetrace;
    WriteEPScreen;
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{Left}     75: Begin If PalSelect>0  then Dec(PalSelect) else PalSelect:=15; End;
{Right}    77: Begin If PalSelect<15 then Inc(PalSelect) else PalSelect:=0;  End;
{Insert}   82: Begin If Barva[PalSelect].R>0  then Dec(Barva[PalSelect].R) else Barva[PalSelect].R:=0;  End;
{Delete}   83: Begin If Barva[PalSelect].R<63 then Inc(Barva[PalSelect].R) else Barva[PalSelect].R:=63; End;
{Home}     71: Begin If Barva[PalSelect].G>0  then Dec(Barva[PalSelect].G) else Barva[PalSelect].G:=0;  End;
{End}      79: Begin If Barva[PalSelect].G<63 then Inc(Barva[PalSelect].G) else Barva[PalSelect].G:=63; End;
{PageUp}   73: Begin If Barva[PalSelect].B>0  then Dec(Barva[PalSelect].B) else Barva[PalSelect].B:=0;  End;
{PageDown} 81: Begin If Barva[PalSelect].B<63 then Inc(Barva[PalSelect].B) else Barva[PalSelect].B:=63; End;
{F2}       60: Begin FnSave; End;
{F8}       66: Begin SoundStorno; End;
{F7}       65: Begin SoundStorno; End;
{F6}       64: Begin SoundStorno; End;
{F5}       63: Begin Ending:=True; End;
{Esc}       1: Begin Ending:=True; End;
    End; {Case Port[$60] End}
  Until Ending=True;
  Blok(0,0,319,199,251);
End;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure Setup4Colors;
Var I,X,Y,Offset: Word;
Begin
  X:=Trunc((EX*8+EX2)/8);
  Y:=Trunc((EY*8+EY2)/8);
  Offset:=(Y*20+X)*4;
  For I:=0 to 3 do
  Color[I]:=mem[BufferSeg2:Offset+I];
End;
 
 
Procedure WriteGScreen;
Var I,Xa,Ya,x,y,X1,Y1,Xp,Yp,Offset32,Offset2: Word;
Begin
  Ramecek(160,160,319,199,252);
 
  {Nastaveni spravnych barev 160x200 po krocich 8x8}
  For Ya:=0 to 24 do
  For Xa:=0 to 19 do
  Begin
    For y:=0 to 7 do
    For x:=0 to 7 do
    Begin
      X1:=Trunc((Xa*8+x)/8);
      Y1:=Trunc((Ya*8+y)/8);
      Offset2:=(Y1*20+X1)*4;
      Offset32:=((Ya*8+y)*160)+(Xa*8+x);
      Case mem[BufferSeg32:Offset32] of
        0: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+0]);
        1: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+1]);
        2: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+2]);
        3: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+3]);
      End; {Case End}
    End;
  End;
 
  {Kurzor 40x40}
  x:=EX*8; y:=EY*8;
  Ramecek(x,y,x+39,y+39,252);
 
  {Vykresleni obsahu 40x40}
  x:=160; y:=0;
  For Y1:=0 to 39 do
  Begin
    x:=160;
    For X1:=0 to 39 do
    Begin
      Xp:=Trunc((EX*8+X1)/8);
      Yp:=Trunc((EY*8+Y1)/8);
      Offset2:=(Yp*20+Xp)*4;
      Offset32:=(EY*8+Y1)*160+(EX*8+X1);
      Case mem[BufferSeg32:Offset32] of
        0: Blok(x+1,y+1,x+2,y+2,mem[BufferSeg2:Offset2+0]);
        1: Blok(x+1,y+1,x+2,y+2,mem[BufferSeg2:Offset2+1]);
        2: Blok(x+1,y+1,x+2,y+2,mem[BufferSeg2:Offset2+2]);
        3: Blok(x+1,y+1,x+2,y+2,mem[BufferSeg2:Offset2+3]);
      End; {Case End;}
      Inc(x,4);
    End;
    Inc(y,4);
  End;
 
  {Vymazavani kurzoru v editacnim poli}
  For Ya:=0 to 39 do
  For Xa:=0 to 39 do
  Begin
    x:=Xa*4+160; y:=Ya*4;
    Ramecek(x,y,x+3,y+3,251);
  End;
 
  {Kurzor v editacnim poli}
  x:=EX2*4+160; y:=EY2*4;
  Ramecek(x,y,x+3,y+3,252);
 
  {4 kreslici barvy ASDF}
  x:=160; y:=160;
  For I:=0 to 3 do
  Begin
    Ramecek(x,y,x+39,y+39,252);
    Blok(x+1,y+1,x+38,y+38,Color[I]);
    Inc(x,40);
  End;
 
End;
 
 
Procedure EditorGrafiky;
Var Ending: Boolean;
Begin
  EX:=0; EY:=0;
  EX2:=0; EY2:=0;
  Ending:=False;
  Blok(0,0,319,199,251);
  Repeat
    Setup4Colors;
    WaitRetrace;
    WriteGScreen;
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{J}     36: Begin If EX2>0  then Dec(EX2) else EX2:=39; End;
{L}     38: Begin If EX2<39 then Inc(EX2) else EX2:=0;  End;
{I}     23: Begin If EY2>0  then Dec(EY2) else EY2:=39; End;
{K}     37: Begin If EY2<39 then Inc(EY2) else EY2:=0;  End;
 
{A}     30: Begin mem[BufferSeg32:((EY*8+EY2)*160)+(EX*8+EX2)]:=0; End;
{S}     31: Begin mem[BufferSeg32:((EY*8+EY2)*160)+(EX*8+EX2)]:=1; End;
{D}     32: Begin mem[BufferSeg32:((EY*8+EY2)*160)+(EX*8+EX2)]:=2; End;
{F}     33: Begin mem[BufferSeg32:((EY*8+EY2)*160)+(EX*8+EX2)]:=3; End;
 
{Left}  75: Begin If EX>0  then Dec(EX) else EX:=15; End;
{Right} 77: Begin If EX<15 then Inc(EX) else EX:=0;  End;
{Up}    72: Begin If EY>0  then Dec(EY) else EY:=20; End;
{Down}  80: Begin If EY<20 then Inc(EY) else EY:=0;  End;
 
{F2}    60: Begin FnSave; End;
{F8}    66: Begin SoundStorno; End;
{F7}    65: Begin SoundStorno; End;
{F6}    64: Begin SoundStorno; End;
{F5}    63: Begin Ending:=True; End;
{Esc}    1: Begin Ending:=True; End;
    End; {Case Port[$60] End}
  Until Ending=True;
  Blok(0,0,319,199,251);
End;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure WriteE4Screen;
Var x,y,X1,Y1,I,I2: Word;
Begin
  Ramecek(160,0,319,199,252);
 
  {Vymazavani kurzoru - vyber barvy}
  x:=160; y:=0; I:=0;
  For Y1:=0 to 3 do
  Begin
    x:=160;
    For X1:=0 to 3 do
    Begin
      Ramecek(x+2,y+2,x+37,y+37,251);
      Blok(x+6,y+6,x+33,y+33,I);
      inc(x,40); Inc(I);
    End;
    Inc(y,40);
  End;
 
  {Kurzor - vyber barvy}
  x:=160+B4X2*40; y:=B4Y2*40;
  Ramecek(x+2,y+2,x+37,y+37,252);
 
  {nahled 4 vybranych barev}
  x:=160; y:=160;
  For I:=0 to 3 do
  Begin
    Ramecek(x,y,x+39,y+39,252);
    Blok(x+2,y+2,x+37,y+37,mem[BufferSeg2:B4Y3*20+B4X3+I]);
    Inc(x,40);
  End;
 
  {Vymazavani kurzoru a vykresleni 4barvy}
  x:=0; y:=0; I:=0;
  For Y1:=0 to 24 do
  Begin
    x:=0;
    For X1:=0 to 19 do
    Begin
      Ramecek(x,y,x+7,y+7,251);
      Blok(x+2,y+2,x+3,y+3,mem[BufferSeg2:I+0]);
      Blok(x+4,y+2,x+5,y+3,mem[BufferSeg2:I+1]);
      Blok(x+2,y+4,x+3,y+5,mem[BufferSeg2:I+2]);
      Blok(x+4,y+4,x+5,y+5,mem[BufferSeg2:I+3]);
      inc(x,8); Inc(I,4);
    End;
    Inc(y,8);
  End;
 
  {Kurzor}
  x:=B4X*8; y:=B4Y*8;
  Ramecek(x,y,x+7,y+7,252);
 
End;
 
 
Procedure Editor4Barvy;
Var Ending: Boolean;
    I: Word;
Begin
  B4X:=0; B4Y:=0;
  B4X2:=0; B4Y2:=0;
  B4X3:=0; B4Y3:=0;
  Ending:=False;
  Blok(0,0,319,199,251);
  Repeat
    WaitRetrace;
    WriteE4Screen;
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{J}     36: Begin
              If B4X>0  then Dec(B4X) else B4X:=19;
              If B4X3>0 then Dec(B4X3,4) else B4X3:=76;
            End;
{L}     38: Begin
              If B4X<19 then Inc(B4X) else B4X:=0;
              If B4X3<76 then Inc(B4X3,4) else B4X3:=0;
            End;
{I}     23: Begin
              If B4Y>0  then Dec(B4Y) else B4Y:=24;
              If B4Y3>0 then Dec(B4Y3,4) else B4Y3:=96;
            End;
{K}     37: Begin
              If B4Y<24 then Inc(B4Y) else B4Y:=0;
              If B4Y3<96 then Inc(B4Y3,4) else B4Y3:=0;
            End;
 
{A}     30: Begin mem[BufferSeg2:(B4Y3*20+B4X3)+0]:=B4Y2*4+B4X2; End;
{S}     31: Begin mem[BufferSeg2:(B4Y3*20+B4X3)+1]:=B4Y2*4+B4X2; End;
{D}     32: Begin mem[BufferSeg2:(B4Y3*20+B4X3)+2]:=B4Y2*4+B4X2; End;
{F}     33: Begin mem[BufferSeg2:(B4Y3*20+B4X3)+3]:=B4Y2*4+B4X2; End;
 
{Left}  75: Begin If B4X2>0 then Dec(B4X2) else B4X2:=3; End;
{Right} 77: Begin If B4X2<3 then Inc(B4X2) else B4X2:=0; End;
{Up}    72: Begin If B4Y2>0 then Dec(B4Y2) else B4Y2:=3; End;
{Down}  80: Begin If B4Y2<3 then Inc(B4Y2) else B4Y2:=0; End;
{F2}    60: Begin FnSave; End;
{F8}    66: Begin SoundStorno; End;
{F7}    65: Begin SoundStorno; End;
{F6}    64: Begin SoundStorno; End;
{F5}    63: Begin Ending:=True; End;
{Esc}    1: Begin Ending:=True; End;
    End; {Case Port[$60] End}
  Until Ending=True;
  Blok(0,0,319,199,251);
End;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure Copy2ClipBoard;
Var Offset32,Offset2,X1,Y1,Xe,Ye,x,y,I: Word;
Begin
  {kopirovani do schranky 64B 8x8}
  x:=Xs*8; y:=Ys*8; I:=0;
  For Ye:=0 to 7 do
  Begin
    For Xe:=0 to 7 do
    Begin
      Offset32:=((y+Ye)*160)+(x+Xe);
      Clipboard[I]:=mem[BufferSeg32:Offset32];
      Inc(I);
    End;
  End;
 
  {kopirovani do schranky barvy 4}
  x:=0; y:=0;
  X1:=Trunc((Xs*8+x)/8);
  Y1:=Trunc((Ys*8+y)/8);
  Offset2:=(Y1*20+X1)*4;
  For I:=0 to 3 do Clipboard2[I]:=mem[BufferSeg2:Offset2+I];
 
End;
 
 
Procedure RestoreFromClipBoard;
Var Offset32,Offset2,X1,Y1,Xe,Ye,x,y,I: Word;
Begin
  {vylozeni ze schranky 64B}
  x:=Xs*8; y:=Ys*8; I:=0;
  For Ye:=0 to 7 do
  Begin
    For Xe:=0 to 7 do
    Begin
      Offset32:=((y+Ye)*160)+(x+Xe);
      mem[BufferSeg32:Offset32]:=Clipboard[I];
      Inc(I);
    End;
  End;
  {vylozeni ze schranky barvy 4}
  x:=0; y:=0;
  X1:=Trunc((Xs*8+x)/8);
  Y1:=Trunc((Ys*8+y)/8);
  Offset2:=(Y1*20+X1)*4;
  For I:=0 to 3 do mem[BufferSeg2:Offset2+I]:=Clipboard2[I];
 
End;
 
 
Procedure WriteEScreen;
Var Offset32,Offset2,Xa,Ya,X1,Y1,x,y,I,BarvaVeSchrance: Word;
Begin
  Ramecek(160,0,319,199,252);
 
  {Nastaveni spravnych barev 160x200 po krocich 8x8}
  For Ya:=0 to 24 do
  For Xa:=0 to 19 do
  Begin
    For y:=0 to 7 do
    For x:=0 to 7 do
    Begin
      X1:=Trunc((Xa*8+x)/8);
      Y1:=Trunc((Ya*8+y)/8);
      Offset2:=(Y1*20+X1)*4;
      Offset32:=((Ya*8+y)*160)+(Xa*8+x);
      Case mem[BufferSeg32:Offset32] of
        0: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+0]);
        1: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+1]);
        2: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+2]);
        3: WritePixel((Xa*8+x),(Ya*8+y),mem[BufferSeg2:Offset2+3]);
      End; {Case End}
    End;
  End;
 
  {Kurzor 8x8}
  x:=Xs*8; y:=Ys*8;
  Ramecek(x,y,x+7,y+7,252);
 
 
  {zobrazeni obsahu schranky - nahled barev}
  x:=194; y:=140;
  For I:=0 to 3 do
  Begin
    Blok(x,y,x+9,y+9,ClipBoard2[I]);
    Inc(x,10);
  End;
 
  {zobrazeni obsahu schranky - 8x8}
  Ramecek(194,49,276,131,252);
  x:=195; y:=50; I:=0;
  For Y1:=0 to 7 do
  Begin
    For X1:=0 to 7 do
    Begin
      Case Clipboard[I] of
       0: BarvaVeSchrance:=Clipboard2[0];
       1: BarvaVeSchrance:=Clipboard2[1];
       2: BarvaVeSchrance:=Clipboard2[2];
       3: BarvaVeSchrance:=Clipboard2[3];
      End;
      Blok(x+1,y+1,x+9,y+9,BarvaVeSchrance);
      inc(x,10); Inc(I);
    End;
    x:=195; Inc(y,10);
  End;
 
End;
 
Procedure FnEditor;
Var Ending: Boolean;
Begin
  Init320x200;
  PrepareColors;
  Ending:=False;
  Repeat
    WaitRetrace;
    WriteEScreen;
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{Left}  75: Begin If Xs>0  then Dec(Xs) else Xs:=19; End;
{Right} 77: Begin If Xs<19 then Inc(Xs) else Xs:=0;  End;
{Up}    72: Begin If Ys>0  then Dec(Ys) else Ys:=24; End;
{Down}  80: Begin If Ys<24 then Inc(Ys) else Ys:=0;  End;
{C}     46: Begin Copy2ClipBoard; End;
{V}     47: Begin RestoreFromClipBoard; End;
{F2}    60: Begin FnSave; End;
{F6}    64: Begin EditorGrafiky; End;
{F7}    65: Begin Editor4Barvy; End;
{F8}    66: Begin EditorPalety; End;
{Esc}    1: Begin Ending:=True; End;
    End; {Case Port[$60] End}
  Until Ending=True;
  Init80x25;
End;
 
 
Procedure LoadError(CisloChyby:Byte);
Var ErrorMSG: array[1..8] of String;
    X,Y,I,I2:Byte;
Begin
  ErrorMSG[1]:='Nenalezen soubor';
  ErrorMSG[2]:='Nenalezena cesta';
  ErrorMSG[3]:='PýĄstup zamĄtnut';
  ErrorMSG[4]:='Neplatně deskriptor';
  ErrorMSG[5]:='Nedostatek pamŘti';
  ErrorMSG[6]:='Neplatn prostýedĄ';
  ErrorMSG[7]:='Neplatně form t';
  ErrorMSG[8]:='Soubor nenalezen';
  {Vypisujeme Error MSG yellow}
  X:=27; Y:=12; {souradnice ErrorMSG}
  TextColor(14); {Zluty ramecek ErrorMSG}
  For I:=0 to 22 do Begin GotoXY(X+I,Y); Write('Ü'); End;
  For I:=0 to 22 do Begin GotoXY(X+I,Y+3); Write('ß'); End;
  GotoXY(X,Y+1);     Write('Ű');
  GotoXY(X+22,Y+1);  Write('Ű');
  GotoXY(X,Y+2);     Write('Ű');
  GotoXY(X+22,Y+2);  Write('Ű');
  TextBackground(4); {Cervene pozadi ramecku}
  For I2:=1 to 2 do {vypln}
  For I:=0 to 20 do Begin GotoXY(X+1+I,Y+I2); Write(' '); End;
  GotoXY(X+2,Y+1); Write('CHYBA      ESC=EXIT');
  {Vypisujeme vzniklou chybu}
  GotoXY(X+2,Y+2);
  Case CisloChyby of
    1: Write(ErrorMSG[1]);
    2: Write(ErrorMSG[2]);
    3: Write(ErrorMSG[3]);
    4: Write(ErrorMSG[4]);
    5: Write(ErrorMSG[5]);
    6: Write(ErrorMSG[6]);
    7: Write(ErrorMSG[7]);
    8: Write(ErrorMSG[8]);
  End;
  Repeat Until Port[$60]=1; {Cekej na ESC}
  TextColor(7); TextBackground(0); {Set puvodni}
  GotoXY(X,Y);    ClrEol; {Smazat ErrorMSG Okno}
  GotoXY(X,Y+1);  ClrEol; {Smazat ErrorMSG Okno}
  GotoXY(X,Y+2);  ClrEol; {Smazat ErrorMSG Okno}
  GotoXY(X,Y+3);  ClrEol; {Smazat ErrorMSG Okno}
End;
 
 
Function FileNameDialog: Byte;
Begin
  TextColor(7); TextBackground(0);
  GotoXY(53,3); Write('ÄÄÄÄÄÄÄÄ');
  GotoXY(39,2); Write('jmeno souboru=');
  ReadLN(FileNameJmeno);
  FileName:=FileNameJmeno+FileNamePripona;
  FindFirst(FileName,Archive,DirInfo);
  If DosError>0 then Begin
                       FileNameDialogOK:=False;
                       Case DosError of
                         2: LoadError(1); {Nenalezen soubor}
                         3: LoadError(2); {Nenalezena cesta}
                         5: LoadError(3); {PýĄstup zamĄtnut}
                         6: LoadError(4); {Neplatně deskriptor}
                         8: LoadError(5); {Nedostatek pamŘti}
                        10: LoadError(6); {Neplatn prostýedĄ}
                        11: LoadError(7); {Neplatně form t}
                        18: LoadError(8); {Soubor nenalezen}
                       End;
                     End
                else FileNameDialogOK:=True; {DosError=0 tzn. zadna chyba}
  GotoXY(53,3); ClrEol;
  GotoXY(39,2); ClrEol;
End;
 
 
Procedure FnLoad;
Begin
  FileNameDialog;
  If FileNameDialogOK=True then
  Begin
    Assign(F,Filename);
    Reset(F,1);
    BlockRead(F,Grafika,8000);
    BlockRead(F,Barvy4,1000);
    BlockRead(F,Paleta,48);
    BlockRead(F,CisloStranky,1);
    Rozkodovat;
    Close(F);
    SoundDone;
  End
  else FileName:='none';
End;
 
 
Procedure FnCreate;
Var I: Byte;
Begin
  FileNameDialog;
  Assign(F,Filename);
  ReWrite(F,1);
  BlockWrite(F,Grafika,8000);
  BlockWrite(F,Barvy4,1000);
  BlockWrite(F,Paleta,48);
  BlockWrite(F,CisloStranky,1);
  Close(F);
  {vytvoreni 16ti mono barev}
  For I:=0 to 15 do
  Begin
    Barva[I].R:=I*4;
    Barva[I].G:=I*4;
    Barva[I].B:=I*4;
  End;
  SoundDone;
End;
 
 
Procedure FnHelp;
Var I: Byte;
    Ending: Boolean;
Begin
  GotoXY(1,8);  For I:=1 to 80 do Write('Ü');
  GotoXY(1,24); For I:=1 to 80 do Write('ß');
  GotoXY(1,9);  For I:=9 to 23 do Begin GotoXY(1,I); Write('Ű'); End;
  GotoXY(80,9); For I:=9 to 23 do Begin GotoXY(80,I); Write('Ű'); End;
  GotoXY(3,10); Write('Editor 8x8 - çipky=kurzor   C=kopĄrovat   V=vlo§it ze schr nky      ESC=EXIT');
  GotoXY(3,11); Write('             F6=Editor40x40   F7=NastavenĄ barev   F8=MĄch nĄ barev         ');
  GotoXY(3,13); Write('Editor 40x40 - çipky=velkě kurzor  IJKL=malě kurzor  ASDF=kreslenĄ          ');
  GotoXY(3,15); Write('NastavenĄ barev - çipky=velkě kurzor IJKL=malě kurzor  ASDF=NastavenĄ barev ');
  GotoXY(3,17); Write('MĄch nĄ barev - çipky doleva,doprava=věbŘr barvy                            ');
  GotoXY(3,18); Write('                Insert,Delete=pýidat,ubrat ervenou                         ');
  GotoXY(3,19); Write('                Home,End=pýidat,unbrat zelenou                              ');
  GotoXY(3,20); Write('                PageUp,PageDown=pýidat,ubrat modrou                         ');
  GotoXY(3,22); Write('Toto menu - çipky nahoru,dol=věbŘr polo§ky ENTER=potvrzenĄ                 ');
  GotoXY(3,23); Write('            PgUp,PgDn=nastavenĄ Ąsla str nky ,klav. zkratky=F1 F2 F3 F4 F5 ');
  Ending:=False;
  Repeat
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{ESC}    1: Begin Ending:=True; End;
    End; {Case End}
  Until Ending=True;
  For I:=8 to 24 do Begin GotoXY(1,I); ClrEol; End;
End;
 
 
Procedure MMFunction; {enter in menu function}
Begin
  Case MMSelect of
    0: Begin SoundStorno;                                       End; {NIC}
    1: Begin If FileName='none' then FnCreate Else SoundStorno; End; {NEW}
    2: Begin If FileName='none' then SoundStorno Else FnSave;   End; {SAVE}
    3: Begin If FileName='none' then FnLoad Else SoundStorno;   End; {OPEN}
    4: Begin If FileName='none' then SoundStorno Else FnEditor; End; {EDITOR}
    5: Begin FnHelp;                                            End; {HELP}
  End;
End;
 
 
Procedure WriteNabidka;
Begin
  TextColor(14); TextBackground(1);
  GotoXY(1,2); Write('vytvoýit F4');
  GotoXY(1,3); Write('ulo§it   F2');
  GotoXY(1,4); Write('otevýĄt  F3');
  GotoXY(1,5); Write('editor   F5');
  GotoXY(1,6); Write('n povŘda F1');
  TextColor(7); TextBackground(0);
  GotoXY(80,25);
End;
 
 
Procedure WriteLista;
Var I: Byte;
Begin
  TextColor(14); TextBackground(1);
  GotoXY(1,1); For I:=1 to 79 do Write(' ');
  GotoXY(2,1); Write('ÉMENUť');
  GotoXY(14,1); Write('EDITOR GRAFIKY');
  GotoXY(34,1); Write('soubor=',FileName);
  GotoXY(58,1); Write('Str nka=',CisloStranky);
  GotoXY(73,1); Write('F10=EXIT');
  TextColor(7); TextBackground(0);
  GotoXY(80,25);
End;
 
 
Procedure WriteMenu;
Begin
  WriteLista; If MMSelect>0 then WriteNabidka;
  Case MMSelect of
    0: Begin
         TextColor(7); TextBackground(0);
         GotoXY(1,2); ClrEol;
         GotoXY(1,3); ClrEol;
         GotoXY(1,4); ClrEol;
         GotoXY(1,5); ClrEol;
         GotoXY(1,6); ClrEol;
         GotoXY(80,25);
       End;
    1: Begin
         TextColor(2); TextBackground(4);
         GotoXY(1,2); Write('vytvoýit F4');
         TextColor(7); TextBackground(0);
       End;
    2: Begin
         TextColor(2); TextBackground(4);
         GotoXY(1,3); Write('ulo§it   F2');
         TextColor(7); TextBackground(0);
       End;
    3: Begin
         TextColor(2); TextBackground(4);
         GotoXY(1,4); Write('otevýĄt  F3');
         TextColor(7); TextBackground(0);
       End;
    4: Begin
         TextColor(2); TextBackground(4);
         GotoXY(1,5); Write('editor   F5');
         TextColor(7); TextBackground(0);
       End;
    5: Begin
         TextColor(2); TextBackground(4);
         GotoXY(1,6); Write('n povŘda F1');
         TextColor(7); TextBackground(0);
       End;
  End;{Case End}
End;
 
 
Procedure MainMenu;
Var Ending: Boolean;
Begin
  ClrScr;
  MMSelect:=0;
  Ending:=False;
  Repeat
    WriteMenu;
    ReadKey; Delay(100); NoBeep;
    Case Port[$60] of
{ESC}    1: Begin MMSelect:=0; End;
{UP}    72: Begin If MMSelect>1 then Dec(MMSelect) Else MMSelect:=5; End;
{DOWN}  80: Begin If MMSelect<5 then Inc(MMSelect) Else MMSelect:=1; End;
{ENTER} 28: Begin MMFunction; End;
{PgUp}  73: Begin If FileName='none' then SoundStorno Else
                  If CisloStranky<7 then Inc(CisloStranky);End;
{PgDn}  81: Begin If FileName='none' then SoundStorno Else
                  If CisloStranky>0 then Dec(CisloStranky); End;
{F1}    59: Begin FnHelp; End;
{F2}    60: Begin If FileName='none' then SoundStorno Else FnSave; End;
{F3}    61: Begin If FileName='none' then FnLoad Else SoundStorno; End;
{F4}    62: Begin If FileName='none' then FnCreate Else SoundStorno; End;
{F5}    63: Begin If FileName='none' then SoundStorno Else FnEditor; End;
{F10}   68: Begin Ending:=True; End;
    End; {Case End}
  Until Ending=True;
End;
 
 
Procedure Main;
Begin
  InitBuffers;
  FileName:='none';
  CisloStranky:=0;
  MainMenu;
  ShutdownBuffers;
  ClrScr;
End;
 
 
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Begin Main; End.
Program editor umoznuje vytvaret, ukladat i nacitat z disku graficke soubory s priponou gra

Navigační menu

Osobní nástroje

Hledat

Pascal programy

Pascal Wiki

Bonus

Kontakty

V jiných jazycích
