'===========================================================================
' Subject: 2D BUMPMAPPING EXAMPLE UPDATE     Date: 03-04-97 (18:50)       
' Author:  Angelo Ken Pesce                  Code: QB, PDS                
' Origin:  ken@uniserv.uniplan.it          Packet: GRAPHICS.ABC
'===========================================================================
DECLARE SUB blood ()
DECLARE SUB bobs ()
DECLARE SUB sinfade ()
DECLARE SUB flam2 ()
DECLARE SUB anim ()
DECLARE SUB bump ()
DECLARE SUB bump1 ()
DECLARE SUB BurnPrint (y%, x%, text$, iter%)
DECLARE SUB circles ()
DECLARE SUB envcalc ()
DECLARE SUB flam ()
DECLARE SUB flam1 ()
DECLARE SUB InputValues ()
DECLARE SUB palinit (n!)
DECLARE SUB ReadRGB (red%, grn%, blu%, slot%)
DECLARE SUB setpal (start.slot%, end.slot%)
DECLARE SUB statef ()
DECLARE SUB testpat2 ()
DECLARE SUB TestPatt (n!)
DECLARE SUB textf ()
DECLARE SUB waitkpress ()
DECLARE SUB writeRGB (red%, grn%, blu%, slot%)
' $DYNAMIC
' USE QBX OR QB WITH /AH /NOFRILLS OPTIONS
' ( to say the truth I don't know if Qb has this options...... )
' You need 612k of conventional memory







' ***************************************************************************
' *******************  History  *********************************************
' ***************************************************************************
'
' Demo v1: First version. (not relased)
'
' Demo v2: I changed some algorithms and added a "new" (minor) routines
'
' ***************************************************************************
' ***************************************************************************
' ******************************************* P L E A S E  R E A D  T H I S *
' ***************************************************************************
' ***************************************************************************
' APSOFTWARE 1997 (Palette routines aren't mine....)
' Angelo KEN Pesce
' ken@uniserv.uniplan.it
' http://www.geocities.com/SiliconValley/Pines/9913/homepage.htm
' 2d BUMPmapping EXAMPLE + FLAME EFFECT + OTHER STUFF
' I can make better animated bump effects if I find the way to make an
' array to store the pattern instead putting it on the screen. (in fact there
' is only one problem: the emp array fills all the avaible memory... if anyone
' know how to get more memory to use for arrays on QuickBasic PDS7 please
' email me, I need 64k more memory)
' I also need to know a way to use the full 16m color vga palette
' (white=256*256*256 instead of 64*64*64)
'
' THIS NEEDS A PENTIUM 100... (to run Interpreted in QBX PDS 7, not Compiled)
' QUICKBASIC ISN'T A FAST LANGUAGE...
' BUT IT'S GOOD TO MAKE "TEST" VERSIONS
' OF PROGRAMS AND ALGORITHMS...
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************




' ***************************************************************************
' ***************************************************************************
' ***************************************************************************
' *****************  THE MAIN CODE  *****************************************
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************

' LIGHT POSITION (needed later in the bump subroutine)
DIM SHARED lposx%
DIM SHARED lposy%
CLS
CALL InputValues

' CALCULATE LIGHT ENVIROMENT MAP "EMP"
PRINT "Please wait: initializing enviroment map";
DIM SHARED emp(255, 255): ' Enviroment map array
' This routine makes a tiny spheric spot light.
' you can modify the array to alter the light (eg. you can implement some noise)
CALL envcalc

' SCREEN AND PALETTE INIT
SCREEN 13
CALL palinit(2)

DIM scrb(5625)
' iNTRO FIRE
FOR r = 1 TO 100
FOR a = 1 TO 15
x = INT((178 - 143 + 1) * RND + 143)
PSET (x, 122), 190
PSET (x, 121), 189
PSET (x, 120), 188
NEXT
CALL flam2
GET (138, 0)-(183, 125), scrb
PUT (138 - 46, 25), scrb, PSET
PUT (138 + 46, 25), scrb, PSET
PUT (138 - 90, 40), scrb, PSET
PUT (138 + 90, 40), scrb, PSET
PUT (138 - 130, 50), scrb, PSET
PUT (138 + 130, 50), scrb, PSET
NEXT
CALL bump
CALL waitkpress
CALL bobs
FOR r = 1 TO 15
CALL sinfade
NEXT
ERASE scrb

