'               ============Alan's Fractal Program=============
'                           *  Coded by Alan King  *
'                                  May 1996
'****************************************************************************
'This program is dedicated to displaying the beautiful mandelbrot formula.
'If you use any portions of this program, PLEASE aknowledge me! (Wouldn't you
'want to be known for the cool stuff you could do with QB?)
'If you have questions, comments, suggestions, send them to:
'                             a_king@geocities.com
'For some more of my programs: www.geocities.com/SiliconValley/Lakes/3842
'I guarantee that you will enjoy this. Have fun!

DECLARE SUB fade (Start%, Finish%, spd)
DECLARE SUB soften (XStart%, YStart%, XEnd%, YEnd%)
DECLARE SUB SphereContour ()
DECLARE SUB FirePal ()
DECLARE SUB AltrntPal ()
DECLARE SUB Instruct ()
DECLARE SUB InvertColors ()
DECLARE SUB ContourMap ()
DECLARE SUB CloudPal ()
DECLARE SUB DrawFractal ()
DECLARE SUB LivePalRot (spd%)
DECLARE SUB MakeRGBPal ()
DECLARE SUB PaletteRot ()
DECLARE SUB InputCommand (Cmnd$)
DECLARE SUB LoadScreen (file$)
DECLARE SUB SaveScreen (file$)
DECLARE SUB Options ()

RANDOMIZE TIMER

DIM SHARED startres%, TotalColors%, grn%, Bump%, res%
DIM SHARED ReportTime$, StartI%, StartZ%, z%, i%, status$, ScreenX%, ScreenY%
DIM SHARED delay%, spd%, SphereSize%, XSize#, YSize#, XCenter#, YCenter#, MaxIter%

        MaxIter% = 193          'Maximum number of iterations.
        startres% = 32          'Starting res. Powers of two for best result.
        XSize# = 1               'X Size from center to each edge.
        YSize# = .9              'Y Size from center to each edge.
        XCenter# = -.5           'Center along the X axis.
        YCenter# = 0             'Center along the Y axis.
        ScreenX% = 320          'Size of window on X-Axis
        ScreenY% = 200          'Size of window on Y-Axis
        ReportTime$ = "n"       'Report the elapsed render time (y or n).
        Bump% = 10               'Percent of bumpiness on 3D contouring.
        delay% = 0              'If the palette is too fast ;) set to 32000.
        SphereSize% = 65       'Nuff said ;)

DIM SHARED Pal.R(0 TO 256 * 2) AS INTEGER
DIM SHARED Pal.G(0 TO 256 * 2) AS INTEGER
DIM SHARED Pal.B(0 TO 256 * 2) AS INTEGER

CLS 0

SCREEN 13

'Calls the instructions sub.
Instruct

CLS 0
TotalColors% = 193      'Maximum number of rotated colors.

SCREEN 13

'Below sets the palette arrays

COLOR 1
PRINT "INITIALIZING PALETTE...PLEASE WAIT"

MakeRGBPal              'MakeRGBPal creates a RGB palette with 193 values

CLS

res% = startres%

DO
CALL DrawFractal

'Rotate the palette
PaletteRot
LOOP

SUB AltrntPal
       
'This section alternates the "center" of the color bands.

        RndmAdj.R% = RND * TotalColors%
        RndmAdj.G% = RND * TotalColors%
        RndmAdj.B% = RND * TotalColors%
        FOR col% = 1 TO TotalColors%
        Pal.R(col%) = Pal.R(col% + RndmAdj.R%)
        Pal.G(col%) = Pal.G(col% + RndmAdj.G%)
        Pal.B(col%) = Pal.B(col% + RndmAdj.B%)
        NEXT col%

'This section copies the palette to the second half of the color arrays.
      
        FOR PalCopy% = 1 TO TotalColors%
        Pal.R(PalCopy% + TotalColors%) = Pal.R(PalCopy%)
        Pal.G(PalCopy% + TotalColors%) = Pal.G(PalCopy%)
        Pal.B(PalCopy% + TotalColors%) = Pal.B(PalCopy%)
        NEXT PalCopy%

