'Code supplement for Lens Flare tutorial 'for QB express 'Relsoft 2004 'Http://Rel.Betterwebber.com ' 'Special thanks to: 'Plasma357 for SetVideoSeg 'Pete for QBexpress 'BlackPawn for the cool flare texturing algos DECLARE SUB transsprite (x%, y%, image%()) DECLARE SUB superput () DECLARE SUB normalizevec (v AS ANY) DECLARE SUB SetVideoSeg (Segment%) DECLARE FUNCTION smoothstep! (a!, b!, x!) DEFINT A-Z '$DYNAMIC TYPE vector2d '2d vector used to get flare positions x AS SINGLE 'x component y AS SINGLE mag AS SINGLE 'length END TYPE CONST PI = 3.141593 'pie CONST radius = 16 'radius of flare CONST xcenter = 160 'center of screen CONST ycenter = 100 'our flare images REDIM flare1(radius * 2, radius * 2) REDIM flare2(radius * 2, radius * 2) REDIM flare3(radius * 2, radius * 2) REDIM flare4(radius * 2, radius * 2) REDIM flare5(radius * 2, radius * 2) REDIM Flare6(radius * 2, radius * 2) 'Setvideoseg stuff REDIM vpage(32009) AS INTEGER 'Clear offscreen buffer vpage(6) = 2560 'Width 320*8 vpage(7) = 200 'Height DIM SHARED Layer Layer = VARSEG(vpage(0)) + 1 'Buffer Seg(Ask Plasma) DIM vec AS vector2d 'dimension both the light DIM light AS vector2d 'and direction vector CLS SCREEN 13 '320*200*256 FOR i = 0 TO 255 'greyscale the pal OUT &H3C8, i OUT &H3C9, i \ 4 OUT &H3C9, i \ 4 OUT &H3C9, i \ 4 NEXT i 'generate lensflare textures 'and store images in flare arrays '// #1 FOR y = 0 TO radius * 2 FOR x = 0 TO radius * 2 dx = radius - x dy = radius - y r! = SQR(dx * dx + dy * dy) / radius c! = 1 - r! c! = c! * c! IF r! > 1 THEN c! = 0 col = c! * 255 PSET (x, y), col flare1(x, y) = col NEXT x NEXT y CLS '// #2 FOR y = 0 TO radius * 2 FOR x = 0 TO radius * 2 dx = radius - x dy = radius - y r! = SQR(dx * dx + dy * dy) / radius c! = r! c! = c! * (1 - smoothstep!(1 - .04, 1 + .04, r!)) col = c! * 255 PSET (x, y), col flare2(x, y) = col NEXT x NEXT y CLS '// #3 FOR y = 0 TO radius * 2 FOR x = 0 TO radius * 2 dx = radius - x dy = radius - y r! = SQR(dx * dx + dy * dy) / radius c! = r! * r! c! = c! * c! c! = c! * c! * c! c! = c! * (1 - smoothstep!(1 - .04, 1 + .04, r!)) col = c! * 255 PSET (x, y), col flare3(x, y) = col NEXT x NEXT y CLS '// #4 FOR y = 0 TO radius * 2 FOR x = 0 TO radius * 2 dx = radius - x dy = radius - y r! = SQR(dx * dx + dy * dy) / radius c! = 1 - ABS(r! - .9) / .19 c! = c! * c! c! = c! * c! IF c! > 1 THEN c! = 1 IF r! > 1 THEN c! = 0 'try to rem this col = c! * 255 PSET (x, y), col flare4(x, y) = col NEXT x NEXT y CLS '// #5 FOR y = 0 TO radius * 2 FOR x = 0 TO radius * 2 dx = radius - x dy = radius - y r! = SQR(dx * dx + dy * dy) / radius c! = 1 - ABS(r! - .9) / .19 IF c! < 0 THEN c! = 0 c! = c! * c! c! = c! * c! IF c! > 1 THEN c! = 1 IF r! > 1 THEN c! = 0 'try to rem this col = c! * 255 PSET (x, y), col flare5(x, y) = col NEXT x NEXT y SetVideoSeg Layer 'Set Draw to Buffer cx = xcenter 'center of screen cy = ycenter DO frame& = (frame& + 1) AND &H7FFFFFFF 'move the flare vector using trig functions 'and timer as parameter T! = TIMER light.x = INT(COS(T! * .4) + SIN(T!) * 100) light.y = INT(SIN(T! + .2) * SIN(T! * .5) * 64) 'change the length for cooler effect leng = INT(SIN(T! + .2) * SIN(T! * .5) * 256) 'center our light vector light.x = light.x + cx light.y = light.y + cy 'derive flare vector from center and light vec.x = cx - light.x vec.y = cy - light.y 'normalize it normalizevec vec 'get positions of flares relative to center l1! = leng l2! = leng / 1.5 l3! = leng / 2 l4! = -leng / 8 l5! = -leng / 2 l6! = -leng SetVideoSeg Layer 'Set Draw to Buffer LINE (0, 0)-(319, 199), 0, BF 'clear screen IF (frame& AND 1) THEN 'do some nice flicker fx 'get flare position of flare using a line derived 'by leng*vec nx! = vec.x * l1! + cx ny! = vec.y * l1! + cy transsprite nx! - radius, ny! - radius, flare5() 'combine 2 flares for transsprite nx! - radius, ny! - radius, flare1() 'cooler fx. :*) 'ditto but single flare nx! = vec.x * l2! + cx ny! = vec.y * l2! + cy transsprite nx! - radius, ny! - radius, flare1() 'ditto nx! = vec.x * l3! + cx ny! = vec.y * l3! + cy transsprite nx! - radius, ny! - radius, flare4() 'ditto nx! = vec.x * l4! + cx ny! = vec.y * l4! + cy transsprite nx! - radius, ny! - radius, flare3() 'ditto nx! = vec.x * l5! + cx ny! = vec.y * l5! + cy transsprite nx! - radius, ny! - radius, flare2() 'ditto nx! = vec.x * l6! + cx ny! = vec.y * l6! + cy transsprite nx! - radius, ny! - radius, flare1() END IF SetVideoSeg &HA000 'set draw to VGA WAIT &H3DA, 8 'wait retrace PUT (0, 0), vpage(6), PSET 'blit to screen LOOP UNTIL INKEY$ <> "" END REM $STATIC SUB normalizevec (v AS vector2d) 'normalizes v to give it a length of 1 dx! = v.x dy! = v.y dist! = SQR(dx! * dx! + dy! * dy!) IF dist! < .00001 THEN EXIT SUB 'just a precaution for too small 'values v.x = dx! / dist! v.y = dy! / dist! v.mag = dist! END SUB SUB SetVideoSeg (Segment) STATIC '=============================================================== ' SetVideoSeg by Plasma '--------------------------------------------------------------- ' Changes QB's active video segment for SCREEN 13 '--------------------------------------------------------------- ' * Works for all graphics functions (does not work with PRINT) ' * Compatible with: QBasic 1.x ' QuickBasic 4.x (IDE & compiled) ' QB PDS 7.1 (IDE & compiled) ' VBDOS 1.0 (IDE & compiled) '=============================================================== DEF SEG ' If SetVideoSeg was previously called, we can just ' set the new segment and bail. IF VideoSegOff <> 0 THEN POKE VideoSegOff, Segment AND &HFF POKE VideoSegOff + 1, (Segment AND &HFF00&) \ &H100 EXIT SUB END IF ' Otherwise we have to search for b$AddrC, which holds the ' graphics offset (b$OffC) and segment (b$SegC). Since b$AddrC ' is in the default segment, we can find it by setting it to a ' certain value, and then searching for that value. SCREEN 13 ' Set b$SegC to A000 (00A0 in memory) PSET (160, 100), 0 ' Set b$OffC to 7DA0 (not needed in the IDE) ' Search for b$AddrC, which is in the default segment and ' should have a value of A0 7D 00 A0. FOR i = 0 TO &H7FFC IF PEEK(i) = &HA0 AND PEEK(i + 1) = &H7D THEN IF PEEK(i + 2) = &H0 AND PEEK(i + 3) = &HA0 THEN ' Found it, so set b$SegC to the specified segment and exit VideoSegOff = i + 2 POKE VideoSegOff, Segment AND &HFF POKE VideoSegOff + 1, (Segment AND &HFF00&) \ &H100 EXIT SUB END IF END IF NEXT SCREEN 0 WIDTH 80, 25 PRINT "SetVideoSeg Error: Cannot find video segment offset." PRINT "Check to make sure you are using a compatible version of QB." END END SUB FUNCTION smoothstep! (a!, b!, x!) 'smooths the edges of the flare 'Algo by BlackPawn IF x! < a! THEN smoothstep! = 0 EXIT FUNCTION ELSEIF x! >= b! THEN smoothstep! = 1 EXIT FUNCTION END IF x! = (x! - a!) / (b! - a!) smoothstep! = (x! * x!) * (3 - 2 * x!) END FUNCTION SUB transsprite (x%, y%, image%()) 'Draws out images translucently using a simple 'blending method xmax% = UBOUND(image%, 1) ymax% = UBOUND(image%, 2) FOR ny% = 0 TO ymax% FOR nx% = 0 TO xmax% c% = image%(nx%, ny%) 'get color of image IF c% <> 0 THEN '0? dc% = POINT(x% + nx%, y% + ny%) 'get color of screen PSET (x% + nx%, y% + ny%), (c% + dc%) \ 2 'blend and draw END IF NEXT nx% NEXT ny% END SUB