1: DEFINT A-Z ' Set default variable to integer for speed 2: 3: DECLARE SUB ChangeVariables (Direction%) 4: DECLARE SUB PrintErr (ErrNum) 5: DECLARE SUB Initialize () 6: DECLARE SUB Main () 7: DECLARE SUB Quit () 8: 9: CONST RaiseFactor = 1, LowerFactor = 2, UpPalette = 3, DownPalette = 4 10: CONST MaxPals = 25 11: 12: DIM SHARED Factor, PalFile AS STRING, NumPals 13: DIM SHARED Pal(255, MaxPals) AS LONG 14: 15: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ The program! ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 16: 17: Initialize 18: 'Frac 19: Main 20: Quit 21: 22: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ Various traps ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 23: 24: UpPal: ' Change up one palette 25: ChangeVariables UpPalette 26: RETURN 27: 28: DownPal: ' Change down one palette 29: ChangeVariables DownPalette 30: RETURN 31: 32: UpFactor: ' Raise the factor by one 33: ChangeVariables RaiseFactor 34: RETURN 35: 36: DownFactor: ' Lower the factor by one 37: ChangeVariables LowerFactor 38: RETURN 39: 40: ClearScreen: ' Clear the screen 41: LINE (0, 10)-(319, 199), 0, BF 42: RETURN 43: 44: ErrorTrap: ' Error trap 45: PrintErr ERR 46: RESUME NEXT 47: 48: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ Program Data ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 49: 50: PaletteFiles: 51: DATA 10 52: DATA "key2.pal", "balloon.pal", "levfont1.pal", "green.pal", "brown.pal" 53: DATA "purple.pal", "yellow.pal","plasma.pal","neon.pal", "chroma.pal" 54: 55: 'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ 56: 57: SUB ChangeVariables (Direction) STATIC 58: 59: ' Sub to change palettes and factor variables 60: ' Note: PalNum is intialized to zero by QBasic the first time this Sub is 61: ' executed. PalNum keeps its value until the next time the Sub is executed 62: ' because the Sub is declared as static. 63: 64: SELECT CASE Direction 65: CASE UpPalette 66: IF PalNum < (NumPals - 1) THEN ' Only change the palette 67: PalNum = PalNum + 1 ' if there is a another 68: PALETTE USING Pal(0, PalNum) ' palette, otherwise 69: ELSE ' make a sound. 70: SOUND 50, .5 71: END IF 72: CASE DownPalette ' Ditto 73: IF PalNum > 0 THEN 74: PalNum = PalNum - 1 75: PALETTE USING Pal(0, PalNum) 76: ELSE 77: SOUND 50, .5 78: END IF 79: CASE RaiseFactor ' Change the factor 80: IF Factor < 10 THEN ' if its within range, 81: Factor = Factor + 1 ' otherwise make a 82: ELSE ' sound. 83: SOUND 50, .5 84: END IF 85: CASE LowerFactor ' Ditto 86: IF Factor > 1 THEN 87: Factor = Factor - 1 88: ELSE 89: SOUND 50, .5 90: END IF 91: END SELECT 92: 93: END SUB 94: 95: SUB Frac 96: ' 97: 'THE MANDELBROT SET 98: ' 99: 'Chaos in low resolution 100: ' 101: ' after you start pick x from -2 to +2 (left and right) 102: ' CHAOS15: 103: ' pick y from -1 to +1 (up and down) 104: ' 105: ' pick m from 1 to 1000 (magnification) 106: ' 107: ' Will beep when picture is done press any key to stop beep 108: ' press Ctrl and Break to abort 109: ' 110: ' Try x=-1.5 y=0 m=3 to start then make 'm' larger to zoom in.) 111: ' 112: ' >>>------------------> PRESS SHIFT F5 to start <----------------<<< 113: ' 114: ' 115: ' 116: CLS : SCREEN 13: cl = 50: FOR p = 10 TO 1 STEP -1: PALETTE p, 70 - p * 7: PALETTE 16 - p, 70 - p * 7: NEXT p 117: PRINT "enter x from -2 to 2 =left and right", "enter y from -1 to 1 =up and down", "enter m from 1 to 1000 =magnification" 118: INPUT "x"; y: INPUT "y"; x: INPUT "m"; w: w = w - .6: IF w = 0 THEN w = .6 119: w = 1 / w: x = x - w / 2: x2 = x + w: y = y - w / 2: y2 = y + w 120: CLS : PRINT , , , , , , , , , , , , , , , , , , , , , , , , " higher magnifications", " take longer", , , , , , " Ctrl Break to abort", , , " press any key to stop beep" 121: FOR a = x TO x2 STEP w / 200 122: r = r + 1: c = 30 123: FOR B = y TO y2 STEP w / 250 124: c = c + 1: yr = B: xi = a 125: FOR z = 53 TO 80 STEP w 126: cl = cl - 1 127: zrt = zr: zit = zi 128: zr = zr * zr + zi * zi * -1 + yr 129: zi = zit * zrt + zit * zrt + xi: IF zi + zr > 12 OR zi + zr < -12 THEN 100 130: NEXT z: PSET (c, r), 17: GOTO 200 131: 100 PSET (c, r), cl 132: 200 cl = 50: zi = 0: zr = 0: NEXT B: NEXT a 133: 300 BEEP: IF INKEY$ = "" THEN 300 134: 400 GOTO 400 135: ' IF you want to a save your picture to disk you must 136: ' load a screen grabber like NEOGRAB before you run this program 137: 138: 139: ' press SHIFT F5 140: ' to run program again 141: 142: ' <EMAIL COMMENTS TO VILBERT> 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: END SUB 156: 157: SUB Initialize 158: 159: ON ERROR GOTO ErrorTrap ' Set errortrap 160: 161: RANDOMIZE TIMER ' Seed RND() with the timer value 162: 163: KEY 15, CHR$(160) + "K" ' Left arrow 164: KEY 16, CHR$(160) + "M" ' Right arrow 165: KEY 17, CHR$(160) + "H" ' Up arrow 166: KEY 18, CHR$(160) + "P" ' Down arrow 167: KEY 19, CHR$(160) + "S" ' Delete key 168: 169: ON KEY(15) GOSUB DownPal ' Set event trapping for the 170: ON KEY(16) GOSUB UpPal ' keys 171: ON KEY(17) GOSUB UpFactor 172: ON KEY(18) GOSUB DownFactor 173: ON KEY(19) GOSUB ClearScreen 174: 175: KEY(15) ON ' Turn on the keys 176: KEY(16) ON 177: KEY(17) ON 178: KEY(18) ON 179: KEY(19) ON 180: 181: SCREEN 13 ' Set the screen to 320x200x256 VGA 182: 183: 184: 185: RESTORE PaletteFiles ' Load each palette into the Pal() array 186: DIM Byte AS STRING * 1 187: 188: PalNumber = 0 189: READ NumPals 190: DO 191: READ PalFile ' Read a filename from the data 192: OPEN PalFile FOR BINARY AS #1 ' Open the file 193: SELECT CASE LOF(1) ' Determine what to so based on the length of file 194: CASE 768 ' If the file is 768 bytes, its probably the right file 195: 196: FOR Index = 0 TO 255 ' Load each RGB value ( write me for tech info ) 197: GET #1, , Byte: Red = ASC(Byte) 198: GET #1, , Byte: Green = ASC(Byte) 199: GET #1, , Byte: Blue = ASC(Byte) 200: Pal(Index, PalNumber) = Red + Green * &H100 + Blue * &H10000 201: LOCATE 1, 1: PRINT Red + Green * &H100 + Blue * &H10000 202: NEXT 203: Pal(255, PalNumber) = &H3F3F3F ' Set color 255 to white for text & stuff 204: CLOSE #1 205: PalNumber = PalNumber + 1 206: CASE 0 ' File has no length, didn't exist 207: CLOSE #1 208: KILL PalFile 209: ERROR 53 210: CASE ELSE ' File wasn't the right length 211: CLOSE #1 212: ERROR 100 213: END SELECT 214: LOOP UNTIL PalNumber = NumPals 215: 216: PALETTE USING Pal(0, 0) ' Change the palette to the first one 217: 218: CLS 219: 220: FOR Clr = 0 TO 255 ' Draw the palette bar 221: LINE (Clr, 0)-(Clr, 9), Clr 222: NEXT 223: 224: LINE (260, 0)-(319, 9), 1, BF ' Draw the current color Box 225: LINE (260, 0)-(319, 9), 255, B 226: 227: END SUB 228: 229: SUB Main 230: 231: x = 159: y = 99: Clr = 0: Factor = 3 ' Initialize variables 232: 233: DO 234: 235: LINE (Clr, 0)-(Clr, 9), 255 ' Draw a white line at the current color 236: PSET (x, y), Clr ' Draw a pixel 237: PAINT (261, 1), Clr, 255 ' Fill current color box 238: 239: SELECT CASE INT(RND * 4) + 1 ' Pick a random direction to move 240: CASE 1: IF x > 1 THEN x = x - 1 241: CASE 2: IF y < 198 THEN y = y + 1 242: CASE 3: IF y > 11 THEN y = y - 1 243: CASE 4: IF x < 318 THEN x = x + 1 244: END SELECT 245: 246: Factor = 2 247: Pixel = POINT(x, y) ' Get the color for the 248: PixelLeft = POINT(x - 1, y) * Factor ' pixel and the pixels 249: PixelUp = POINT(x, y - 1) * Factor ' around it 250: PixelRight = POINT(x + 1, y) * Factor 251: PixelDown = POINT(x, y + 1) * Factor 252: 253: LINE (Clr, 0)-(Clr, 9), Clr ' Erase the old line on the palette bar 254: 255: ' Figure the new color with my formula 256: Clr = (254 + Pixel + PixelLeft + PixelUp + PixelRight + PixelDown) \ (Factor * 4 + 2) 257: 258: LOOP UNTIL INKEY$ = CHR$(27) ' Loop this sucker till you press ESC 259: 260: END SUB 261: 262: SUB PrintErr (ErrNum) 263: 264: SELECT CASE ErrNum ' Print the error message 265: CASE 5 266: PRINT : PRINT "Sorry, I couldn't initialize VGA graphics on your computer." 267: SYSTEM 268: CASE 53 269: PRINT : PRINT 270: PRINT "Could not open "; PalFile 271: NumPals = NumPals - 1 272: CASE 100 273: PRINT : PRINT 274: PRINT PalFile; " is not a valid PAL file." 275: NumPals = NumPals - 1 276: CASE ELSE 277: PRINT : PRINT "Error number"; ErrNum; "occured" 278: SYSTEM 279: END SELECT 280: 281: END SUB 282: 283: SUB Quit 284: 285: SCREEN 0: WIDTH 80 ' Clean up the screen 286: PRINT "Ok, you can stop staring mindlessly at the screen now!" 287: SYSTEM 288: 289: END SUB 290: |