Power-Programmierung/CD1.mdf/basic/library/qb_pds/qbpacket/fractals.bas

BASIC Source File | 1991-10-30 | 21.0 KB | 542 lines

REM QBASIC FRACTAL EXPLORER (FRACTALS.BAS)

'Subprogram declarations, generated automatically by QBasic
DECLARE SUB DrawTriFract ()
DECLARE SUB ShowFile ()
DECLARE SUB ShowStats ()
DECLARE SUB SaveCGA (FileName$)
DECLARE SUB SaveEGA (FileName$)
DECLARE SUB ShowCGA (FileName$)
DECLARE SUB ShowEGA (FileName$)
DECLARE SUB AnimateCGA ()
DECLARE SUB AnimateEGA ()
DECLARE SUB DrawFractal ()
DECLARE SUB SetupCGA ()
DECLARE SUB SetupEGA ()
DECLARE SUB SetupMDA ()
DECLARE SUB WaitKey ()
DECLARE SUB SetImage ()
DECLARE SUB SetSave ()
DECLARE SUB SetFractal ()
DECLARE SUB DoFractal ()
DECLARE SUB SetScreen ()
DECLARE SUB ShowMenu ()
DECLARE SUB TextScreen ()

'Constants to make loop tests more readable
CONST True = -1
CONST False = 0

ON ERROR GOTO HandleError:                             'Set up error trapping

TYPE ScreenType                         'Data type to hold screen information
     Number AS INTEGER         'Number of screen to use with SCREEN statement
     MaxColumns AS INTEGER                    'Maximum columns (X coordinate)
     MaxRows AS INTEGER                          'Maximum rows (Y coordinate)
     MaxColors AS INTEGER                                     'Maximum colors
     Description AS STRING * 30                        'Description of screen
     Extension AS STRING * 3         'Filename extension for this screen type
END TYPE

MaxScreens% = 3                        'Number of different screens supported
DIM Screens(1 TO MaxScreens%) AS ScreenType         'Holds ScreenType records

'Read in the information for each screen supported
FOR S = 1 TO MaxScreens%
     READ Screens(S).Number
     READ Screens(S).MaxColumns
     READ Screens(S).MaxRows
     READ Screens(S).MaxColors
     READ Screens(S).Description
     READ Screens(S).Extension
NEXT S
DATA 1,320,200,4, "CGA 320 x 200  4 colors","CGA"
DATA 2,640,200,2, "MDA 640 x 200  2 colors","MDA"
DATA 9,640,350,16,"EGA 640 x 350 16 colors","EGA"

'Default initialization
FractalType% = 1                                    'For Escape Time Fractals
Mode% = 1                             'Screen mode; defaults to SCREEN 1, CGA
Save% = False                          'Whether to save to disk after drawing
SetupCGA                                       'Set up default CGA parameters

DoMenu:                                            'Label for ON ERROR resume
ShowMenu                                       'This is the main program loop
END

'Error trapping routine
HandleError:
     ErrNum = ERR                         'Get error number from ERR function
     SELECT CASE ErrNum                            'Print appropriate message
          CASE IS = 53
               PRINT "File not found.  Make sure you've typed"
               PRINT "the name correctly."
               WaitKey                 'Let user read message and press a key
               RESUME NEXT                      'Loop back in calling routine
          CASE IS = 64
               PRINT "Bad file name.  Filenames may not have"
               PRINT "more than 8 characters and a 3-character"
               PRINT "extension."
               WaitKey
               RESUME NEXT
          CASE IS = 71
               PRINT "Disk error.  Make sure you have put a disk"
               PRINT "in the drive and closed the drive door, if"
               PRINT "necessary."
               WaitKey
               RESUME NEXT                      'Loop back in calling routine
          CASE ELSE                            'Some other error has occurred
               PRINT "Error number"; ErrNum; "has occurred"
               WaitKey
               RESUME DoMenu:   'Possibly serious error; so loop back to main
                                                                        'menu
     END SELECT
END