' iNTRO
CLS
CALL BurnPrint(11, 11, "ApsoftWare 1997", 50)
CALL BurnPrint(12, 12, "*** PRESENTS: ***", 50)
CALL BurnPrint(13, 13, "Fire and Bump", 50)
CALL BurnPrint(14, 14, "A QuickBasic DEMO", 50)
CLS

CALL palinit(1)
CALL BurnPrint(14, 14, "2D BumpMaps ahead", 50)

' Static Bump Effect
CALL statef

CLS
CALL BurnPrint(14, 14, "Don't play with fire", 50)

' Animated Fire Effect
CALL palinit(2)
CALL flam1
' Bump fire pattern
CALL palinit(1)
lposx% = 160
lposy% = 200
CALL bump
CALL waitkpress
CALL blood

CALL palinit(1)
CLS
CALL BurnPrint(14, 14, "Animated BumpMaps", 50)
CALL palinit(2)

CLS
' Animated Bump Effect
DIM SHARED scr(100, 70)
lposy% = 100
CALL testpat2
CALL anim

CLS
CALL palinit(1)
CALL BurnPrint(14, 14, "Text fire effect", 50)

' Text Fireeffect
ERASE scr: ' We have to gain more memory
ERASE emp: ' So we deallocate unused arrays
CALL textf

' THE END
END
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************
' ***************************************************************************

REM $STATIC
DEFINT A-Z
SUB anim

' animated 2d bump effect
DO
FOR r = 0 TO 100 STEP 5
lposx% = r
CALL bump1
IF INKEY$ <> "" THEN EXIT DO
NEXT
FOR r = 100 TO 0 STEP -5
lposx% = r
CALL bump1
IF INKEY$ <> "" THEN EXIT DO
NEXT
LOOP
END SUB

DEFSNG A-Z
SUB blood
  DEFINT A-Z
  DIM ta(100)
  FOR i = 1 TO 30000
    X1 = INT(RND * 270)
    Y1 = INT(RND * 196)
    GET (X1, Y1)-(X1 + 50, Y1 + 2), ta
    PUT (X1, Y1 + 2), ta, PSET
  NEXT
  ERASE ta
END SUB

SUB bobs
numcol = 63

FOR i = 1 TO 10
CIRCLE (10, 10), i, numcol - i
CIRCLE (11, 10), i, numcol - i
NEXT

DIM x(20 * 20)
GET (1, 1)-(20, 20), x

movx = 1
movy = 2
xpos = 1
ypos = 2

FOR i = 1 TO 10000
xpos = xpos + movx
ypos = ypos + movy
IF xpos = 300 THEN movx = -1
IF xpos = 1 THEN movx = 1
IF ypos >= 180 THEN movy = -2
IF ypos <= 2 THEN movy = 2
PUT (xpos, ypos), x, XOR
NEXT
ERASE x

END SUB

DEFSNG A-Z
SUB bump
' bump effect routine

DEF SEG = &HA000
FOR y% = 0 TO 100
FOR x% = 0 TO 319
lx% = x% - lposx%
ly% = y% - lposy%

' *********************************************************************
nx% = PEEK(y% * 320 + (x% + 1)) - PEEK(y% * 320 + x%) + 128 - lx%
ny% = PEEK((y% + 1) * 320 + x%) - PEEK(y% * 320 + x%) + 128 - ly%
' ORIGINAL VERSION (BEFORE V2)
'nx% = PEEK(y% * 320 + (x% + 1)) - PEEK(y% * 320 + (x%-1)) + 128 - lx%
'ny% = PEEK((y% + 1) * 320 + x%) - PEEK((y%-1) * 320 + x%) + 128 - ly%
' *********************************************************************

