'===========================================================================
' Subject: UPDATED FIRE SPHERE               Date: 03-19-97 (00:00)       
' Author:  Angelo Ken Pesce                  Code: QB, PDS                
' Origin:  us0082@uniserv.uniplan.it       Packet: GRAPHICS.ABC
'===========================================================================
DECLARE SUB stars ()
DECLARE SUB DrawPoints ()
DECLARE SUB flam ()
DECLARE SUB ppset (x%, y%, c%)
DECLARE SUB ReadRGB (red%, grn%, blu%, slot%)
DECLARE SUB Rotate ()
DECLARE SUB SetPal (start.slot%, end.slot%)
DECLARE SUB SetupBall ()
DECLARE SUB writeRGB (red%, grn%, blu%, slot%)
DEFINT A-Z
'$DYNAMIC
DIM SHARED scr(320, 200)


' USE QBX /AH OR QB /AH


'{A little rotating sphere, by Glen Jeh, 8/12/1994, use freely}
'{Try messing with the constants...code is squished a little}
' Converted to BASIC by William Yu (05-28-96)
' Revision + Static FastFireEffect v3 + Stars added by Angelo Pesce (1997)
'
' 192 colors version (palette routines by Andrew L. Ayers)
'
' COMPILE WITH ALTERNATE MATH FOR BEST PERFORMANCE
' TOTAL JUMP
' DIRECT PSET METHOD / 2 HALFS / ALL INTEGERS
' 5 PIXEL INTERPOLATION
' ARRAY FIRE (SLOWER BUT CLEANER)
' 191 COLORS
' STARS BACKGROUND

PRINT "FireSphere"
PRINT ".........."
PRINT
PRINT "press enter for defaults"
PRINT

' x and y are multiplied by scale and divided by distance
0 DIM SHARED Scale AS INTEGER
INPUT "Scale:"; temp1$
IF temp1$ = "" THEN Scale = 45: GOTO 1
Scale = VAL(temp1$)

' mystery constant :-)
1 DIM SHARED Radius AS INTEGER
INPUT "Radius:"; temp2$
IF temp2$ = "" THEN Radius = 80: GOTO 2
Radius = VAL(temp2$)

' number of slices
2 DIM SHARED Slices AS INTEGER
INPUT "Slices:"; temp3$
IF temp3$ = "" THEN Slices = 24: GOTO 3
Slices = VAL(temp3$)

' points per slice
3 DIM SHARED PPS AS INTEGER
INPUT "Points Per Slice:"; temp4$
IF temp4$ = "" THEN PPS = 40: GOTO 4
PPS = VAL(temp4$)

4 CONST Pi = 3.1415

TYPE PointType
  x AS INTEGER
  y AS INTEGER
  z AS INTEGER
END TYPE

DIM SHARED points(1 TO Slices, 1 TO PPS) AS PointType
DIM SHARED Ball(1 TO Slices, 1 TO PPS) AS PointType
DIM SHARED XAngle, YAngle, ZAngle
DIM SHARED SinTable(0 TO 255)  AS INTEGER
DIM SHARED CosTable(0 TO 255)  AS INTEGER
DIM SHARED Distance, Dir
CONST nstars = 1000
CONST scolor = 15
DIM SHARED y(nstars)
DIM SHARED x(nstars)
DIM SHARED s(nstars)

SCREEN 13: CLS
FOR i = 1 TO nstars
x(i) = RND * 320
y(i) = RND * 200
s(i) = RND * 5
NEXT i


  FOR i = 0 TO 255
      SinTable(i) = INT(SIN(2 * Pi / 255 * i) * 128)
      CosTable(i) = INT(COS(2 * Pi / 255 * i) * 128)
  NEXT i
  SCREEN 13

  Distance = 100: Dir = -3
  SetupBall
  XAngle = 0
  YAngle = 0
  ZAngle = 0

' FORM BLACK TO RED
CALL writeRGB(0, 0, 0, 1)
CALL writeRGB(63, 0, 0, 63)
CALL SetPal(1, 63)

' FROM RED TO YELLOW
CALL writeRGB(63, 0, 0, 64)
CALL writeRGB(63, 63, 0, 127)
CALL SetPal(64, 127)

' FROM YELLOW TO WHITE
CALL writeRGB(63, 63, 0, 128)
CALL writeRGB(63, 63, 63, 191)
CALL SetPal(128, 191)
'
' ALL THE OTHERS WHITE (this avoid using IF COL>191 THEN COL=191 in flam sub)
FOR i = 192 TO 255
CALL writeRGB(63, 63, 63, i)
NEXT i

 DO
    Rotate
    DrawPoints
    flam
    XAngle = XAngle + 3
    YAngle = YAngle + 2
    ZAngle = ZAngle + 1
    Distance = Distance + Dir
    IF XAngle > 250 THEN XAngle = 0
    IF YAngle > 250 THEN YAngle = 0
    IF ZAngle > 250 THEN ZAngle = 0
    IF Distance >= 300 THEN Dir = -3
    IF Distance <= 30 THEN Dir = 2
    LOOP UNTIL INKEY$ <> ""