SUB AnimateCGA
     WHILE INKEY$ = ""                          'Run until user presses a key
          COLOR , 0                                'Switch CGA palette colors
          FOR P = 1 TO 1000                                      'Pause a bit
          NEXT P
          COLOR , 1                             'Switch back to first palette
          FOR P = 1 TO 1000                                      'Pause again
          NEXT P
     WEND
END SUB

SUB AnimateEGA                             'Animation (color cycling) for EGA
     SHARED MaxColumns%, MaxRows%

     DIM Palettearray%(15)      'Set up the initial colors of the EGA palette
     FOR Temp% = 0 TO 15
          Palettearray%(Temp%) = Temp%'This will "flash" the screen colors of
     NEXT                           'the fractal until the user presses a key
     WHILE INKEY$ = ""
          FOR Temp% = 0 TO 15    'Switch the EGA palette to successive colors
               Palettearray%(Temp%) = Palettearray%(Temp%) + 1
               IF Palettearray%(Temp%) > 63 THEN
                    Palettearray%(Temp%) = Palettearray%(Temp%) - 64
               END IF
          NEXT
          PALETTE USING Palettearray%(0)     'Rotate the colors on the screen
     WEND
END SUB

SUB DoFractal
     SHARED Mode%, Save%, Time
     CLS
     SCREEN Mode%                         'Make sure we have the right screen
     T1 = TIMER                                            'Set up for timing
     IF Save% THEN
          PRINT "Enter filename to save"
          INPUT "(no extension)"; FileName$
     END IF
     CLS
     DrawFractal                                  'Generate the fractal image
     T2 = TIMER                                               'Stop the timer
     Time = T2 - T1                                   'Calculate elapsed time
     SELECT CASE Mode%'Choose correct animation routine for screen mode being
                                                                        'used
          CASE IS = 1, IS = 2         'Add more CASEs if you add screen modes
               AnimateCGA
          CASE IS = 9
               AnimateEGA
          CASE ELSE
               PRINT "Unsupported video mode in subprogram DoFractal"
     END SELECT

     IF Save% THEN                    'Did user turn on save to disk feature?
          SELECT CASE Mode%      'If so, choose correct disk save routine for
               CASE IS = 1, IS = 2                    'screen mode being used
                    SaveCGA (FileName$)     'Add more CASEs if you add screen
                                                                       'modes
               CASE IS = 9
                    SaveEGA (FileName$)
               CASE ELSE
                    LOCATE 22, 1
                    PRINT "ERROR: Mode not defined for saving!"
          END SELECT
     END IF
END SUB

SUB DrawFractal    'For Escape Time fractals substitute different formulas as
                                                                     'desired
     SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%, FractalType%
     FOR X1% = 1 TO MaxColumns%                              'For each column
          FOR Y1% = 1 TO MaxColumns%                            'For each row
               X = X1% / MaxColumns%            'Calculate initial comparison
               Y = Y1% / MaxRows%                         'For column and row
               Count% = 0                                'Start at count of 0
               WHILE X * X + Y * Y <= Limit%'Until formulas pass cutoff point
                    '--------------------------------------------------------
                    '"Target" formulas for fractals.  Instead of the
                    'following two lines, you can use other formulas.  Put a
                    'REM or ' mark in front of other lines.
                    '--------------------------------------------------------
                    SELECT CASE FractalType%
                         CASE IS = 1
                              X = 2 * X                    '-----------------
                              Y = 2 * Y                    '"Target" formulas
                         CASE IS = 2                       '-----------------
                              IF Y <= .5 THEN
                                   IF X <= .5 THEN
                                        X = 2 * X
                                        Y = 2 * Y
                                   ELSE X = 2 * X - 1
                                        Y = 2 * Y
                                   END IF
                              ELSE
                                   X = 2 * X
                                   Y = 2 * Y - 1
                              END IF
                         CASE ELSE
                              PRINT "Error in subprogram DrawFractal"
                              WaitKey
                              EXIT SUB
                    END SELECT
                    Count% = Count% + 1       'Keep track of number of passes
               WEND                'When cutoff point reached, draw the point
               PSET (X1%, Y1%), Count% \ ColorDivisor%
               'SOUND 100 * Count%, 1                 'Optional sound effects
                                                   'Use the appropriate color
          NEXT                                               'Do the next row
     NEXT                                                 'Do the next column
