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 12 52: DATA "key2.pal", "balloon.pal", "levfont1.pal", "green.pal", "brown.pal" 53: DATA "purple.pal", "yellow.pal","plasma.pal","neon.pal", "chroma.pal","Red.pal" 54: DATA "PAL1.PAL" 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: PALETTE 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: f$ = MID$(PalFile, 1, LEN(PalFile) - 4) + ".pa2" 196: OPEN f$ FOR OUTPUT AS #2 197: FOR Index = 0 TO 255 ' Load each RGB value ( write me for tech info ) 198: GET #1, , Byte: Red = ASC(Byte) 199: GET #1, , Byte: Green = ASC(Byte) 200: GET #1, , Byte: Blue = ASC(Byte) 201: pal(Index, PalNumber) = Red + Green * &H100 + Blue * &H10000 202: LOCATE 1, 1: PRINT #2, Red + Green * &H100 + Blue * &H10000: PRINT #2, Red + Green * &H100 + Blue * &H10000 203: NEXT 204: CLOSE 2 205: pal(255, PalNumber) = &H3F3F3F ' Set color 255 to white for text & stuff 206: CLOSE #1 207: PalNumber = PalNumber + 1 208: CASE 0 ' File has no length, didn't exist 209: CLOSE #1 210: KILL PalFile 211: ERROR 53 212: CASE ELSE ' File wasn't the right length 213: CLOSE #1 214: ERROR 100 215: END SELECT 216: LOOP UNTIL PalNumber = NumPals 217: 218: PALETTE USING pal(0, 0) ' Change the palette to the first one 219: 220: CLS 221: 222: FOR Clr = 0 TO 255 ' Draw the palette bar 223: LINE (Clr, 0)-(Clr, 9), Clr 224: NEXT 225: 226: LINE (260, 0)-(319, 9), 1, BF ' Draw the current color Box 227: LINE (260, 0)-(319, 9), 255, B 228: 229: END SUB 230: 231: SUB Main 232: 233: x = 159: y = 99: Clr = 0: Factor = 3 ' Initialize variables 234: 235: DO 236: 237: LINE (Clr, 0)-(Clr, 9), 255 ' Draw a white line at the current color 238: PSET (x, y), Clr ' Draw a pixel 239: PAINT (261, 1), Clr, 255 ' Fill current color box 240: 241: SELECT CASE INT(RND * 4) + 1 ' Pick a random direction to move 242: CASE 1: IF x > 1 THEN x = x - 1 243: CASE 2: IF y < 198 THEN y = y + 1 244: CASE 3: IF y > 11 THEN y = y - 1 245: CASE 4: IF x < 318 THEN x = x + 1 246: END SELECT 247: 248: Factor = 2 249: Pixel = POINT(x, y) ' Get the color for the 250: PixelLeft = POINT(x - 1, y) * Factor ' pixel and the pixels 251: PixelUp = POINT(x, y - 1) * Factor ' around it 252: PixelRight = POINT(x + 1, y) * Factor 253: PixelDown = POINT(x, y + 1) * Factor 254: 255: LINE (Clr, 0)-(Clr, 9), Clr ' Erase the old line on the palette bar 256: 257: ' Figure the new color with my formula 258: Clr = (254 + Pixel + PixelLeft + PixelUp + PixelRight + PixelDown) \ (Factor * 4 + 2) 259: 260: LOOP UNTIL INKEY$ = CHR$(27) ' Loop this sucker till you press ESC 261: 262: END SUB 263: 264: SUB PrintErr (ErrNum) 265: 266: SELECT CASE ErrNum ' Print the error message 267: CASE 5 268: PRINT : PRINT "Sorry, I couldn't initialize VGA graphics on your computer." 269: SYSTEM 270: CASE 53 271: PRINT : PRINT 272: PRINT "Could not open "; PalFile 273: NumPals = NumPals - 1 274: CASE 100 275: PRINT : PRINT 276: PRINT PalFile; " is not a valid PAL file." 277: NumPals = NumPals - 1 278: CASE ELSE 279: PRINT : PRINT "Error number"; ErrNum; "occured" 280: SYSTEM 281: END SELECT 282: 283: END SUB 284: 285: SUB Quit 286: 287: SCREEN 0: WIDTH 80 ' Clean up the screen 288: PRINT "Ok, you can stop staring mindlessly at the screen now!" 289: SYSTEM 290: 291: END SUB 292: |