'This section substitutes the colors to RGB.
FOR z% = 1 TO TotalColors%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z%)
        OUT &H3C9, Pal.G(z%)
        OUT &H3C9, Pal.B(z%)
NEXT z%



END SUB

SUB CloudPal

'*******     THIS IS A CUSTOM PALETTE, CALLED WHEN 2 IS PRESSED     *********

'You can make your own palettes, but make sure to you call them with the num's
'0-9 in the InputCommand sub.

'This section resets the RGB arrays.
FOR col% = 1 TO 2 * TotalColors%
        Pal.R(col%) = 0
        Pal.G(col%) = 0
        Pal.B(col%) = 63
NEXT col%

'Use this section to define the palette colors.
FOR col% = 1 TO 63
        Pal.R(col%) = 63
        Pal.G(col%) = 63
        Pal.R(col% + 63) = 63 - col%
        Pal.G(col% + 63) = 63 - col%
        Pal.R(col% + 130) = col%
        Pal.G(col% + 130) = col%
NEXT col%

'This section copies the palette to the second half of the color arrays.
FOR PalCopy% = 1 TO TotalColors%
        Pal.R(PalCopy% + TotalColors%) = Pal.R(PalCopy%)
        Pal.G(PalCopy% + TotalColors%) = Pal.G(PalCopy%)
        Pal.B(PalCopy% + TotalColors%) = Pal.B(PalCopy%)
NEXT PalCopy%

'This section substitutes the colors to the screen.
FOR z% = 1 TO TotalColors%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z%)
        OUT &H3C9, Pal.G(z%)
        OUT &H3C9, Pal.B(z%)
        NEXT z%
END SUB

SUB ContourMap

VIEW
WINDOW

'Change the status so that only color routines and redraw can be called.
status$ = "unfinished"

'Adjust the bump% value to a usable range
Adj! = TotalColors% * (Bump% / 15000)

'Inititate contour draw
FOR Y% = 0 TO ScreenY%
       
        FOR X% = 0 TO ScreenX%
                col% = POINT(X%, Y%)    'Get the current color.
                LINE (X%, Y%)-(X%, Y% - col% * Adj!), col%      'Draw line.
        NEXT X%
       
        LivePalRot spd%         'Rotate the palette.
       
        Cmnd$ = INKEY$          'Check for input
        IF Cmnd$ <> "" THEN     'once/per X loop.
        InputCommand Cmnd$      '        |
        END IF                  '       \|/

NEXT Y%
       status$ = "finished"    'Reset the status so contour sub's are useable
END SUB

SUB DrawFractal

'This section resets all values
status$ = "unfinished"
spd% = 1                'Palette speed.
grn% = 1                'Dissolve effect.
CurrentI% = 0           'Current rotation value.
'Res% = StartRes%        'User defined grid resolution.

'*******        The following is the main function of the AFractal program.
'*******        If you're looking for speed up's, you probably won't find
'*******        one in my extremely fast (for QBasic) code ;) !

IF LCASE$(LEFT$(ReportTime$, 1)) = "y" THEN StartTime# = TIMER

SCREEN 13

VIEW (0, 0)-(ScreenX% - 1, ScreenY% - 1)

redraw:

CLS