IF nx% < 0 OR nx% > 255 THEN nx% = 0
IF ny% < 0 OR ny% > 255 THEN ny% = 0

' *********************************************************************
POKE (y% * 320 + x%), emp(nx%, ny%)
' ORIGINAL VERSION (BEFORE V2)
' POKE ((y%-1) * 320 + (x%-1)), emp(nx%, ny%)
' *********************************************************************

NEXT
NEXT

DEF SEG = (&HA000 + &H7D0)
FOR y% = 1 TO 99
FOR x% = 0 TO 319
lx% = x% - lposx%
ly% = y% - (lposy% - 100): ' Use ly%=y%-(lposy%+100) to make a tiny 2 lights
'                            effect

' *********************************************************************
nx% = PEEK(y% * 320 + (x% + 1)) - PEEK(y% * 320 + x%) + 128 - lx%
ny% = PEEK((y% + 1) * 320 + x%) - PEEK(y% * 320 + x%) + 128 - ly%
' ORIGINAL VERSION (BEFORE V2)
'nx% = PEEK(y% * 320 + (x% + 1)) - PEEK(y% * 320 + (x%-1)) + 128 - lx%
'ny% = PEEK((y% + 1) * 320 + x%) - PEEK((y%-1) * 320 + x%) + 128 - ly%
' *********************************************************************

IF nx% < 0 OR nx% > 255 THEN nx% = 0
IF ny% < 0 OR ny% > 255 THEN ny% = 0

' *********************************************************************
POKE (y% * 320 + x%), emp(nx%, ny%)
' ORIGINAL VERSION (BEFORE V2)
' POKE ((y%-1) * 320 + (x%-1)), emp(nx%, ny%)
' *********************************************************************

NEXT
NEXT
DEF SEG
END SUB

SUB bump1
' animated bump effect routine

DEF SEG = &HA000
FOR y% = 0 TO 69
FOR x% = 0 TO 99
lx% = x% - lposx%
ly% = y% - lposy%
nx% = scr((x% + 1), y%) - scr(x%, y%) + 128 - lx%
ny% = scr(x%, (y% + 1)) - scr(x%, y%) + 128 - ly%
IF nx% < 0 OR nx% > 255 THEN nx% = 0
IF ny% < 0 OR ny% > 255 THEN ny% = 0
col = emp(nx%, ny%)
POKE (y% * 320 + x%), col
NEXT
NEXT
DEF SEG
END SUB

DEFINT A-Z
SUB BurnPrint (y%, x%, text$, iter%)
' burning text routine

' Sin Table
DIM sn(360)
FOR r = 0 TO 360
sn(r) = SIN(r)
NEXT

' PRINT THE TEXT
COLOR 189: LOCATE y%, x%
PRINT text$

' WAIT KEYPRESS
DO: LOOP WHILE INKEY$ = ""

' CALCULATE TEXT POSITION

lenght = LEN(text$)

xstart = (x * 8) - 8
xend = ((x + lenght) * 8) - 8
ystart = (y * 8) - 25
yend = (y * 8) - 8

FOR r = 1 TO iter%

FOR y = ystart TO yend + 8
FOR x = xstart TO xend

col = FIX(POINT(x + sn(a), y) + POINT(x, y + 1)) / 2 - (3 * RND)
IF col < 0 THEN col = 0
PSET (x, y), col
a = a + 1: IF a = 360 THEN a = 0
NEXT x
NEXT y
NEXT r
END SUB

SUB circles
' circle generator routine - test pattern

FOR i = 0 TO 12
FOR x = 35 TO 0 STEP -1
c = x + (i * i)
d = ABS(x * x / 4 + i)
CIRCLE (111, 200), d, c
CIRCLE (110, 200), d, c
CIRCLE (211, 200), d, c
CIRCLE (210, 200), d, c
NEXT
NEXT
END SUB

