'еЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭИ
'Г   QPlasma 1.0  Copyright (C) Michael Teator, 1994. All rights reserved.   Г
'ЦЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЕ
'Г          жФФФФФП вФФП в    жФФП  жФП жФвФП жФФП   ФЗ    жФФП              Г
'Г          К     Г ЧФФй К    ЧФФД  гФП К К Г ЧФФД    К    К  Г              Г
'Г          К     Г а    аФФй а  С гФФй а а С а  С   ФаФ o гФФй              Г
'Г          К     Г                                                          Г
'Г          гФФФХФй     Press Shift F5 to start                              Г
'Г                                                                           Г
'Г    Control keys during program:                                           Г
'Г        Up, down arrows:    Changes the factor used in calculating the     Г
'Г                            pixels color.  The greater the factor, the     Г
'Г                            more subtle the colore change will be.         Г
'Г        Left, right arrows: Changes the palette.                           Г
'Г        Delete:             Clear the screen.                              Г
'Г        ESC:                Exit program.                                  Г
'Г                                                                           Г
'Г    Some notes:                                                            Г
'Г        Play with the color factor some.  Some of the palettes look great  Г
'Г        with a low factor while others look better with a high factor.     Г
'Г        Have fun!                                                          Г
'Г                                                                           Г
'Г    Please try my other QBasic graphics demos available on AOL:            Г
'Г        Bouncer: Interesting bouncing 256 color 3-D boxes                  Г
'Г        StarField: Nice hi-res 3-D starfield                               Г
'Г    There may be others, I'm always coming out with something new.         Г
'Г                                                                           Г
'Г    Coming Soon:                                                           Г
'Г        QStar: Delay vectors, starfields, and 3-D tunnels (real time!)     Г
'Г        QTris: 256 color tetris with photorealistic raytraced backgrounds. Г
'Г        QPadel: 3-D paddleball game                                        Г
'Г        QWindows 95: GUI operating system wil OLE 2.0, multimedia support, Г
'Г                     multitasking and multithreading.   ( joke )           Г
'Г                                                                           Г
'Г    As usual these and all my QBasic programs are free of charge.  Feel    Г
'Г    free to borrow ideas (not code) from my programs.  Please remember     Г
'Г    that programmers work hard on their code.  I would appreciate it VERY  Г
'Г    much if you would send me a postcard with a picture of your city or    Г
'Г    state on it.  I'll send you a disk with lots of stuff if you send me   Г
'Г    5 dollars (postage, disks, and mailers aren't free), and I'll keep     Г
'Г    your name around for when I release some of the shareware that I'm     Г
'Г    working on so you will get a discount.  I'm programming them in        Г
'Г    object-oriented C++ (great!)  Any details right now are TOP SECRET!    Г
'Г                                                                           Г
'Г    You can reach me at:                                                   Г
'Г        e-mail:    skream@aol.com                                          Г
'Г                                                                           Г
'Г        us-mail:   Michael Teator                                          Г
'Г                   4 Widgeon Court                                         Г
'Г                   Bloomingdale Ga, 31302                                  Г
'Г                   USA                                                     Г
'Г                                                                           Г
'Г    Legal Stuff:                                                           Г
'Г        In no way are any guaranties or warranties implied in this text    Г
'Г        and if by some mishap or otherwise your computer blows up don't    Г
'Г        come knocking on my door cause it wasn't my fault.                 Г
'Г                                                                           Г
'дЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭО

DEFINT A-Z                                       ' Set default variable to integer for speed

DECLARE SUB ChangeVariables (Direction%)
DECLARE SUB PrintErr (ErrNum)
DECLARE SUB Initialize ()
DECLARE SUB Main ()
DECLARE SUB Quit ()

CONST RaiseFactor = 1, LowerFactor = 2, UpPalette = 3, DownPalette = 4
CONST MaxPals = 25

DIM SHARED Factor, PalFile AS STRING, NumPals
DIM SHARED Pal(255, MaxPals) AS LONG

'ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ The program! ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ

Initialize
Main
Quit

'ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ Various traps ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ

UpPal:                                           ' Change up one palette
    ChangeVariables UpPalette
RETURN

DownPal:                                         ' Change down one palette
     ChangeVariables DownPalette
RETURN

UpFactor:                                        ' Raise the factor by one
    ChangeVariables RaiseFactor
RETURN

DownFactor:                                      ' Lower the factor by one
    ChangeVariables LowerFactor
RETURN

ClearScreen:                                     ' Clear the screen
    LINE (0, 10)-(319, 199), 0, BF
RETURN

ErrorTrap:                                       ' Error trap
    PrintErr ERR
RESUME NEXT

'ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ Program Data ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ

PaletteFiles:
DATA 10
DATA "purple2.pal", "red.pal", "blue.pal", "green.pal", "brown.pal"
DATA "purple.pal", "yellow.pal","plasma.pal","neon.pal", "chroma.pal"

'ЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭЭ

SUB ChangeVariables (Direction) STATIC

' Sub to change palettes and factor variables
' Note: PalNum is intialized to zero by QBasic the first time this Sub is
' executed.  PalNum keeps its value until the next time the Sub is executed
' because the Sub is declared as static.

    SELECT CASE Direction
        CASE UpPalette
            IF PalNum < (NumPals - 1) THEN       ' Only change the palette
                PalNum = PalNum + 1              ' if there is a another
                PALETTE USING Pal(0, PalNum)     ' palette, otherwise
            ELSE                                 ' make a sound.
                SOUND 50, .5
            END IF
        CASE DownPalette                         ' Ditto
            IF PalNum > 0 THEN
                PalNum = PalNum - 1
                PALETTE USING Pal(0, PalNum)
            ELSE
                SOUND 50, .5
            END IF
        CASE RaiseFactor                         ' Change the factor
            IF Factor < 10 THEN                  ' if its within range,
                Factor = Factor + 1              ' otherwise make a
            ELSE                                 ' sound.
                SOUND 50, .5
            END IF
        CASE LowerFactor                         ' Ditto
            IF Factor > 1 THEN
                Factor = Factor - 1
            ELSE
                SOUND 50, .5
            END IF
    END SELECT