END SUB

SUB SaveCGA (FileName$)
     DEF SEG = &HB800                             'Switch to CGA video memory
     BSAVE FileName$, 0, 16383                                'Save CGA image
     DEF SEG                                  'Switch back to default segment
END SUB

SUB SaveEGA (FileName$)
'============================================================================
'Save EGA fractal image to disk--thanks to Ethan Winer of Crescent Software
'for this routine
'============================================================================
     DEF SEG = &HA000                             'Switch to EGA video memory
     SIZE% = 28000                           'Each plane is 28,000 bytes long

     'Save blue plane
     OUT &H3CE, 4
     OUT &H3CF, 0
     BSAVE FileName$ + ".BLU", 0, SIZE%
     'Save green plane
     OUT &H3CE, 4
     OUT &H3CF, 1
     BSAVE FileName$ + ".GRN", 0, SIZE%
     'Save red plane
     OUT &H3CE, 4
     OUT &H3CF, 2
     BSAVE FileName$ + ".RED", 0, SIZE%
     'Save intensity plane
     OUT &H3CE, 4
     OUT &H3CF, 3
     BSAVE FileName$ + ".INT", 0, SIZE%
     OUT &H3CE, 4: OUT &H3CF, 0
     DEF SEG                                  'Switch back to default segment
END SUB

SUB SetFractal
     SHARED FractalType%
     CLS
     PRINT "Set the type of fractal."
     PRINT
     PRINT "1. Escape Time Fractal"
     PRINT "2. Triangular Fractal"
     ValidFractal% = False
     WHILE NOT ValidFractal%
          PRINT "Enter selection or press Escape to exit"
          F$ = INPUT$(1)
          IF F$ = CHR$(27) THEN EXIT SUB
          FractalType% = VAL(F$)
          IF FractalType% < 1 OR FractalType% > 2 THEN
               PRINT "Error in subprogram SetFractal: Invalid fractal type"
          ELSE
               ValidFractal% = True
          END IF
     WEND
END SUB

SUB SetImage
     SHARED MaxScreens%, Screens() AS ScreenType
     SHARED Mode%, MaxColumns%, MaxRows%
     FOR S = 1 TO MaxScreens%
          IF Screens(S).Number = Mode% THEN        'Find out maximum rows and
               ScrCols% = Screens(S).MaxColumns   'columns for current screen
               ScrRows% = Screens(S).MaxRows                            'mode
               Found = True
               EXIT FOR
          END IF
     NEXT S
     IF NOT Found THEN
          PRINT "ERROR: Invalid screen in SetImage program!"
          EXIT SUB
     END IF

     CLS
     PRINT "Set size of screen image."
     PRINT "Number of columns (1 -"; ScrCols%; ")"
     INPUT ImageCols%
     IF ImageCols% < 1 OR ImageCols% > ScrCols% THEN     'Make sure number of
          PRINT "Invalid number of columns"   'columns doesn't exceed maximum
          WaitKey                                                 'for screen
          EXIT SUB
     END IF
     PRINT "Number of rows (1 -"; ScrRows%; ")"
     INPUT ImageRows%
     IF ImageRows% < 1 OR ImageRows% > ScrRows% THEN  'Check rows in same way
          PRINT "Invalid number of rows"
          WaitKey
          EXIT SUB
     END IF
     MaxColumns% = ImageCols%
     MaxRows% = ImageRows%         'Set global variables for drawing routines
END SUB

