Draw texture with rotate quadrate
Delphi & Pascal (česká wiki)
Category: KMP (Club of young programmers)
Author: Ján Benkovič
web: www.tbteacher.host.sk
Program: Texure_p.pas
File exe: Texure_p.exe
Author: Ján Benkovičweb: www.tbteacher.host.sk
Program: Texure_p.pas
File exe: Texure_p.exe
Draw texture with rotate quadrate.
{ TEXURE_P.PAS } { Vykresli texturu a otacajuci sa stvorec. } { } { Datum:07.11.2000 http://www.trsek.com } {$r-,g+} program texure_poly; uses crt; Type TE = Record X : Integer; px, py : Byte; End; Table = Array[0..199] of TE; PTable = ^Table; Var Left, Right : Table; stab:array[0..255] of integer; polyz:array[0..7] of integer; pind:array[0..7] of byte; page,virscr:pointer; pageseg,virseg:word; Frame, St, Et : Longint; Time : Longint Absolute $0000:$046c; pxVal, pxStep : Integer; pyVal, pyStep : Integer; Count, res : Integer; O1 : Word; b:byte; Const Bitmap :Array[0..16*16-1] of Byte = ( 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,5,5,5,5,5,5,5,5,5,5,5,5,5,5,2, 2,5,5,1,1,1,1,1,1,1,1,1,1,5,5,2,2,5,1,5,1,1,1,1,1,1,1,1,5,1,5,2, 2,5,1,1,5,1,1,1,1,1,1,5,1,1,5,2,2,5,1,1,1,5,1,1,1,1,5,1,1,1,5,2, 2,5,1,1,1,1,5,1,1,5,1,1,1,1,5,2,2,5,1,1,1,1,1,5,5,1,1,1,1,1,5,2, 2,5,1,1,1,1,1,5,5,1,1,1,1,1,5,2,2,5,1,1,1,1,5,1,1,5,1,1,1,1,5,2, 2,5,1,1,1,5,1,1,1,1,5,1,1,1,5,2,2,5,1,1,5,1,1,1,1,1,1,5,1,1,5,2, 2,5,1,5,1,1,1,1,1,1,1,1,5,1,5,2,2,5,5,1,1,1,1,1,1,1,1,1,1,5,5,2, 2,5,5,5,5,5,5,5,5,5,5,5,5,5,5,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2); pointnum=11; planenum=7; border=false; vidseg:word=$a000; divd=128; dist=200; points:array[0..pointnum,0..2] of integer=( (-20,-20, 30),( 20,-20, 30),( 40,-40, 0),( 20,-20,-30), (-20,-20,-30),(-40,-40, 0),(-20, 20, 30),( 20, 20, 30), ( 40, 40, 0),( 20, 20,-30),(-20, 20,-30),(-40, 40, 0)); planes:array[0..planenum,0..3] of byte=( (1,2,8,7),(9,8,2,3),(10,4,5,11),(6,11,5,0), (0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10)); { -------------------------------------------------------------------------- } Procedure TextureHLine(X1, X2, px1, py1, px2, py2, Y : Integer; Dim : Word); Begin pxStep := ((px2-px1) Shl 8) Div (x2-x1+1); pyStep := ((py2-py1) Shl 8) Div (x2-x1+1); asm mov bx, px1; shl bx, 8; mov pxval,bx; { pxVal := px1 Shl 8;} mov bx, py1; shl bx, 8; mov pyval,bx; { pyVal := py1 Shl 8;} mov ax,y; shl ax,6; mov di,ax; shl ax,2 add di,ax; add di,x1; mov o1, di; End; For Count := X1 to X2 do Begin b:= Bitmap[Hi(pxVal)+(Hi(pyVal)) Shl 4]; Asm mov ax,virseg; mov es,ax; mov ax,o1; mov di,ax; mov al, b; mov es:[di],al; mov ax, pxval; add ax, pxstep; mov pxval, ax; mov ax, pyval; add ax, pystep; mov pyval, ax; inc o1; end; End; End; Procedure Swap(Var A, B : Integer); Var t : Integer; Begin t := a; a := b; b := t; End; Procedure Texture4Poly(X1, Y1, X2, Y2, X3, Y3, X4, Y4 : Integer; Dim : Byte); Var yMin, yMax : Integer; xStart, xEnd : Integer; yStart, yEnd : Integer; pxStart, pxEnd : Integer; pyStart,pyEnd : Integer; XVal, XStep : Longint; pxVal, pxStep : Integer; pyVal, pyStep : Integer; Count : Integer; Side : PTable; Begin yMin := Y1; yMax := Y1; If Y2 > yMax Then yMax := Y2; If Y3 > yMax Then yMax := Y3; If Y4 > yMax Then yMax := Y4; If Y2 < yMin Then yMin := Y2; If Y3 < yMin Then yMin := Y3; If Y4 < yMin Then yMin := Y4; xStart := X1; yStart := Y1; xEnd := X2; yEnd := Y2; pxStart := 0; pyStart := 0; pxEnd := Dim-1; pyEnd := 0; If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd); Swap(pxStart, pxEnd); Side := @Left; End Else Side := @Right; XVal := Longint(xStart) Shl 8; XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1); pxVal := pxStart Shl 8; pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1); For Count := yStart to yEnd do Begin Side^[Count].x := XVal Shr 8; Side^[Count].px := pxVal Shr 8; Side^[Count].py := pyStart; XVal := XVal + XStep; pxVal := pxVal + pxStep; End; xStart := X2; yStart := Y2; xEnd := X3; yEnd := Y3; pxStart := Dim-1; pyStart := 0; pxEnd := Dim-1; pyEnd := Dim-1; If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd); Swap(pyStart, pyEnd); Side := @Left; End Else Side := @Right; XVal := Longint(xStart) Shl 8; XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1); pyVal := pyStart Shl 8; pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1); For Count := yStart to yEnd do Begin Side^[Count].x := XVal Shr 8; Side^[Count].py := pyVal Shr 8; Side^[Count].px := pxStart; XVal := XVal + XStep; pyVal := pyVal + pyStep; End; xStart := X3; yStart := Y3; xEnd := X4; yEnd := Y4; pxStart := Dim-1; pyStart := Dim-1; pxEnd := 0; pyEnd := Dim-1; If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd); Swap(pxStart, pxEnd); Side := @Left; End Else Side := @Right; XVal := Longint(xStart) Shl 8; XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1); pxVal := pxStart Shl 8; pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1); For Count := yStart to yEnd do Begin Side^[Count].x := XVal Shr 8; Side^[Count].px := pxVal Shr 8; Side^[Count].py := pyStart; XVal := XVal + XStep; pxVal := pxVal + pxStep; End; xStart := X4; yStart := Y4;xEnd := X1; yEnd := Y1; pxStart := 0; pyStart := Dim-1; pxEnd := 0; pyEnd := 0; If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd); Swap(pyStart, pyEnd); Side := @Left; End Else Side := @Right; XVal := Longint(xStart) Shl 8; XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1); pyVal := pyStart Shl 8; pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1); For Count := yStart to yEnd do Begin Side^[Count].x := XVal Shr 8; Side^[Count].py := pyVal Shr 8; Side^[Count].px := pxStart; XVal := XVal + XStep; pyVal := pyVal + pyStep; End; For Count := yMin to yMax do If Left[Count].x < Right[Count].x Then TextureHLine(Left[Count].x, Right[Count].x, Left[Count].px, Left[Count].py, Right[Count].px, Right[Count].py, Count, Dim) Else TextureHLine(Right[Count].x, Left[Count].x, Right[Count].px, Right[Count].py, Left[Count].px, Left[Count].py, Count, Dim); End; {Asi sa zastrelim..........} procedure setpal(c,r,g,b:byte); assembler; asm; mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]; out dx,al mov al,[g]; out dx,al; mov al,[b]; out dx,al; end; procedure flip(src,dst:word); assembler; asm push ds; mov es,[dst]; mov ds,[src]; xor si,si; xor di,di; mov cx,320*200/2 rep movsw; pop ds; end; procedure quicksort(lo,hi:integer); procedure sort(l,r:integer); var i,j,x,y:integer; begin i:=l; j:=r; x:=polyz[(l+r) div 2]; repeat while polyz[i]<x do inc(i); while x<polyz[j] do dec(j); if i<=j then begin y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y; y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y; inc(i); dec(j); end; until i>j; if l<j then sort(l,j); if i<r then sort(i,r); end; begin sort(lo,hi); end; function sinus(i:byte):integer; begin sinus:=stab[i]; end; function cosinus(i:byte):integer; begin cosinus:=stab[(i+192) mod 255]; end; procedure rotate_cube; const xst=2; yst=3; zst=-4; var xp,yp,z:array[0..11] of integer; x,y,i,j,k:integer; n,Key,phix,phiy,phiz:byte; begin phix:=0; phiy:=0; phiz:=40; fillchar(xp,sizeof(xp),0); fillchar(yp,sizeof(yp),0); Frame := 0; St := Time; repeat flip(pageseg,virseg); for n:=0 to pointnum do begin i:=(cosinus(phiy)*points[n,0]-sinus(phiy)*points[n,2]) div divd; j:=(cosinus(phiz)*points[n,1]-sinus(phiz)*i) div divd; k:=(cosinus(phiy)*points[n,2]+sinus(phiy)*points[n,0]) div divd; x:=(cosinus(phiz)*i+sinus(phiz)*points[n,1]) div divd; y:=(cosinus(phix)*j+sinus(phix)*k) div divd; z[n]:=(cosinus(phix)*k-sinus(phix)*j) div divd+cosinus(phix) div 3; xp[n]:=160+sinus(phix) div 2+(-x*dist) div (z[n]-dist); yp[n]:=100+(-y*dist) div (z[n]-dist); end; for n:=0 to planenum do begin polyz[n]:=(z[planes[n,0]]+z[planes[n,2]]) div 2; pind[n]:=n; end; quicksort(0,planenum); for n:=0 to planenum do texture4poly(xp[planes[pind[n],0]],yp[planes[pind[n],0]], xp[planes[pind[n],1]],yp[planes[pind[n],1]], xp[planes[pind[n],2]],yp[planes[pind[n],2]], xp[planes[pind[n],3]],yp[planes[pind[n],3]],16); inc(phix,xst); inc(phiy,yst); inc(phiz,zst); flip(virseg,vidseg); inc(frame); delay(15); until keypressed; Et:=time; end; var i,j:word; {$Q-} begin asm mov ax,13h; int 10h; end; getmem(virscr,64000); virseg:=seg(virscr^); getmem(page,64000); pageseg:=seg(page^); for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd); for i:=1 to 104 do setpal(150+i,0,20+i div 4,30+i div 5); for i:=0 to 319 do for j:=0 to 199 do mem[pageseg:j*320+i]:=151+(i*i+j*j) mod 104; rotate_cube; freemem(page,64000); freemem(virscr,64000); textmode(lastmode); Writeln(Frame*18.2/(Et-St):5:2, ' fps'); end.