'=========================================================================== ' Subject: YET ANOTHER STAR FIELD Date: 02-04-96 (02:00) ' Author: Churl Beck Code: QB, QBasic, PDS ' Origin: FidoNet QUIK_BAS Echo Packet: GRAPHICS.ABC '=========================================================================== 'YASF.BAS: "Yet Another Star Field" 'Written on 02-04-96 by Churl Beck 'Based on assembly source originally by Draeden (with thanks to Mark ' Butler for posting it) 'Notes: ' 1.) Use the "+" and "-" keys to accelerate and decelerate. ' 2.) Certain speeds tend to cause an overflow error while in the QB ' environment. So either compile or don't test your luck w/the keys. ' 3.) There are no built-in delays at this time. Make sure to adjust ' the code to suit your computer's speed. ' 4.) For those of you with masochistic personalities, I left in the ' code for PALETTE USING. Just REM the OUTs and unREM the rest. DEFINT A-Z DECLARE SUB MakeStar () DECLARE SUB DisplayStars () CONST ScreenWidth = 320 'Screen width CONST ScreenHeight = 200 'Screen height CONST MinZpos = 2, MaxZpos = 4096 'Screen depth CONST NumColors = 5 '# of Base colors CONST NumRnds = 400 '# of random numbers defined CONST MaxStars = 190 'Maximum # of stars CONST MaxWarp = 90 'Maximum speed of stars TYPE Star X AS INTEGER Y AS INTEGER Z AS INTEGER OldX AS INTEGER 'Where to erase last dot OldY AS INTEGER Colr AS INTEGER 'BASE color. END TYPE DIM SHARED Star(1 TO MaxStars) AS Star 'Where all the data is held DIM SHARED WarpSpeed, NumActive, CIndex 'Make these public WarpSpeed = 20 'Speed of stars 'CIndex = 0 'Index into ColorChart 'NumActive = 0 '# of active stars '------------------------------------------------------------------------ SCREEN 13 'Set video mode 320x200x256 'DIM Pal&(0 TO 255) 'For PALETTE USING only DIM Table(0 TO 17) Table(0) = 2: Table(3) = 2: Table(6) = 3 Table(1) = 3: Table(4) = 2: Table(7) = 3 Table(2) = 4: Table(5) = 4: Table(8) = 4 Table(9) = 3: Table(12) = 3: Table(15) = 2 Table(10) = 2: Table(13) = 3: Table(16) = 4 Table(11) = 4: Table(14) = 3: Table(17) = 3 OUT &H3C8, 1 'Begin at color #1 FOR M = 0 TO 15 STEP 3 FOR i = 15 TO 0 STEP -1 OUT &H3C9, (Table(M) * i + 7) 'Red OUT &H3C9, (Table(M + 1) * i + 7) 'Green OUT &H3C9, (Table(M + 2) * i + 7) 'Blue 'Colr = Colr + 1 'Next color 'Pal&(Colr) = 65536 * (Table(M + 2) * i + 3) 'Blue 'Pal&(Colr) = Pal&(Colr) + 256 * (Table(M + 1) * i + 3) 'Green 'Pal&(Colr) = Pal&(Colr) + (Table(M) * i + 3) 'Red NEXT NEXT 'FOR Colr = Colr TO 255 ' Pal&(Colr) = -1 '-1 = don't change this color 'NEXT 'PALETTE USING Pal& DO DO CALL MakeStar '2 calls = twice the stars CALL MakeStar CALL DisplayStars Ky$ = INKEY$ LOOP UNTIL LEN(Ky$) SELECT CASE ASC(Ky$) CASE 43 'ASC("+") IF WarpSpeed < MaxWarp THEN WarpSpeed = WarpSpeed + 1 CASE 45 'ASC("-") IF WarpSpeed > 0 THEN WarpSpeed = WarpSpeed - 1 CASE ELSE EXIT DO END SELECT LOOP SCREEN 0, 0, 0 SUB DisplayStars STATIC 'Draws all of the stars FOR Num = 1 TO MaxStars IF Star(Num).Z <> 0 THEN 'Is this star alive? 'Erase the star from its previous coordinates PSET (Star(Num).OldX, Star(Num).OldY), 0 IF Star(Num).Z < MinZpos THEN Star(Num).Z = 0 'Kill this star NumActive = NumActive - 1 ELSE 'Multiply by 256 and center it on the screen Y = (Star(Num).Y * 256&) \ Star(Num).Z + (ScreenHeight \ 2) IF Y >= ScreenHeight THEN Star(Num).Z = 1 'Star will get erased the GOTO Continue ' next time through END IF Star(Num).OldY = Y 'Save coordinate 'Multiply by 256 and center it on the screen X = (Star(Num).X * 256&) \ Star(Num).Z + (ScreenWidth \ 2) IF X >= ScreenWidth THEN Star(Num).Z = 1 'Star will get erased the GOTO Continue ' next time through END IF Star(Num).OldX = X 'Save coordinate 'Calculate the color Colr = Star(Num).Colr + (Star(Num).Z \ 256) PSET (X, Y), Colr 'Move the stars inward at WarpSpeed Star(Num).Z = Star(Num).Z - WarpSpeed END IF END IF Continue: NEXT END SUB SUB MakeStar STATIC 'Finds an available slot for a star & puts it there IF NumActive < MaxStars THEN 'Search for 1st available slot FOR Num = 1 TO MaxStars IF Star(Num).Z = 0 THEN 'Is this slot empty? 'Random starting coordinates Star(Num).Y = ((RND * NumRnds) - (NumRnds \ 2)) * 8 Star(Num).X = ((RND * NumRnds) - (NumRnds \ 2)) * 8 Star(Num).Z = MaxZpos 'Reset Zpos to the max NumActive = NumActive + 1 'Increase the counter 'Increase the color counter CIndex = (CIndex MOD NumColors) + 1 Star(Num).Colr = 16 * CIndex 'Select a color END IF NEXT END IF END SUB