[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 "ÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃ""
PRINT "º Quit the program immediatly if you have a monochrome display º"
PRINT "ÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃÃ1/4"
PRINT
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