END SUB

SUB Initialize

    ON ERROR GOTO ErrorTrap                      ' Set errortrap
   
    RANDOMIZE TIMER                              ' Seed RND() with the timer value
    
    KEY 15, CHR$(160) + "K"                      ' Left arrow
    KEY 16, CHR$(160) + "M"                      ' Right arrow
    KEY 17, CHR$(160) + "H"                      ' Up arrow
    KEY 18, CHR$(160) + "P"                      ' Down arrow
    KEY 19, CHR$(160) + "S"                      ' Delete key

    ON KEY(15) GOSUB DownPal                     ' Set event trapping for the
    ON KEY(16) GOSUB UpPal                       ' keys
    ON KEY(17) GOSUB UpFactor
    ON KEY(18) GOSUB DownFactor
    ON KEY(19) GOSUB ClearScreen

    KEY(15) ON                                   ' Turn on the keys
    KEY(16) ON
    KEY(17) ON
    KEY(18) ON
    KEY(19) ON

    SCREEN 13                                    ' Set the screen to 320x200x256 VGA

    
   
    RESTORE PaletteFiles                         ' Load each palette into the Pal() array
    DIM Byte AS STRING * 1

    PalNumber = 0
    READ NumPals
    DO
        READ PalFile                             ' Read a filename from the data
        OPEN PalFile FOR BINARY AS #1            ' Open the file
        SELECT CASE LOF(1)                       ' Determine what to so based on the length of file
            CASE 768                             ' If the file is 768 bytes, its probably the right file
             
                FOR Index = 0 TO 255             ' Load each RGB value ( write me for tech info )
                    GET #1, , Byte: Red = ASC(Byte)
                    GET #1, , Byte: Green = ASC(Byte)
                    GET #1, , Byte: Blue = ASC(Byte)
                    Pal(Index, PalNumber) = Red + Green * &H100 + Blue * &H10000
                NEXT
                Pal(255, PalNumber) = &H3F3F3F   ' Set color 255 to white for text & stuff
                CLOSE #1
                PalNumber = PalNumber + 1
            CASE 0                               ' File has no length, didn't exist
                CLOSE #1
                KILL PalFile
                ERROR 53
            CASE ELSE                            ' File wasn't the right length
                CLOSE #1
                ERROR 100
        END SELECT
    LOOP UNTIL PalNumber = NumPals
   
    PALETTE USING Pal(0, 0)                      ' Change the palette to the first one

    CLS

    FOR Clr = 0 TO 255                           ' Draw the palette bar
        LINE (Clr, 0)-(Clr, 9), Clr
    NEXT
   
    LINE (260, 0)-(319, 9), 1, BF                ' Draw the current color Box
    LINE (260, 0)-(319, 9), 255, B

END SUB

SUB Main

    x = 159: y = 99: Clr = 0: Factor = 3         ' Initialize variables
   
    DO
       
        LINE (Clr, 0)-(Clr, 9), 255              ' Draw a white line at the current color
        PSET (x, y), Clr                         ' Draw a pixel
        PAINT (261, 1), Clr, 255                 ' Fill current color box
       
        SELECT CASE INT(RND * 4) + 1             ' Pick a random direction to move
            CASE 1: IF x > 1 THEN x = x - 1
            CASE 2: IF y < 198 THEN y = y + 1
            CASE 3: IF y > 11 THEN y = y - 1
            CASE 4: IF x < 318 THEN x = x + 1
        END SELECT
       
        Factor = 2
        Pixel = POINT(x, y)                      ' Get the color for the
        PixelLeft = POINT(x - 1, y) * Factor     ' pixel and the pixels
        PixelUp = POINT(x, y - 1) * Factor       ' around it
        PixelRight = POINT(x + 1, y) * Factor
        PixelDown = POINT(x, y + 1) * Factor

        LINE (Clr, 0)-(Clr, 9), Clr              ' Erase the old line on the palette bar
      
        ' Figure the new color with my formula
        Clr = (254 + Pixel + PixelLeft + PixelUp + PixelRight + PixelDown) \ (Factor * 4 + 2)
   
    LOOP UNTIL INKEY$ = CHR$(27)                 ' Loop this sucker till you press ESC

END SUB

SUB PrintErr (ErrNum)

    SELECT CASE ErrNum                           ' Print the error message
        CASE 5
            PRINT : PRINT "Sorry, I couldn't initialize VGA graphics on your computer."
            SYSTEM
        CASE 53
            PRINT : PRINT
            PRINT "Could not open "; PalFile
            NumPals = NumPals - 1
        CASE 100
            PRINT : PRINT
            PRINT PalFile; " is not a valid PAL file."
            NumPals = NumPals - 1
        CASE ELSE
            PRINT : PRINT "Error number"; ErrNum; "occured"
            SYSTEM
    END SELECT

END SUB

SUB Quit

    SCREEN 0: WIDTH 80                           ' Clean up the screen
    PRINT "Ok, you can stop staring mindlessly at the screen now!"
    SYSTEM

END SUB