rem 3D Shade ........ Rev 5.1 rem A J Tooth // July 2006 rem Preamble================================== remon error if (err=17) then quit *FLOAT 64 himem=lomem + 100000000 install @lib$+"MyUtils.bbc" install @lib$+"BMP_Utils.bbc" rem Preamble================================== rem Setup proc_setup rem Choose a picture proc_pichoose24(Name$, FulName$, Pre$, ntused%, ntused%, ntused%) rem Go to full screen proc_fullscreen(xscreen%,yscreen%) rem Display the picture initially proc_gendisp(1, FulName$, 0, 0, xmax%, ymax%, pic%, lgth%) rem ASM Setup proc_setup2 repeat rem Rotation Matrix Setup rem Initial values are: Th=90 : Ph=3 : Ps=-90 proc_rotmat(Th,Ph,Ps) rem Grey scale array call grey% rem Height call hyte% rem Rotate the image call rotat% rem Display proc_display proc_event(a$,b&) : rem Wait for a mouse-click or a key-press. rem Alter a variable according to key pressed proc_alter(a$) until b&=1 or b&=4 if (b&=4 or a$=" ") then run else quit quit rem End of Program ========================================== rem ========================================================= rem Setup def proc_setup rem Revert to normal windowed screen proc_revert(xscreen%,yscreen%) mouse on colour 132,0,0,50 : colour 4,0,0,50 : colour 128 : cls : colour 3 mode 22 : off rem Change the Windows Title title$ = " 3-D Shade" sys "SetWindowText", @hwnd%, title$ rem Standard grey-scale weightings wr=0.30 : wg=0.59 : wb=0.11 A=-15.0 : Dis=5000.0 : M=20.0 xmax%=640 : ymax%=480 Cl&=1 Th=90.0 : Ph=2.0 : Ps=-90.0 dx=-20.0 : dz=-10.0 : dy=5.0 dim rgb% 3 dim hgt(xmax%-1,ymax%-1,3) hgt()=0.0 dim grey&(xmax%-1,ymax%-1) dim mat(2,2), com% 10 $com%="REFRESH" rem Display a background picture proc_BackPic("BPic.jpg",xscreen%,yscreen%) *FONT Blackadder ITC,30,B vdu 5 colour 8,160,90,20 gcol 8 : move 1400,350 : print;"3-D SHADE" *FONT Georgia Italic,12,B proc_back(100,1250,1100,200,150,150,150) move 200,1400 : gcol 6: print;"Choose to view either a jpeg, gif or bitmap image." gcol 3 : move 200,1350 : print;"PRESS ANY KEY OR CLICK THE MOUSE TO CONTINUE." proc_back(100,350,1250,400,150,150,150) move 200,700 : gcol 6: print;"Once the first mock-3D picture appears:..." move 200,650 : gcol 2: print;"Click either mouse button or "; gcol 11:print;"ESC"; gcol 2:print;" to "; gcol 9:print;"EXIT" move 200,600 : gcol 2:print;"Press the "; gcol 11:print;"ARROW "; gcol 2:print;"and "; gcol 11:print;"< > "; gcol 2:print;"keys to rotate the image"; move 200,550 : print;"Press -"; gcol 11:print;"G"; gcol 2:print;"- for greyscale, -"; gcol 11:print;"I"; gcol 2:print;"- for greyscale inverted, -"; gcol 11:print;"C"; gcol 2:print;"- for colour"; move 200,500 : print;"Press -"; gcol 11:print;"F"; gcol 2:print;"- to zoom IN, -"; gcol 11:print;"B"; gcol 2:print;"- to zoom OUT"; move 200,450 : print;"Press "; gcol 11:print;"+"; gcol 2:print;" or "; gcol 11:print;"-"; gcol 2:print;" to increase/decrease the 'height'"; vdu 4 proc_event(a$,b&) : rem Wait for a mouse-click or a key-press. endproc rem ======================================================================= rem Alter a variable according to key pressed def proc_alter(A$) case asc(A$) of when 45: M-=5.0 : if M<5.0 then M=5.0 when 61: M+=5.0 if M>1000.0 then M=1000.0 when 44: Ps-=10.0 : if Ps<-180.0 then Ps=-180.0 when 46: Ps+=10.0 : if Ps>180.0 then Ps=180.0 when 98: Dis+=1000.0 when 102: Dis-=1000.0 : if Dis<1000.0 then Dis=1000.0 when 136: Th-=10.0 : if Th<-180.0 then Th=-180.0 when 137: Th+=10.0 : if Th>180.0 then Th=180.0 when 138: Ph-=0.5 : if Ph<-90.0 then Ph=-90.0 when 139: Ph+=0.5 : if Ph>90.0 then Ph=90.0 when 99: Cl&=1 : rem Colour when 103: Cl&=0 : rem Greyscale when 105: Cl&=2 : rem Inverted greyscale otherwise rem Do nothing endcase endproc rem ======================================================================= rem ASM Setup def proc_setup2 dim dysp% 2000, ftmp% 7, hyte% 2000, itmp% 3, f01% 7, f085% 7 dim rotat% 1000, grey% 1000 |f01%=0.01 : |f085%=0.85 rem Dual-pass assembly, in case of labels for pass&=0 to 2 step 2 proc_dysp(pass&) proc_hyte(pass&) proc_rotat(pass&) proc_grey(pass&) next pass& endproc rem ======================================================================= rem Display def proc_display cls origin xscreen%,yscreen% *REFRESH OFF rem Display sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &100 call dysp% sys "GetCurrentProcess" to hprocess% sys "SetPriorityClass", hprocess%, &20 *REFRESH ON endproc rem ======================================================================= rem Rotation Matrix Update def proc_rotmat(Thet,Phii,Psii) local Th,Ph,Ps Th=rad(Thet) : Ph=rad(Phii) : Ps=rad(Psii) mat(0,0)= cos(Ps)*cos(Ph)*cos(Th) - sin(Ps)*sin(Th) mat(0,1)=-sin(Ps)*cos(Ph)*cos(Th) - cos(Ps)*sin(Th) mat(0,2)=-sin(Ph)*cos(Th) mat(1,0)= cos(Ps)*cos(Ph)*sin(Th) + sin(Ps)*cos(Th) mat(1,1)=-sin(Ps)*cos(Ph)*sin(Th) + cos(Ps)*cos(Th) mat(1,2)=-sin(Ph)*sin(Th) mat(2,0)= cos(Ps)*sin(Ph) mat(2,1)=-sin(Ph)*sin(Ps) mat(2,2)= cos(Ph) mat()*=1.0 endproc rem =================================================================== rem Display Routine def proc_dysp(opt&) P%=dysp% [opt opt& mov edx,[^ymax%] dec edx mov [^q%],edx .qloop mov edx,1 mov [^p%],edx .ploop finit mov eax,[^p%] dec eax imul eax,[^ymax%] shl eax,5 mov ebx,[^q%] dec ebx shl ebx,5 add eax,ebx add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^X1] add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^Z1] add eax,8 fld qword (^hgt(0,0,0))[eax] fld qword [^M] fmulp st1,st0 fstp qword [^Y1] mov eax,[^p%] imul eax,[^ymax%] shl eax,5 mov ebx,[^q%] dec ebx shl ebx,5 add eax,ebx add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^X2] add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^Z2] add eax,8 fld qword (^hgt(0,0,0))[eax] fld qword [^M] fmulp st1,st0 fstp qword [^Y2] mov eax,[^p%] dec eax imul eax,[^ymax%] shl eax,5 mov ebx,[^q%] shl ebx,5 add eax,ebx add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^X3] add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^Z3] add eax,8 fld qword (^hgt(0,0,0))[eax] fld qword [^M] fmulp st1,st0 fstp qword [^Y3] mov eax,[^p%] imul eax,[^ymax%] shl eax,5 mov ebx,[^q%] shl ebx,5 add eax,ebx add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^X4] add eax,8 fld qword (^hgt(0,0,0))[eax] fstp qword [^Z4] add eax,8 fld qword (^hgt(0,0,0))[eax] fld qword [^M] fmulp st1,st0 fstp qword [^Y4] fld qword [^Z1] fld qword [^Z2] fld qword [^Z3] fld qword [^Z4] faddp st1,st0 faddp st1,st0 faddp st1,st0 fild dword [i4%] fdivp st1,st0 ;Average 0f Zi's fld qword [^Dis] faddp st1,st0 fld qword [^A] fsubrp st1,st0 fld qword [^A] fdivrp st1,st0 fst qword [^Fac] ;Calc 0f Fac fild dword [^xscreen%] fmulp st1,st0 fld qword [^X1] fmul st0,st1 fistp dword [^x1%] fld qword [^X2] fmul st0,st1 fistp dword [^x2%] fld qword [^X3] fmul st0,st1 fistp dword [^x3%] fld qword [^X4] fmulp st1,st0 fistp dword [^x4%] fld qword [^Fac] fild dword [^yscreen%] fmulp st1,st0 fld qword [^Y1] fmul st0,st1 fistp dword [^y1%] fld qword [^Y2] fmul st0,st1 fistp dword [^y2%] fld qword [^Y3] fmul st0,st1 fistp dword [^y3%] fld qword [^Y4] fmulp st1,st0 fistp dword [^y4%] mov eax,[^xmax%] ;ref% imul eax,[^q%] imul eax,3 add eax,[^p%] add eax,[^p%] add eax,[^p%] add eax,54 ;ref% mov ecx,0 mov ebx,0 ;Colour mov bl,pic%[eax] add ecx,ebx mov [^bl&],bl mov bl,pic%[eax+1] add ecx,ebx mov [^gr&],bl mov bl,pic%[eax+2] add ecx,ebx mov [^re&],bl ;Colour mov bl,[^Cl&] cmp bl,1 je clr mov eax,ecx mov edx,0 idiv dword [i3%] cmp bl,2 jne noinv mov bl,al mov al,255 sub al,bl .noinv mov [^re&],al mov [^gr&],al mov [^bl&],al .clr mov al,19 ;Changes the rgb vlue f0r colr 10 call "oswrch" mov al,10 call "oswrch" mov al,16 call "oswrch" mov al,[^re&] call "oswrch" mov al,[^gr&] call "oswrch" mov al,[^bl&] call "oswrch" mov al,18 ;Calls gc0l routine call "oswrch" mov al,0 call "oswrch" mov al,10 call "oswrch" mov al,25 ;Calls Move routine For x1%,y1% call "oswrch" mov al,4 call "oswrch" mov bx,[^x1%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov bx,[^y1%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov al,25 ;Calls Move routine For x2%,y2% call "oswrch" mov al,4 call "oswrch" mov bx,[^x2%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov bx,[^y2%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov al,25 ;Calls Plot 85 routine For x3%,y3% call "oswrch" mov al,85 call "oswrch" mov bx,[^x3%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov bx,[^y3%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov al,25 ;Calls Plot 85 routine For x4%,y4% call "oswrch" mov al,85 call "oswrch" mov bx,[^x4%] mov al,bl call "oswrch" mov al,bh call "oswrch" mov bx,[^y4%] mov al,bl call "oswrch" mov al,bh call "oswrch" inc dword [^p%] mov edx,[^p%] cmp edx,[^xmax%] jl near ploop mov edx,com% call "oscli" ;Do REFRESH dec dword [^q%] mov edx,[^q%] cmp edx,1 jge near qloop jmp over .i4% dd 4 .i3% dd 3 .over ret ] endproc rem ====================================================================== rem Coded in ASM above def proc_dump1 X1=hgt(p%-1,q%-1,1) : Z1=hgt(p%-1,q%-1,2) : Y1=M*hgt(p%-1,q%-1,3) : rem Done X2=hgt(p%,q%-1,1) : Z2=hgt(p%,q%-1,2) : Y2=M*hgt(p%,q%-1,3) : rem Done X3=hgt(p%-1,q%,1) : Z3=hgt(p%-1,q%,2) : Y3=M*hgt(p%-1,q%,3) : rem Done X4=hgt(p%,q%,1) : Z4=hgt(p%,q%,2) : Y4=M*hgt(p%,q%,3) : rem Done rem Reduction or scale factors for perspective - DONE Z=(Z1+Z2+Z3+Z4)/4 Fac=A/(A-(Z+Dis)) rem Scale to screen size - DONE x1%=int(xscreen%*Fac*X1) : y1%=int(yscreen%*Fac*Y1) x2%=int(xscreen%*Fac*X2) : y2%=int(yscreen%*Fac*Y2) x3%=int(xscreen%*Fac*X3) : y3%=int(yscreen%*Fac*Y3) x4%=int(xscreen%*Fac*X4) : y4%=int(yscreen%*Fac*Y4) rem Get colour - DONE ref%=3*xmax%*q% + 3*p% + 54 bl&=?(pic%+ref%) gr&=?(pic%+ref%+1) re&=?(pic%+ref%+2) rem Plot to screen colour 10,re%,gr%,bl% : gcol 10 : rem Done move x1%,y1% : move x2%,y2% : plot 85,x3%,y3% : plot 85,x4%,y4% : rem Done endproc rem ====================================================================== rem Height Routine def proc_hyte(opt&) P%=hyte% [opt opt& finit fld qword [^dx] fld st0 fmulp st1,st0 fld qword [^dz] fld st0 fmulp st1,st0 faddp st1,st0 fld qword [^dy] fld st0 fmulp st1,st0 faddp st1,st0 fsqrt ;n fld qword [^dx] fdiv st0,st1 fstp qword [^dx] fld qword [^dz] fdiv st0,st1 fstp qword [^dz] fld qword [^dy] fdiv st0,st1 fstp qword [^dy] fld qword [^dx] fld st0 fmul st0,st1 fstp qword [^dx2] fabs fchs fld qword [^dz] fld st0 fmul st0,st1 fstp qword [^dz2] faddp st1,st0 ;dxz fld qword [^dy] fmul st0,st1 fstp qword [^dxyz] fld st0 fmulp st1,st0 fstp qword [^dxz2] mov edx,1 mov [^y%],edx .yloop mov edx,1 mov [^x%],edx .xloop finit mov eax,[^x%] dec eax imul eax,[^ymax%] shl eax,5 mov ebx,[^y%] shl ebx,5 add eax,ebx fld qword (^hgt(0,0,0))[eax] fstp qword [^By] mov eax,[^x%] imul eax,[^ymax%] shl eax,5 mov ebx,[^y%] dec ebx shl ebx,5 add eax,ebx fld qword (^hgt(0,0,0))[eax] fstp qword [^Ay] mov eax,[^x%] imul eax,[^ymax%] add eax,[^y%] mov ebx,0 mov bl,(^grey&(0,0))[eax] mov ecx,0 mov cl,[^Min&] sub ebx,ecx mov [itmp%],ebx fild dword [itmp%] mov cl,[^Dif&] mov [itmp%],ecx fild dword [itmp%] fdivp st1,st0 fld qword [f085%] fmulp st1,st0 fstp qword [^cstheta] fld qword [^cstheta] fld1 fcompp fstsw ax and ah,1 cmp ah,1 je twobig jmp rnd1 .twobig fld1 fstp qword [^cstheta] jmp rnd2 .rnd1 fldz fld qword [^cstheta] fcompp fstsw ax and ah,1 cmp ah,1 je twosml jmp rnd2 .twosml fldz fstp qword [^cstheta] .rnd2 fld qword [^cstheta] fld st0 fmulp st1,st0 fstp qword [^csq] fld qword [^dx] ;Calc f0r F fld qword [^dz] fmulp st1,st0 fld qword [^csq] fsubp st1,st0 fld qword [^Ay] fld qword [^By] faddp st1,st0 fmulp st1,st0 fld qword [^dxyz] faddp st1,st0 fstp qword [^F] ;Calc f0r F fld qword [^dxz2] ;Calc f0r G fld qword [^csq] fld st0 faddp st1,st0 fsubp st1,st0 fstp qword [^G] ;Calc f0r G fld qword [^By] ;Calc f0r C fld st0 fmulp st1,st0 fld qword [^Ay] fld st0 fmulp st1,st0 faddp st1,st0 fld1 faddp st1,st0 fld qword [^csq] fmulp st1,st0 fld qword [^dy] fld st0 fmulp st1,st0 fsubrp st1,st0 fld qword [^dx] fld qword [^By] fmulp st1,st0 fld qword [^dz] fld qword [^Ay] fmulp st1,st0 faddp st1,st0 fld qword [^dy] fld st0 faddp st1,st0 fmulp st1,st0 faddp st1,st0 fld qword [^Ay] fld st0 fmulp st1,st0 fld qword [^dz2] fmulp st1,st0 fld qword [^By] fld st0 fmulp st1,st0 fld qword [^dx2] fmulp st1,st0 faddp st1,st0 faddp st1,st0 fstp qword [^C] ;Calc f0r C fld qword [^F] ;Calc f0r H fld st0 fmulp st1,st0 fld qword [^G] fld qword [^C] fmulp st1,st0 fsubp st1,st0 fabs ;ADDED fstp qword [^H] ;Calc f0r H fldz fld qword [^H] fcompp fstsw ax and ah,1 cmp ah,1 je blow fld qword [^H] fsqrt fld qword [^F] faddp st1,st0 ;Q 0n stack fld qword [f01%] fld qword [^G] fabs fcompp fstsw ax and ah,1 cmp ah,1 je lesser fld qword [^G] fabs ;ADDED fdivp st1,st0 ;Finally Q/0.01 here jmp fin .lesser fld qword [f01%] fdivp st1,st0 ;Finally Q/G here jmp fin .blow fldz .fin mov eax,[^x%] imul eax,[^ymax%] shl eax,5 mov ebx,[^y%] shl ebx,5 add eax,ebx fstp qword (^hgt(0,0,0))[eax] inc dword [^x%] mov edx,[^x%] cmp edx,[^xmax%] jl near xloop inc dword [^y%] mov edx,[^y%] cmp edx,[^ymax%] jl near yloop ret ] endproc rem ====================================================================== rem Coded in ASM above def proc_dump2 n=sqr(dx*dx + dz*dz + dy*dy) : rem DONE dx/=n : dz/=n : dy/=n : rem DONE dxz= -abs(dx) + dz : rem DONE dxyz=dy*dxz : rem DONE dxz2=dxz*dxz : rem DONE dx2=dx*dx : dz2=dz*dz : rem DONE rem DONE for y%=1 to ymax%-1 for x%=1 to xmax%-1 next next Ay=hgt(x%,y%-1,0) : rem DONE By=hgt(x%-1,y%,0) : rem DONE cstheta=0.85*((grey&(x%,y%)-Min&)/Dif&) : rem DONE if cstheta>1.0 then cstheta=1.0 : rem DONE if cstheta<0.0 then cstheta=0.0 : rem DONE csq=cstheta*cstheta : rem DONE F=dxyz + (Ay+By)*(dx*dz-csq) : rem DONE G=dxz2 - 2*csq : rem DONE C=dx2*By*By + dz2*Ay*Ay + 2*dy*(dx*By + dz*Ay) + dy*dy - ((By*By+Ay*Ay+1)*csq) : rem DONE H=abs(F*F - G*C) : rem DONE rem All DONE if H<0.0 then hgt(x%,y%,0)=0.0 else Q= F + sqr(H) if abs(G)>0.01 then Q/=G else Q/=0.01 endif if Q-Ay>1.0 then Q=Ay+1.0 if Q-Ay<-1.0 then Q=Ay-1.0 hgt(x%,y%,0)=Q endif endproc rem ====================================================================== rem Rotate Routine def proc_rotat(opt&) P%=rotat% [opt opt& mov edx,0 mov [^y%],edx .yyloop mov eax,[^y%] mov ebx,[^ymax%] shr ebx,1 sub eax,ebx mov [^ys%],eax mov edx,0 mov [^x%],edx .xxloop mov eax,[^x%] mov ebx,[^xmax%] shr ebx,1 sub eax,ebx mov [^xs%],eax finit mov edx,0 .dloop mov eax,edx imul eax,3 shl eax,3 fld qword (^mat(0,0))[eax] fild dword [^xs%] fmulp st1,st0 add eax,8 fld qword (^mat(0,0))[eax] fild dword [^ys%] fmulp st1,st0 faddp st1,st0 add eax,8 fld qword (^mat(0,0))[eax] mov eax,[^x%] imul eax,[^ymax%] shl eax,5 mov ebx,[^y%] shl ebx,5 add eax,ebx fld qword (^hgt(0,0,0))[eax] fmulp st1,st0 faddp st1,st0 ;xs%*mat(i,0) + ys%*mat(i,1) + hgt(x%,y%,0)*mat(i,2) mov ebx,edx inc ebx shl ebx,3 add eax,ebx fstp qword (^hgt(0,0,0))[eax] ;Answer In hgt(x%,y%,i) inc edx cmp edx,2 jle dloop inc dword [^x%] mov edx,[^x%] cmp edx,[^xmax%] jl near xxloop inc dword [^y%] mov edx,[^y%] cmp edx,[^ymax%] jl near yyloop ret ] endproc rem ====================================================================== rem Coded in ASM above def proc_dump3 rem All DONE for y%=0 to ymax%-1 ys%=y%-(ymax%/2) : rem DONE rem All DONE for x%=0 to xmax%-1 xs%=x%-(xmax%/2) : rem DONE hgt(x%,y%,1)=xs%*mat(0,0) + ys%*mat(0,1) + hgt(x%,y%,0)*mat(0,2) : rem DONE hgt(x%,y%,2)=xs%*mat(1,0) + ys%*mat(1,1) + hgt(x%,y%,0)*mat(1,2) : rem DONE hgt(x%,y%,3)=xs%*mat(2,0) + ys%*mat(2,1) + hgt(x%,y%,0)*mat(2,2) : rem DONE next x% next y% endproc rem ====================================================================== rem Grey Routine def proc_grey(opt&) P%=grey% [opt opt& mov al,0 mov [^Max&],al mov al,255 mov [^Min&],al mov edx,0 mov [^y%],edx .y2loop mov edx,0 mov [^x%],edx .x2loop mov eax,[^y%] imul eax,[^xmax%] imul eax,3 add eax,[^x%] add eax,[^x%] add eax,[^x%] add eax,54 mov ebx,pic%[eax] mov [rgb%],ebx mov ebx,0 mov bl,[rgb%] mov [itmp%],ebx fild dword [itmp%] fld qword [^wb] fmulp st1,st0 mov eax,1 mov bl,rgb%[eax] mov [itmp%],ebx fild dword [itmp%] fld qword [^wg] fmulp st1,st0 faddp st1,st0 mov eax,2 mov bl,rgb%[eax] mov [itmp%],ebx fild dword [itmp%] fld qword [^wr] fmulp st1,st0 faddp st1,st0 fistp dword [itmp%] mov eax,[^x%] imul eax,[^ymax%] add eax,[^y%] mov ebx,[itmp%] mov (^grey&(0,0))[eax],bl cmp bl,[^Min&] ja frwrd mov [^Min&],bl .frwrd cmp bl,[^Max&] jb fint mov [^Max&],bl .fint inc dword [^x%] mov edx,[^x%] cmp edx,[^xmax%] jl near x2loop inc dword [^y%] mov edx,[^y%] cmp edx,[^ymax%] jl near y2loop mov al,[^Max&] sub al,[^Min&] mov [^Dif&],al ret ] endproc rem ====================================================================== rem Coded in ASM above def proc_dump4 Min&=255 : Max&=0 : rem DONE rem All DONE for y%=0 to ymax%-1 for x%=0 to xmax%-1 ref%=3*xmax%*y% + 3*x% + 54 : rem DONE !rgb%=!(pic% + ref%) : rem DONE grey&(x%,y%)=int(wb*(?(rgb%)) + wg*(?(rgb%+1)) + wr*(?(rgb%+2))) : rem DONE if grey&(x%,y%)Max& then Max&=grey&(x%,y%) : rem DONE next x% next y% rem DONE Dif&=Max&-Min& : rem Greatest difference in greyscale values endproc rem ======================================================================