DEFSNG A-Z
SUB envcalc
' enviroment map array initializiation routine

FOR y% = 0 TO 255
FOR x% = 0 TO 255
nrmx = (x% - 128) / 128
nrmy = (y% - 128) / 128
nrmz = 1 - SQR((nrmx * nrmx) + (nrmy * nrmy))
IF nrmz < 0 THEN nrmz = 0
emp(x%, y%) = CINT(nrmz * 190)
NEXT
PRINT ".";
NEXT
END SUB

DEFINT A-Z
SUB flam
' fire - fade routine

DEF SEG = &HA000
FOR yp = 0 TO 100
FOR xp = 0 TO 319
col = PEEK(yp * 320 + xp)
col1 = PEEK(yp * 320 + (xp + 1))
' ************** JUMP ROUTINE **************************
IF col = col1 THEN GOTO fastout ELSE col = col + col1
' ************************************************************
col = col + PEEK((yp - 1) * 320 + xp)
col = col + PEEK((yp + 1) * 320 + xp)
col = col + PEEK(yp * 320 + (xp - 1))
col = col / 5 - 6
IF col < 0 THEN col = 0
POKE yp * 320 + xp, col
fastout:
NEXT
NEXT
sg = &HA000 + &H7D0
DEF SEG = sg
FOR yp = 1 TO 99
FOR xp = 0 TO 319
col = PEEK(yp * 320 + xp)
col1 = PEEK(yp * 320 + (xp + 1))
' ************** JUMP ROUTINE **************************
IF col = col1 THEN GOTO fastout1 ELSE col = col + col1
' ************************************************************
col = col + PEEK((yp - 1) * 320 + xp)
col = col + PEEK((yp + 1) * 320 + xp)
col = col + PEEK(yp * 320 + (xp - 1))
col = col / 5 - 6
IF col < 0 THEN col = 0
POKE yp * 320 + xp, col
fastout1:
NEXT
NEXT
DEF SEG
END SUB

SUB flam1
' fire routine
sg = &HA000 + &H7D0
DEF SEG = sg
DO

FOR r = 0 TO 50
a = INT(320 * RND)
PSET (a, 198), 190
PSET (a + 1, 198), 0
NEXT

FOR yp = 60 TO 99
FOR xp = 0 TO 319
col = PEEK((yp + 1) * 320 + xp)
col1 = PEEK(yp * 320 + xp + 1)
IF col = col1 THEN GOTO fast ELSE col = col + col1
col = col + PEEK(yp * 320 + xp)
col = col / 3 - 3
IF col < 0 THEN col = 0
POKE (yp - 1) * 320 + xp, col
fast:
NEXT
NEXT
LOOP WHILE INKEY$ = ""
DEF SEG
END SUB

DEFSNG A-Z
SUB flam2
DEFINT A-Z
sp = 3: REM FIRE Y SPEED

REM ROUTINE RANGE: X 138-183, Y 0-125

REM ROUTINE 0 FASTEST *************************************** Pixels 0 - 40
FOR y = 0 TO 40
    FOR x = 138 TO 183
      col = POINT(x, y - 1)
      IF col = 0 THEN GOTO a1
      col = col - 1
      PSET (x, y - sp), col
a1:
NEXT
NEXT

REM ROUTINE 1 FAST ****************************************** Pixels 41 - 65

FOR y = 41 TO 65
    FOR x = 138 TO 183
      col = POINT(x, y + 1)
      col = col + POINT(x, y - 1): IF col = 0 THEN GOTO ken1
      col = col / 2 - 1
      IF col < 0 THEN col = 0
      PSET (x, y - sp), col
ken1:
NEXT
NEXT

REM ROUTINE 2 MEDIUM ******************************************* Pixels 66-80

FOR y = 66 TO 80
    FOR x = 138 TO 183
      col = POINT(x, y)
      col = col + POINT(x, y + 1): IF col = 0 THEN GOTO ken3
      col = col + POINT(x, y - 1)
      col = col / 3 - 1
      IF col < 0 THEN col = 0
      PSET (x, y - sp), col