WINDOW (-XSize# + XCenter#, YSize# + YCenter#)-(XSize# + XCenter#, -YSize# + YCenter#)

XRes# = XSize# / 159.5 * res% * (320 / ScreenX%)
YRes# = YSize# / 99.5 * res% * (200 / ScreenY%)

FOR X = -XSize# + XCenter# TO XSize# + XCenter# STEP XRes#
        FOR Y = -YSize# + YCenter# TO YSize# + YCenter# STEP YRes#
    
        z# = 0
        last.real.z# = X
        last.imag.z# = Y
        c% = POINT(X + XRes# * 2, Y) + POINT(X, Y + YRes# * 2) + POINT(X + XRes# * 2, Y + YRes# * 2) + POINT(X - XRes#, Y) + POINT(X, Y - YRes#) + POINT(X - XRes#, Y - YRes#) + POINT(X - XRes#, Y + YRes# * 2) + POINT(X + XRes# * 2, Y - YRes#)
        IF POINT(X, Y) * 8 <> c% THEN
                FOR iter% = 1 TO MaxIter%
                IF ABS(z#) > 90000000000# THEN
                LINE (X, Y)-(X + XRes#, Y + YRes#), lastiter% MOD TotalColors% + 1, BF
                EXIT FOR
                END IF
                real.z# = last.real.z# ^ 2 - last.imag.z# ^ 2 + X
                imag.z# = last.real.z# * last.imag.z# * 2 + Y
                last.real.z# = real.z#
                last.imag.z# = imag.z#
                z# = (real.z# + imag.z#) + X + Y
                IF z# < 2 THEN
                lastiter% = iter%
                ELSE
                LINE (X, Y)-(X + XRes#, Y + YRes#), lastiter% MOD TotalColors% + 1, BF
                EXIT FOR
                END IF
                NEXT iter%
                IF iter% <= MaxIter% THEN GOTO SkipBlock2
                LINE (X, Y)-(X + XRes#, Y + YRes#), 0, BF
SkipBlock2:
      
        END IF
        NEXT
NEXT

res% = res% / 2

WINDOW (-XSize# + XCenter#, YSize# + YCenter#)-(XSize# + XCenter#, -YSize# + YCenter#)

WHILE res% >= 1

XRes# = XSize# / 159.5 * res% * (320 / ScreenX%)
YRes# = YSize# / 99.5 * res% * (200 / ScreenY%)

FOR X = -XSize# + XCenter# TO XSize# + XCenter# STEP XRes#
        FOR Y = -YSize# + YCenter# TO YSize# + YCenter# STEP YRes#
    
        z# = 0
        last.real.z# = X
        last.imag.z# = Y
        c% = POINT(X + XRes# * 2, Y) + POINT(X, Y + YRes# * 2) + POINT(X + XRes# * 2, Y + YRes# * 2) + POINT(X - XRes#, Y) + POINT(X, Y - YRes#) + POINT(X - XRes#, Y - YRes#) + POINT(X - XRes#, Y + YRes# * 2) + POINT(X + XRes# * 2, Y - YRes#)
        IF POINT(X, Y) * 8 <> c% THEN
                FOR iter% = 1 TO MaxIter%
                IF ABS(z#) > 90000000000# THEN
                LINE (X, Y)-(X + XRes#, Y + YRes#), lastiter% MOD TotalColors% + 1, BF
                EXIT FOR
                END IF
                real.z# = last.real.z# ^ 2 - last.imag.z# ^ 2 + X
                imag.z# = last.real.z# * last.imag.z# * 2 + Y
                last.real.z# = real.z#
                last.imag.z# = imag.z#
                z# = (real.z# + imag.z#) + X + Y
                IF z# < 2 THEN
                lastiter% = iter%
                ELSE
                LINE (X, Y)-(X + XRes#, Y + YRes#), lastiter% MOD TotalColors% + 1, BF
                EXIT FOR
                END IF
                NEXT iter%
                IF iter% <= MaxIter% THEN GOTO SkipBlock
                LINE (X, Y)-(X + XRes#, Y + YRes#), 0, BF
SkipBlock:
     
        'LivePalRot spd%

        Cmnd$ = INKEY$
        IF Cmnd$ <> "" THEN
       
        InputCommand Cmnd$
      
        IF status$ = "redraw" THEN status$ = "unfinished": GOTO redraw

        END IF
      
        END IF
        NEXT
NEXT

res% = res% / 2

WEND

COLOR 120

IF LCASE$(LEFT$(ReportTime$, 1)) = "y" THEN LOCATE 1: PRINT TIMER - StartTime#

'Fractal status = finished
status$ = "finished"

END SUB

SUB fade (Start%, Finish%, spd)

stp = spd / 100

IF Start% > Finish% THEN stp = stp * -1

FOR Intens = Start% / 100 TO Finish% / 100 STEP stp
FOR q% = 1 TO 255
        OUT &H3C8, q%
        OUT &H3C9, Pal.R(q%) * Intens
        OUT &H3C9, Pal.G(q%) * Intens
        OUT &H3C9, Pal.B(q%) * Intens
NEXT
NEXT

END SUB

SUB FirePal

'*******     THIS IS A CUSTOM PALETTE, CALLED WHEN 1 IS PRESSED     *********

'You can make your own palettes, but make sure to you call them with the num's
'0-9 in the InputCommand sub.

'Resets palette.
FOR a% = 1 TO 255
        Pal.R(a%) = 0
        Pal.G(a%) = 0
        Pal.B(a%) = 0
NEXT

'First half of palette arrays.
FOR a% = 0 TO TotalColors%
        IF a% < 64 THEN Pal.R(a% + 1) = a%
        IF a% >= 64 THEN Pal.R(a% + 1) = 63
        IF a% >= 64 THEN Pal.G(a% + 1) = (a% - 64) / 3
        IF a% >= 196 THEN Pal.B(a% + 1) = (a% - 196)
NEXT

'Copies first half to second half.
FOR a% = 1 TO TotalColors%
        Pal.R(TotalColors% + a%) = Pal.R(a%)
        Pal.G(TotalColors% + a%) = Pal.G(a%)
        Pal.B(TotalColors% + a%) = Pal.B(a%)
NEXT

'This section substitutes the colors on the screen.
FOR z% = 1 TO TotalColors%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z%)
        OUT &H3C9, Pal.G(z%)
        OUT &H3C9, Pal.B(z%)
        NEXT z%
END SUB

SUB InputCommand (Cmnd$)
SHARED ScreenX%
SHARED ScreenY%

        IF Cmnd$ = " " THEN
        CLS 0
        XSize# = 1               'X Size from center to each edge.
        YSize# = .9              'Y Size from center to each edge.
        XCenter# = -.5           'Center along the X axis.
        YCenter# = 0             'Center along the Y axis.
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF


        IF Cmnd$ = CHR$(0) + "R" AND XSize# > .00001 AND YSize# > .00001 THEN
        CLS 0
        XSize# = XSize# / 2
        YSize# = YSize# / 2
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF
       
        IF Cmnd$ = CHR$(0) + "S" THEN
        CLS 0
        XSize# = XSize# * 2
        YSize# = YSize# * 2
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF
                     

        IF Cmnd$ = CHR$(0) + "H" THEN
        CLS 0
        YCenter# = YCenter# + YSize#
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF
       
       
        IF Cmnd$ = CHR$(0) + "M" THEN
        CLS 0
        XCenter# = XCenter# + XSize#
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF
       

        IF Cmnd$ = CHR$(0) + "K" THEN
        CLS 0
        XCenter# = XCenter# - XSize#
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF

        IF Cmnd$ = CHR$(0) + "P" THEN
        CLS 0
        YCenter# = YCenter# - YSize#
        res% = startres%: status$ = "redraw"
        EXIT SUB
        END IF
       
        IF LCASE$(Cmnd$) = "p" THEN        'If the input = o...
        CALL SaveScreen("c:\fractal5")                            'call the options screen!
        END IF
                 

        IF LCASE$(Cmnd$) = "o" THEN        'If the input = o...
        Options                            'call the options screen!
        END IF
       
        'Increse speed...
        IF LCASE$(Cmnd$) = "+" AND spd% < TotalColors% THEN spd% = spd% + 1: grn% = ABS(grn%): GOTO EndInptCmnd
       
        'Decrease speed...
        IF LCASE$(Cmnd$) = "-" AND ABS(spd%) < TotalColors% THEN spd% = spd% - 1: grn% = ABS(grn%) * -1: GOTO EndInptCmnd
       
        'Stop palette rotation...
        IF Cmnd$ = CHR$(8) THEN spd% = 0: GOTO EndInptCmnd
       
        'Set to default speed...
        IF LCASE$(Cmnd$) = "=" THEN spd% = 1: GOTO EndInptCmnd
       
        'Set the dissolve effect on...
        IF LCASE$(Cmnd$) = "z" AND ABS(grn%) = 1 THEN grn% = 2: GOTO EndInptCmnd
       
        'Set the dissolve effect off...
        IF LCASE$(Cmnd$) = "z" AND ABS(grn%) = 2 THEN grn% = 1: GOTO EndInptCmnd
       
        'Call ContourMap if the DrawFractal SUB is finished...
        IF LCASE$(Cmnd$) = "c" AND status$ = "finished" THEN CALL ContourMap
       
        'Quit the program...
        IF LCASE$(Cmnd$) = "q" THEN END
       
        'Soften the current Fractal field...
        IF LCASE$(Cmnd$) = "x" AND status$ = "finished" THEN CALL soften(0, 0, ScreenX% - 1, ScreenY% - 1)

        'Custom Palette #1
        IF LCASE$(Cmnd$) = "1" THEN FirePal
       
        'Custom Palette #2
        IF LCASE$(Cmnd$) = "2" THEN CloudPal
       
        'Contoured 3D sphere (really cool)...
        IF LCASE$(Cmnd$) = "s" AND status$ = "finished" THEN SphereContour
                      
        'Invert the palette colors when "i" is pressed...
        IF LCASE$(Cmnd$) = "i" THEN
        InvertColors
        GOTO EndInptCmnd
        END IF
       
        'Alternate the palette when "a" is pressed...
        IF LCASE$(Cmnd$) = "a" THEN
        AltrntPal
        GOTO EndInptCmnd
        END IF
       
        'Build the default RGB palette when "d" is pressed...
        IF LCASE$(Cmnd$) = "d" THEN
        MakeRGBPal
        GOTO EndInptCmnd
        END IF
       
        'Adjust the red values...
        IF LCASE$(Cmnd$) = "r" THEN
                FOR col% = 1 TO TotalColors% * 2
                Pal.R(col%) = Pal.R(col%) + 1
        NEXT col%
        GOTO EndInptCmnd
        END IF
       
        'Adjust the green values...
        IF LCASE$(Cmnd$) = "g" THEN
                FOR col% = 1 TO TotalColors% * 2
                Pal.G(col%) = Pal.G(col%) + 1
        NEXT col%
        GOTO EndInptCmnd
        END IF
       
        'Adjust the blue values...
        IF LCASE$(Cmnd$) = "b" THEN
                FOR col% = 1 TO TotalColors% * 2
                Pal.B(col%) = Pal.B(col%) + 1
        NEXT col%
        END IF

EndInptCmnd:
        StartZ% = z%    'Reduces flicker.
        StartI% = i%    'Etc...
END SUB

SUB Instruct

'********     Program instructions.   ********

SCREEN 9

COLOR 2
PRINT "                               INSTRUCTIONS"
PRINT
COLOR 2
PRINT "                         +  key:";
COLOR 1
PRINT " Speed up color shifting."
COLOR 2
PRINT "                         -  key:";
COLOR 1
PRINT " Slow down color shifting."
COLOR 2
PRINT "                         =  key:";
COLOR 1
PRINT " Return to default speed."
COLOR 2
PRINT "                      Backspace:";
COLOR 1
PRINT " Freezes the color rotation."
COLOR 2
PRINT "                       0-9 keys:";
COLOR 1
PRINT " Custom palettes."
COLOR 2
PRINT "                         a  key:";
COLOR 1
PRINT " Alternate colors."
COLOR 2
PRINT "                         r  key:";
COLOR 1
PRINT " Shift all red values."
COLOR 2
PRINT "                         g  key:";
COLOR 1
PRINT " Shift all green values."
COLOR 2
PRINT "                         b  key:";
COLOR 1
PRINT " Shift all blue values."
COLOR 2
PRINT "                         d  key:";
COLOR 1
PRINT " Use default RGB palette."
COLOR 2
PRINT "                         z  key:";
COLOR 1
PRINT " Dissolve effect."
COLOR 2
PRINT "                         s  key:";
COLOR 1
PRINT " 3D Sphere of finished fractal."
COLOR 2
PRINT "                         c  key:";
COLOR 1
PRINT " Contour map."
COLOR 2
PRINT "                         x  key:";
COLOR 1
PRINT " Soften finished fractal."

COLOR 2
PRINT "                     arrow keys:";
COLOR 1
PRINT " Move around the fractal."

COLOR 2
PRINT "                       ins  key:";
COLOR 1
PRINT " Zoom in."
COLOR 2
PRINT "                       Del  key:";
COLOR 1
PRINT " Zoom out."

COLOR 2
PRINT "                      space bar:";
COLOR 1
PRINT " Return to default position."


COLOR 2
PRINT "                         q  key:";
COLOR 1
PRINT " Exit program."

LOCATE 23
PRINT "Press any key to continue."
SLEEP
END SUB

SUB InvertColors

'This section resets the RGB arrays.
FOR col% = 1 TO 2 * TotalColors%
        Pal.R(col%) = 63 - Pal.R(col%)
        Pal.G(col%) = 63 - Pal.G(col%)
        Pal.B(col%) = 63 - Pal.B(col%)
NEXT col%

'This section substitutes the colors to RGB.
FOR z% = 1 TO TotalColors%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z%)
        OUT &H3C9, Pal.G(z%)
        OUT &H3C9, Pal.B(z%)
NEXT z%


END SUB

SUB LivePalRot (spd%)
SHARED CurrentI%        'Share the CurrentI% with all sub's.

'If the CurrentI% is beyond range, then set to opposite end.
IF CurrentI% > TotalColors% AND spd% > 0 THEN CurrentI% = 0
IF CurrentI% < 0 AND spd% < 0 THEN CurrentI% = TotalColors%

'If the speed is < 0, switch Start/End values...
IF spd% < 0 THEN
StartZ% = TotalColors%: EndZ% = 1: grn% = ABS(grn%) * -1
'Else set them to normal.
ELSE StartZ% = 1: EndZ% = TotalColors%: grn% = ABS(grn%)
END IF

'Change the screen colors.
FOR z% = StartZ% TO EndZ% STEP grn%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z% + CurrentI%)
        OUT &H3C9, Pal.G(z% + CurrentI%)
        OUT &H3C9, Pal.B(z% + CurrentI%)
NEXT z%
CurrentI% = CurrentI% + spd%    'Set the new offset.
END SUB

SUB LoadScreen (file$)

SCREEN 13

OPEN (file$ + ".app") FOR BINARY AS 1                      'Create file named file$.

byte% = 1

FOR X% = 1 TO 256                               'Get the whole palette.
        GET 1, byte%, col.r&: byte% = byte% + 1 'Get the red.
        GET 1, byte%, col.g&: byte% = byte% + 1 'Get the green.
        GET 1, byte%, col.b&: byte% = byte% + 1 'Get the blue.
   
        Pal.R%(X%) = col.r& \ 16777216
        Pal.G%(X%) = col.g& \ 16777216
        Pal.B%(X%) = col.b& \ 16777216

        'OUT 968, x%' + 1
        'OUT 969, col.r& \ 16777216      'Don't ask me why this works.
        'OUT 969, col.g& \ 16777216      'It took a% lot of trial + error
        'OUT 969, col.b& \ 16777216      'just to get this!
NEXT

CLOSE 1

DEF SEG = 40960
BLOAD file$ + ".apf"
DEF SEG

END SUB

SUB MakeRGBPal

'*******        This is the plain-old RGB palette.

'This section resets the RGB arrays.
FOR col% = 1 TO 2 * TotalColors%
        Pal.R(col%) = 0
        Pal.G(col%) = 0
        Pal.B(col%) = 0
NEXT col%

'Use this section to define the palette colors.
FOR col% = 1 TO 63
        Pal.R(col%) = 63 - col%
        Pal.R(col% + 130) = col%
        Pal.G(col%) = col%
        Pal.G(col% + 63) = 63 - col%
        Pal.B(col% + 63) = col%
        Pal.B(col% + 126) = 63 - col%
NEXT col%

'This section copies the palette to the second half of the color arrays.
FOR PalCopy% = 1 TO TotalColors%
        Pal.R(PalCopy% + TotalColors%) = Pal.R(PalCopy%)
        Pal.G(PalCopy% + TotalColors%) = Pal.G(PalCopy%)
        Pal.B(PalCopy% + TotalColors%) = Pal.B(PalCopy%)
NEXT PalCopy%

'This section substitutes the colors to RGB.
FOR z% = 1 TO TotalColors%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z%)
        OUT &H3C9, Pal.G(z%)
        OUT &H3C9, Pal.B(z%)
NEXT z%

END SUB

 SUB Options
CLS 0
SCREEN 13

WINDOW

'FOR q% = 0 TO 199
'LINE (0, q%)-(319, q%), q% MOD 193 + 1
'NEXT

DEF SEG = 40960
BLOAD "c:\fractal.apf", 0
DEF SEG

LOCATE 5, 6: PRINT "PREVIEW"

CALL DrawFractal

PaletteRot

END SUB

SUB PaletteRot
SHARED CurrentI%        'Declare the start/end values and offset as global.
SHARED StartI%          '       |
SHARED StartZ%          '      \|/
DO
restart:
IF spd% < 0 THEN
StartI% = CurrentI%
EndI% = 0
StartZ% = TotalColors%
EndZ% = 1
grn% = ABS(grn%) * -1
ELSE
StartI% = CurrentI%
EndI% = TotalColors%
StartZ% = 1
EndZ% = TotalColors%
grn% = ABS(grn%)
END IF
Cmnd$ = ""
FOR i% = StartI% TO EndI% STEP spd%
  FOR z% = StartZ% TO EndZ% STEP grn%
        OUT &H3C8, z%
        OUT &H3C9, Pal.R(z% + i%)
        OUT &H3C9, Pal.G(z% + i%)
        OUT &H3C9, Pal.B(z% + i%)
        Cmnd$ = INKEY$
        IF Cmnd$ <> "" THEN
        CurrentI% = i%
        InputCommand Cmnd$
        IF status$ = "redraw" THEN EXIT SUB
        GOTO restart
        END IF
  NEXT z%
  IF spd% < 0 THEN
  StartZ% = TotalColors%: EndZ% = 1: grn% = ABS(grn%) * -1
  ELSE StartZ% = 1: EndZ% = TotalColors%: grn% = ABS(grn%)
  END IF
WAIT 986, 8
NEXT i%
IF spd% < 0 THEN
StartI% = TotalColors%: EndI% = 1
ELSE StartI% = 1: EndI% = TotalColors%
END IF
IF spd% > 0 THEN CurrentI% = 0 ELSE CurrentI% = TotalColors%
LOOP
escape:
END SUB

SUB SaveScreen (file$)

OPEN file$ + ".app" FOR BINARY AS 1             'Open a new file named file$.

byte% = 1                               'Initialize first byte.

FOR X% = 0 TO 255                       'Read the whole palette
        OUT 967, X%                     'Call the read palette port.
        FOR q% = 1 TO 3                 'Loop for RGB respectively.
                col& = INP(&H3C9)       'Color = the current; R, G, ir B.
                PUT 1, byte%, col&      'Put the value in the file.
                byte% = byte% + 1       'Next byte.
        NEXT
NEXT

CLOSE 1                                 'Close the file.

DEF SEG = 40960
BSAVE file$ + ".apf", 0, 64000
DEF SEG

END SUB

SUB soften (XStart%, YStart%, XEnd%, YEnd%)
'This sub "softens" the fractal.

VIEW
WINDOW

FOR Y% = YStart% TO YEnd%
        FOR X% = XStart% TO XEnd%
       
        'Get the surrounding pixels and average.
        col% = (POINT(X%, Y%) + POINT(X% + 1, Y% + 1) + POINT(X%, Y% + 1) + POINT(X% + 1, Y%)) / 4
       
        'If past the right boundry, get from the left...
        IF Y% + 1 > YEnd% THEN col% = POINT(X%, YStart%)
       
        'If past the bottom boundry, get from the right...
        IF X% + 1 > XEnd% THEN col% = POINT(XStart%, Y%)
       
        'Set the pixel...
        PSET (X%, Y%), col%
       
        NEXT X%
LivePalRot spd%
NEXT Y%
END SUB

SUB SphereContour
CONST Pi = 3.1415927#
status$ = "unfinished"
IF Bump% >= 1 THEN
        Adj% = TotalColors% / (Bump% * 2)
        ELSE Adj% = 0
END IF

'VIEW (0, 0)-(319, 199)
WINDOW

DIM LeftFractal%(0 TO (ScreenX% / 2) * ScreenY%)
DIM RightFractal%(0 TO (ScreenX% / 2) * ScreenY%)

Offset% = (ScreenX% / 2)

FOR X% = 0 TO Offset% - 1
        FOR Y% = ScreenY% - 1 TO 0 STEP -1
                LeftFractal%(q%) = POINT(X%, Y%)
                RightFractal%(q%) = POINT((ScreenX% - 1) - X%, (ScreenY% - 2) - Y%)
                q% = q% + 1
        NEXT
NEXT

WINDOW (-160, 100)-(159, -99)
CLS 0

TimeStart# = TIMER

maxval% = (ScreenX% - 1) / 2 * (ScreenY% - 1)

FOR AngleX! = 0 TO Pi / 2 STEP Pi / ScreenX%
       
        IF maxval% - pnt% < ScreenY% - 1 THEN EXIT FOR

        FOR AngleY! = 0 TO Pi STEP Pi / ScreenY%
                ColL% = ABS(LeftFractal%(pnt%))
                ColR% = ABS(RightFractal%(pnt%))

                sineX = SIN(AngleY!)
                cosineX = COS(AngleY!)
                cosineY = COS(AngleX!)
             
                IF Adj% >= 1 THEN
                radius1% = SphereSize% + ColL% / Adj%
                radius2% = SphereSize% + ColR% / Adj%
                x1! = -1 * sineX * radius1% * cosineY
                y1! = -1 * cosineX * radius1% * .85
                x2! = sineX * radius2% * cosineY
                y2! = cosineX * radius2% * .85
                ELSE
                x1! = -1 * sineX * (SphereSize%) * cosineY
                y1! = -1 * cosineX * (SphereSize%) * .85
                x2! = sineX * (SphereSize%) * cosineY
                y2! = cosineX * (SphereSize%) * .85
                END IF
             
                IF ColL% > 0 THEN
                CIRCLE (x1!, y1!), 2, ColL%
                PAINT (x1!, y1!), ColL%
                'PSET (x1!, y1!), ColL%
                END IF
                           
                IF ColR% > 0 THEN
                CIRCLE (x2!, y2!), 2, ColR%
                PAINT (x2!, y2!), ColR%
                'pset (x2!, y2!), ColR%
                END IF

                pnt% = pnt% + 1
        NEXT AngleY!

'Rotate the palette.
LivePalRot spd%

Cmnd$ = INKEY$          'Look for user inputs
IF Cmnd$ <> "" THEN     'only once/per X loop.
InputCommand Cmnd$      '          |
END IF                  '         \|/

NEXT AngleX!

COLOR 200: PRINT TIMER - TimeStart#: SLEEP
ERASE LeftFractal%
PStat$ = "unfinshed"
END SUB