'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

