Program pre otáčanie texturou pomocou kolineránich transformácií
Delphi & Pascal (česká wiki)
Kategorija: KMP (Programy mladňakoch
Program: Krychle.pas, U_crt.pas, U_graf13.pas, U_znacka.pas
Subor exe: Krychle.exe
Mušiš mac: Textura2.bmp, Textura2.obj
Program: Krychle.pas, U_crt.pas, U_graf13.pas, U_znacka.pasSubor exe: Krychle.exe
Mušiš mac: 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.