CLS
SCREEN 0
WIDTH 80
PRINT "Angelo KEN Pesce 1997"
END

REM $STATIC
'{mystery procedure}
SUB DrawPoints
  FOR i = 1 TO Slices
    FOR i2 = 1 TO PPS
      IF (points(i, i2).z >= 0) AND (points(i, i2).x <= 319) AND (points(i, i2).x >= 0) AND (points(i, i2).y >= 0) AND (points(i, i2).y < 199) THEN
        CALL ppset(points(i, i2).x, points(i, i2).y, 10)
      END IF
    NEXT i2
  NEXT i
END SUB

SUB dstars STATIC
FOR i = 1 TO nstars
IF scr(x(i), y(i)) = scolor THEN scr(x(i), y(i)) = 0
NEXT
END SUB

SUB flam
DEF SEG = &HA000
FOR yp = 1 TO 100
FOR xp = 1 TO 319
POKE (yp * 320 + xp), scr(xp, yp)
NEXT
NEXT
DEF SEG = &HA000 + &H7D0
FOR yp = 1 TO 100
FOR xp = 1 TO 319
POKE (yp * 320 + xp), scr(xp, yp + 100)
NEXT
NEXT

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

SUB ppset (x, y, c)
IF y < 1 THEN y = 1 ELSE IF y > 199 THEN y = 199
IF x < 1 THEN x = 1 ELSE IF x > 319 THEN x = 319

a = scr(x, y)
c = a + c
scr(x, y) = c + 30
scr(x - 1, y) = c
scr(x + 1, y) = c
scr(x, y + 1) = c
scr(x, y - 1) = c
END SUB

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

DEFINT A-Z
SUB Rotate
'UPDATES all (X,Y,Z) coordinates according to XAngle,YAngle,ZAngle
 
  FOR i = 1 TO Slices
    FOR i2 = 1 TO PPS
                     '{rotate on X-axis}
      TempY = (Ball(i, i2).y * CosTable(XAngle) - Ball(i, i2).z * SinTable(XAngle)) / 128
      TempZ = (Ball(i, i2).y * SinTable(XAngle) + Ball(i, i2).z * CosTable(XAngle)) / 128
                    ' {rotate on y-anis}
      TempX = (Ball(i, i2).x * CosTable(YAngle) - TempZ * SinTable(YAngle)) / 128
      TempZ = (Ball(i, i2).x * SinTable(YAngle) + TempZ * CosTable(YAngle)) / 128
                     '{rotate on z-axis}
      OldTempX = TempX
      TempX = (TempX * CosTable(ZAngle) - TempY * SinTable(ZAngle)) / 128
      TempY = (OldTempX * SinTable(ZAngle) + TempY * CosTable(ZAngle)) / 128
      points(i, i2).x = (TempX * Scale) / Distance + 320 / 2
      points(i, i2).y = (TempY * Scale) / Distance + 200 / 2
      points(i, i2).z = TempZ
    NEXT i2
  NEXT i
END SUB

SUB SetPal (start.slot%, end.slot%)
  '
  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

'{sets up the ball's data..}
SUB SetupBall ' {set up the points}
  FOR SliceLoop = 1 TO Slices
      Phi! = Pi / Slices * SliceLoop        ' 0 <= Phi <= Pi
      FOR PPSLoop = 1 TO PPS
          Theta! = 2 * Pi / PPS * PPSLoop   ' 0 <= Theta <= 2*Pi
              '{convert Radius,Thetha,Phi to (x,y,z) coordinates}
          Ball(SliceLoop, PPSLoop).y = INT(Radius * SIN(Phi!) * COS(Theta!))
          Ball(SliceLoop, PPSLoop).x = INT(Radius * SIN(Phi!) * SIN(Theta!))
          Ball(SliceLoop, PPSLoop).z = INT(Radius * COS(Phi!))
      NEXT PPSLoop
 NEXT SliceLoop
END SUB

SUB stars STATIC
FOR i = 1 TO nstars
x(i) = x(i) - s(i)
IF x(i) <= 1 THEN
x(i) = 320
y(i) = RND * 200
END IF
IF scr(x(i), y(i)) = 0 THEN scr(x(i), y(i)) = scolor + s(i)
NEXT i
END SUB

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