ken3:
NEXT
NEXT

REM ROUTIME 3 SLOW ******************************************** Pixels 81-125
FOR y = 81 TO 125
   FOR x = 138 TO 183
      col = POINT(x, y)
       col = col + POINT(x + 1, y): IF col = 0 THEN GOTO ken6:
       col = col + POINT(x - 1, y)
       col = col + POINT(x, y + 1)
       col = col + POINT(x, y - 1)
       col = col / 5 - 1
       IF col < 0 THEN col = 0
ken6:
      PSET (x, y - sp), col
NEXT
NEXT

END SUB

DEFSNG A-Z
SUB InputValues
PRINT "Light position (good values are 160,100)"
INPUT "x (from 1 to 320)"; lposx%
INPUT "y (from 1 to 200)"; lposy%
IF lposx% < 1 OR lposx% > 320 THEN lposx% = 160
IF lposy% < 1 OR lposy% > 200 THEN lposy% = 100
PRINT
END SUB

SUB palinit (n)
' palette setup routine

SELECT CASE n
CASE IS = 1

CALL writeRGB(0, 0, 0, 0)
CALL writeRGB(0, 0, 63, 63)
CALL setpal(0, 63)

CALL writeRGB(0, 0, 63, 64)
CALL writeRGB(0, 63, 63, 127)
CALL setpal(64, 127)

CALL writeRGB(0, 63, 63, 128)
CALL writeRGB(63, 63, 63, 190)
CALL setpal(128, 190)

CASE IS = 2
CALL writeRGB(0, 0, 0, 0)
CALL writeRGB(63, 0, 0, 63)
CALL setpal(0, 63)

CALL writeRGB(63, 0, 0, 64)
CALL writeRGB(63, 63, 0, 127)
CALL setpal(64, 127)

CALL writeRGB(63, 63, 0, 128)
CALL writeRGB(63, 63, 63, 190)
CALL setpal(128, 190)
END SELECT
END SUB

DEFINT A-Z
SUB ReadRGB (red%, grn%, blu%, slot%)
' palette value read routine

  '
  OUT &H3C7, slot% ' Read RGB values from slot
  '
  red% = INP(&H3C9)
  grn% = INP(&H3C9)
  blu% = INP(&H3C9)
  '
END SUB

SUB setpal (start.slot%, end.slot%)
' smooth palette generator routine

  '
  num.slots% = end.slot% - start.slot%
  '
  CALL ReadRGB(sr%, sg%, sb%, start.slot%)
  CALL ReadRGB(er%, eg%, eb%, end.slot%)
  '
  rr% = ABS(er% - sr%): rg% = ABS(eg% - sg%): rb% = ABS(eb% - sb%)
  rs% = SGN(er% - sr%): gs% = SGN(eg% - sg%): bs% = SGN(eb% - sb%)
  '
  stepr = (rr% / num.slots%) * rs%
  stepg = (rg% / num.slots%) * gs%
  stepb = (rb% / num.slots%) * bs%
  '
  r = sr%: g = sg%: b = sb%
  wr% = r: wg% = g: wb% = b
  '
  FOR t% = start.slot% TO end.slot%
    '
    CALL writeRGB(wr%, wg%, wb%, t%)
    '
    r = r + stepr: wr% = r
    g = g + stepg: wg% = g
    b = b + stepb: wb% = b
    '
  NEXT t%
  '
END SUB

SUB sinfade

DEF SEG = &HA000
FOR y = 0 TO 100
FOR x = 0 TO 318
col = PEEK(y * 320 + x + 5) - 15
IF col < 0 THEN col = 0
POKE (y * 320 + x), col
NEXT
NEXT

sg = &HA000 + &H7D0
DEF SEG = sg
FOR y = 1 TO 99
FOR x = 319 TO 1 STEP -1
col = PEEK(y * 320 + x - 5) - 15
IF col < 0 THEN col = 0
POKE (y * 320 + x), col
NEXT
NEXT
END SUB