SUB SetSave                    'Turn on saving and get filename for next save
     SHARED Save%           'Global variable will be used by drawing routimes
     CLS
     PRINT "Save is ";                           'Display current Save status
     IF Save% THEN
          PRINT "ON"
     ELSE
          PRINT "OFF"
     END IF
     PRINT
     PRINT "Press any key to toggle Save Status"
     PRINT "or Escape to leave: ";
     PRINT
     Status$ = INPUT$(1)
     IF Status$ = CHR$(27) THEN                           'Escape was pressed
          EXIT SUB
     ELSE
          Save% = NOT Save%'Toggle Save status to opposite state and show the
          IF Save% THEN                                               'result
               PRINT "Save is ON"
          ELSE
               PRINT "Save is OFF"
          END IF
          WaitKey
     END IF
END SUB

SUB SetScreen
     SHARED Screens() AS ScreenType, MaxScreens%, Mode%
     'Set screen mode
     CLS
     FOR S = 1 TO MaxScreens%       'List menu of available screens using the
          PRINT Screens(S).Number;                             'Screens array
          PRINT Screens(S).Description
     NEXT S
     PRINT "Type the number of the screen you want"
     PRINT "or Escape to exit"
     Scr$ = INPUT$(1)
     IF Scr$ = CHR$(27) THEN EXIT SUB
     Scr% = VAL(Scr$)
     Found = False                          'Did user specify a valid screen?
     FOR S = 1 TO MaxScreens%
          IF Screens(S).Number = Scr% THEN
               Found = True
               EXIT FOR
          END IF
     NEXT S
     IF Found THEN
          Mode% = Scr%
          SELECT CASE Mode%    'Choose proper initialization routine for this
               CASE IS = 1                                            'screen
                    SetupCGA
               CASE IS = 2
                    SetupMDA
               CASE IS = 9
                    SetupEGA
               CASE ELSE
                    PRINT "No code to set mode"; Mode%;
                    PRINT "in subprogram SetScreen."
          END SELECT
          PRINT "Screen set to"; Mode%
          WaitKey
          EXIT SUB
     ELSE                                     'Specified screen was not found
          PRINT "Sorry! Screen number"; Scr%;
          PRINT "is not supported."
          WaitKey
          EXIT SUB
     END IF
END SUB

SUB SetupCGA
     SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
     Limit% = 1500                                   'How far to test formula
     ColorDivisor% = 4                           'Scale colors to CGA palette
     MaxColumns% = 320      'Maximum values; SetImage routine can lower these
     MaxRows% = 200                                                   'values
     SCREEN 1                                      'CGA (320 x 200, 4 colors)
END SUB

SUB SetupEGA
     SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
     Limit% = 200                                               'Cutoff point
     ColorDivisor% = 1                            'Don't need to scale colors
     MaxColumns% = 640      'Maximum values; SetImage routine can lower these
     MaxRows% = 350                                                   'values
     SCREEN 9                              'Hi-res EGA (640 x 350, 16 colors)
END SUB

SUB SetupMDA
     SHARED MaxColumns%, MaxRows%, Limit%, ColorDivisor%
     Limit% = 3000
     ColorDivisor% = 8
     MaxColumns% = 640
     MaxRows% = 200
     SCREEN 2
END SUB

SUB ShowCGA (FileName$)
     SCREEN 1                                    'CGA 320 x 200, 4 color mode
     CLS
     DEF SEG = &HB800                             'Set to start of CGA memory
     BLOAD FileName$    'Load file directly into screen memory to show image;
     AnimateCGA                                     'then add special effects
     DEF SEG                                         'Restore default segment
END SUB

SUB ShowEGA (FileName$)
     'Strip off the .EGA extension, since real files have four-color plane
     'extensions
     DotPos% = INSTR(FileName$, ".")
     Name$ = LEFT$(FileName$, DotPos% - 1)
     SCREEN 9                                    'EGA 640 x 350 16 color mode
     CLS
     DEF SEG = &HA000                             'Set to start of EGA memory

     'Manipulate EGA registers to load four planes from files
     OUT &H3C4, 2
     OUT &H3C5, 1
     BLOAD Name$ + ".BLU", 0
     OUT &H3C4, 2
     OUT &H3C5, 2
     BLOAD Name$ + ".GRN", 0
     OUT &H3C4, 2
     OUT &H3C5, 4
     BLOAD Name$ + ".RED", 0
     OUT &H3C4, 2
     OUT &H3C5, 8
     BLOAD Name$ + ".INT", 0
     OUT &H3C4, 2
     OUT &H3C5, 15
     AnimateEGA                                  'Now add EGA special effects
     DEF SEG                                         'Restore default segment
