02-20-2006, 08:39 PM
Quote:If you really need to program using 32 bit colour I would recommend learning FreeBasic, it has native 32bit colour.
Not true for the real DOS mode.
Joshy
sorry about my english
Qbasicnews.com
›
QBasic
›
QB Discussion & Programming Help
NEED HELP WRITING A 32-BIT TRUE COLOR PIXEL SUB PROGRAM
NEED HELP WRITING A 32-BIT TRUE COLOR PIXEL SUB PROGRAM
|
NEED HELP WRITING A 32-BIT TRUE COLOR PIXEL SUB PROGRAM
|
 Not true for the real DOS mode. Joshy 
02-22-2006, 02:48 AM
[code]
DECLARE SUB SetPixel3d (x%, y%, z%) DECLARE SUB SetRay (cx1%, cy1%, cx2%, cy2%) DECLARE SUB Box (cx1%, cy1%, cx2%, cy2%, Pattern%) DECLARE SUB xLine (x1%, y1%, x2%, y2%) DECLARE SUB LoadBMP (Name$, x1%, y1%, x2%, y2%, t%) DECLARE FUNCTION EMSPages% (func%) DECLARE FUNCTION EMSstatus% () DECLARE FUNCTION GetEMS% (numpages%) DECLARE FUNCTION NumEMSHandles% () DECLARE FUNCTION NumEMSPages% (Handle%) DECLARE FUNCTION PageFrame% () DECLARE SUB INTERRUPT (intnum AS INTEGER, inreg AS ANY, outreg AS ANY) DECLARE SUB INTERRUPTx (intnum AS INTEGER, inreg AS ANY, outreg AS ANY) DECLARE SUB xWindow (x1%, y1%, x2%, y2%, Text$) DECLARE SUB DetVideo (MaxX%, MaxY%, BitDepth%) DECLARE FUNCTION ceil% (x!) DECLARE FUNCTION CompCol% (x%, y%, r%, g%, b%, a%) DECLARE SUB cross (V1 AS ANY, V2 AS ANY, V AS ANY) DECLARE FUNCTION floor% (x!) DECLARE SUB FullScreen () DECLARE SUB GetPixel (x%, y%) DECLARE SUB InitializeScene () DECLARE FUNCTION IntersectCone% (i%, n AS ANY) DECLARE FUNCTION IntersectSphere% (c1!, c0!) DECLARE SUB IsConeHit (i%, Ns AS ANY) DECLARE SUB IsSphereHit (spherenum%, Ns AS ANY, ds!, Left AS ANY, scanlinedir AS ANY) DECLARE SUB loadpcx (a$, idx%) DECLARE FUNCTION magnitude! (nix!, niy!, niz!) DECLARE FUNCTION maxidx! (w AS ANY) DECLARE SUB normalize (x AS SINGLE, y AS SINGLE, z AS SINGLE) DECLARE FUNCTION phong! (L AS ANY, V AS ANY, n AS ANY) DECLARE SUB Precalculations () DECLARE SUB rayscan () DECLARE SUB raytrace (v0 AS ANY, dv AS ANY, c!, depth!) DECLARE SUB Rgba (r%, g%, b%, a%) DECLARE SUB SetAlpha (x%, y%) DECLARE SUB SetPhoton (x%, y%) DECLARE SUB SetPixel (x%, y%) DECLARE SUB SetTextx () DECLARE SUB SetVideo () DECLARE FUNCTION totaldirectlight! (v0 AS ANY, V AS ANY, n AS ANY) DECLARE SUB WaitKey () DECLARE SUB xPrint (xPos%, yPos%, Text$) TYPE RegType Ax AS INTEGER bx AS INTEGER cx AS INTEGER Dx AS INTEGER bp AS INTEGER Si AS INTEGER di AS INTEGER FLAGS AS INTEGER ds AS INTEGER es AS INTEGER END TYPE TYPE ModeInfo ModeAttributes AS INTEGER WinAAttributes AS STRING * 1 WinBAttributes AS STRING * 1 WinGranularity AS INTEGER WinSize AS INTEGER WinASegment AS INTEGER WinBSegment AS INTEGER WinFuncPtr AS LONG BytesPerScanxLine AS INTEGER xResolution AS INTEGER yResolution AS INTEGER xCharSize AS STRING * 1 yCharSize AS STRING * 1 NumberOfPlanes AS STRING * 1 BitsPerPixel AS STRING * 1 NumberOfBanks AS STRING * 1 MemoryModel AS STRING * 1 Banksize AS STRING * 1 NumberOfImagePages AS STRING * 1 Rsvd AS STRING * 1 RedMaskSize AS STRING * 1 RedFieldPosition AS STRING * 1 GreenMaskSize AS STRING * 1 GreenFieldPosition AS STRING * 1 BlueMaskSize AS STRING * 1 BlueFieldPosition AS STRING * 1 Rsvdmasksize AS STRING * 1 DirectColorModeInfo AS STRING * 1 Reserved AS STRING * 216 VideoMode AS INTEGER END TYPE TYPE ySVGA Bank AS INTEGER Offset AS LONG END TYPE TYPE THeader '= signs are for loading requirements MAN AS STRING * 1 'manufacturer = 10 VER AS STRING * 1 'version = 5+ ENC AS STRING * 1 'encoding = 1 (RLE) Bpp AS STRING * 1 'bits per pixel per plane = 8 MNX AS INTEGER 'minimum X size MNY AS INTEGER 'minimum Y size MAX AS INTEGER 'maximum X size MAY AS INTEGER 'maximum Y size HRS AS INTEGER 'horizontal resolution VRS AS INTEGER 'vertical resolution Col AS STRING * 48 'EGA color palette (ignored) RES AS STRING * 1 'reserved NMP AS STRING * 1 'number of planes = 1 BPL AS INTEGER 'bytes per scanline PLI AS INTEGER 'palette info (ignored) FIL AS STRING * 58 'filler END TYPE TYPE rgbtype Red AS INTEGER Green AS INTEGER Blue AS INTEGER END TYPE TYPE FHstatustype flag AS INTEGER IntervalL AS INTEGER IntervalR AS INTEGER END TYPE TYPE vec x AS SINGLE y AS SINGLE z AS SINGLE END TYPE TYPE spheretype a AS SINGLE 'center of sphere b AS SINGLE 'is (a,b,c) c AS SINGLE clr AS INTEGER 'base color of sphere r AS SINGLE 'radius of sphere r2 AS SINGLE 'radius^2 da AS SINGLE db AS SINGLE dc AS SINGLE rn AS SINGLE textureofs AS INTEGER texturenum AS INTEGER END TYPE TYPE conetype V AS vec 'vertex (tip) of o h AS vec 'axis of o (from tip to base) hn AS vec 'axis of o (from tip to base) normalized Alpha AS SINGLE 'angle of spread of o costheta AS SINGLE 'cosine of angle between scanline plane and o axis cosalpha AS SINGLE 'cosine of alpha tantheta AS SINGLE tanalpha AS SINGLE tanalpha2 AS SINGLE hitflag AS INTEGER END TYPE TYPE pln a AS SINGLE 'coefficients for the plane equation b AS SINGLE ' Ax+By+Cz-D = 0 c AS SINGLE D AS SINGLE s AS SINGLE 'used for speeding up plane intersection test END TYPE ' Common variables for screen management COMMON SHARED exitflag% COMMON SHARED Power2%() COMMON SHARED SizeScreen AS INTEGER COMMON SHARED ScreenRes$, Name$ COMMON SHARED ScrWidth AS LONG, ScrHeight AS LONG COMMON SHARED Red%, Green%, Blue%, Alpha% COMMON SHARED xScrCenter%, yScrCenter% COMMON SHARED MaxIndex COMMON SHARED CurBank%, BPL AS LONG, Bpp AS LONG COMMON SHARED xPlotMin%, xPlotMax% COMMON SHARED yPlotMin%, yPlotMax% COMMON SHARED FontSeg%, FontOffset% COMMON SHARED FileNumber% COMMON SHARED Regs AS RegType ' Bitmaps management directory CONST SaveDir$ = "" ' Constants for Raytracer CONST tracedepth = 1 CONST false = 0, true = NOT false CONST dorefract = false CONST dobilinear = true CONST antialiasplane = false CONST reflectivity = .1 CONST texturedimness = 100 CONST nrefract = .1 ' n2/n1 in physics literature CONST invnrefract = 1! / nrefract ' n1/n2 in physics literature CONST txmax = 127 CONST tymaxover2 = txmax \ 2 CONST txscale = txmax / 6.28318530717958# 'actually, there is always one more object than specified here CONST numlights = 1 CONST numspheres = 2 CONST numplanes = 0 CONST numcones = 0 CONST numtextures = 1 REDIM SHARED xBpp&(0) REDIM SHARED yLut(256) AS ySVGA DIM SHARED Video AS ModeInfo DIM SHARED eye AS vec DIM SHARED o(numspheres) AS spheretype DIM SHARED cone(numcones) AS conetype DIM SHARED FHStatus(numspheres) AS FHstatustype DIM SHARED plane(numplanes) AS pln DIM SHARED lights(numlights) AS vec DIM SHARED dx2%(-360 TO 360) '$DYNAMIC DIM SHARED texture%(txmax, txmax, numtextures) '$STATIC DIM isr(0 TO 5) AS LONG isr(0) = &H53EC8B55: isr(1) = &H83025E8B isr(2) = &H8E0602EB: isr(3) = &HC7260446 isr(4) = &H79B9007: isr(5) = &HCF9B5D5B DEF SEG = 0 OldISR1 = PEEK(&HF4) OldISR2 = PEEK(&HF5) OldISR3 = PEEK(&HF6) OldISR4 = PEEK(&HF7) POKE &HF4, VARPTR(isr(0)) AND 255 POKE &HF5, (CLNG(VARPTR(isr(0))) AND &HFF00&) \ 256 POKE &HF6, VARSEG(isr(0)) AND 255 POKE &HF7, (CLNG(VARSEG(isr(0))) AND &HFF00&) \ 256 DetVideo 1024, 768, 32 SetVideo REDIM SHARED NsLUT(ScrWidth - 1) AS vec REDIM SHARED dsLUT(ScrWidth - 1) AS SINGLE DO UNTIL INKEY$ <> "" IF INKEY$ <> "" THEN GOTO eop LoadBMP "WaterL~1", 0, 0, ScrWidth - 1, ScrHeight - 1, 0 IF INKEY$ <> "" THEN GOTO eop SLEEP 5: SetVideo IF INKEY$ <> "" THEN GOTO eop LoadBMP "BlueHI~1", 0, 0, ScrWidth - 1, ScrHeight - 1, 0 IF INKEY$ <> "" THEN GOTO eop SLEEP 5: SetVideo IF INKEY$ <> "" THEN GOTO eop LoadBMP "SunSet", 0, 0, ScrWidth - 1, ScrHeight - 1, 0 IF INKEY$ <> "" THEN GOTO eop SLEEP 5: SetVideo IF INKEY$ <> "" THEN GOTO eop LoadBMP "Winter", 0, 0, ScrWidth - 1, ScrHeight - 1, 0 IF INKEY$ <> "" THEN GOTO eop SLEEP 5: SetVideo IF INKEY$ <> "" THEN GOTO eop LoadBMP "Bliss", 0, 0, ScrWidth - 1, ScrHeight - 1, 0 IF INKEY$ <> "" THEN GOTO eop SLEEP 5: SetVideo IF INKEY$ <> "" THEN GOTO eop LOOP eop: 'WaitKey SetTextx SCREEN 0: WIDTH 80, 25 DEF SEG = 0 POKE &HF4, OldISR1 POKE &HF5, OldISR2 POKE &HF6, OldISR3 POKE &HF7, OldISR4 CLS SYSTEM END SCREEN 0: WIDTH 80, 25 CLS SUB Box (cx1%, cy1%, cx2%, cy2%, Pattern%) x1% = cx1%: x2% = cx2%: y1% = cy1%: y2% = cy2% IF x1% > x2% THEN SWAP x1%, x2% IF y1% > y2% THEN SWAP y1%, y2% x% = x1%: DO UNTIL x% = x2% IF Pattern% = 0 OR (x% AND Pattern%) THEN SetPixel x%, y1% x% = x% + 1: LOOP x% = x1%: DO UNTIL x% = x2% IF Pattern% = 0 OR (x% AND Pattern%) THEN SetPixel x%, y2% x% = x1% + 1: LOOP FOR y% = y1% TO y2% IF Pattern% = 0 OR (y% AND Pattern%) THEN SetPixel x1%, y% NEXT y% FOR y% = y1% TO y2% IF Pattern% = 0 OR (y% AND Pattern%) THEN SetPixel x2%, y% NEXT y% END SUB FUNCTION ceil% (x) IF x > 32767 THEN x = 32767 ELSEIF x < -32767 THEN x = -32767 END IF ceil% = (x + .5) AND -1 '=INT(x + .999999!) END FUNCTION SUB ComButton (x1%, y1%, x2%, y2%, Text$) x% = x2%: y% = y2% DO UNTIL x% = x1% AND y% = y1% SetAlpha x%, y% x% = x% + 1: IF x% > x1% THEN x% = x2%: y% = y% + 1 LOOP x% = x2% + 4: y% = y2% + 4 Rgba 191, 191, 191, 191 DO UNTIL x% = x1% - 4 AND y% = y1% - 4 SetAlpha x%, y% x% = x% + 1: IF x% > x1% - 4 THEN x% = x2% + 4: y% = y% + 1 LOOP Rgba 0, 0, 0, 0 xPrint ((x1% + x2%) / 2 - 47), ((y1% + y2%) / 2) - 7, Text$ Rgba 127, 127, 127, 127 xPrint ((x1% + x2%) / 2 - 48), ((y1% + y2%) / 2) - 8, Text$ END SUB FUNCTION CompCol% (x%, y%, r%, g%, b%, a%) GetPixel x%, y% IF Red% = r% AND Green% = g% AND Blue% = b% AND Alpha% = a% THEN CompCol% = 1 ELSE CompCol% = 0 END IF END FUNCTION SUB cross (V1 AS vec, V2 AS vec, V AS vec) 'vector V = V1 x V2 V.x = V1.y * V2.z - V2.y * V1.z V.y = V2.x * V1.z - V1.x * V2.z V.z = V1.x * V2.y - V2.x * V1.y END SUB SUB DetVideo (MaxX%, MaxY%, BitDepth%) CLS Regs.Ax = &H4F00 Regs.es = VARSEG(Video.ModeAttributes) Regs.di = VARPTR(Video.ModeAttributes) CALL INTERRUPTx(&H10, Regs, Regs) IF Regs.Ax <> &H4F THEN COLOR 17 PRINT ">>>ERROR Founction not found of this Computer<<<" WaitKey ELSE PRINT " VESA Card detected" PRINT "ÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃ"" PRINT "º Quit the program immediatly if you have a monochrome display º" PRINT "ÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃ1/4" END IF FOR Mode = &H100 TO &HFFF Regs.Ax = &H4F01 Regs.cx = Mode Regs.es = VARSEG(Video.ModeAttributes) Regs.di = VARPTR(Video.ModeAttributes) CALL INTERRUPTx(&H10, Regs, Regs) ScrWidth = Video.xResolution ScrHeight = Video.yResolution Bpp = ASC(Video.BitsPerPixel) IF Bpp > 0 OR ScrHeight > 0 OR ScrHeight > 0 THEN IF BitDepth% = Bpp AND MaxY% = ScrHeight AND MaxX% = ScrWidth THEN Video.VideoMode = Mode EXIT SUB END IF END IF NEXT Mode END SUB '************* EMSPages%() **************** '*** When func% is 0, returns the total *** '*** number of 16k pages, when func% is *** '*** 1, returns the number of available *** '*** 16k pages. *** '****************************************** FUNCTION EMSPages% (func%) asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180) asm$ = asm$ + CHR$(66) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126) asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(139) + CHR$(126) asm$ = asm$ + CHR$(8) + CHR$(137) + CHR$(21) + CHR$(93) + CHR$(203) TotalPages% = 0: AvailablePages% = 0 DEF SEG = VARSEG(asm$) CALL Absolute(TotalPages%, AvailablePages%, SADD(asm$)) DEF SEG IF func% = 0 THEN EMSPages% = TotalPages% ELSE EMSPages% = AvailablePages% END IF END FUNCTION '**************** EMSstatus%() ****************** '*** Returns whether EMS is available. -1 is *** '*** returned if it is available, 0 otherwise *** '************************************************ FUNCTION EMSstatus% asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180) asm$ = asm$ + CHR$(64) + CHR$(205) + CHR$(103) + CHR$(176) + CHR$(0) asm$ = asm$ + CHR$(139) + CHR$(94) + CHR$(6) + CHR$(137) + CHR$(7) asm$ = asm$ + CHR$(93) + CHR$(203) EMS% = -1 DEF SEG = VARSEG(asm$) CALL Absolute(EMS%, SADD(asm$)) DEF SEG IF EMS% = 0 THEN EMSstatus = -1 'EMS installed, set to BASIC's TRUE value. ELSE EMSstatus = 0 'EMS not installed, set to FALSE. END IF END FUNCTION SUB Fill (x0%, y0%) DrawRed% = Red%: DrawGreen% = Green%: DrawBlue% = Blue%: DrawAlpha% = Alpha% MaxX% = ScrWidth - 1 StackSize% = 2000 REDIM Stackx%(StackSize%, 4) IF CompCol%(x0%, y0%, DrawRed%, DrawGreen%, DrawBlue%, DrawAlpha%) = 1 THEN EXIT SUB GetPixel x0%, y0%: BRed% = Red%: BGreen% = Green%: BBlue% = Blue%: BAlpha% = Alpha% Stackx%(0, 3) = y0% + 1 Stackx%(0, 1) = x0% Stackx%(0, 2) = x0% Stackx%(0, 4) = -1 Sp% = 1 WHILE Sp2% <> Sp% dy% = Stackx%(Sp2%, 4) y% = Stackx%(Sp2%, 3) + dy% x1% = Stackx%(Sp2%, 1) x2 = Stackx%(Sp2%, 2) Sp2% = Sp2% + 1 IF Sp2% > StackSize% THEN Sp2% = 0 x% = x1% WHILE x% > -1 AND CompCol%(x%, y%, BRed%, BGreen%, BBlue%, BAlpha%) = 1 x% = x% - 1: WEND IF x% >= x1% THEN GOTO Skip L% = x% + 1 IF L% < x1% THEN Stackx%(Sp%, 3) = y% Stackx%(Sp%, 1) = L% Stackx%(Sp%, 2) = x1% - 1 Stackx%(Sp%, 4) = -dy% Sp% = Sp% + 1 IF Sp% > StackSize% THEN Sp% = 0 END IF x% = x1% + 1 DO WHILE x% <= MaxX% AND CompCol%(x%, y%, BRed%, BGreen%, BBlue%, BAlpha%) = 1 x% = x% + 1: WEND Rgba DrawRed%, DrawGreen%, DrawBlue%, DrawAlpha% FOR i% = L% TO x% - 1 SetPixel i%, y% NEXT i% Stackx%(Sp%, 3) = y%: Stackx%(Sp%, 1) = L%: Stackx%(Sp%, 2) = x% - 1 Stackx%(Sp%, 4) = dy%: Sp% = Sp% + 1 IF Sp% > StackSize% THEN Sp% = 0 IF x% > x2 + 1 THEN Stackx%(Sp%, 3) = y% Stackx%(Sp%, 1) = x2 + 1 Stackx%(Sp%, 2) = x% - 1 Stackx%(Sp%, 4) = -dy% Sp% = Sp% + 1 IF Sp% > StackSize% THEN Sp% = 0 END IF Skip: x% = x% + 1 WHILE (x% <= x2) AND CompCol%(x%, y%, BRed%, BGreen%, BBlue%, BAlpha%) = 0 x% = x% + 1: WEND L% = x% LOOP WHILE x% <= x2 WEND ERASE Stackx% END SUB FUNCTION floor% (x) IF x > 32767 THEN x = 32767 ELSEIF x < -32767 THEN x = -32767 END IF floor% = (x - .499999) AND -1 END FUNCTION SUB FullScreen ' The SetPixel routine can plot any SetPixel on the screen xPlotMin% = 0 xPlotMax% = ScrWidth - 1 yPlotMin% = 0 yPlotMax% = ScrHeight - 1 xScrCenter% = INT((xPlotMin% + xPlotMax%) / 2 + .5) yScrCenter% = INT((yPlotMin% + yPlotMax%) / 2 + .5) END SUB '********************** GetEMS%() ******************** '*** Function returns the handle value for a block *** '*** of EMS memory that consists of numpages% 16k *** '*** pages. You _must_ keep the handle value for *** '*** later calls that require the handle. Example:*** '*** *** '*** EmsHandle% = GetEMS%(5) *** '*** *** '*** EmsHandle% holds the handle info for a block *** '*** of memory 5 16k pages in size, or 80k. *** '***************************************************** FUNCTION GetEMS% (numpages%) 'pageoffset% = EMSPages%(0) - EMSPages%(1) asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139) asm$ = asm$ + CHR$(94) + CHR$(8) + CHR$(180) + CHR$(67) + CHR$(205) asm$ = asm$ + CHR$(103) + CHR$(139) + CHR$(94) + CHR$(6) + CHR$(137) asm$ = asm$ + CHR$(23) + CHR$(93) + CHR$(203) Handle% = 0 DEF SEG = VARSEG(asm$) CALL Absolute(BYVAL numpages%, Handle%, SADD(asm$)) DEF SEG 'asm$ = "" 'asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139) 'asm$ = asm$ + CHR$(86) + CHR$(8) + CHR$(139) + CHR$(126) + CHR$(6) 'asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(10) + CHR$(177) + CHR$(0) 'asm$ = asm$ + CHR$(48) + CHR$(237) + CHR$(180) + CHR$(68) + CHR$(136) 'asm$ = asm$ + CHR$(200) + CHR$(137) + CHR$(243) + CHR$(205) + CHR$(103) 'asm$ = asm$ + CHR$(70) + CHR$(65) + CHR$(57) + CHR$(254) + CHR$(117) 'asm$ = asm$ + CHR$(242) + CHR$(93) + CHR$(203) ' 'DEF SEG = VARSEG(asm$) ' CALL Absolute(BYVAL pageoffset%, BYVAL Handle%, BYVAL numpages%, SADD(asm$)) 'DEF SEG GetEMS% = Handle% END FUNCTION SUB GetPixel (x%, y%) CONST Ww = &HFFFF& IF x% < xPlotMin% OR x% > xPlotMax% OR y% < yPlotMin% OR y% > yPlotMax% THEN EXIT SUB DEF SEG = &HA000 3 Offset& = xBpp&(x%) + yLut(y%).Offset Bank% = yLut(y%).Bank% SELECT CASE (Bpp * 8) CASE 1, 4, 8 IF Offset& > Ww THEN Offset& = Offset& AND Ww Bank% = Bank% + 1 END IF IF Bank% <> CurBank% THEN CurBank% = Bank% Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF xColor% = PEEK(Offset&) Offset& = Offset& + 1 CASE 15, 16 IF Offset& > Ww THEN Offset& = Offset& AND Ww Bank% = Bank% + 1 END IF IF Bank% <> CurBank% THEN CurBank% = Bank% Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF HiColor1 = PEEK(Offset&) Offset& = Offset& + 1 IF Offset& > Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF HiColor2 = PEEK(Offset&) Offset& = Offset& + 1 CASE 24 IF Offset& > Ww THEN Offset& = Offset& AND Ww Bank% = Bank% + 1 END IF IF Bank% <> CurBank% THEN CurBank% = Bank% Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF POKE Offset&, Blue% Offset& = Offset& + 1 IF Offset& > Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF Green% = PEEK(Offset&) Offset& = Offset& + 1 IF Offset& >= Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF POKE Offset&, Red% Red% = PEEK(Offset&) Offset& = Offset& + 1 CASE 32 IF Offset& > Ww THEN Offset& = Offset& AND Ww Bank% = Bank% + 1 END IF IF Bank% <> CurBank% THEN CurBank% = Bank% Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF Blue% = PEEK(Offset&) Offset& = Offset& + 1 IF Offset& > Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF Alpha% = PEEK(Offset&) Offset& = Offset& + 1 IF Offset& >= Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF Red% = PEEK(Offset&) Offset& = Offset& + 1 IF Offset& >= Ww THEN Offset& = Offset& AND Ww CurBank% = CurBank% + 1 Regs.Ax = &H4F05 Regs.bx = 0 Regs.Dx = CurBank% CALL INTERRUPT(&H10, Regs, Regs) END IF Green% = PEEK(Offset&) Offset& = Offset& + 1 END SELECT END SUB SUB GetPixel3D (x%, y%, z%) dist = xb% + 20 GetPixel ScrWidth / 2 + 40 * (yb% - 160) \ dist, ScrHeight / 2 - zb% \ dist END SUB SUB InitializeScene FOR i% = 0 TO numlights lights(i%).x = eye.x - 20 + (360 * i%) lights(i%).y = eye.y + 10 + (360 * i%) * -(i% AND 1) lights(i%).z = eye.z NEXT i% 'plane eq: Ax+By+Cz=-D FOR i% = 0 TO numplanes SELECT CASE i% CASE 0 plane(i%).a = .8'.1 plane(i%).b = 1 plane(i%).c = 0 plane(i%).D = eye.y + 50 plane(i%).s = plane(i%).a * eye.x + plane(i%).b * eye.y + c * eye.z + plane(i%).D CASE 2 plane(i%).a = 0 plane(i%).b = 0 plane(i%).c = 1 plane(i%).D = eye.z - 5000 plane(i%).s = plane(i%).a * eye.x + plane(i%).b * eye.y + c * eye.z + plane(i%).D CASE 1 plane(i%).a = -.1 plane(i%).b = 1 plane(i%).c = 0 plane(i%).D = eye.y + 50 plane(i%).s = plane(i%).a * eye.x + plane(i%).b * eye.y + c * eye.z + plane(i%).D CASE ELSE plane(i%).a = RND * 1 plane(i%).b = RND * 1 plane(i%).c = 0 plane(i%).D = eye.y + RND * 360 plane(i%).s = plane(i%).a * eye.x + plane(i%).b * eye.y + c * eye.z + plane(i%).D END SELECT NEXT i% FOR i% = 0 TO numcones cone(i%).V.x = eye.x cone(i%).V.y = eye.y cone(i%).V.z = eye.z + ScrHeight cone(i%).h.x = 0 cone(i%).h.y = -1 cone(i%).h.z = 0 cone(i%).hn.x = cone(i%).h.x cone(i%).hn.y = cone(i%).h.y cone(i%).hn.z = cone(i%).h.z CALL normalize(cone(i%).hn.x, cone(i%).hn.y, cone(i%).hn.z) NEXT i% END SUB SUB INTERRUPT (intnum AS INTEGER, inreg AS RegType, outreg AS RegType) STATIC a() AS LONG, bReady AS INTEGER, i AS INTEGER, p AS INTEGER, S1 AS INTEGER, S2 AS INTEGER IF bReady = 0 THEN i = 44: DIM a(1 TO i) AS LONG a(1) = &H53EC8B55: a(2) = &H1E575651: a(3) = &H5E8B9C06: a(4) = &HA078B0E a(5) = &HC70774E4: a(6) = &HE9FFFF07: a(7) = &HEC830086: a(8) = &HB3F88A0A a(9) = &HE85E89CD: a(10) = &HCBEA46C7: a(11) = &H74253C90: a(12) = &H75263C04 a(13) = &HEA46C714: a(14) = &H46C701E8: a(15) = &HC7CB00EC: a(16) = &H2C2EE46 a(17) = &HF046C7: a(18) = &H85E8B90: a(19) = &H5E8B37FF: a(20) = &HE37FF06 a(21) = &H50007BB8: a(22) = &HE85E8D16: a(23) = &HD88C1E53: a(24) = &H5E8BC08E a(25) = &H8B378B0A: a(26) = &H1F8E0C5E: a(27) = &H5C8B048B: a(28) = &H44C8B02 a(29) = &H8B06548B: a(30) = &H748B0C7C: a(31) = &H9CCB1F0A: a(32) = &H83EC8B55 a(33) = &HC55620C5: a(34) = &H489E476: a(35) = &H89025C89: a(36) = &H5489044C a(37) = &HC7C8906: a(38) = &H8F0A448F: a(39) = &H448F0844: a(40) = &HEC4830E a(41) = &H5F1F079D: a(42) = &H5D5B595E: a(43) = &HACA: a(44) = &H887E0000 S1 = 0: S2 = 0: p = VARPTR(a(1)): DEF SEG = VARSEG(a(1)) FOR i = 0 TO 175 S1 = (S1 + PEEK(p + i)) MOD 255: S2 = (S2 + S1) MOD 255 NEXT i IF S1 OR S2 THEN ERROR 2: intnum = -1: EXIT SUB ' Checksum Error END IF bReady = -1 END IF DEF SEG = VARSEG(a(1)) CALL Absolute(intnum, VARSEG(inreg), VARPTR(inreg), VARSEG(outreg), VARPTR(outreg), VARPTR(a(1))) DEF SEG END SUB SUB INTERRUPTx (intnum AS INTEGER, inreg AS RegType, outreg AS RegType) STATIC a() AS LONG, bReady AS INTEGER, i AS INTEGER, p AS INTEGER, S1 AS INTEGER, S2 AS INTEGER IF bReady = 0 THEN i = 50: DIM a(1 TO i) AS LONG a(1) = &H53EC8B55: a(2) = &H1E575651: a(3) = &H5E8B9C06: a(4) = &HA078B0E a(5) = &HC70774E4: a(6) = &HE9FFFF07: a(7) = &HEC8300A1: a(8) = &HB3F88A0A a(9) = &HE85E89CD: a(10) = &HCBEA46C7: a(11) = &H74253C90: a(12) = &H75263C04 a(13) = &HEA46C714: a(14) = &H46C701E8: a(15) = &HC7CB00EC: a(16) = &H2C2EE46 a(17) = &HF046C7: a(18) = &H85E8B90: a(19) = &H5E8B37FF: a(20) = &HE37FF06 a(21) = &H50008FB8: a(22) = &HE85E8D16: a(23) = &H8BDA8C53: a(24) = &H378B0A5E a(25) = &H8E0C5E8B: a(26) = &H10448B1F: a(27) = &H75FFFF3D: a(28) = &H50C28B02 a(29) = &H3D12448B: a(30) = &H275FFFF: a(31) = &HC08EC28B: a(32) = &H5C8B048B a(33) = &H44C8B02: a(34) = &H8B06548B: a(35) = &H748B0C7C: a(36) = &H9CCB1F0A a(37) = &H83EC8B55: a(38) = &H1E5620C5: a(39) = &H89E476C5: a(40) = &H25C8904 a(41) = &H89044C89: a(42) = &H7C890654: a(43) = &H12448C0C: a(44) = &H8F10448F a(45) = &H448F0A44: a(46) = &HE448F08: a(47) = &H9D0EC483: a(48) = &H5E5F1F07 a(49) = &HCA5D5B59: a(50) = &H9165000A S1 = 0: S2 = 0: p = VARPTR(a(1)): DEF SEG = VARSEG(a(1)) FOR i = 0 TO 199 S1 = (S1 + PEEK(p + i)) MOD 255: S2 = (S2 + S1) MOD 255 NEXT i IF S1 OR S2 THEN ERROR 2: intnum = -1: EXIT SUB ' Checksum Error END IF bReady = -1 END IF DEF SEG = VARSEG(a(1)) CALL Absolute(intnum, VARSEG(inreg), VARPTR(inreg), VARSEG(outreg), VARPTR(outreg), VARPTR(a(1))) DEF SEG END SUB FUNCTION IntersectCone% (i%, n AS vec) DIM u AS vec: DIM V AS vec: DIM w AS vec 'v=radius axis V = cone(i%).hn 'u = v x n CALL cross(V, n, u) 'w = u x v CALL cross(u, V, w) DIM d1 AS vec: DIM d2 AS vec halfAB = SQR(cone(i%).tanalpha2 - cone(i%).tantheta * cone(i%).tantheta) 'common subexpression elimination using partial results dpx = V.x + cone(i%).tantheta * w.x dpy = V.y + cone(i%).tantheta * w.y dpz = V.z + cone(i%).tantheta * w.z del1.x = dpx + halfAB * u.x del1.y = dpy + halfAB * u.y del1.z = dpz + halfAB * u.z del2.x = dpx - halfAB * u.x del2.y = dpy - halfAB * u.y del2.z = dpz - halfAB * u.z 'can use halfAB,tantheta, etc for cone normal (perpendicular vector) calc. rscale = 1.2' FIXME conen1u = halfAB * rscale conen1v = -cone(i%).tanalpha2 * rscale conen1w = cone(i%).tantheta * rscale conen2u = -halfAB * rscale conen2v = -cone(i%).tanalpha2 * rscale conen2w = cone(i%).tantheta * rscale DIM conen1 AS vec DIM conen2 AS vec conen1.x = conen1u * u.x + conen1v * V.x + conen1w * w.x conen1.y = conen1u * u.y + conen1v * V.y + conen1w * w.y conen1.z = conen1u * u.z + conen1v * V.z + conen1w * w.z conen2.x = conen2u * u.x + conen2v * V.x + conen2w * w.x conen2.y = conen2u * u.y + conen2v * V.y + conen2w * w.y conen2.z = conen2u * u.z + conen2v * V.z + conen2w * w.z 'solve eye + t1*dv = cone(i%).V + r*del1 'solve eye + t2*dv = cone(i%).V + s*del2 'for t1 and t2 END FUNCTION FUNCTION IntersectSphere% (c1, c0) 'intersectsphere% reports the number of distinct, real valued >1 intercepts 'INP: c1 and c0 are parameters for quadratic equation (A)*t^2+(C1)*t+C0 = 0 'OUT: c1 is used to return the parameter t values for the closest intercepts 'NOTE: USE EPSILON=1 BECAUSE THESE COORDINATES ARE NORMALIZED TO PIXEL UNITS! eps = .1 discr = c1 * c1 - 4 * c0 IF discr < 0 THEN IntersectSphere% = 0 ELSEIF discr > .01 THEN sd = SQR(discr) 'always sd >=0 c0 = .5 * (-c1 + sd)'order ! c1 = .5 * (-c1 - sd)'matters! because overwrites c1 IF c0 <= eps AND c1 <= eps THEN IntersectSphere% = 0: EXIT FUNCTION 'store closer intersection in c1, farther in c0 IF c1 <= eps THEN c1 = c0 IntersectSphere% = 2 ELSE 'discr = 0 IntersectSphere% = 1 c1 = -.5 * c1 END IF END FUNCTION SUB IsConeHit (i%, Ns AS vec) 'calculates at the beginning of the scanline 'whether cone i% is hit by any rays that pass through that scanline 'NOTE: NEED TO WRITE SPECIAL CASE WHEN RAY HITS the VERTEX of the CONE ndothn = Ns.x * hn.x + Ns.y * hn.y + Ns.z * hn.z cosphi = ndothn IF cosphi > 1 OR cosphi < -1 THEN COLOR 255: PRINT "cosine too big": BEEP: END cosalpha = COS(cone(i%).Alpha) costheta = SQR(1 - cosphi * cosphi) cone(i%).cosalpha = cosalpha cone(i%).costheta = costheta IF costheta < cosalpha THEN 'no intersections cone(i%).hitflag = -1 ELSEIF costheta > cosalpha THEN 'up to two intersections cone(i%).hitflag = 2 sintheta = -cosphi cone(i%).tantheta = sintheta / costheta tanalpha = TAN(cone(i%).Alpha) cone(i%).tanalpha2 = tanalpha * tanalpha ELSE 'grazing the cone so at most one intersection cone(i%).hitflag = 2 sintheta = -cosphi'used cosine angle addition trig identity cone(i%).tantheta = sintheta / costheta tanalpha = TAN(cone(i%).Alpha) cone(i%).tanalpha2 = tanalpha * tanalpha END IF END SUB SUB IsSphereHit (spherenum%, Ns AS vec, ds, Left AS vec, scanlinedir AS vec) 'based on ideas and C code by Thomas Moller 'Purpose: ' calculates whether sphere spherenum% will be hit on this scanline 'Params: ' spherenum% - which sphere to use ' Ns - normal of the scanline plane = (Right-Eye)x(Left-Eye) ' ds - the offset of the scanline plane from the origin ' Left - leftmost point on scanline ' Scanlinedir - direction of scanline in space ' = (dx,0,0) for our simple case ' CONST scanwidth% - number of pixels per scanline 'Result: ' fills FirstHitStatus() array 'throw away the coordinate 'that corresponds to max(Ns.x,Ns.y,Ns.z) badidx% = maxidx(Ns) signeddist = Ns.x * o(spherenum%).a + Ns.y * o(spherenum%).b + Ns.z * o(spherenum%).c + ds IF signeddist > o(spherenum%).r THEN ' sphere is above the plane, so won't hit it anymore FHStatus(spherenum%).flag = -2 ELSEIF signeddist < -o(spherenum%).r THEN ' sphere is below the scanline plane FHStatus(spherenum%).flag = -1 ELSE 'we might hit the sphere DIM D AS vec DIM h AS vec DIM Cc AS vec 'note: Cc is cut circle's center point DIM Nd AS vec '' vector CC = spherecenter - (signeddist * Ns ) Cc.x = o(spherenum%).a - signeddist * Ns.x Cc.y = o(spherenum%).b - signeddist * Ns.y Cc.z = o(spherenum%).c - signeddist * Ns.z ''cr2=(Sr * Sr)- signeddist^2 cr2 = o(spherenum%).r * o(spherenum%).r - signeddist * signeddist '' vector D = CC-Eyepos D.x = Cc.x - eye.x D.y = Cc.y - eye.y D.z = Cc.z - eye.z '' D2 = D dot D = (magnitude(D))^2 d2 = D.x * D.x + D.y * D.y + D.z * D.z IF (d2 <= cr2) THEN FHStatus(spherenum%).flag = 2 EXIT SUB END IF '' H = D cross Ns CALL cross(D, Ns, h) t1 = cr2 / d2 sintheta = SQR(t1) costheta = SQR(1 - t1) SELECT CASE badidx% CASE 1 t1 = h.y * sintheta t2 = D.y * costheta V1u = t1 + t2 V2u = t2 - t1 t1 = h.z * sintheta t2 = D.z * costheta V1v = t1 + t2 V2v = t2 - t1 t1 = Left.y - eye.y t2 = eye.z - Left.z t3 = V1u * scanlinedir.z - V1v * scanlinedir.y IF t3 <> 0! THEN 'V1 is not parallel to scanline FHStatus(spherenum%).IntervalR = floor%((V1v * t1 + V1u * t2) / t3) t3 = V2u * scanlinedir.z - V2v * scanlinedir.y IF (t3 = 0!) THEN FHStatus(spherenum%).IntervalL = 0 ELSE FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) END IF ELSE 'rare case when V1 is parallel to scanline t3 = (V2u * scanlinedir.z - V2v * scanlinedir.y) + 1 FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) FHStatus(spherenum%).IntervalR = ScrWidth - 1 END IF CASE 2 ' .x=.y from case 1 t1 = h.x * sintheta t2 = D.x * costheta V1u = t1 + t2 V2u = t2 - t1 t1 = h.z * sintheta t2 = D.z * costheta V1v = t1 + t2 V2v = t2 - t1 t1 = Left.x - eye.x t2 = eye.z - Left.z t3 = V1u * scanlinedir.z - V1v * scanlinedir.x IF t3 <> 0! THEN 'V1 is not parallel to scanline FHStatus(spherenum%).IntervalR = floor%((V1v * t1 + V1u * t2) / t3) t3 = V2u * scanlinedir.z - V2v * scanlinedir.x IF (t3 = 0!) THEN FHStatus(spherenum%).IntervalL = 0 ELSE FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) END IF ELSE 'rare case when V1 is parallel to scanline t3 = V2u * scanlinedir.z - V2v * scanlinedir.x FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) FHStatus(spherenum%).IntervalR = ScrWidth - 1 END IF CASE 3 ' let .y=.z from case 2 t1 = h.x * sintheta t2 = D.x * costheta V1u = t1 + t2 V2u = t2 - t1 t1 = h.y * sintheta t2 = D.y * costheta V1v = t1 + t2 V2v = t2 - t1 t1 = Left.x - eye.x t2 = eye.y - Left.y t3 = V1u * scanlinedir.y - V1v * scanlinedir.x IF t3 <> 0! THEN 'V1 is not parallel to scanline FHStatus(spherenum%).IntervalR = floor%((V1v * t1 + V1u * t2) / t3) t3 = V2u * scanlinedir.y - V2v * scanlinedir.x IF (t3 = 0!) THEN FHStatus(spherenum%).IntervalL = 0 ELSE FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) END IF ELSE 'rare case when V1 is parallel to scanline t3 = V2u * scanlinedir.y - V2v * scanlinedir.x FHStatus(spherenum%).IntervalL = ceil%((V2v * t1 + V2u * t2) / t3) FHStatus(spherenum%).IntervalR = ScrWidth - 1 END IF CASE ELSE SCREEN 0: PRINT "max(Ns) didn't work correctly": BEEP: END END SELECT ' check if interval is valid and set status IF ((FHStatus(spherenum%).IntervalL >= ScrWidth) OR (FHStatus(spherenum%).IntervalR < 0)) THEN FHStatus(spherenum%).flag = -1 'off screen to left or right ELSE IF (FHStatus(spherenum%).IntervalR >= ScrWidth) THEN FHStatus(spherenum%).IntervalR = ScrWidth - 1 IF (FHStatus(spherenum%).IntervalL < 0) THEN FHStatus(spherenum%).IntervalL = 0 IF ((FHStatus(spherenum%).IntervalL = 0) AND (FHStatus(spherenum%).IntervalR = ScrWidth - 1)) THEN FHStatus(spherenum%).flag = 2 ELSE FHStatus(spherenum%).flag = 1 END IF END IF IF (FHStatus(spherenum%).IntervalL > FHStatus(spherenum%).IntervalR) THEN FHStatus(spherenum%).flag = -1 END IF END IF '' this implicitly returns FHstatus END SUB SUB LoadBMP (Name$, x1%, y1%, x2%, y2%, t%) Rgba 0, 0, 0, 0 ' Displays a bitmap (8 bits or 24 bits per pixel) in the specified window 'Open the bitmap Pic$ = SaveDir$ + Name$ + ".bmp" OPEN Pic$ FOR BINARY AS #2 ' Read and set-up the bitmap information GET #2, 11, Offset% GET #2, 19, Pw% GET #2, 23, Ph% GET #2, 29, BppBmp% Bw& = Pw% Bh& = Ph% Os& = Offset% ' Adjust the picture to the window WinWidth& = x2% - x1% + 1 WinHeight& = y2% - y1% + 1 IF Bw& <= WinWidth& AND Bh& <= WinHeight& THEN Ax = 1 ay = -1 bx = x1% + WinWidth& / 2 - Bw& / 2 by = y2% + Bh& / 2 - WinHeight& / 2 END IF IF Bw& > WinWidth& AND Bh& <= WinHeight& THEN Ax = WinWidth& / Bw& ay = -Ax bx = x1% by = y2% + WinWidth& / Bw& * Bh& / 2 - WinHeight& / 2 END IF IF Bw& <= WinWidth& AND Bh& > WinHeight& THEN ay = -WinHeight& / Bh& Ax = -ay bx = x1% + WinWidth& / 2 - WinHeight& / Bh& * Bw& / 2 by = y2% END IF IF Bw& > WinWidth& AND Bh& > WinHeight& THEN Ax = WinWidth& / Bw& ay = WinHeight& / Bh& IF Ax < ay THEN ay = -Ax bx = x1% by = y2% ELSE Ax = ay ay = -ay bx = x1% by = y2% END IF END IF ' Display the pixels in the window SELECT CASE BppBmp% CASE 8 ' 8 bits per pixel bitmap (256 colours) IF Bw& MOD (4) <> 0 THEN PadBytes% = 4 - Bw& MOD (4) ELSE PadBytes% = 0 END IF LineLength& = Bw& + PadBytes% ' Read and store palet data Pal$ = SPACE$(1024) GET #2, 55, Pal$ REDIM Palet256%(256, 3) FOR k% = 0 TO 255 Palet256%(k%, 3) = ASC(MID$(Pal$, 4 * k% + 1, 1)) Palet256%(k%, 2) = ASC(MID$(Pal$, 4 * k% + 2, 1)) Palet256%(k%, 1) = ASC(MID$(Pal$, 4 * k% + 3, 1)) NEXT k% ' Read and display pixels Buffer$ = SPACE$(LineLength&) FOR y% = (Bh& - 1) TO 0 STEP -1 GET #2, (Os& + 1) + LineLength& * y%, Buffer$ FOR x% = 0 TO (Bw& - 1) Col% = ASC(MID$(Buffer$, x% + 1, 1)) Red% = Palet256%(Col%, 1) Green% = Palet256%(Col%, 2) Blue% = Palet256%(Col%, 3) xp% = INT(Ax * x% + bx + .5) yp% = INT(ay * y% + by + .5) SetPixel xp%, yp% NEXT x% NEXT y% CASE 24 ' 24 bits per pixel bitmap (true-colour) IF 3 * Bw& MOD (4) <> 0 THEN PadBytes% = 4 - 3 * Bw& MOD (4) ELSE PadBytes% = 0 END IF LineLength& = 3 * Bw& + PadBytes% Buffer$ = " " FOR y% = (Bh& - 1) TO 0 STEP -1 FOR x% = 0 TO (Bw& - 1) GET #2, (Os& + 1) + y% * LineLength& + 3 * x%, Buffer$ Blue% = ASC(LEFT$(Buffer$, 1)) Green% = ASC(MID$(Buffer$, 2, 1)) Red% = ASC(RIGHT$(Buffer$, 1)) xp% = INT(Ax * x% + bx + .5) yp% = INT(ay * y% + by + .5) SetPixel xp%, yp% 'SetRay xp%, yp%, (xLineLength& / 2) + 115, (WinHeight& / 2) + 75 NEXT x% NEXT y% END SELECT ' Close the bitmap CLOSE 2 END SUB DEFINT A-Z SUB loadpcx (a$, idx) DIM Byte AS STRING * 1 'used to read bytes DIM Header AS THeader 'used for header info DIM index AS LONG 'used to control decoding DIM size AS LONG 'used to control decoding DIM XSize AS INTEGER, YSize AS INTEGER 'image size DIM totalbytes AS INTEGER 'used to measure scan lines DIM value AS INTEGER 'used for converting char to int DIM rlp 'used for run length loop DIM x AS LONG, y AS LONG 'used for pixel tracking OPEN a$ FOR INPUT AS #1: CLOSE #1 OPEN a$ FOR BINARY AS #1 GET #1, 1, Header 'load header 'BASIC TEST (NOT fool-proof) -- REQUIREMENTS IF ASC(Header.MAN) <> 10 THEN CLOSE #1: END 'not PCX IF ASC(Header.VER) < 5 THEN CLOSE #1: END 'not 256 color IF ASC(Header.ENC) <> 1 THEN CLOSE #1: END 'not RLE IF ASC(Header.NMP) <> 1 THEN CLOSE #1: END 'not supportive of Mode X planes 'LOAD WHILE LOOP INFORMATION XSize = Header.MAX - Header.MNX + 1 'load horizontal graphic size YSize = Header.MAY - Header.MNY + 1 'load vertical graphic size totalbytes = Header.BPL 'used to track end of scan line size = 1& * XSize * YSize 'load size -- force long IF size > 76800 THEN CLOSE : END 'graphic too large -- won't fit on screen 'CHANGE PALETTE GET #1, LOF(1) - 768, Byte: 'load palette info FOR index = 0 TO 255 GET #1, , Byte: Red% = ASC(Byte) \ 4'RED GET #1, , Byte: Green% = ASC(Byte) \ 4'GREEN GET #1, , Byte: Blue% = ASC(Byte) \ 4 'BLUE NEXT index GET #1, 1, Header 'LOAD HEADER 'DECODE AND DISPLAY WHILE index <= size 'While the picture isn't done loading... GET #1, , Byte 'read a byte from the PCX file IF (ASC(Byte) AND &HC0) = &HC0 THEN 'test top two bits for 1'S (RLE?) rlp = ASC(Byte) AND &H3F 'set run length GET #1, , Byte 'read data byte WHILE rlp > 0 'while run length has not yet finished IF NOT x > XSize THEN IF x <= txmax AND y <= txmax THEN texture%(x, y, idx) = ASC(Byte)'plot pixel END IF END IF x = x + 1 'increment pixel position IF x >= totalbytes THEN x = 0: y = y + 1 'test for end of scanline rlp = rlp - 1 'one less pixel to plot in run index = index + 1 'increase total WEND ELSE 'if the byte is not encoded as RLE (then it's easy!) IF NOT x > XSize THEN IF x <= txmax AND y <= txmax THEN texture%(x, y, idx) = ASC(Byte)'plot one pixel END IF END IF x = x + 1 'renew pixel position IF x >= totalbytes THEN x = 0: y = y + 1 'test for end of scanline index = index + 1 'increase total END IF WEND CLOSE #1 END SUB DEFSNG A-Z FUNCTION magnitude (nix, niy, niz) magnitude = SQR(nix * nix + niy * niy + niz * niz) END FUNCTION '***************** MapEMS () *********************************** '*** Sets the page of a memory block (identified by Handle%) *** '*** that is located at the beginning of the page frame. *** '*** Example: *** '*** *** '*** EmsHandle% = GetEMS%(8) *** '*** MapEMS EmsHandle%, 4 *** '*** *** '*** When the page frame segment is next written to, the info*** '*** will be placed starting at the 4th page in the block of *** '*** memory represented by EmsHandle%. This could be use, *** '*** for instance, to store multiple SCREEN 13 images in one *** '*** EMS block, by moving the first 64k image into the first *** '*** 4 16k pages (16000 * 4 = 64000) by using: *** '*** *** '*** MapEMS EmsHandle%, 0 *** '*** *** '*** And then putting the next 64k image into the next 4 EMS *** '*** pages by using: *** '*** *** '*** MapEMS EmsHandle%, 4 *** '*** *** '*** ... and then moving the image into the memory block. *** '*************************************************************** SUB MapEMS (Handle%, pageoffset%) numpages% = 4 asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139) asm$ = asm$ + CHR$(86) + CHR$(8) + CHR$(139) + CHR$(126) + CHR$(6) asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(10) + CHR$(177) + CHR$(0) asm$ = asm$ + CHR$(48) + CHR$(237) + CHR$(180) + CHR$(68) + CHR$(136) asm$ = asm$ + CHR$(200) + CHR$(137) + CHR$(243) + CHR$(205) + CHR$(103) asm$ = asm$ + CHR$(70) + CHR$(65) + CHR$(57) + CHR$(249) + CHR$(117) asm$ = asm$ + CHR$(242) + CHR$(93) + CHR$(203) DEF SEG = VARSEG(asm$) CALL Absolute(BYVAL pageoffset%, BYVAL Handle%, BYVAL numpages%, SADD(asm$)) DEF SEG END SUB FUNCTION maxidx (w AS vec) 'Params: ' W, the vector to find the max coordinate index of 'returns: ' 1 if W.x coordinate is greatest ' 2 if W.y coordinate is greatest ' 3 if W.z coordinate is greatest MAX = ABS(w.x): tmaxidx = 1 IF (ABS(w.y) > MAX) THEN MAX = ABS(w.y): tmaxidx = 2 IF (ABS(w.z) > MAX) THEN MAX = ABS(w.z): tmaxidx = 3 maxidx = tmaxidx END FUNCTION DEFINT A-Z '******************************* MemCopy() *********************** '*** Copies the number of bytes specified in 'bytes' from the *** '*** memory location fromseg:fromoff to the memory location *** '*** toseg:tooff. To copy more than 32,767 bytes (max. of *** '*** 65,536 bytes) put the 'bytes' value in HEX form. *** '***************************************************************** SUB MemCopy (fromseg, fromoff, toseg, tooff, bytes) asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(30) asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(10) + CHR$(142) + CHR$(192) asm$ = asm$ + CHR$(139) + CHR$(70) + CHR$(14) + CHR$(142) + CHR$(216) asm$ = asm$ + CHR$(139) + CHR$(118) + CHR$(8) + CHR$(139) + CHR$(126) asm$ = asm$ + CHR$(12) + CHR$(139) + CHR$(78) + CHR$(6) + CHR$(243) asm$ = asm$ + CHR$(164) + CHR$(31) + CHR$(93) + CHR$(203) DEF SEG = VARSEG(asm$) CALL Absolute(BYVAL fromseg, BYVAL fromoff, BYVAL toseg, BYVAL tooff, BYVAL bytes, SADD(asm$)) DEF SEG END SUB DEFSNG A-Z SUB normalize (x AS SINGLE, y AS SINGLE, z AS SINGLE) mag = SQR(x * x + y * y + z * z) 'should make this beep in debug mode IF mag = 0 THEN x = 0 y = 0 z = 0 EXIT SUB END IF x = x / mag y = y / mag z = z / mag END SUB '****************************** NumEMSHandles%() ********************* '*** Returns the number of EMS handles presently being used (there *** '*** are a maximum of 256 handles possible at any given time). *** '********************************************************************* FUNCTION NumEMSHandles% asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180) asm$ = asm$ + CHR$(75) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126) asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(93) + CHR$(203) NumHandles% = 0 DEF SEG = VARSEG(asm$) CALL Absolute(NumHandles%, SADD(asm$)) DEF SEG NumEMSHandles% = NumHandles% END FUNCTION '***************************** NumEMSPages%() ************************* '*** Returns the number of 16k pages being used by the memory block *** '*** that is represented by Handle%. *** '********************************************************************** FUNCTION NumEMSPages% (Handle%) asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(139) asm$ = asm$ + CHR$(86) + CHR$(6) + CHR$(180) + CHR$(76) + CHR$(205) asm$ = asm$ + CHR$(103) + CHR$(139) + CHR$(126) + CHR$(8) + CHR$(137) asm$ = asm$ + CHR$(29) + CHR$(93) + CHR$(203) DEF SEG = VARSEG(asm$) CALL Absolute(numpages%, Handle%, SADD(asm$)) DEF SEG NumEMSPages% = numpages% END FUNCTION '******************************* PageFrame% *************************** '*** Returns the segment that you will need to write to in order to *** '*** store your data into EMS memory. For example, PageFrame% may *** '*** return D000 (HEX, -12288 decimal), and then you might do this: *** '*** *** '*** DEF SEG = PageFrame% 'D000 *** '*** MyData$ = "This is a block of data I want to store in EMS." *** '*** FOR X = 1 TO LEN(MyData$) *** '*** POKE X, ASC(MID$(MyData$, X, 1)) *** '*** NEXT X *** '*** DEF SEG *** '*** *** '*** Note, though, that you have to have a block of EMS opened with *** '*** GetEMS%() and maped with MapEMS before you can write to the *** '*** block. *** '********************************************************************** FUNCTION PageFrame% asm$ = "" asm$ = asm$ + CHR$(85) + CHR$(137) + CHR$(229) + CHR$(180) asm$ = asm$ + CHR$(65) + CHR$(205) + CHR$(103) + CHR$(139) + CHR$(126) asm$ = asm$ + CHR$(6) + CHR$(137) + CHR$(29) + CHR$(93) + CHR$(203) PageFrameAddr% = 0 DEF SEG = VARSEG(asm$) CALL Absolute(PageFrameAddr%, SADD(asm$)) DEF SEG PageFrame% = PageFrameAddr% END FUNCTION FUNCTION phong (L AS vec, V AS vec, n AS vec) DIM r AS vec fac = .8 / (numlights + 1) 'the object absorbs 20% of the light that shines on it. m = 82 'specularity coefficient (higher is more specular (and shinier) ) 'R is reflection of L about N 'R = 2(N dot L)*N - L b = (n.x * L.x + n.y * L.y + n.z * L.z) ndotL2 = b * 2 r.x = ndotL2 * n.x - L.x r.y = ndotL2 * n.y - L.y r.z = ndotL2 * n.z - L.z 'brightness is proportional to (R dot V)^m rdotv = (r.x * V.x + r.y * V.y + r.z * V.z) IF rdotv <= 0 THEN 'rdotv=0 phong = (b * 125) * fac: EXIT FUNCTION ELSE 'use m=8 for a somewhat shiny surface 'use m=80 for very shiny surface 'use m=256 for mirrors 'Brightness = specular + diffuse + ambient IF rdotv > 1 THEN 'this was causing overflow phong = (127 + b * 125) * fac: EXIT FUNCTION ELSE phong = (rdotv ^ m * 127 + b * 125) * fac END IF END IF END FUNCTION SUB Precalculations 'nothing to precalc! FOR i% = -180 TO 180 dx2%(i%) = i% * i% NEXT i% DIM BE AS vec 'vector Right-Eye DIM AE AS vec 'vector Left-Eye DIM Left AS vec 'leftmost pixel of scanline DIM Right AS vec 'rightmost pixel of scanline DIM Ns AS vec Left.x = 0: Right.x = ScrWidth - 1 Left.z = z: Right.z = z AE.z = Left.z - eye.z BE.z = Right.z - eye.z AE.x = Left.x - eye.x BE.x = Right.x - eye.x FOR y% = 0 TO ScrHeight - 1 Left.y = y% Right.y = y% AE.y = Left.y - eye.y BE.y = Right.y - eye.y CALL cross(BE, AE, Ns) CALL normalize(Ns.x, Ns.y, Ns.z) NsLUT(y%) = Ns dsLUT(y%) = -(Ns.x * eye.x + Ns.y * eye.y + Ns.z * eye.z) NEXT y% END SUB SUB rayscan 'First pass of raytracing to determine visible surfaces. 'This calls the recursive raytrace routine. DIM dv AS vec: DIM v0 AS vec DIM n AS vec DIM V AS vec 'for plane intersections DIM pv AS vec DIM pv0 AS vec DIM pn AS vec DIM Left AS vec 'added for fastSphereHit calcs DIM Ns AS vec 'vector BExAE Left.x = 0: DIM scanlinedir AS vec scanlinedir.x = 1 scanlinedir.y = 0 scanlinedir.z = 0 t1 = TIMER '------------interlaced field 1------------------------- DEF SEG = Video.WinASegment FOR i% = 0 TO numspheres FHStatus(i%).flag = 0 NEXT i% FOR i% = 0 TO numcones cone(i%).hitflag = 0 NEXT i% Left.z = z 'don't erase dz = z - eye.z dz2 = dz * dz clr = 0 'pp% = 320 * 179 FOR y% = 0 TO ScrHeight key$ = INKEY$ IF key$ <> "" THEN END dy = y% - eye.y dy2 = dy * dy dyZ2 = dy2 + dz2 Left.y = y% 'don't erase! ds = dsLUT(y%) Ns = NsLUT(y%) FOR i% = 0 TO numspheres IF FHStatus(i%).flag <> -2 THEN CALL IsSphereHit(i%, Ns, ds, Left, scanlinedir) 'IF FHStatus(i%).flag = 1 THEN ' Rgba 253, 253, 253, 253 ' xLine FHStatus(i%).IntervalL, y%, FHStatus(i%).IntervalR, y% 'ELSEIF FHStatus(i%).flag = 2 THEN ' Rgba 128, 128, 128, 128 ' xLine 0, y%, ScrWidth - 1, y% 'END IF END IF NEXT i% FOR i% = 0 TO numcones CALL IsConeHit(i%, Ns) ' don't use this as a hittest ' use only as a precalc at each scanline NEXT i% FOR x% = 0 TO ScrWidth - 1 Dx = x% - eye.x isdr2 = 1! / SQR(dx2%(Dx) + dyZ2) dxn = Dx * isdr2 dyn = dy * isdr2 dzn = dz * isdr2 closestobj% = -1 neart = 1E+09 FOR i% = 0 TO numspheres IF (FHStatus(i%).flag = 1 AND x% >= FHStatus(i%).IntervalL AND x% <= FHStatus(i%).IntervalR) OR FHStatus(i%).flag = 2 THEN 'a is the quadratic, b is the linear, and c is the constant term 'o(i%) is the center of the sphere we're testing against 'a = 1 b = 2 * (dxn * o(i%).da + dyn * o(i%).db + dzn * o(i%).dc) c = o(i%).rn IF IntersectSphere(b, c) THEN IF b < neart THEN neart = b closestobj% = i% END IF END IF END IF NEXT i% ' check for plane intersection IF closestobj% = -1 THEN closestpln% = -1 neart2 = 1E+09 'it hit none of the spheres 'now test against plane FOR i% = 0 TO numplanes denom = plane(i%).a * dxn + plane(i%).b * dyn + plane(i%).c * dzn IF denom <> 0 THEN t = -(plane(i%).s) / denom IF t > 0 THEN IF t < neart2 THEN closestpln% = i% neart2 = t END IF END IF END IF NEXT i% END IF IF closestpln% <> -1 AND neart2 < neart THEN pv.x = (neart2 * dxn) pv.y = (neart2 * dyn) pv.z = (neart2 * dzn) pv0.x = pv.x + eye.x pv0.y = pv.y + eye.y pv0.z = pv.z + eye.z pv.x = pv.x pv.y = pv.y pv.z = pv.z pn.x = plane(closestpln%).a pn.y = plane(closestpln%).b pn.z = plane(closestpln%).c 'LOCATE 1, 1: COLOR 255: PRINT pv0.z IF pv0.z < 32766 THEN zzz% = INT(pv0.z) AND 255 ELSE zzz% = RND * 3 + 128 END IF zzz% = zzz% * totaldirectlight(pv0, pv, pn) \ 256 'cheesy antialiasing IF antialiasplane THEN GetPixel x% - 1, ScrHeight - y% SetPixel x%, ScrHeight - y% 'POKE pp%, (zzz% + POINT(x% - 1, ScrHeight - y%)) \ 2 ELSE Rgba Red% + zzz% / 2, Green% + zzz% / 2, Blue% + zzz% / 2, Alpha% + zzz% / 2 SetPixel x%, ScrHeight - y% 'POKE pp%, zzz% END IF END IF IF closestobj% <> -1 THEN 'LOCATE 1, 1: COLOR 255: PRINT neart 'difference between eye and collision point dxi = -neart * dxn dyi = -neart * dyn dzi = -neart * dzn 'position of collision in world coordinates v0.x = eye.x - dxi v0.y = eye.y - dyi v0.z = eye.z - dzi 'V=(dxi,dyi,dzi) is the vector from sphere pt. back to eye 'new V0=(xi,yi,zi) is point of i'sect of ray on sphere's surface 'new ray origin is at collision point on surface of sphere 'COLOR 255: PRINT USING "delta=##.## ##.## ##.## ctr=##.## ##.## ##.##"; o(closestobj%).a; o(closestobj%).b; o(closestobj%).c 'THESE TWO SHOULD BE EQUAL! ' COLOR 255: PRINT USING "###.#"; SQR((V0.x - o(closestobj%).a) ^ 2 + (V0.y - o(closestobj%).b) ^ 2 + (V0.z - o(closestobj%).c) ^ 2); ' PRINT USING "###.#"; o(closestobj%).r2 'N = normal of the sphere at the collision point 'N is normalized by the 1/r operation. n.x = (v0.x - o(closestobj%).a) / o(closestobj%).r n.y = (v0.y - o(closestobj%).b) / o(closestobj%).r n.z = (v0.z - o(closestobj%).c) / o(closestobj%).r 'New direction dv = reflection of V about N. V.x = dxi: V.y = dyi: V.z = dzi: CALL normalize(V.x, V.y, V.z) ndoti2 = 2 * (n.x * V.x + n.y * V.y + n.z * V.z) IF dorefract THEN 
02-22-2006, 02:54 AM
(As well as/Instead of) posting a load of code, you could try asking for help or telling us what you have problems with.
02-22-2006, 02:54 AM
Quote:@Z!re Code: COLOUR = VAL("&H" + HEX$(BLUE%) + "&H" + HEX$(ALPHA%) + "&H" + HEX$(RED%) + "&H" + HEX$(GREEN%))Ya, anyways.. there's lots of questions up there you never answered.. So.. whatever..
02-22-2006, 03:45 AM
How do you make this sub program run faster?
Code: SUB SetPixel (x%, y%)
02-22-2006, 03:53 AM
Rest of the code...
Code: txnum% = o(closestobj%).texturenum
02-22-2006, 09:29 AM
put that text in code tags
[code] Put Code In These [/code] or else it's not even worth looking at. |
|
« Next Oldest | Next Newest »
|
Users browsing this thread: 1 Guest(s)