1: 'ÕÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͸ 2: '³ QPlasma 1.0 Copyright (C) Michael Teator, 1994. All rights reserved. ³ 3: 'ÆÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͵ 4: '³ ÖÄÄÄÄÄ¿ ÒÄÄ¿ Ò ÖÄÄ¿ ÖÄ¿ ÖÄÒÄ¿ ÖÄÄ¿ Ä· ÖÄÄ¿ ³ 5: '³ º ³ ÇÄÄÙ º ÇÄÄ´ ÓÄ¿ º º ³ ÇÄÄ´ º º ³ ³ 6: '³ º ³ Ð ÐÄÄÙ Ð Á ÓÄÄÙ Ð Ð Á Ð Á ÄÐÄ o ÓÄÄÙ ³ 7: '³ º ³ ³ 8: '³ ÓÄÄÄÅÄÙ Press Shift F5 to start ³ 9: '³ ³ 10: '³ Control keys during program: ³ 11: '³ Up, down arrows: Changes the factor used in calculating the ³ 12: '³ pixels color. The greater the factor, the ³ 13: '³ more subtle the colore change will be. ³ 14: '³ Left, right arrows: Changes the palette. ³ 15: '³ Delete: Clear the screen. ³ 16: '³ ESC: Exit program. ³ 17: '³ ³ 18: '³ Some notes: ³ 19: '³ Play with the color factor some. Some of the palettes look great ³ 20: '³ with a low factor while others look better with a high factor. ³ 21: '³ Have fun! ³ 22: '³ ³ 23: '³ Please try my other QBasic graphics demos available on AOL: ³ 24: '³ Bouncer: Interesting bouncing 256 color 3-D boxes ³ 25: '³ StarField: Nice hi-res 3-D starfield ³ 26: '³ There may be others, I'm always coming out with something new. ³ 27: '³ ³ 28: '³ Coming Soon: ³ 29: '³ QStar: Delay vectors, starfields, and 3-D tunnels (real time!) ³ 30: '³ QTris: 256 color tetris with photorealistic raytraced backgrounds. ³ 31: '³ QPadel: 3-D paddleball game ³ 32: '³ QWindows 95: GUI operating system wil OLE 2.0, multimedia support, ³ 33: '³ multitasking and multithreading. ( joke ) ³ 34: '³ ³ 35: '³ As usual these and all my QBasic programs are free of charge. Feel ³ 36: '³ free to borrow ideas (not code) from my programs. Please remember ³ 37: '³ that programmers work hard on their code. I would appreciate it VERY ³ 38: '³ much if you would send me a postcard with a picture of your city or ³ 39: '³ state on it. I'll send you a disk with lots of stuff if you send me ³ 40: '³ 5 dollars (postage, disks, and mailers aren't free), and I'll keep ³ 41: '³ your name around for when I release some of the shareware that I'm ³ 42: '³ working on so you will get a discount. I'm programming them in ³ 43: '³ object-oriented C++ (great!) Any details right now are TOP SECRET! ³ 44: '³ ³ 45: '³ You can reach me at: ³ 46: '³ e-mail: skream@aol.com ³ 47: '³ ³ 48: '³ us-mail: Michael Teator ³ 49: '³ 4 Widgeon Court ³ 50: '³ Bloomingdale Ga, 31302 ³ 51: '³ USA ³ 52: '³ ³ 53: '³ Legal Stuff: ³ 54: '³ In no way are any guaranties or warranties implied in this text ³ 55: '³ and if by some mishap or otherwise your computer blows up don't ³ 56: '³ come knocking on my door cause it wasn't my fault. ³ 57: '³ ³ 58: 'ÔÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ; 59: 60: DEFINT A-Z ' Set default variable to integer for speed 61: 62: DECLARE SUB ChangeVariables (Direction%) 63: DECLARE SUB PrintErr (ErrNum) 64: DECLARE SUB Initialize () 65: DECLARE SUB Main () 66: DECLARE SUB Quit () 67: 68: CONST RaiseFactor = 1, LowerFactor = 2, UpPalette = 3, DownPalette = 4 69: CONST MaxPals = 25 70: 71: DIM SHARED Factor, PalFile AS STRING, NumPals 72: DIM SHARED Pal(255, MaxPals) AS LONG 73: 74: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ The program! ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 75: 76: Initialize 77: Main 78: Quit 79: 80: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ Various traps ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 81: 82: UpPal: ' Change up one palette 83: ChangeVariables UpPalette 84: RETURN 85: 86: DownPal: ' Change down one palette 87: ChangeVariables DownPalette 88: RETURN 89: 90: UpFactor: ' Raise the factor by one 91: ChangeVariables RaiseFactor 92: RETURN 93: 94: DownFactor: ' Lower the factor by one 95: ChangeVariables LowerFactor 96: RETURN 97: 98: ClearScreen: ' Clear the screen 99: LINE (0, 10)-(319, 199), 0, BF 100: RETURN 101: 102: ErrorTrap: ' Error trap 103: PrintErr ERR 104: RESUME NEXT 105: 106: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ Program Data ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 107: 108: PaletteFiles: 109: DATA 10 110: DATA "purple2.pal", "red.pal", "blue.pal", "green.pal", "brown.pal" 111: DATA "purple.pal", "yellow.pal","plasma.pal","neon.pal", "chroma.pal" 112: 113: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 114: 115: SUB ChangeVariables (Direction) STATIC 116: 117: ' Sub to change palettes and factor variables 118: ' Note: PalNum is intialized to zero by QBasic the first time this Sub is 119: ' executed. PalNum keeps its value until the next time the Sub is executed 120: ' because the Sub is declared as static. 121: 122: SELECT CASE Direction 123: CASE UpPalette 124: IF PalNum < (NumPals - 1) THEN ' Only change the palette 125: PalNum = PalNum + 1 ' if there is a another 126: PALETTE USING Pal(0, PalNum) ' palette, otherwise 127: ELSE ' make a sound. 128: SOUND 50, .5 129: END IF 130: CASE DownPalette ' Ditto 131: IF PalNum > 0 THEN 132: PalNum = PalNum - 1 133: PALETTE USING Pal(0, PalNum) 134: ELSE 135: SOUND 50, .5 136: END IF 137: CASE RaiseFactor ' Change the factor 138: IF Factor < 10 THEN ' if its within range, 139: Factor = Factor + 1 ' otherwise make a 140: ELSE ' sound. 141: SOUND 50, .5 142: END IF 143: CASE LowerFactor ' Ditto 144: IF Factor > 1 THEN 145: Factor = Factor - 1 146: ELSE 147: SOUND 50, .5 148: END IF 149: END SELECT 150: 151: END SUB 152: 153: SUB Initialize 154: 155: ON ERROR GOTO ErrorTrap ' Set errortrap 156: 157: RANDOMIZE TIMER ' Seed RND() with the timer value 158: 159: KEY 15, CHR$(160) + "K" ' Left arrow 160: KEY 16, CHR$(160) + "M" ' Right arrow 161: KEY 17, CHR$(160) + "H" ' Up arrow 162: KEY 18, CHR$(160) + "P" ' Down arrow 163: KEY 19, CHR$(160) + "S" ' Delete key 164: 165: ON KEY(15) GOSUB DownPal ' Set event trapping for the 166: ON KEY(16) GOSUB UpPal ' keys 167: ON KEY(17) GOSUB UpFactor 168: ON KEY(18) GOSUB DownFactor 169: ON KEY(19) GOSUB ClearScreen 170: 171: KEY(15) ON ' Turn on the keys 172: KEY(16) ON 173: KEY(17) ON 174: KEY(18) ON 175: KEY(19) ON 176: 177: SCREEN 13 ' Set the screen to 320x200x256 VGA 178: 179: 180: 181: RESTORE PaletteFiles ' Load each palette into the Pal() array 182: DIM Byte AS STRING * 1 183: 184: PalNumber = 0 185: READ NumPals 186: DO 187: READ PalFile ' Read a filename from the data 188: OPEN PalFile FOR BINARY AS #1 ' Open the file 189: SELECT CASE LOF(1) ' Determine what to so based on the length of file 190: CASE 768 ' If the file is 768 bytes, its probably the right file 191: 192: FOR Index = 0 TO 255 ' Load each RGB value ( write me for tech info ) 193: GET #1, , Byte: Red = ASC(Byte) 194: GET #1, , Byte: Green = ASC(Byte) 195: GET #1, , Byte: Blue = ASC(Byte) 196: Pal(Index, PalNumber) = Red + Green * &H100 + Blue * &H10000 197: NEXT 198: Pal(255, PalNumber) = &H3F3F3F ' Set color 255 to white for text & stuff 199: CLOSE #1 200: PalNumber = PalNumber + 1 201: CASE 0 ' File has no length, didn't exist 202: CLOSE #1 203: KILL PalFile 204: ERROR 53 205: CASE ELSE ' File wasn't the right length 206: CLOSE #1 207: ERROR 100 208: END SELECT 209: LOOP UNTIL PalNumber = NumPals 210: 211: PALETTE USING Pal(0, 0) ' Change the palette to the first one 212: 213: CLS 214: 215: FOR Clr = 0 TO 255 ' Draw the palette bar 216: LINE (Clr, 0)-(Clr, 9), Clr 217: NEXT 218: 219: LINE (260, 0)-(319, 9), 1, BF ' Draw the current color Box 220: LINE (260, 0)-(319, 9), 255, B 221: 222: END SUB 223: 224: SUB Main 225: 226: x = 159: y = 99: Clr = 0: Factor = 3 ' Initialize variables 227: 228: DO 229: 230: LINE (Clr, 0)-(Clr, 9), 255 ' Draw a white line at the current color 231: PSET (x, y), Clr ' Draw a pixel 232: PAINT (261, 1), Clr, 255 ' Fill current color box 233: 234: SELECT CASE INT(RND * 4) + 1 ' Pick a random direction to move 235: CASE 1: IF x > 1 THEN x = x - 1 236: CASE 2: IF y < 198 THEN y = y + 1 237: CASE 3: IF y > 11 THEN y = y - 1 238: CASE 4: IF x < 318 THEN x = x + 1 239: END SELECT 240: 241: Factor = 2 242: Pixel = POINT(x, y) ' Get the color for the 243: PixelLeft = POINT(x - 1, y) * Factor ' pixel and the pixels 244: PixelUp = POINT(x, y - 1) * Factor ' around it 245: PixelRight = POINT(x + 1, y) * Factor 246: PixelDown = POINT(x, y + 1) * Factor 247: 248: LINE (Clr, 0)-(Clr, 9), Clr ' Erase the old line on the palette bar 249: 250: ' Figure the new color with my formula 251: Clr = (254 + Pixel + PixelLeft + PixelUp + PixelRight + PixelDown) \ (Factor * 4 + 2) 252: 253: LOOP UNTIL INKEY$ = CHR$(27) ' Loop this sucker till you press ESC 254: 255: END SUB 256: 257: SUB PrintErr (ErrNum) 258: 259: SELECT CASE ErrNum ' Print the error message 260: CASE 5 261: PRINT : PRINT "Sorry, I couldn't initialize VGA graphics on your computer." 262: SYSTEM 263: CASE 53 264: PRINT : PRINT 265: PRINT "Could not open "; PalFile 266: NumPals = NumPals - 1 267: CASE 100 268: PRINT : PRINT 269: PRINT PalFile; " is not a valid PAL file." 270: NumPals = NumPals - 1 271: CASE ELSE 272: PRINT : PRINT "Error number"; ErrNum; "occured" 273: SYSTEM 274: END SELECT 275: 276: END SUB 277: 278: SUB Quit 279: 280: SCREEN 0: WIDTH 80 ' Clean up the screen 281: PRINT "Ok, you can stop staring mindlessly at the screen now!" 282: SYSTEM 283: 284: END SUB 285: |