DEFSNG A-Z
SUB statef
' static 2d bump effect

' TEST PATTERN (You can use any pattern or image)
CALL palinit(2)
CALL TestPatt(0)
CALL palinit(1)
CALL bump: ' Bump Map
CALL waitkpress
CALL blood
FOR r = 1 TO 20
CALL flam: 'More than flam we can call this "fade"
NEXT
CALL palinit(2)
CALL TestPatt(1)
CALL palinit(1)
CALL bump: ' Bump Map
CALL waitkpress
CALL blood
FOR r = 1 TO 20
CALL flam
NEXT
END SUB

SUB testpat2
' pattern generator for animated bump

FOR x = 0 TO 100
FOR y = 0 TO 70
PSET (x, y), RND * 100
NEXT
NEXT
flam
flam
FOR x = 0 TO 100
FOR y = 0 TO 70
scr(x, y) = POINT(x, y)
NEXT
NEXT

END SUB

SUB TestPatt (n)
' pattern generator for static bump routine
SELECT CASE n
CASE IS = 0
CALL circles
CASE IS = 1
FOR x = 1 TO 320
FOR y = 1 TO 200
PSET (x, y), RND * 100
NEXT
NEXT
CALL flam: ' this smooths the pattern
END SELECT
END SUB

DEFINT A-Z
SUB textf
' text fireeffect routine

SCREEN 0: WIDTH 80, 50
DIM scrbuf(80, 50)

DO
GOSUB lastline
GOSUB randput
GOSUB fire
GOSUB updscr
LOOP WHILE INKEY$ = ""

END
REM ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ SUBS
updscr:
LOCATE 1, 1
FOR y = 1 TO 49
FOR x = 1 TO 80
SELECT CASE scrbuf(x, y)
CASE 0 TO 9
COLOR 0, 0: PRINT " ";
CASE 10 TO 19
COLOR 4, 0: PRINT "°";
CASE 20 TO 29
COLOR 4, 0: PRINT "±";
CASE 30 TO 39
COLOR 4, 0: PRINT "²";
CASE 40 TO 44
COLOR 14, 4: PRINT " ";
CASE 45 TO 50
COLOR 14, 4: PRINT "°";
CASE 51 TO 69
COLOR 14, 4: PRINT "±";
CASE 70 TO 89
COLOR 14, 4: PRINT "²";
CASE 90 TO 124
COLOR 14, 4: PRINT "Û";
CASE 125 TO 160
COLOR 15, 0: PRINT "Û";
END SELECT
NEXT
NEXT
RETURN

lastline:
FOR x = 1 TO 80
a = CINT(RND)
IF a = 1 THEN scrbuf(x, 50) = 0
IF a = 0 THEN scrbuf(x, 50) = 160
NEXT
RETURN

randput:
FOR i = 1 TO 5
x = INT(79 * RND + 1)
y = INT(49 * RND + 1)
scrbuf(x, y) = 160
scrbuf(x, y + 1) = 160
scrbuf(x + 1, y + 1) = 160
NEXT
RETURN

fire:
FOR x = 1 TO 79
FOR y = 1 TO 49
colr = scrbuf(x, y) + scrbuf(x + 1, y) + scrbuf(x, y + 1) + scrbuf(x - 1, y) + scrbuf(x, y - 1)
colr = INT(colr / 5.3 - INT(11 * RND - 5))
IF colr > 160 THEN colr = 160
IF colr < 0 THEN colr = 0
scrbuf(x, y - 1) = colr
NEXT
NEXT
RETURN

END SUB

DEFSNG A-Z
SUB waitkpress
DO: LOOP WHILE INKEY$ = ""
END SUB

DEFINT A-Z
SUB writeRGB (red%, grn%, blu%, slot%)
' palette write routine

  '
  OUT &H3C8, slot% ' Write RGB values to slot
  '
  OUT &H3C9, red%
  OUT &H3C9, grn%
  OUT &H3C9, blu%
  '
END SUB