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

Program: Krychle.pas, U_crt.pas, U_graf13.pas, U_znacka.pas
Subor exe: Krychle.exe
Mušiš mac: Textura2.bmp, Textura2.obj
Program pre otáčanie texturou pomocou kolineránich transformácií.
{ krychle.pas                                                        }
{ Program pre otacanie kockou pomocou kolineranich transformacii.    }
{                                                                    }
{ Kolinerani transformace:                                           }
{         a1*x + a2*y + a3          b1*x + b2*y + b3                 }
{   X' = ------------------   Y' = ------------------                }
{         c1*x + c2*y + 1           c1*x + c2*y + 1                  }
{                                                                    }
{ Upravena kolinearni transformace:  X' = la/lc, Y' = lb/lc          }
{                                                                    }
{ la a lb je vetsi nez lc x krat, kde x je velikost textury (= tak   } 
{ 9 bitove cislo)                                                    }
{                                                                    }
{ lc se nastavi tak aby bylo co nejvetsi ale ne vetsi jak 15 bitu    }
{ (16 je znamenko), a o trochu mene kvuli preteceni pres 15 bitu diky}
{ zaokrouhlovani (viz s := 32000/s a ne 32768/s)                     }
{                                                                    }
{ la a lb maji tedy max 24 bitu. Max chyba ze zaokrouhlovani cisla   }
{ la nebo lb {je 320*0.5=+-160 (v prave casti obrazu)                }
{                                                                    }
{ Author:                                                            }
{ Datum:02.02.2008                              http://www.trsek.com }
 
{$M 1200,64640,64640}
{$D-,E-,G+,I-,L-,N-,P+,Q-,R-,S-,T-,V-,Y- exe}
{B+,D+,L+,I+,Q+,R+,S+,T+,V+,Y+ ladici}
{$N+,G+}
Uses U_Znacka,U_Graf13,U_CRT;
 
Type
    BGRNul= record
       Blue :Byte;
       Green:Byte;
       Red  :Byte;
       Nula :Byte; {vzdy = 0}
    End;
    TypPaleta256=Array[0..255] of BGRNul;
    Vektor = Array [1..3] of Single;
    TypBaze=Array[1..3] of Vektor;
    _Sour = record
        x,y:Single;
    end;
    _Bod = record
        Old,New:_Sour;
    End;
   Sour2D = Record
      Sour:_Sour;
      JeVidet:Boolean;
   End;
Const
   Xpul= 159;
   Ypul= 99;
   RozhledX = 300;
   RozhledY = 240;
   TvrdyMaxPol=6;
   TvrdyMaxHran=4;
   TvrdyMaxBod=8;
 
   MaxPol{:Word}=6;
   MaxBod{:Word}=8;
    Uhly:array[1..5] of Integer=(1,3,7,9,3);
   Posun:Byte = 4;
   Cekej:Byte=0;
   Ohen:Boolean=False;
   Rotace:Boolean=False;
   Pohyb:Boolean=False;
   Stop:Boolean=False;
 
    StredPohybuKrychle:Array[1..3] of Integer =(80,0,0);
    StredKrychle:Array[1..3] of Single =(110,0,0);
    LokalKrychle:array[1..TvrdyMaxBod,1..3] of Integer=
{1}((-20, 20,-20),
{2} (-20,-20,-20),
{3} ( 20,-20,-20),
{4} ( 20, 20,-20),
{5} (-20, 20, 20),
{6} (-20,-20, 20),
{7} ( 20,-20, 20),
{8} ( 20, 20, 20));
{[polygon,0]=pocet bodu, viditelna strana ve smeru hod rucicek}
    SezPolBod:array[1..TvrdyMaxPol,1..TvrdyMaxHran] of Integer=
{1}((1,2,3,4),
{2} (3,7,8,4),
{3} (1,5,6,2),
{4} (3,2,6,7),
{5} (1,4,8,5),
{6} (5,8,7,6));
    BazeOka:TypBaze=((1,0,0),(0,1,0),(0,0,1));
    BazeKrychle:TypBaze=((1,0,0),(0,1,0),(0,0,1));
    VekStredu:TypBaze=((1,0,0),(0,1,0),(0,0,1));
   Ident:Array[1..4] of _Bod=(   {New = velikost obrazku}
   (Old:(X:0;Y:0);New:(X:0  ;Y:0)),
   (Old:(X:0;Y:0);New:(X:0  ;Y:199)),
   (Old:(X:0;Y:0);New:(X:207;Y:199)),
    (Old:(X:0;Y:0);New:(X:207;Y:0)));
Var
   CTab:Array[0..39] of Single;
   STab:Array[0..39] of Single;
 
   Body :Array[1..TvrdyMaxBod,1..3] of Single; {3D souradnice polygonu}
   Kolmy:Array[1..TvrdyMaxPol] of Vektor; {smeruje dovnitr (od viditelne strany k neviditelne)}
   Paleta256:^TypPaleta256;
   _Ofs,TOfs,_13Ofs,_13Seg:Word;
   a1,a2,a3,b1,b2,b3,c1,c2:Single;
   Oko  :Vektor; {3D souradnice}
   Obr  :Array [1..TvrdyMaxBod] of Sour2D; {2D souradnice polygonu}
   Matice:Array[0..8,0..8] of Single; {[sloupce,radky]}
   Roz  :String[2];
 
 
procedure Textura2;external;
{$L textura2.obj}
 
 
Procedure NastavMatici;
Var
a:Byte;
Begin
   For a := 1 to 4 do
   Begin
{a1}  Matice[0,a] := Ident[a].Old.X;
{a2}  Matice[1,a] := Ident[a].Old.Y;
{a3}  Matice[2,a] := 1;
{b1}  Matice[3,a] := 0;
{b2}  Matice[4,a] := 0;
{b3}  Matice[5,a] := 0;
{c1}  Matice[6,a] := -Ident[a].Old.X*Ident[a].New.X;
{c2}  Matice[7,a] := -Ident[a].Old.Y*Ident[a].New.X;
{X'}    Matice[8,a] :=  Ident[a].New.X;
 
{a1}  Matice[0,a+4] := 0;
{a2}  Matice[1,a+4] := 0;
{a3}  Matice[2,a+4] := 0;
{b1}  Matice[3,a+4] := Ident[a].Old.X;
{b2}  Matice[4,a+4] := Ident[a].Old.Y;
{b3}  Matice[5,a+4] := 1;
{c1}  Matice[6,a+4] := -Ident[a].Old.X*Ident[a].New.Y;
{c2}  Matice[7,a+4] := -Ident[a].Old.Y*Ident[a].New.Y;
{Y'}    Matice[8,a+4] :=  Ident[a].New.Y;
   End;
End;
 
 
Procedure GaussovaEliminacniMetoda;
Var
a,min,y,x:Byte;
d:Single;
 
Procedure ZamenRadky(r1,r2:Byte);
Var
a:Byte;
r:Single;
Begin
   For a := 0 to 8 do
   Begin
      r := Matice[a,r1];
      Matice[a,r1] := Matice[a,r2];
      Matice[a,r2] := r;
   End;
End;
 
Begin
    FOR min := 1 TO 7 do
   Begin
      {Vyber radku}
      d := 0;
      FOR y := Min TO 8 do
       Begin
         IF ABS(Matice[Min-1,y]) > d Then
         Begin
             a := y;
            d := ABS(Matice[Min-1,y]);
         End;
      End;
      IF d = 0 Then Continue;
      ZamenRadky(Min,a);
 
       FOR y := min + 1 TO 8 do
       Begin
          d := -Matice[min - 1, y] / Matice[min - 1, min];
          FOR x := min - 1 TO 8 do Matice[x, y] := Matice[x, min] * d + Matice[x, y];
      End;
   End;
 
    FOR y := 8 DownTO 1 do
   Begin
      d := Matice[8, y];
       FOR a := y TO 7 do d := d - Matice[a, y] * Matice[a, 0];
      IF Matice[y-1,y] <> 0 then Matice[y - 1, 0] := d / Matice[y - 1, y]
        Else Matice[y - 1, 0] := 0;
   End;
   a1 := Matice[0,0];
   a2 := Matice[1,0];
   a3 := Matice[2,0];
   b1 := Matice[3,0];
   b2 := Matice[4,0];
   b3 := Matice[5,0];
   c1 := Matice[6,0];
   c2 := Matice[7,0];
End;
 
 
 
Procedure XLoadPal;
Var a:Integer;
Begin
   For a := 0 to 255 do SetRGBPalette(a,Paleta256^[a].Red,Paleta256^[a].Green,Paleta256^[a].Blue);
   SetRGBPalette(255,255,255,255);
   LoadPal;
End;
 
 
Procedure SSouc(Var Vek1,Vek2,Vek3:Vektor);
Var
r:Single;
Begin
  Vek1[1] := Vek2[2] * Vek3[3] - Vek2[3] * Vek3[2];
  Vek1[2] := Vek2[3] * Vek3[1] - Vek2[1] * Vek3[3];
  Vek1[3] := Vek2[1] * Vek3[2] - Vek2[2] * Vek3[1];
  r := sqrt(Vek1[1] * Vek1[1] + Vek1[2] * Vek1[2] + Vek1[3] * Vek1[3]);
  Vek1[1] := Vek1[1] / r;
  Vek1[2] := Vek1[2] / r;
  Vek1[3] := Vek1[3] / r;
end;
 
 
Procedure OtocBazi(var Baze:TypBaze;Od,K,Uhel:ShortInt);
Begin
  Baze[Od,1] := Baze[Od,1] * ctab[Uhel] + Baze[K,1] * stab[Uhel];
  Baze[Od,2] := Baze[Od,2] * ctab[Uhel] + Baze[K,2] * stab[Uhel];
  Baze[Od,3] := Baze[Od,3] * ctab[Uhel] + Baze[K,3] * stab[Uhel];
  SSouc(Baze[K],Baze[K Mod 3 + 1],Baze[6-K-(K Mod 3 + 1)]);
End;
 
 
Procedure PohybOka;
 
Procedure PosunOka(a,b:ShortInt);
Begin
   Oko[1] := Oko[1] + BazeOka[a,1] * posun * b;
   Oko[2] := Oko[2] + BazeOka[a,2] * posun * b;
   Oko[3] := Oko[3] + BazeOka[a,3] * posun * b;
End;
 
begin
   {proti smeru hodinovych rucicek}
   IF (roz = ',') OR (roz = '<') THEN OtocBazi(BazeOka,3,2,Posun);
 
    {po smeru hodinovych rucicek}
   IF (roz = '.') OR (roz = '>') THEN OtocBazi(BazeOka,2,3,Posun);
 
   {dopredu} IF roz = '+' THEN PosunOka(1,1);
   {dozadu}  IF roz = '-' THEN PosunOka(1,-1);
   IF Roz[1] = #0 Then
   Case Roz[2] of
{nahoru}       'H': OtocBazi(BazeOka,3,1,Posun);
{dolu}         'P': OtocBazi(BazeOka,1,3,Posun);
{doleva}       'K': OtocBazi(BazeOka,1,2,Posun);
{doprava}      'M': OtocBazi(BazeOka,2,1,Posun);
{ukrok vlevo}  's': PosunOka(2,1);
{ukrok vpravo} 't': PosunOka(2,-1);
{ukrok nahoru} 'I': PosunOka(3,1);
{ukrok dolu}   'Q': PosunOka(3,-1);
    End; {case}
End;
 
 
Procedure VypocetKolmychVektoru;
var
a,b:Integer;
x,y:Vektor;
Begin
   For a := 1 to MaxPol do
   Begin
       For b := 1 to 3 do
       Begin
          x[b] := Body[SezPolBod[a,3],b] - Body[SezPolBod[a,2],b];
          y[b] := Body[SezPolBod[a,1],b] - Body[SezPolBod[a,2],b];
       End;
      SSouc(Kolmy[a],x,y);
   End;
End;
 
 
 
Procedure PocitejBody;
var
   a:integer;
   cos,dx,dy,dz,t:Single;
   PomVek:vektor;
begin
   FOR a := 1 TO MaxBod do
   begin
      dx := body[a, 1] - Oko[1];
      dy := body[a, 2] - Oko[2];
      dz := body[a, 3] - Oko[3];
      {cos...skalarni soucin normaly roviny a smeroveho vektoru primky (dx,dy,dz)
       cos = |1|*|dxyz|*cos(Fi)
       cos = 0 tak primka je rovnobezna s rovinou => bod je v rovine oka
       cos < 0 tak bod je za okem}
      cos := BazeOka[1,1] * dx + BazeOka[1,2] * dy + BazeOka[1,3] * dz;
      IF cos = 0 THEN Obr[a].JeVidet := False
      ELSE
      Begin
          {t..pomer mezi vzdalenosti (oko..prusecik)/(oko..bod)
           1..sqr(vek[1,1]) + sqr(vek[1,2]) + sqr(vek[1,3])
           t = (1/cos)*(1/(oko..bod)}
         t := 1 / cos;
         IF t > 0 Then Obr[a].JeVidet := True Else Obr[a].JeVidet := False;
         {pomvek = vektor v rovine obrazu od stredu obrazu(bodu H, H-Oko=vek[1]) k pruseciku}
         PomVek[1] := -BazeOka[1,1] + dx * t;
         PomVek[2] := -BazeOka[1,2] + dy * t;
         PomVek[3] := -BazeOka[1,3] + dz * t;
         Obr[a].Sour.x := Xpul - rozhledx * (PomVek[1] * BazeOka[2,1] + PomVek[2] * BazeOka[2,2] + PomVek[3] * BazeOka[2,3]);
         Obr[a].Sour.y := Ypul - rozhledy * (PomVek[1] * BazeOka[3,1] + PomVek[2] * BazeOka[3,2] + PomVek[3] * BazeOka[3,3]);
      end;
   end;
end;
 
Procedure Info;
Begin
   SetColor(255);
   AktObraz13 := True;
   ClearDevice;
   OutTextXY(1,1,'OVLADANI'#13);
   OutText(#24','#25','#26','#27',<,>...otaceni baze'#13);
   OutText('+,-,Ctrl'#26',Ctrl'#27',PUp,PDown...posun baze'#13);
   OutText('F1...tato napoveda'#13);
   OutText('F2,F3...+,- zdrzovaci lhuty v 0.055 s'#13);
   OutText('F4...prepinac simulace ohne'#13);
   OutText('F5...prepinac rotace objektu'#13);
   OutText('F6...prepinac pohybu objektu'#13);
   OutText('P...prepinac krokovani (ceka se na'#13'    stisk klavesy)'#13);
   OutText('R,G,B...prepinac slozek barvy'#13);
   OutText('1 az 9...velikost otoceni a posunu'#13);
   Outtext('Q,Esc...konec'#13);
   AktObraz13 := False;
   Repeat Until KeyPressed;
   While KeyPressed do ReadKey;
End;
 
procedure ZobrazPoly4(Polygon:Byte);
var
    a,sum:Byte;
    y,x1,x2:Integer;
    fromx,tox,s,s2,value:Single;
    DeltaXY:array[1..4] of Single;
    Xa,Ya:array[0..4] of Single;
   Ba:array[0..4] of Boolean;
    Bool:Boolean;
lc,ldc,la,lb,lda,ldb:LongInt;
 
begin
   For a := 1 to 4 do Xa[a] := Obr[SezPolBod[Polygon,a]].Sour.X;
   For a := 1 to 4 do Ya[a] := Obr[SezPolBod[Polygon,a]].Sour.Y;
   For a := 1 to 4 do Ba[a] := Obr[SezPolBod[Polygon,a]].JeVidet;
   Xa[0] := Xa[4];
   Ya[0] := Ya[4];
   Ba[0] := Ba[4];
   For a := 1 to 4 do if not(Ya[a]=Ya[a-1]) Then deltaxy[a]:=(Xa[a]-Xa[a-1])/(Ya[a]-Ya[a-1]);
    for y:= 0 to 199 do
    begin
       fromx:=320;
       tox:=-1;
       sum := 0;
       For a := 1 to 4 do
        IF not(ya[a]=ya[a-1]) Then
         IF Ba[a] Or Ba[a-1] Then
          Begin
           IF Ba[a] xor Ba[a-1] Then
            Begin
             IF Ba[a] Then
             Begin
               if ya[a]-ya[a-1] < 0 Then s := -1 Else s := 200;
               Bool := ((s>=y)or(ya[a]>=y)) and ((s<=y)or(ya[a]<=y));
             end;
             IF Ba[a-1] Then
             Begin
               if ya[a-1]-ya[a] < 0 Then s := -1 Else s := 200;
               Bool := ((s>=y)or(ya[a-1]>=y)) and ((s<=y)or(ya[a-1]<=y));
             end;
            End
         Else Bool := ((ya[a-1]>=y)or(ya[a]>=y)) and ((ya[a-1]<=y)or(ya[a]<=y));
          IF Bool Then
            begin
              value:=(y-ya[a-1])*deltaxy[a] + xa[a-1];
              if value<fromx then fromx:=value;
              if value>tox then tox:=value;
              If Sum = 0 then
              Begin
              {s2 + tak textura pokracuje doprava, - doleva}
                IF Ba[a] Then
                  Begin
                    s2 := Ya[a-1]-Ya[a];
                    if not Ba[a-1] Then s2 := -s2;
                  End
                  Else {If Ba[a-1] Then} s2 := Ya[a]-Ya[a-1];
            End;
            Sum := Sum + 1;
          end;
        end;
        if sum = 1 {=3, tak hrana je bez "drobnych"} Then
        Begin
            If (s2 < 0)    and (tox > 0) Then fromx := 0
            Else If (s2 > 0) and (fromx < 319) then tox := 319;
        end;
        if fromx<0 then fromx:=0;
        if tox>319 then tox:=319;
        If fromx<tox then
        Begin
         x1 := Round(fromx+0.5);
         x2 := Trunc(tox);
         IF x1 > x2 then Continue;
 
           s := abs(c2*y + 1);
           s2:= abs(320*c1 + c2*y + 1);
           IF s2 > s Then s := s2;
           s2 := abs(320*c1);
           IF s2 > s Then s := s2;
           If s = 0 Then Exit;
           s := 32000/s;
 
           lda := Trunc(a1*s);
           ldb := Trunc(b1*s);
           ldc := Trunc(c1*s*65536);
           la := Trunc(((x1-1)*a1+a2*y+a3)*s);
           lb := Trunc(((x1-1)*b1+b2*y+b3)*s);
           lc := Trunc(((x1-1)*c1+c2*y+ 1)*s*65536);
{
Kolinerani transformace:
         a1*x + a2*y + a3          b1*x + b2*y + b3
   X' = ------------------   Y' = ------------------
         c1*x + c2*y + 1           c1*x + c2*y + 1
 
Upravena kolinearni transformace:  X' = la/lc, Y' = lb/lc
 
la a lb je vetsi nez lc x krat, kde x je velikost textury (= tak 9 bitove
cislo)
 
lc se nastavi tak aby bylo co nejvetsi ale ne vetsi jak 15 bitu (16 je zna-
menko), a o trochu mene kvuli preteceni pres 15 bitu diky zaokrouhlovani
(viz s := 32000/s a ne 32768/s)
 
la a lb maji tedy max 24 bitu. Max chyba ze zaokrouhlovani cisla la nebo lb
je 320*0.5=+-160 (v prave casti obrazu)
 
S 16 bitovym lc pri vetsim priblizeni textura "tepala" tak jsem lc vynasobil
65536=(shl 16) ale delim jen 16 hornimy bity.
Max chyba pri zaokrouhlovani je 320*0.5/65536=0.0024=0 a diky tomu ze pri
deleni vezmu hornich 16 bitu bez ohledu na spodni tak +-0.99..=+-1
 
I pres usilovnou snahu nastava obcas chyba, kdy by pri deleni vzniklo cislo
vetsi nez 16 bitu a program by vytuhl s hlaskou "ze se deli nulou". Nastava
to jen kdyz je oko prilis blizko krychle. Proto obsahuje nize vkladany
assembler test (jae @Error) zda to nastane. Ten test samozrejmne trochu
zpomaluje rutinu.
}
        Asm
            mov    DI,_13Ofs
            MOV    BX,y
            XCHG    BH,BL
            ADD    DI,BX
            SHR   BX,2
            ADD    DI,BX
            mov    ax,x1
            add    di,ax
            MOV    _Ofs,DI
            mov    cx,x2
            sub    cx,ax
            inc    cx
            jmp    @Dal    {takhle blbe do delam kvuli tomu ze: false js = 1 cyklus, true js = 3 cykly}
@11:
            db $66;    neg    [word ptr la]
            db $66;    neg    [word ptr lda]
            jmp    @1
@22:
            db $66;    neg    [word ptr lb]
            db $66;    neg    [word ptr ldb]
            jmp    @2
@33:
            db $66;    neg    [word ptr lc]
            db $66;    neg    [word ptr ldc]
            jmp    @3
@Error:
            INC    _Ofs
            DEC    CX
            JZ     @Exit
@Dal:
            mov    ax,word ptr[lda]
            mov    bx,word ptr[lda+2]
            add    word ptr[la],ax
            adc    word ptr[la+2],bx
            js    @11
@1:
            mov    ax,word ptr[ldb]
            mov    bx,word ptr[ldb+2]
            add    word ptr[lb],ax
            adc    word ptr[lb+2],bx
            js    @22
@2:
            mov    ax,word ptr[ldc]
            mov    bx,word ptr[ldc+2]
            add    word ptr[lc],ax
            adc    word ptr[lc+2],bx
            js    @33
@3:
            mov   bx,word ptr[lc+2]
            or     bx,bx
            jz     @Error
 
            mov    dx,word ptr[la+2]
            mov    ax,word ptr[la]
            cmp    dx,bx
            jae    @Error
            div    bx
 
            mov    DI,TOfs
            add    DI,ax
 
            mov    dx,word ptr[lb+2]
            mov    ax,word ptr[lb]
            cmp    dx,bx
            jae    @Error
            div    bx
 
            SHL    AX,4
            ADD    DI,AX
            SHL    AX,2
            ADD    DI,AX
            SHL    AX,1
            ADD    DI,AX
            MOV   AL,CS:[DI]
 
            MOV    ES,_13Seg
            MOV    BX,_Ofs
            MOV   ES:[BX],AL
 
            INC    BX
            MOV    _Ofs,BX
            loop    @dal
@Exit:
            End;
      End; {fromx < tox}
    End; {y}
End;
 
Procedure LokalDoAbs;
Var a,b:Byte;
Begin
  For a := 1 to TvrdyMaxBod do
   For b := 1 to 3 do Body[a,b] := StredKrychle[b] +
        LokalKrychle[a,1]*BazeKrychle[1,b] +
        LokalKrychle[a,2]*BazeKrychle[2,b] +
        LokalKrychle[a,3]*BazeKrychle[3,b];
   VypocetKolmychVektoru;
End;
 
 
Procedure PohybKrychle;
Var
a:Byte;
Begin
   IF (Random(10)= 0) AND (Random(10)=0) Then Uhly[4]:= (Uhly[4] + 1) mod 40;
   IF (Random(10)= 0) AND (Random(10)=0) Then Uhly[5]:= (Uhly[5] + 1) mod 40;
{nahoru/dolu}
   OtocBazi(VekStredu,3,1,Uhly[4]);
{doleva/doprava}
   OtocBazi(VekStredu,1,2,Uhly[5]);
   For a := 1 to 3 do StredKrychle[a] := StredPohybuKrychle[a] + 30*VekStredu[1,a];
End;
 
Procedure PohybBazeKrychle;
Begin
   IF (Random(10)= 0) AND (Random(10)= 0) Then Uhly[1]:= (Uhly[1] + 1) mod 40;
   IF (Random(10)= 0) AND (Random(10)= 0) Then Uhly[2]:= (Uhly[2] + 1) mod 40;
   IF (Random(10)= 0) AND (Random(10)= 0) Then Uhly[3]:= (Uhly[3] + 1) mod 40;
   {po/proti smeru hodinovych rucicek}
   OtocBazi(BazeKrychle,2,3,Uhly[1]);
   {nahoru/dolu}
   OtocBazi(BazeKrychle,3,1,Uhly[2]);
   {doprava/doleva}
   OtocBazi(BazeKrychle,2,1,Uhly[3]);
End;
 
 
Var
   a,b:Integer;
   s  :Single;
   JeVidet:Boolean;
   t  :LongInt;
begin
    asm {rychle opakovani dlouho(nastaveno na kratce) stiskle klavesy}
        mov    ax,$0305
        mov    bx,$0000
        int    16h
    end;
{0,1..9,10,  9..1, 0,-1..-9,-10,-9..-1}
{0,1..9,10,11..19,20,21..29, 30,31..39}
   ctab[0] := 1;
   stab[0] := 0;
   s := pi/(4*180);
   For a := 1 to 10 do
   Begin
      ctab[a]   := cos(s);
      ctab[20-a]:= ctab[a];
      stab[a]   := sin(s);
      stab[20-a]:= stab[a];
      s := s * (1 + 1/a);
   End;
   For a := 20 to 39 do
   Begin
      ctab[a] :=  ctab[a-20];
      stab[a] := -stab[a-20];
   End;
 
   Paleta256:= @Textura2;
   TOfs := Ofs(Paleta256^) + 1024 + 54;
   Paleta256 := PTR(Seg(Paleta256^),Ofs(Paleta256^)+54);
   InitGraph; _13Ofs := Ofs(Schranka13^); _13Seg := Seg(Schranka13^);
   XLoadPal;
 
   Info;
   ClearDevice;
   AktObraz13 := False;
   LokalDoABS;
   Repeat
      IF Pohyb Then PohybKrychle;
      IF Rotace Then PohybBazeKrychle;
      IF Pohyb Or Rotace Then LokalDoABS;
 
      IF Not Ohen Then ClearDevice;
{      SetColor(255);}
      For a := 1 to MaxPol do
      begin
         JeVidet := False;
         FOR b := 1 to 4 do
         begin
            IF Obr[SezPolBod[a,b]].JeVidet Then JeVidet := True;
            Ident[b].Old.X := Obr[SezPolBod[a,b]].Sour.X;
            Ident[b].Old.Y := Obr[SezPolBod[a,b]].Sour.Y;
         end;
         IF JeVidet then
         begin
            {vektorovy soucin, s= |x|*|y|*cos(alfa)}
            s := 0;
            For b := 1 to 3 do s := s + Kolmy[a,b]*(Body[SezPolBod[a,1],b]-Oko[b]);
            if s > 0 then
            Begin
                   NastavMatici;
                   GaussovaEliminacniMetoda;
                   ZobrazPoly4(a);
            end;
         end;
      end;
 
      IF Ohen then Rozmazni;
 
      SetColor(255);
 
      CIRCLE(15, 10, 9);
      a:=15 - Round(10 * BazeOka[1,2]);
      b:=10 - Round(9  * BazeOka[1,1]);
      LINE (15, 10, a,b);
 
      CIRCLE(15, 29, 9);
      a:= Round(10 * Sqrt(ABS(1 - BazeOka[1,3] * BazeOka[1,3])));
      IF BazeOka[3,3] < 0 THEN a := -a;
      a:= 15 + a;
      b:= 29 - Round(9 * BazeOka[1,3]);
      LINE (15, 29, a,b);
 
      Tet13.y := 15;
      Tet13.X := 30;
      OutInteger(Time-t);
      Tet13.x := 30;
      Tet13.y := 25;
      OutInteger(Cekej);
      If Red13   Then OutTextXY(30,5,'R');
      If Green13 Then OutTextXY(38,5,'G');
      If Blue13  Then OutTextXY(46,5,'B');
      If Stop    Then OutTextXY(54,5,'P');
 
      t := Time;
 
      ZobrazSchranku13;
 
      IF Stop Then Repeat Until KeyPressed;;
 
      IF KeyPressed Then
      Begin
         Roz := UpCase(ReadKey);
         IF Roz = #0 then Roz := Roz + ReadKey;
      End
      Else Roz := #255;
      Delay27(Cekej);
 
      IF (Roz = 'Q') or (Roz = #27) THEN
      Begin
         CloseGraph;
         Halt;
      End;
 
{F1}  IF Roz = #0#59 Then Info;
 
      IF (Roz = #0#60) or (Roz=#0#61) then
      Begin
{F2}     IF (Roz = #0#60) AND (Cekej < 9) Then Cekej := Cekej + 1;
{F3}     IF (Roz = #0#61) AND (Cekej > 0) Then Cekej := Cekej - 1;
      End;
 
{F4}  IF Roz = #0#62 Then Ohen := Not Ohen;
 
{F5}  IF Roz = #0#63 Then Rotace := Not Rotace;
 
{F6}  IF Roz = #0#64 Then Pohyb := Not Pohyb;
 
{1..9}
      For a := 1 to 9 do
        IF ord(roz[1]) = 48+a Then Posun := a;
 
      If Roz = 'R'  Then Red13   := Not Red13;
      If Roz = 'G'  Then Green13 := Not Green13;
      If Roz = 'B'  Then Blue13  := Not Blue13;
      If (Roz = 'R') OR (Roz = 'G') OR (Roz = 'B') Then
      Begin
         IF Not(red13 OR green13 OR blue13) Then XLoadPal Else
         Begin
             InitPalRGB;
            SetRGBPalette(255,255,255,255);
            LoadPal;
         End;
      End;
 
      IF Roz = 'P' Then Stop := Not Stop;
 
      PohybOka;
      PocitejBody;
   Until False;
End.
Program pre otáčanie texturou pomocou kolineránich transformácií

Navigační menu

Osobní nástroje

Hledat

Pascal programy

Pascal Wiki

Daco vecej

Kontakty

Vof daľšich rečoch