END SUB

SUB ShowFile
     SHARED MaxScreens%, Screens() AS ScreenType, Mode%

     'Show a fractal image from disk
     'Calls specific routines for each screen type

     TextScreen                                          'Restore text screen
     PRINT "Enter name of file to show, including extension"
     INPUT FileName$
     Ext$ = UCASE$(RIGHT$(FileName$, 3))
     Found = False
     FOR S = 1 TO MaxScreens%                     'Is this a valid extension?
          IF Screens(S).Extension = Ext$ THEN
               Found = True                           'Extension is supported
          END IF
     NEXT S
     IF Found = False THEN                              'Extension is invalid
          PRINT "Extension "; Ext$; " not supported"
          EXIT SUB
     ELSE
          SELECT CASE Ext$                  'Call appropriate loading routine
               CASE IS = "CGA", IS = "MDA"     'Fill in other CASEs as needed
                    ShowCGA (FileName$)
               CASE IS = "EGA"
                    ShowEGA (FileName$)
               CASE ELSE
                    PRINT "Invalid extension "; Ext$
          END SELECT
     END IF
END SUB

SUB ShowMenu
     CONST MaxChoices% = 8                 'Change if you add more menu items
     DIM Choices$(10)
     Choices$(1) = "1) Set Screen Type"
     Choices$(2) = "2) Set Image Size"
     Choices$(3) = "3) Set Save Status"
     Choices$(4) = "4) Generate Fractal Image"
     Choices$(5) = "5) Show Fractal from Disk"
     Choices$(6) = "6) Statistics on Last Image Generated"
     Choices$(7) = "7) Set Fractal Type"
     Choices$(8) = "8) Exit Fractal Explorer"

     WHILE True
          TextScreen       'Start each time with normal 80 column text screen
          PRINT "QBasic Fractal Explorer"
          PRINT
          FOR Choice = 1 TO MaxChoices%
               PRINT Choices$(Choice)
          NEXT Choice

          ValidChoice% = False
          WHILE NOT ValidChoice%             'Loop until valid choice entered
               PRINT "Press number between 1 and"; MaxChoices%
               PRINT "or press"; MaxChoices%; "to end program"
               Choice$ = INPUT$(1)
               Choice% = VAL(Choice$)
               IF Choice% = MaxChoices% THEN END
               IF Choice% < 1 OR Choice% > MaxChoices% THEN
                    BEEP
               ELSE ValidChoice% = True
               END IF
          WEND
          SELECT CASE Choice% 'Add more CASEs if you add features to the menu
               CASE IS = 1
                    SetScreen
               CASE IS = 2
                    SetImage
               CASE IS = 3
                    SetSave
               CASE IS = 4
                    DoFractal
               CASE IS = 5
                    ShowFile
               CASE IS = 6
                    ShowStats
               CASE IS = 7
                    SetFractal
               CASE ELSE         'Doesn't hurt to prepare for the unexpected!
                    PRINT "Error in menu setup"
                    PRINT "Choice was: "; Choice%
                    EXIT SUB
          END SELECT
     WEND
END SUB

SUB ShowStats
     SHARED Time                       'Value calculated in DoFractal routine
     CLS
     IF Time = 0 THEN
          PRINT "No previous image generated this session."
          WaitKey
          EXIT SUB
     END IF
     PRINT "Last image took"; Time; "seconds."
     WaitKey
END SUB

SUB TextScreen
     SCREEN 0                                         'Set normal text screen
     WIDTH 80, 25               'Set width to 80 columns and clear the screen
     CLS
END SUB

SUB WaitKey
     PRINT "Press any key to continue"
     WHILE INKEY$ = ""                                'Loop until key pressed
     WEND
END SUB