Program pre otáčanie texturou pomocou kolineránich transformácií

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Kategória: KMP (Klub mladých programátorov)
krychle.pngProgram: Krychle.pas,  U_crt.pas,  U_graf13.pas,  U_znacka.pas
Súbor exe: Krychle.exe
Potrebné: Textura2.bmp,  Textura2.obj

Program pre otáčanie texturou pomocou kolineránich transformácií.
{ u_graf13.pas                                                       }
{ Unit pre program krychle.pas                                       }
{                                                                    }
{ Author:                                                            }
{ Datum:02.02.2008                              http://www.trsek.com }
 
{$D-,E-,G+,I-,L-,N-,P+,Q-,R-,S-,T-,V-,Y- exe}
{$G+}
{VGA a 386 nebo vyssi}
Unit U_Graf13;
Interface
 
Type
    PointType= record
      x,y:integer;
    end;
    Pole13=Array[0..201,0..319] of Byte;    {o 2 spodni radky vetsi}
    TypPaleta=Array[0..767] Of Byte; {RGB}
Const
    Scr13=$A000;    {pri SCR13:Word=$A000 pouzivat mov ax,[Scr13]}
    Color13:Byte=1;
    AktObraz13:Boolean=True;
    Vypln13:Boolean=False;
    Tet13:PointType=(x:0;y:0); {aktualni souradnice}
Var
    Red13,Green13,Blue13:Boolean;
    Pal13:TypPaleta; {RGB}
    FSeg13,FOfs13:Word;
    Schranka13:^Pole13;
    Obrazovka13:Pole13 Absolute SCR13:$0000;
 
 
Procedure PutPixel(X,Y:Integer;Barva:Byte);
Function  GetPixel(X,Y:Integer): Byte;
Procedure Line(X1,Y1,X2,Y2:Integer);
Procedure SetColor(Barva:Byte);
Function  GetColor:Byte;
Procedure SetRGBPalette(IndexBarvy,Red,Green,Blue:Byte);
Procedure Elipsa13(Sx,Sy:Integer;a,b:Real);
Procedure Circle(X,Y:Integer;Polomer:Word);
Procedure ClearDevice;
Procedure InitGraph;
Procedure CloseGraph;
Procedure OutText(Retezec:String);
Procedure OutInteger(Cislo:LongInt);
Procedure OutTextXY(X,Y:Integer;Retezec:String);
Procedure OutXYCode(X,Y:Integer;Cod:Byte);
Procedure DrawPoly(Pocet:word;var Seznam);
Procedure FillPoly(Pocet:word;var Seznam);
 
Procedure Rozmazni;    {Rozmaze Schranku13}
Procedure InitPalRGB;
Procedure InitPalSpektrum;
Procedure InitPalOhen;
Procedure Vybarvi(a:Byte); {vybarvi i skrytou cast (2 radky)}
Procedure ZobrazSchranku13;    {32 bit!!! Kopiruje Schranku13 do Obrazovky13}
Procedure UlozSchranku13;    {32 bit!!! naopak..}
Procedure LoadPal;
 
 
Implementation
 
Function Orez(var x1,y1,x2,y2:Integer):Boolean;
Const
MaxX = 319;
MaxY = 199;
MinX = 0;
MinY = 0;
Var
   P:array[0..9] of LongInt;
   W,O,N,M:Byte;
   D:LongInt;
Begin
   Orez := False;
   IF (x1 < MinX) and (x2 < MinX) Then Exit;
   IF (x1 > MaxX) and (x2 > MaxX) Then Exit;
   IF (y1 < MinY) and (y2 < MinY) Then Exit;
   IF (y1 > MaxY) and (y2 > MaxY) Then Exit;
   {zbavili jsme se tecek u neprotinajicich primek na okraji}
   Orez := True;
   P[0] := x1;
   P[1] := x2;
   P[2] := P[1] - P[0]; {dx}
   P[3] := MinX;
   P[4] := MaxX;
   P[5] := y1;
   P[6] := y2;
   P[7] := P[6] - P[5]; {dy}
   P[8] := MinY;
   P[9] := MaxY;
   For W := 0 to 1 do
    For O := 0 to 1 do
     For N := 0 to 1 do
      Begin
        M := (w shl 2) + w; {0,0,0,0,5,5,5,5}
        D := P[M + 3 + O] - P[M + N]; {3-0,3-1,4-0,4-1,8-5,8-6,9-5,9-6}
        IF (D * (1 - (O shl 1))) <= 0 THEN Continue;
        {bod je vne ohrady}
        IF P[M + 2] = 0 THEN
        Begin
         {rovnobezka mimo obdelnik}
         Orez := False;
         Exit;
        End;
        {(3-0)/2, (3-1)/2, (4-0)/2, (4-1)/2, (8-5)/7, (8-6)/7, (9-5)/7, (9-6)/7}
        P[5 - M + N] := P[5 - M + N] + (D * P[5 - M + 2]) div P[M + 2];
        P[M + N] := P[M + 3 + O];
        P[2] := P[1] - P[0];
        P[7] := P[6] - P[5];
      End;
   x1 := P[0];
   x2 := P[1];
   y1 := P[5];
   y2 := P[6];
   IF (x1 < MinX) Or (x1 > MaxX) Then Orez := False;
   IF (x2 < MinX) Or (x2 > MaxX) Then Orez := False;
   IF (y1 < MinY) Or (y1 > MaxY) Then Orez := False;
   IF (y2 < MinY) Or (y2 > MaxY) Then Orez := False;
End;
 
 
Procedure PutPixel(X,Y:Integer;Barva:Byte); Assembler;
ASM
    MOV    AX,X
    TEST   AX,$8000
    JNZ    @Exit
    CMP    AX,319
    JA     @Exit
    MOV    BX,Y
    TEST   BX,$8000
    JNZ    @Exit
    CMP    BX,199
    JA     @Exit
    XCHG   BH,BL      {Zameni BH a BL, jako * 256}
    TEST   AktObraz13,1
    JNZ    @Obraz
    LES    DI,Schranka13
    ADD    DI,BX
    JMP    @1
@Obraz:
    MOV    CX,SCR13
    MOV    ES,CX
    MOV    DI,BX
@1:
    SHR    BX,2
    ADD    BX,AX
    ADD    DI,BX
    MOV    AL,Barva
    MOV    ES:[DI],AL
@Exit:
End;
 
Function  GetPixel(X,Y: Integer): Byte;
Begin
   IF AktObraz13 Then GetPixel := Obrazovka13[y,x]
   Else GetPixel := Schranka13^[y,x];
End;
 
Procedure Line(X1,Y1,X2,Y2:Integer);
Var
DeltaS:Integer;    {Zmena za 1 ds}
Dskok,XRoz,XRoz2,YRoz,i:Integer;
Begin
   IF NOT Orez(x1,y1,x2,y2) Then Exit;
   XRoz := x2-x1;
   YRoz := y2-y1;
   IF XRoz < 0 Then    {1 reseni zacatku}
   Begin
      x1 := x2;
      y1 := y2;
      XRoz := - XRoz;
      YRoz := - YRoz;
   End;
   IF XRoz >= Abs(YRoz) Then
    Begin
        DeltaS:= 1;
        IF YRoz >= 0 Then DSkok := 320 Else Begin DSkok := -320; YRoz := -YRoz; End;
    End Else Begin
        IF YRoz >= 0 Then DeltaS:= 320 Else Begin DeltaS:= -320; YRoz := -YRoz; End;
        DSkok := 1;
      i := XRoz; XRoz := YRoz; YRoz := i;
    End;
    XRoz2 := -(XRoz Shl 1);
    ASM
        MOV    BX,y1
        XCHG   BH,BL      {Zameni BH a BL, jako * 256}
        TEST   AktObraz13,1
        JNZ    @Obraz
        LES    DI,Schranka13
        ADD    DI,BX
        JMP    @1
@Obraz:
        MOV    CX,SCR13
        MOV    ES,CX
        MOV    DI,BX
@1:
        SHR    BX,2
        ADD    BX,x1
        ADD    DI,BX            {cil ES:DI}
        MOV    AL,Color13    {AL := Color13}
        MOV    ES:[DI],AL
        MOV    CX,XRoz        {CX := XRoz na Smycku}
        OR     CX,CX
        JZ     @Exit
        MOV    DX,YRoz
        SHL    DX,1            {DX := 2*YRoz}
        MOV    SI,dx
        SUB    SI,CX            {SI := P}
        MOV    BX,DeltaS    {BX := DeltaS}
@Smycka:
        ADD    DI,BX
        TEST   SI,$8000
        JNZ    @2
        ADD    DI,DSkok
        ADD    SI,XRoz2
@2:
        MOV    ES:[DI],AL
        ADD    SI,DX
        LOOP   @Smycka
@Exit:
    End;
{  
   _Ofs := _Ofs + y1 Shl 8 + y1 Shl 6 + x1;
   YRoz := YRoz Shl 1;
   p := YRoz - XRoz;
   For i := 1 To XRoz do
   Begin
      IF p >= 0 Then    _Ofs := _Ofs + DeltaS + DSkok Else _Ofs := _Ofs + DeltaS;
      Mem[_Seg:_Ofs] := Color13;
      IF p >= 0 Then p := p + YRoz + XRoz2 Else p := p + YRoz;
   End;
}
End;
 
Procedure SetColor(Barva:Byte);
Begin
  Color13 := Barva;
End;
 
Function  GetColor:Byte;
Begin
  GetColor := Color13;
End;
 
Procedure SetRGBPalette(IndexBarvy,Red,Green,Blue:Byte);
Begin
  Pal13[IndexBarvy*3]  := Red Shr 2;
  Pal13[IndexBarvy*3+1]:= Green Shr 2;
  Pal13[IndexBarvy*3+2]:= Blue Shr 2;
End;
 
 
Procedure Elipsa13(Sx,Sy:Integer;a,b:Real);
Var
   x,y,MinX,MaxX:Integer;
   SegObr,OfsObr,OfsBodu:Word;
Begin
   IF (a>0) And (b>0) Then
   Begin
      IF Vypln13 Then
      Begin
         IF AktObraz13 Then Begin 
           SegObr := SCR13;
           OfsObr := 0;
         End
         Else Begin
           SegObr := Seg(Schranka13^);
           OfsObr := Ofs(Schranka13^);
         End;
      End;
      For y := Trunc(-b) to Trunc(b) do
      IF (Sy + y >= 0) And (Sy + y <= 199) Then
        Begin
         x := Trunc(SQRT(SQR(a)*(1-y*y/SQR(b))));
         IF Vypln13 Then
         Begin
            MinX := SX - x;
            MaxX := SX + x;
            IF MinX < 0   Then MinX := 0;
            IF MaxX > 319 Then MaxX := 319;
            IF MaxX >= MinX Then
            Begin
              OfsBodu := OfsObr + (Sy+y) Shl 8 + (Sy+y) Shl 6;
              FillChar(Ptr(SegObr,OfsBodu + MinX)^,MaxX-MinX + 1,Color13);
            End;
         End Else
         Begin
           PutPixel(Sx + x, Sy + y,Color13);
           PutPixel(Sx - x, Sy + y,Color13);
         End;
      End;
      IF Not Vypln13 Then
      For x := Trunc(-a) to Trunc(a) do
      IF (Sx + x >= 0) And (Sx + x <= 319) Then
      Begin
         y := Trunc(SQRT(SQR(b)*(1-x*x/SQR(a))));
         PutPixel(Sx + x,Sy + y,Color13);
         PutPixel(Sx + x,Sy - y,Color13);
      End;
   End;
End;
 
 
Procedure Circle(X,Y:Integer;Polomer:Word);
Begin
   Elipsa13(X,Y,Polomer*1.212,Polomer);
End;
 
 
Procedure ClearDevice; Assembler;
ASM
    TEST   AktObraz13,1
    JNZ    @Obraz
    LES    DI,Schranka13
    JMP    @1
@Obraz:
    MOV    CX,SCR13
    MOV    ES,CX
    XOR    DI,DI
@1:
    MOV    BX,320*200
    XOR    AX,AX
@2:
    MOV    ES:[DI+BX-2],AX
    SUB    BX,2
    JNZ    @2
    MOV    Tet13.X,0
    MOV    Tet13.Y,0
End;
 
 
Procedure Vybarvi(a:Byte); Assembler;
ASM
    TEST   AktObraz13,1
    JNZ    @Obraz
    LES    DI,Schranka13
    JMP    @1
@Obraz:
    MOV    CX,SCR13
    MOV    ES,CX
    XOR    DI,DI
@1:
    MOV    BX,320*202
    MOV    AL,a
    MOV    AH,AL
@2:
    MOV    ES:[DI+BX-2],AX
    SUB    BX,2
    JNZ    @2
    MOV    Tet13.X,0
    MOV    Tet13.Y,0
End;
 
 
Procedure InitGraph;
Var
b:Byte;
Begin
   Asm
    push ds
    push bp
    Mov ax,$1a00 {cteni kombinace monitoru}
    Int 10h
    Mov B,al
    pop bp
    pop ds
   End;
   IF b <> $1a Then Begin Writeln('Karta VGA nebyla nalezena.'); Halt; End;
   IF Schranka13 = nil Then
   Begin
       IF MaxAvail < SizeOf(Pole13) Then
       Begin
          Writeln('Nedostatek pameti, potrebuji jeste: ',SizeOf(Pole13)-MaxAvail,'b souvisleho bloku.');
          Halt;
       End;
       GetMem(Schranka13,SizeOf(Pole13));
      {Ofs(Schranka13^) = 0 nebo 8}
       Fillchar(Schranka13^,SizeOf(Schranka13^),0);
    End;
   Asm
    push ds
    push bp
{sluzba 0;ah=0,al=13h; nastaveni modu 13h}
    mov ax,13h
    int 10h
{sluzba 11; funkce 30; zjisteni informaci o fontu}
    mov ax,1130h
    mov bh,1
    int 10h
    mov FSeg13,es
    mov FOfs13,bp
    pop bp
    pop ds
   End;
End;
 
Procedure CloseGraph;
Begin
    IF Schranka13 <> nil Then
   Begin
        FreeMem(Schranka13, SizeOf(Pole13));
      Schranka13 := nil;
   End;
    Asm
      push ds
      push bp
      mov ax,3h
      int 10h
      pop bp
      pop ds
    End;
End;
 
Procedure OutInteger(Cislo:LongInt);
var Slovo:string[11];
Begin
   Str(Cislo,Slovo);
   OutTextXY(Tet13.x,Tet13.y,Slovo);
End;
 
Procedure OutText(Retezec:String);
Begin
   OutTextXY(Tet13.x,Tet13.y,Retezec);
End;
 
Procedure OutXYCode(X,Y:Integer;Cod:Byte);
Var
    a,dx,dy:byte;
   Cod8:Word;
Begin
   Tet13.x := x;
   Tet13.y := y;
   Cod8 := Cod Shl 3;
   For dy := 0 to 7 do
   Begin
      a:= Mem[FSeg13:FOfs13 + dy + Cod8];
      For dx := 0 to 7 do
      Begin
         Asm
            mov al,a
            rol al,1
{SHR al,1 dx:= 7 downto 0}
            mov a,al
         End;
         IF a And 1 = 1 then PutPixel(Tet13.x+dx,Tet13.y+dy,Color13);
      End;
   End;
   Tet13.x := Tet13.x + 8;
End;
 
Procedure OutTextXY(X,Y:Integer;Retezec:String);
Var
   a,delka,dx,dy:byte;
   p:Word;
Begin
   Tet13.x := x;
   Tet13.y := y;
   For Delka := 1 To Length(Retezec) do
   Begin
      p := Ord(Retezec[Delka]);
      IF (Tet13.x > 311) or (p = 13) Then
      Begin
         Tet13.x := 0;
         Tet13.y := Tet13.y + 8;
         If p = 13 then continue;
      End;
      p := p Shl 3;
      For dy := 0 to 7 do
      Begin
         a:= Mem[FSeg13:FOfs13+dy+p];
         For dx := 0 to 7 do
         Begin
            Asm
            mov al,a
            rol al,1
            mov a,al
            End;
            IF a And 1 = 1 then PutPixel(Tet13.x+dx,Tet13.y+dy,Color13);
         End;
      End;
      Tet13.x := Tet13.x + 8;
   End;
End;
 
Procedure DrawPoly(Pocet:word;var Seznam);
Var
   S:Array[1..1000] of PointType absolute Seznam;
   a:Word;
Begin
   For a := Pocet DownTo 2 do Line(S[a].x,S[a].y,S[a-1].x,S[a-1].y);
   Line(S[Pocet].x,S[Pocet].y,S[1].x,S[1].y);
End;
 
 
 
Procedure Rozmazni; Assembler;
ASM
    LES    DI,Schranka13
    ADD    DI,320            {ES:DI adresa meneneho bodu zvetsena o radek}
 
    XOR    BH,BH
    XOR    AH,AH
    MOV    CX,64000;      {320*200 = pocita se i z radku 200 a 201, posledni meneny je 199}
@1:
    MOV    AL,ES:[DI-1]   {   +----+}
    MOV    BL,ES:[DI]     {   |-320| =meneny bod}
    ADD    AX,BX          {+--+----+--+}
    MOV    BL,ES:[DI+1]   {|-1| DI |+1|}
    ADD    AX,BX          {+--+----+--+}
    MOV    BL,ES:[DI+320] {   |+320|}
    ADD    AX,BX          {   +----+}
    SHR    AX,2                {AX := (Bod(DI-1)+Bod(DI)+Bod(DI+1)+Bod(DI+320)) div 4}
    JZ     @2
    DEC    AX                    {IF AX > 0 Then AX := Ax -1}
@2:
    MOV    BYTE PTR ES:[DI-320],AL  {nastavena barva}
    INC    DI
    LOOP   @1
END;
 
 
 
Procedure LoadPal; Assembler;
Asm
{cekani na paprsek}
   mov dx,3dah
@1:in  al,dx
   and al,8
   jz @1
@2:in  al,dx
   and al,8
   jnz @2
{}
   push ds
   push bp
   mov si,offset pal13
   mov cx,768
   mov dx,03c8h
   xor al,al
   out dx,al
   inc dx
@3:outsb
   dec cx
   jnz @3
   pop bp
   pop ds
End;
 
 
Procedure InitPalRGB;
{Procedura je predelana z procedur Radovana Urbana}
Var
   w:Word;
   b:Byte;
Begin
   IF Red13 And Green13 And Blue13 Then
   Begin
      InitPalSpektrum;
      Exit;
   End;
   w := 0;
   {cerna..barevna/cerna}
   For b := 0 to 31 do
   Begin
      IF Red13   Then Pal13[w]   := b Shl 1 Else Pal13[w]   := 0;
      IF Green13 Then Pal13[w+1] := b Shl 1 Else Pal13[w+1] := 0;
      IF Blue13  Then Pal13[w+2] := b Shl 1 Else Pal13[w+2] := 0;
      Inc(w,3);
    End;
   {barevna/cerna..bila}
   For b := 32 to 63 do
   Begin
      IF Red13   Then Pal13[w]   := 63 Else Pal13[w]   := (b - 32) Shl 1;
      IF Green13 Then Pal13[w+1] := 63 Else Pal13[w+1] := (b - 32) Shl 1;
      IF Blue13  Then Pal13[w+2] := 63 Else Pal13[w+2] := (b - 32) Shl 1;
      Inc(w,3);
    End;
   {bila..barevna/cerna}
   For b := 64 to 159 do
   Begin
      IF Red13   Then Pal13[w]   := 63 Else Pal13[w]   := ((159 - b) Shl 1) Div 3;
      IF Green13 Then Pal13[w+1] := 63 Else Pal13[w+1] := ((159 - b) Shl 1) Div 3;
      IF Blue13  Then Pal13[w+2] := 63 Else Pal13[w+2] := ((159 - b) Shl 1) Div 3;
      Inc(w,3);
   End;
   {barevna/cerna..cerna}
    For b := 160 to 255 do
   Begin
      IF Red13   Then Pal13[w]   := ((255 - b) Shl 1) Div 3 Else Pal13[w]   := 0;
      IF Green13 Then Pal13[w+1] := ((255 - b) Shl 1) Div 3 Else Pal13[w+1] := 0;
      IF Blue13  Then Pal13[w+2] := ((255 - b) Shl 1) Div 3 Else Pal13[w+2] := 0;
      Inc(w,3);
   End;
   LoadPal;
End;
 
 
Procedure _InitPalSpektrum;
{Procedura je predelana z procedur Radovana Urbana}
Var
   w:Word;
   b:Byte;
Begin
   w := 0;
   {cerna}
   For b := 0 to 31 do {32}
   Begin
      {R} Pal13[w]  := b Shl 1;
      {G} Pal13[w+1]:= 0;
      {B} Pal13[w+2]:= 0;
      Inc(w,3);
   End;
   {cervena}
   For b := 32 to 95 do {64}
   Begin
      {64 = oranzova}
      {R}Pal13[w]   := 63;
      {G}Pal13[w+1] := b - 32;
      {B}Pal13[w+2] := 0;
      Inc(w,3);
   End;
   {zluta}
   For b := 96 to 127 do {32}
   Begin
      {R} Pal13[w]   := (127 - b) Shl 1;
      {G} Pal13[w+1] := 63;
      {B} Pal13[w+2] := 0;
      Inc(w,3);
   End;
   {zelena}
   For b := 128 to 191 do {64}
   Begin
      {160 = azurova}
      {R} Pal13[w]   := 0;
      {G} Pal13[w+1] := 191 - b;
      {B} Pal13[w+2] := b - 128;
      Inc(w,3);
   End;
   {modra}
   For b := 192 to 223 do {32}
   Begin
      {R} Pal13[w]   := (b - 192) Shl 1;
      {G} Pal13[w+1] := 0;
      {B} Pal13[w+2] := 63;
      Inc(w,3);
   End;
   {fialova}
   For b := 224 to 255 do {32}
   Begin
      {R} Pal13[w]   := (255 - b) Shl 1;
      {G} Pal13[w+1] := 0;
      {B} Pal13[w+2] := (255 - b) Shl 1;
      Inc(w,3);
   End;
   {cerna}
   LoadPal;
End;
 
 
Procedure InitPalSpektrum;
{Procedura je predelana z procedur Radovana Urbana}
Type
TypAkce=(min,max,up32,up64,down32,down64);
 
Function Akce(Kolik,b:Byte;A:TypAkce):Byte;
Begin
    Case A Of
      min : Akce := 0;
      max : Akce := 63;
      up32: Akce := b Shl 1;
      up64: Akce := b;
      down32: Akce := (Kolik - b - 1) Shl 1;
      down64: Akce := Kolik - b - 1;
   End;
End;
 
Procedure Pomocna(Kolik:Byte;Var Index:Word;ARed,AGreen,ABlue:TypAkce);
Var b:Byte;
Begin
   For b := 0 To Kolik - 1 Do
   Begin
      {R} Pal13[Index]  := Akce(Kolik,b,ARed);
      {G} Pal13[Index+1]:= Akce(Kolik,b,AGreen);
      {B} Pal13[Index+2]:= Akce(Kolik,b,ABlue);
      Inc(Index,3);
   End;
End;
 
Var
   w:Word;
   b:Byte;
Begin
   w := 0;
   {cerna}
   Pomocna(32,w,up32,min,min);
   {cervena}
   Pomocna(64,w,max,up64,min); {64 = oranzova}
   {zluta}
   Pomocna(32,w,down32,max,min);
   {zelena}
   Pomocna(64,w,min,down64,up64); {160 = azurova}
   {modra}
   Pomocna(32,w,up32,min,max);
   {fialova}
   Pomocna(32,w,down32,min,down32);
   {cerna}
   LoadPal;
End;
 
Procedure _InitPalOhen;
{Procedura je predelana z procedur Radovana Urbana}
Type
TypAkce=(min,max,up32,up64,down32,down64);
 
Function Akce(Kolik,b:Byte;A:TypAkce):Byte;
Begin
    Case A Of
      min : Akce := 0;
      max : Akce := 63;
      up32: Akce := b Shl 1;
      up64: Akce := b;
      down32: Akce := (Kolik - b - 1) Shl 1;
      down64: Akce := Kolik - b - 1;
   End;
End;
 
Procedure Pomocna(Kolik:Byte;Var Index:Word;ARed,AGreen,ABlue:TypAkce);
Var b:Byte;
Begin
   For b := 0 To Kolik - 1 Do
   Begin
      {R} Pal13[Index]  := Akce(Kolik,b,ARed);
      {G} Pal13[Index+1]:= Akce(Kolik,b,AGreen);
      {B} Pal13[Index+2]:= Akce(Kolik,b,ABlue);
      Inc(Index,3);
   End;
End;
 
Var
   w:Word;
   b:Byte;
Begin
   w := 0;
   {cerna}
   Pomocna(32,w,min,min,up32);
   {modra}
   Pomocna(32,w,up32,min,max);
   {fialova}
   Pomocna(64,w,max,min,down64);
   {cervena}
   Pomocna(64,w,max,up64,min);
   {zluta}
   Pomocna(64,w,max,max,up64);
   {bila}
{   Pomocna(32,w,max,down32,min);
   {cervena}
{   Pomocna(32,w,max,min,up32);
   {fialova}
{   Pomocna(32,w,down32,min,down32);
   {cerna}
   LoadPal;
End;
 
 
 
Procedure InitPalOhen;
{Procedura je predelana z procedur Radovana Urbana}
Var
   w:Word;
   b:Byte;
Begin
   w := 0;
   {cerna}
   For b := 0 to 15 do
   Begin
      {R} Pal13[w]  := 0;
      {G} Pal13[w+1]:= 0;
      {B} Pal13[w+2]:= b;
      Inc(w,3);
   End;
   {ctvrtmodra}
   For b := 16 to 31 do
   Begin
      {R}Pal13[w]   := b - 16;
      {G}Pal13[w+1] := 0;
      {B}Pal13[w+2] := b;
      Inc(w,3);
   End;
   {pulfialova}
   For b := 32 to 63 do
   Begin
      {R} Pal13[w]   := b - 16;
      {G} Pal13[w+1] := 0;
      {B} Pal13[w+2] := 63 - b;
      Inc(w,3);
   End;
   {cervena}
   For b := 64 to 79 do
   Begin
      {R} Pal13[w]   := b - 16;
      {G} Pal13[w+1] := 0;
      {B} Pal13[w+2] := 0;
      Inc(w,3);
   End;
   {cervena}
   For b := 80 to 95 do
   Begin
      {R} Pal13[w]   := 63;
      {G} Pal13[w+1] := 0;
      {B} Pal13[w+2] := 0;
      Inc(w,3);
   End;
   {cervena}
   For b := 96 to 159 do {64}
   Begin
      {v puli = oranzova}
      {R} Pal13[w]   := 63;
      {G} Pal13[w+1] := b - 96;
      {B} Pal13[w+2] := 0;
      Inc(w,3);
   End;
   {zluta}
   For b := 160 to 223 do {64}
   Begin
      {R} Pal13[w]   := 63;
      {G} Pal13[w+1] := 63;
      {B} Pal13[w+2] := b - 160;
      Inc(w,3);
   End;
   {bila}
   For b := 224 to 255 do
   Begin
      {R} Pal13[w]   := (255 - b) Shl 1;
      {G} Pal13[w+1] := (255 - b) Shl 1;
      {B} Pal13[w+2] := (255 - b) Shl 1;
      Inc(w,3);
   End;
   {cerna}
   LoadPal;
End;
 
 
Procedure ZobrazSchranku13; assembler;
Asm  {0..199}
{cekani na paprsek}
   mov dx,3dah
@1:in  al,dx
   and al,8
   jz  @1
@2:in  al,dx
   and al,8
   jnz @2
{}
    Push   ds
    mov    AX,SCR13
    mov    ES,ax
    Xor    DI,Di                {nastaven segment a offset cile ES:DI}
    LDS    SI,Schranka13    {nastaven segment a offset startu DS:SI}
    MOV    CX,16000            {kolikrat se bude opakovat rep}
    DB     66h                {32 bit instrukce?}
    REP    MOVSW                {rep = IF cx>0 then cx := cx - 1}
    Pop    ds
End;
 
 
Procedure UlozSchranku13; assembler;
Asm  {0..199}
    Push   ds
    mov    AX,SCR13
    LES    DI,Schranka13  {nastaven segment a offset cile ES:DI}
    MOV    DS,ax
    Xor    SI,SI                {nastaven segment a offset startu DS:SI}
    MOV    CX,16000            {kolikrat se bude opakovat rep}
    DB     66h                {32 bit instrukce?}
    REP    MOVSW                {rep = IF cx>0 then cx := cx - 1}
    Pop    ds
End;
 
 
Procedure FillPoly(Pocet:word;var Seznam);
Var
  S:Array[1..1000] of PointType absolute Seznam;
  DeltaX,DeltaY:Array[1..1000] of Integer;
  Pomocny:Array[1..1000] of Integer Absolute DeltaY;
  MinY,MaxY,Y,x1,x2:Integer;
  a,a2,Sum:Word;
  PrusecikX:Array[1..1000] of Integer;
  ZmenaStoupani:Boolean;
  L:LongInt;
  SegObr,OfsObr,OfsBodu:Word;
 
  Procedure Serad(Pocet:Word;Var IntegerBuffer);
  Var
     S:Array[1..1000] of Integer absolute IntegerBuffer;
     a,b:Word;
     i:Integer;
  Begin
     For a := 2 to Pocet do
     Begin
        For b := a downto 2 do
        Begin
          IF S[b] < S[b-1] Then
          Begin
             i      := S[b-1];
             S[b-1] := S[b];
             S[b]   := i;
          End
        Else Break;
        End;
    End;
  End;
 
Begin
  IF AktObraz13 then
  Begin
     SegObr := SCR13;
     OfsObr := 0;
  End
  Else begin
     SegObr := Seg(Schranka13^);
     OfsObr := Ofs(Schranka13^);
  End;
  For a := 1 To Pocet do Pomocny[a] := S[a].Y;
  Serad(Pocet,Pomocny);
  MinY := Pomocny[1];
  MaxY := Pomocny[Pocet];
  If MinY < 0 then MinY := 0;
  If MinY>199 then Exit;
  If MaxY>199 then MaxY := 199;
  If MaxY < 0 then Exit;
 
  DeltaX[1] := S[1].X - S[Pocet].X;
  DeltaY[1] := S[1].Y - S[Pocet].Y;
  For a := 2 to Pocet do DeltaX[a] := S[a].X - S[a-1].X;
  For a := 2 to Pocet do DeltaY[a] := S[a].Y - S[a-1].Y;
  DeltaX[Pocet+1] := DeltaX[1];
  DeltaY[Pocet+1] := DeltaY[1];
 
  For Y := MinY to MaxY do
  Begin
    Sum := 0;
    For a := 1 to Pocet do
    Begin
      IF a = 1 Then a2 := Pocet Else a2 := a - 1;
      ZmenaStoupani := Not (((DeltaY[a]>0) And (DeltaY[a+1]>0)) Or ((DeltaY[a]<0) And (DeltaY[a+1]<0)));
      {Test zda y protina usecku d(a,a2)}
      IF (S[a].y >= y) or (S[a2].y >= y) Then 
      IF (S[a].y <= y) or (S[a2].y <= y) Then 
      IF Not (S[a].y = S[a2].y) {vod primka, DeltaY = 0} Then 
      IF ZmenaStoupani OR (S[a].y <> y) Then Begin
        Sum := Sum + 1;
        L := y - S[a2].y; {jinak to obcas pretece}
{        PrusecikX[Sum] := L*DeltaX[a] div DeltaY[a] + S[a2].x;}
        L := L*DeltaX[a];
        IF ((L > 0) And (DeltaY[a] > 0)) Or ((L < 0) And (DeltaY[a] < 0)) Then
          PrusecikX[Sum] := (L + DeltaY[a] Div 2) div DeltaY[a] + S[a2].x
        Else
          PrusecikX[Sum] := (L - DeltaY[a] Div 2) div DeltaY[a] + S[a2].x;
      End;
    End;
    If Sum = 0 Then Continue;
    If Odd(Sum) Then OutText('Chyba pri vybarvovani n-uhelniku'#13); {nastane nekdy pokud jsou 2 totozne body(1= posledni)}
    Serad(Sum,PrusecikX);
    OfsBodu := OfsObr + y Shl 8 + y Shl 6;
    For a := 1 To Sum SHR 1 do
    Begin
      x1 := PrusecikX[(a SHL 1)-1];
      x2 := PrusecikX[(a SHL 1)];
      IF (x2 < 0) OR (x1 > 319) Then Continue;
      IF x1 < 0 then x1 := 0;
      IF x2 > 319 then x2 := 319;
      FillChar(Ptr(SegObr,OfsBodu + x1)^,x2-x1+1,Color13);
    End;
  End;
End;
 
 
End.