1: ' ====================================================================== 2: ' TORUS 3: ' This program draws a Torus figure. The program accepts user input 4: ' to specify various TORUS parameters. It checks the current system 5: ' configuration and takes appropriate action to set the best possible 6: ' initial mode. 7: ' ====================================================================== 8: 9: DEFINT A-Z 10: DECLARE SUB GetConfig () 11: DECLARE SUB SetPalette () 12: DECLARE SUB TorusDefine () 13: DECLARE SUB TorusCalc (T() AS ANY) 14: DECLARE SUB TorusColor (T() AS ANY) 15: DECLARE SUB TorusSort (Low, High) 16: DECLARE SUB TorusDraw (T() AS ANY, Index()) 17: DECLARE SUB TileDraw (T AS ANY) 18: DECLARE SUB TorusRotate (First) 19: DECLARE SUB Delay (Seconds!) 20: DECLARE SUB CountTiles (T1, T2) 21: DECLARE SUB Message (Text$) 22: DECLARE SUB SetConfig (mode) 23: DECLARE FUNCTION Inside (T AS ANY) 24: DECLARE FUNCTION DegToRad! (Degrees) 25: DECLARE FUNCTION Rotated (Lower, Upper, Current, Inc) 26: 27: ' General purpose constants 28: CONST PI = 3.14159 29: CONST TRUE = -1, FALSE = 0 30: CONST BACK = 0 31: CONST TROW = 24, TCOL = 60 32: 33: ' Rotation flags 34: CONST RNDM = -1 35: CONST START = 0 36: CONST CONTINUE = 1 37: 38: ' Constants for best available screen mode 39: CONST VGA = 12 40: CONST MCGA = 13 41: CONST EGA256 = 9 42: CONST EGA64 = 8 43: CONST MONO = 10 44: CONST HERC = 3 45: CONST CGA = 1 46: 47: ' User-defined type for tiles - an array of these make a torus 48: TYPE Tile 49: x1 AS SINGLE 50: x2 AS SINGLE 51: x3 AS SINGLE 52: x4 AS SINGLE 53: y1 AS SINGLE 54: y2 AS SINGLE 55: y3 AS SINGLE 56: y4 AS SINGLE 57: z1 AS SINGLE 58: xc AS SINGLE 59: yc AS SINGLE 60: TColor AS INTEGER 61: END TYPE 62: 63: ' User-defined type to hold information about the mode 64: TYPE Config 65: Scrn AS INTEGER 66: Colors AS INTEGER 67: Atribs AS INTEGER 68: XPix AS INTEGER 69: YPix AS INTEGER 70: TCOL AS INTEGER 71: TROW AS INTEGER 72: END TYPE 73: 74: DIM VC AS Config 75: 76: ' User-defined type to hold information about current Torus 77: TYPE TORUS 78: Panel AS INTEGER 79: Sect AS INTEGER 80: Thick AS SINGLE 81: XDegree AS INTEGER 82: YDegree AS INTEGER 83: Bord AS STRING * 3 84: Delay AS SINGLE 85: END TYPE 86: 87: DIM TOR AS TORUS, Max AS INTEGER 88: 89: ' A palette of colors to paint with 90: DIM Pal(0 TO 300) AS LONG 91: 92: ' Error variables to check screen type 93: DIM InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING 94: 95: ' The code of the module-level program begins here 96: 97: ' Initialize defaults 98: TOR.Thick = 3: TOR.Bord = "YES" 99: TOR.Panel = 8: TOR.Sect = 14 100: TOR.XDegree = 60: TOR.YDegree = 165 101: 102: ' Get best configuration and set initial graphics mode to it 103: GetConfig 104: VC.Scrn = BestMode 105: 106: DO WHILE TRUE ' Loop forever (exit is from within a SUB) 107: 108: ' Get Torus definition from user 109: TorusDefine 110: 111: ' Dynamically dimension arrays 112: DO 113: Tmp = TOR.Panel 114: Max = TOR.Panel * TOR.Sect 115: 116: ' Array for indexes 117: REDIM Index(0 TO Max - 1) AS INTEGER 118: ' Turn on error trap for insufficient memory 119: ON ERROR GOTO MemErr 120: ' Array for tiles 121: REDIM T(0 TO Max - 1) AS Tile 122: ON ERROR GOTO 0 123: LOOP UNTIL Tmp = TOR.Panel 124: 125: ' Initialize array of indexes 126: FOR Til = 0 TO Max - 1 127: Index(Til) = Til 128: NEXT 129: 130: ' Calculate the points of each tile on the torus 131: Message "Calculating" 132: TorusCalc T() 133: 134: ' Color each tile in the torus. 135: TorusColor T() 136: 137: ' Sort the tiles by their "distance" from the screen 138: Message "Sorting" 139: TorusSort 0, Max - 1 140: 141: ' Set the screen mode 142: SCREEN VC.Scrn 143: 144: ' Mix a palette of colors 145: SetPalette 146: 147: ' Set logical window with variable thickness 148: ' Center is 0, up and right are positive, down and left are negative 149: WINDOW (-(TOR.Thick + 1), -(TOR.Thick + 1))-(TOR.Thick + 1, TOR.Thick + 1) 150: 151: ' Draw and paint the tiles, the farthest first and nearest last 152: TorusDraw T(), Index() 153: 154: ' Rotate the torus by rotating the color palette 155: DO WHILE INKEY$ = "" 156: Delay (TOR.Delay) 157: TorusRotate CONTINUE 158: LOOP 159: SCREEN 0 160: WIDTH 80 161: LOOP 162: 163: ' Restore original rows 164: WIDTH 80, InitRows 165: 166: END 167: 168: ' Error trap to make torus screen independent 169: VideoErr: 170: SELECT CASE BestMode ' Fall through until something works 171: CASE VGA 172: BestMode = MCGA 173: Available = "12BD" 174: CASE MCGA 175: BestMode = EGA256 176: Available = "12789" 177: CASE EGA256 178: BestMode = CGA 179: Available = "12" 180: CASE CGA 181: BestMode = MONO 182: Available = "A" 183: CASE MONO 184: BestMode = HERC 185: Available = "3" 186: CASE ELSE 187: PRINT "Sorry. Graphics not available. Can't run Torus." 188: END 189: END SELECT 190: RESUME 191: 192: ' Trap to detect 64K EGA 193: EGAErr: 194: BestMode = EGA64 195: Available = "12789" 196: RESUME NEXT 197: 198: ' Trap to detect insufficient memory for large Torus 199: MemErr: 200: LOCATE 22, 1 201: PRINT "Out of memory" 202: PRINT "Reducing panels from"; TOR.Panel; "to"; TOR.Panel - 1 203: PRINT "Reducing sections from"; TOR.Sect; "to"; TOR.Sect - 1; 204: DO WHILE INKEY$ = "": LOOP 205: TOR.Panel = TOR.Panel - 1 206: TOR.Sect = TOR.Sect - 1 207: RESUME NEXT 208: 209: ' Trap to determine initial number of rows so they can be restored 210: RowErr: 211: IF InitRows = 50 THEN 212: InitRows = 43 213: RESUME 214: ELSE 215: InitRows = 25 216: RESUME NEXT 217: END IF 218: 219: ' ============================ CountTiles ============================== 220: ' Displays number of the tiles currently being calculated or sorted. 221: ' ====================================================================== 222: ' 223: SUB CountTiles (T1, T2) STATIC 224: 225: ' Erase previous 226: LOCATE TROW - 1, TCOL: PRINT SPACE$(19); 227: ' If positive, display - give negative values to erase 228: IF T1 > 0 AND T2 > 0 THEN 229: LOCATE TROW - 1, TCOL 230: PRINT "Tile "; 231: PRINT USING " ###"; T1; 232: PRINT USING " ###"; T2; 233: END IF 234: 235: END SUB 236: 237: ' ============================ DegToRad ================================ 238: ' Convert degrees to radians, since BASIC trigonometric functions 239: ' require radians. 240: ' ====================================================================== 241: ' 242: FUNCTION DegToRad! (Degrees) STATIC 243: 244: DegToRad! = (Degrees * 2 * PI) / 360 245: 246: END FUNCTION 247: 248: ' =============================== Delay ================================ 249: ' Delay based on time so that wait will be the same on any processor. 250: ' Notice the check for negative numbers so that the delay won't 251: ' freeze at midnight when the delay could become negative. 252: ' ====================================================================== 253: ' 254: SUB Delay (Seconds!) STATIC 255: 256: Begin! = TIMER 257: DO UNTIL (TIMER - Begin! > Seconds!) OR (TIMER - Begin! < 0) 258: LOOP 259: 260: END SUB 261: 262: ' ============================ GetConfig =============================== 263: ' Get the starting number of lines and the video adapter. 264: ' ====================================================================== 265: ' 266: SUB GetConfig STATIC 267: SHARED InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING 268: 269: ' Assume 50 line display and fall through error 270: ' until we get the actual number 271: InitRows = 50 272: ON ERROR GOTO RowErr 273: LOCATE InitRows, 1 274: 275: ' Assume best possible screen mode 276: BestMode = VGA 277: Available = "12789BCD" 278: 279: ON ERROR GOTO VideoErr 280: ' Fall through error trap until a mode works 281: SCREEN BestMode 282: ' If EGA, then check pages to see whether more than 64K 283: ON ERROR GOTO EGAErr 284: IF BestMode = EGA256 THEN SCREEN 8, , 1 285: 286: ON ERROR GOTO 0 287: 288: ' Reset text mode 289: SCREEN 0, , 0 290: WIDTH 80, 25 291: 292: END SUB 293: 294: ' ============================== Inside ================================ 295: ' Finds a point, T.xc and T.yc, that is mathematically within a tile. 296: ' Then check to see if the point is actually inside. Because of the 297: ' jagged edges of tiles, the center point is often actually inside 298: ' very thin tiles. Such tiles will not be painted, This causes 299: ' imperfections that are often visible at the edge of the Torus. 300: ' 301: ' Return FALSE if a center point is not found inside a tile. 302: ' ====================================================================== 303: ' 304: FUNCTION Inside (T AS Tile) STATIC 305: SHARED VC AS Config 306: DIM Highest AS SINGLE, Lowest AS SINGLE 307: 308: Border = VC.Atribs - 1 309: 310: ' Find an inside point. Since some tiles are triangles, the 311: ' diagonal center isn't good enough. Instead find the center 312: ' by drawing a diagonal from the center of the outside to 313: ' a bottom corner. 314: T.xc = T.x2 + ((T.x3 + (T.x4 - T.x3) / 2 - T.x2) / 2) 315: T.yc = T.y2 + ((T.y3 + (T.y4 - T.y3) / 2 - T.y2) / 2) 316: 317: ' If we're on a border, no need to fill 318: IF POINT(T.xc, T.yc) = Border THEN 319: Inside = FALSE 320: EXIT FUNCTION 321: END IF 322: 323: ' Find highest and lowest Y on the tile 324: Highest = T.y1 325: Lowest = T.y1 326: IF T.y2 > Highest THEN Highest = T.y2 327: IF T.y2 < Lowest THEN Lowest = T.y2 328: IF T.y3 > Highest THEN Highest = T.y3 329: IF T.y3 < Lowest THEN Lowest = T.y3 330: IF T.y4 > Highest THEN Highest = T.y4 331: IF T.y4 < Lowest THEN Lowest = T.y4 332: 333: ' Convert coordinates to pixels 334: X = PMAP(T.xc, 0) 335: YU = PMAP(T.yc, 1) 336: YD = YU 337: H = PMAP(Highest, 1) 338: L = PMAP(Lowest, 1) 339: 340: ' Search for top and bottom tile borders until we either find them 341: ' both, or check beyond the highest and lowest points. 342: 343: IsUp = FALSE 344: IsDown = FALSE 345: 346: DO 347: YU = YU - 1 348: YD = YD + 1 349: 350: ' Search up 351: IF NOT IsUp THEN 352: IF POINT(T.xc, PMAP(YU, 3)) = Border THEN IsUp = TRUE 353: END IF 354: 355: ' Search down 356: IF NOT IsDown THEN 357: IF POINT(T.xc, PMAP(YD, 3)) = Border THEN IsDown = TRUE 358: END IF 359: 360: ' If top and bottom are found, we're inside 361: IF IsUp AND IsDown THEN 362: Inside = TRUE 363: EXIT FUNCTION 364: END IF 365: 366: LOOP UNTIL (YD > L) AND (YU < H) 367: Inside = FALSE 368: 369: END FUNCTION 370: 371: ' ============================= Message ================================ 372: ' Displays a status message followed by blinking dots. 373: ' ====================================================================== 374: ' 375: SUB Message (Text$) STATIC 376: SHARED VC AS Config 377: 378: LOCATE TROW, TCOL: PRINT SPACE$(19); 379: LOCATE TROW, TCOL 380: COLOR 7 ' White 381: PRINT Text$; 382: COLOR 23 ' Blink 383: PRINT " . . ."; 384: COLOR 7 ' White 385: 386: END SUB 387: 388: ' ============================ Rotated ================================= 389: ' Returns the Current value adjusted by Inc and rotated if necessary 390: ' so that it falls within the range of Lower and Upper. 391: ' ====================================================================== 392: ' 393: FUNCTION Rotated (Lower, Upper, Current, Inc) 394: 395: ' Calculate the next value 396: Current = Current + Inc 397: 398: ' Handle special cases of rotating off top or bottom 399: IF Current > Upper THEN Current = Lower 400: IF Current < Lower THEN Current = Upper 401: Rotated = Current 402: 403: END FUNCTION 404: 405: ' ============================ SetConfig =============================== 406: ' Sets the correct values for each field of the VC variable. They 407: ' vary depending on Mode and on the current configuration. 408: ' ====================================================================== 409: ' 410: SUB SetConfig (mode AS INTEGER) STATIC 411: SHARED VC AS Config, BestMode AS INTEGER 412: 413: SELECT CASE mode 414: CASE 1 ' Four-color graphics for CGA, EGA, VGA, and MCGA 415: IF BestMode = CGA OR BestMode = MCGA THEN 416: VC.Colors = 0 417: ELSE 418: VC.Colors = 16 419: END IF 420: VC.Atribs = 4 421: VC.XPix = 319 422: VC.YPix = 199 423: VC.TCOL = 40 424: VC.TROW = 25 425: CASE 2 ' Two-color medium-res graphics for CGA, EGA, VGA, and MCGA 426: IF BestMode = CGA OR BestMode = MCGA THEN 427: VC.Colors = 0 428: ELSE 429: VC.Colors = 16 430: END IF 431: VC.Atribs = 2 432: VC.XPix = 639 433: VC.YPix = 199 434: VC.TCOL = 80 435: VC.TROW = 25 436: CASE 3 ' Two-color high-res graphics for Hercules 437: VC.Colors = 0 438: VC.Atribs = 2 439: VC.XPix = 720 440: VC.YPix = 348 441: VC.TCOL = 80 442: VC.TROW = 25 443: CASE 7 ' 16-color medium-res graphics for EGA and VGA 444: VC.Colors = 16 445: VC.Atribs = 16 446: VC.XPix = 319 447: VC.YPix = 199 448: VC.TCOL = 40 449: VC.TROW = 25 450: CASE 8 ' 16-color high-res graphics for EGA and VGA 451: VC.Colors = 16 452: VC.Atribs = 16 453: VC.XPix = 639 454: VC.YPix = 199 455: VC.TCOL = 80 456: VC.TROW = 25 457: CASE 9 ' 16- or 4-color very high-res graphics for EGA and VGA 458: VC.Colors = 64 459: IF BestMode = EGA64 THEN VC.Atribs = 4 ELSE VC.Atribs = 16 460: VC.XPix = 639 461: VC.YPix = 349 462: VC.TCOL = 80 463: VC.TROW = 25 464: CASE 10 ' Two-color high-res graphics for EGA or VGA monochrome 465: VC.Colors = 0 466: VC.Atribs = 2 467: VC.XPix = 319 468: VC.YPix = 199 469: VC.TCOL = 80 470: VC.TROW = 25 471: CASE 11 ' Two-color very high-res graphics for VGA and MCGA 472: ' Note that for VGA screens 11, 12, and 13, more colors are 473: ' available, depending on how the colors are mixed. 474: VC.Colors = 216 475: VC.Atribs = 2 476: VC.XPix = 639 477: VC.YPix = 479 478: VC.TCOL = 80 479: VC.TROW = 30 480: CASE 12 ' 16-color very high-res graphics for VGA 481: VC.Colors = 216 482: VC.Atribs = 16 483: VC.XPix = 639 484: VC.YPix = 479 485: VC.TCOL = 80 486: VC.TROW = 30 487: CASE 13 ' 256-color medium-res graphics for VGA and MCGA 488: VC.Colors = 216 489: VC.Atribs = 256 490: VC.XPix = 639 491: VC.YPix = 479 492: VC.TCOL = 40 493: VC.TROW = 25 494: CASE ELSE 495: VC.Colors = 16 496: VC.Atribs = 16 497: VC.XPix = 0 498: VC.YPix = 0 499: VC.TCOL = 80 500: VC.TROW = 25 501: VC.Scrn = 0 502: EXIT SUB 503: END SELECT 504: VC.Scrn = mode 505: 506: END SUB 507: 508: ' ============================ SetPalette ============================== 509: ' Mixes palette colors in an array. 510: ' ====================================================================== 511: ' 512: SUB SetPalette STATIC 513: SHARED VC AS Config, Pal() AS LONG 514: 515: ' Mix only if the adapter supports color attributes 516: IF VC.Colors THEN 517: SELECT CASE VC.Scrn 518: CASE 1, 2, 7, 8 519: ' Red, green, blue, and intense in four bits of a byte 520: ' Bits: 0000irgb 521: ' Change the order of FOR loops to change color mix 522: Index = 0 523: FOR Bs = 0 TO 1 524: FOR Gs = 0 TO 1 525: FOR Rs = 0 TO 1 526: FOR Hs = 0 TO 1 527: Pal(Index) = Hs * 8 + Rs * 4 + Gs * 2 + Bs 528: Index = Index + 1 529: NEXT 530: NEXT 531: NEXT 532: NEXT 533: CASE 9 534: ' EGA red, green, and blue colors in 6 bits of a byte 535: ' Capital letters repesent intense, lowercase normal 536: ' Bits: 00rgbRGB 537: ' Change the order of FOR loops to change color mix 538: Index = 0 539: FOR Bs = 0 TO 1 540: FOR Gs = 0 TO 1 541: FOR Rs = 0 TO 1 542: FOR HRs = 0 TO 1 543: FOR HGs = 0 TO 1 544: FOR HBs = 0 TO 1 545: Pal(Index) = Rs * 32 + Gs * 16 + Bs * 8 + HRs * 4 + HGs * 2 + HBs 546: Index = Index + 1 547: NEXT 548: NEXT 549: NEXT 550: NEXT 551: NEXT 552: NEXT 553: CASE 11, 12, 13 554: ' VGA colors in 6 bits of 3 bytes of a long integer 555: ' Bits: 000000000 00bbbbbb 00gggggg 00rrrrrr 556: ' Change the order of FOR loops to change color mix 557: ' Decrease the STEP and increase VC.Colors to get more colors 558: Index = 0 559: FOR Rs = 0 TO 63 STEP 11 560: FOR Bs = 0 TO 63 STEP 11 561: FOR Gs = 0 TO 63 STEP 11 562: Pal(Index) = (65536 * Bs) + (256 * Gs) + Rs 563: Index = Index + 1 564: NEXT 565: NEXT 566: NEXT 567: CASE ELSE 568: END SELECT 569: ' Assign colors 570: IF VC.Atribs > 2 THEN TorusRotate RNDM 571: END IF 572: 573: END SUB 574: 575: ' ============================ TileDraw ================================ 576: ' Draw and optionally paint a tile. Tiles are painted if there are 577: ' more than two atributes and if the inside of the tile can be found. 578: ' ====================================================================== 579: ' 580: SUB TileDraw (T AS Tile) STATIC 581: SHARED VC AS Config, TOR AS TORUS 582: 583: 'Set border 584: Border = VC.Atribs - 1 585: 586: IF VC.Atribs = 2 THEN 587: ' Draw and quit for two-color modes 588: LINE (T.x1, T.y1)-(T.x2, T.y2), T.TColor 589: LINE -(T.x3, T.y3), T.TColor 590: LINE -(T.x4, T.y4), T.TColor 591: LINE -(T.x1, T.y1), T.TColor 592: EXIT SUB 593: ELSE 594: ' For other modes, draw in the border color 595: ' (which must be different than any tile color) 596: LINE (T.x1, T.y1)-(T.x2, T.y2), Border 597: LINE -(T.x3, T.y3), Border 598: LINE -(T.x4, T.y4), Border 599: LINE -(T.x1, T.y1), Border 600: END IF 601: 602: ' See if tile is large enough to be painted 603: IF Inside(T) THEN 604: 'Black out the center to make sure it isn't paint color 605: PRESET (T.xc, T.yc) 606: ' Paint tile black so colors of underlying tiles can't interfere 607: PAINT STEP(0, 0), BACK, Border 608: ' Fill with the final tile color. 609: PAINT STEP(0, 0), T.TColor, Border 610: END IF 611: 612: ' A border drawn with the background color looks like a border. 613: ' One drawn with the tile color doesn't look like a border. 614: IF TOR.Bord = "YES" THEN 615: Border = BACK 616: ELSE 617: Border = T.TColor 618: END IF 619: 620: ' Redraw with the final border 621: LINE (T.x1, T.y1)-(T.x2, T.y2), Border 622: LINE -(T.x3, T.y3), Border 623: LINE -(T.x4, T.y4), Border 624: LINE -(T.x1, T.y1), Border 625: 626: END SUB 627: 628: DEFSNG A-Z 629: ' =========================== TorusCalc ================================ 630: ' Calculates the x and y coordinates for each tile. 631: ' ====================================================================== 632: ' 633: SUB TorusCalc (T() AS Tile) STATIC 634: SHARED TOR AS TORUS, Max AS INTEGER 635: DIM XSect AS INTEGER, YPanel AS INTEGER 636: 637: ' Calculate sine and cosine of the angles of rotation 638: XRot = DegToRad(TOR.XDegree) 639: YRot = DegToRad(TOR.YDegree) 640: CXRot = COS(XRot) 641: SXRot = SIN(XRot) 642: CYRot = COS(YRot) 643: SYRot = SIN(YRot) 644: 645: ' Calculate the angle to increment between one tile and the next. 646: XInc = 2 * PI / TOR.Sect 647: YInc = 2 * PI / TOR.Panel 648: 649: ' First calculate the first point, which will be used as a reference 650: ' for future points. This point must be calculated separately because 651: ' it is both the beginning and the end of the center seam. 652: FirstY = (TOR.Thick + 1) * CYRot 653: 654: ' Starting point is x1 of 0 section, 0 panel last 0 655: T(0).x1 = FirstY ' +------+------+ 656: ' Also x2 of tile on last section, 0 panel ' | | | last 657: T(TOR.Sect - 1).x2 = FirstY ' | x3|x4 | 658: ' Also x3 of last section, last panel ' +------+------+ 659: T(Max - 1).x3 = FirstY ' | x2|x1 | 0 660: ' Also x4 of 0 section, last panel ' | | | 661: T(Max - TOR.Sect).x4 = FirstY ' +------+------+ 662: ' A similar pattern is used for assigning all points of Torus 663: 664: ' Starting Y point is 0 (center) 665: T(0).y1 = 0 666: T(TOR.Sect - 1).y2 = 0 667: T(Max - 1).y3 = 0 668: T(Max - TOR.Sect).y4 = 0 669: 670: ' Only one z coordinate is used in sort, so other three can be ignored 671: T(0).z1 = -(TOR.Thick + 1) * SYRot 672: 673: ' Starting at first point, work around the center seam of the Torus. 674: ' Assign points for each section. The seam must be calculated separately 675: ' because it is both beginning and of each section. 676: FOR XSect = 1 TO TOR.Sect - 1 677: 678: ' X, Y, and Z elements of equation 679: sx = (TOR.Thick + 1) * COS(XSect * XInc) 680: sy = (TOR.Thick + 1) * SIN(XSect * XInc) * CXRot 681: sz = (TOR.Thick + 1) * SIN(XSect * XInc) * SXRot 682: ssx = (sz * SYRot) + (sx * CYRot) 683: 684: T(XSect).x1 = ssx 685: T(XSect - 1).x2 = ssx 686: T(Max - TOR.Sect + XSect - 1).x3 = ssx 687: T(Max - TOR.Sect + XSect).x4 = ssx 688: 689: T(XSect).y1 = sy 690: T(XSect - 1).y2 = sy 691: T(Max - TOR.Sect + XSect - 1).y3 = sy 692: T(Max - TOR.Sect + XSect).y4 = sy 693: 694: T(XSect).z1 = (sz * CYRot) - (sx * SYRot) 695: NEXT 696: 697: ' Now start at the first seam between panel and assign points for 698: ' each section of each panel. The outer loop assigns the initial 699: ' point for the panel. This point must be calculated separately 700: ' since it is both the beginning and the end of the seam of panels. 701: FOR YPanel = 1 TO TOR.Panel - 1 702: 703: ' X, Y, and Z elements of equation 704: sx = TOR.Thick + COS(YPanel * YInc) 705: sy = -SIN(YPanel * YInc) * SXRot 706: sz = SIN(YPanel * YInc) * CXRot 707: ssx = (sz * SYRot) + (sx * CYRot) 708: 709: ' Assign X points for each panel 710: ' Current ring, current side 711: T(TOR.Sect * YPanel).x1 = ssx 712: ' Current ring minus 1, next side 713: T(TOR.Sect * (YPanel + 1) - 1).x2 = ssx 714: ' Current ring minus 1, previous side 715: T(TOR.Sect * YPanel - 1).x3 = ssx 716: ' Current ring, previous side 717: T(TOR.Sect * (YPanel - 1)).x4 = ssx 718: 719: ' Assign Y points for each panel 720: T(TOR.Sect * YPanel).y1 = sy 721: T(TOR.Sect * (YPanel + 1) - 1).y2 = sy 722: T(TOR.Sect * YPanel - 1).y3 = sy 723: T(TOR.Sect * (YPanel - 1)).y4 = sy 724: 725: ' Z point for each panel 726: T(TOR.Sect * YPanel).z1 = (sz * CYRot) - (sx * SYRot) 727: 728: ' The inner loop assigns points for each ring (except the first) 729: ' on the current side. 730: FOR XSect = 1 TO TOR.Sect - 1 731: 732: ' Display section and panel 733: CountTiles XSect, YPanel 734: 735: ty = (TOR.Thick + COS(YPanel * YInc)) * SIN(XSect * XInc) 736: tz = SIN(YPanel * YInc) 737: sx = (TOR.Thick + COS(YPanel * YInc)) * COS(XSect * XInc) 738: sy = ty * CXRot - tz * SXRot 739: sz = ty * SXRot + tz * CXRot 740: ssx = (sz * SYRot) + (sx * CYRot) 741: 742: T(TOR.Sect * YPanel + XSect).x1 = ssx 743: T(TOR.Sect * YPanel + XSect - 1).x2 = ssx 744: T(TOR.Sect * (YPanel - 1) + XSect - 1).x3 = ssx 745: T(TOR.Sect * (YPanel - 1) + XSect).x4 = ssx 746: 747: T(TOR.Sect * YPanel + XSect).y1 = sy 748: T(TOR.Sect * YPanel + XSect - 1).y2 = sy 749: T(TOR.Sect * (YPanel - 1) + XSect - 1).y3 = sy 750: T(TOR.Sect * (YPanel - 1) + XSect).y4 = sy 751: 752: T(TOR.Sect * YPanel + XSect).z1 = (sz * CYRot) - (sx * SYRot) 753: NEXT 754: NEXT 755: ' Erase message 756: CountTiles -1, -1 757: 758: END SUB 759: 760: DEFINT A-Z 761: ' =========================== TorusColor =============================== 762: ' Assigns color atributes to each tile. 763: ' ====================================================================== 764: ' 765: SUB TorusColor (T() AS Tile) STATIC 766: SHARED VC AS Config, Max AS INTEGER 767: 768: ' Skip first and last atributes 769: LastAtr = VC.Atribs - 2 770: Atr = 1 771: 772: ' Cycle through each attribute until all tiles are done 773: FOR Til = 0 TO Max - 1 774: IF (Atr >= LastAtr) THEN 775: Atr = 1 776: ELSE 777: Atr = Atr + 1 778: END IF 779: T(Til).TColor = Atr 780: NEXT 781: 782: END SUB 783: 784: ' ============================ TorusDefine ============================= 785: ' Define the attributes of a Torus based on information from the 786: ' user, the video configuration, and the current screen mode. 787: ' ====================================================================== 788: ' 789: SUB TorusDefine STATIC 790: SHARED VC AS Config, TOR AS TORUS, Available AS STRING 791: 792: ' Constants for key codes and column positions 793: CONST ENTER = 13, ESCAPE = 27 794: CONST DOWNARROW = 80, UPARROW = 72, LEFTARROW = 75, RIGHTARROW = 77 795: CONST COL1 = 20, COL2 = 50, ROW = 9 796: 797: ' Display key instructions 798: LOCATE 1, COL1 799: PRINT "UP .............. Move to next field" 800: LOCATE 2, COL1 801: PRINT "DOWN ........ Move to previous field" 802: LOCATE 3, COL1 803: PRINT "LEFT ......... Rotate field value up" 804: LOCATE 4, COL1 805: PRINT "RIGHT ...... Rotate field value down" 806: LOCATE 5, COL1 807: PRINT "ENTER .... Start with current values" 808: LOCATE 6, COL1 809: PRINT "ESCAPE .................. Quit Torus" 810: 811: ' Block cursor 812: LOCATE ROW, COL1, 1, 1, 12 813: ' Display fields 814: LOCATE ROW, COL1: PRINT "Thickness"; 815: LOCATE ROW, COL2: PRINT USING "[ # ]"; TOR.Thick; 816: 817: LOCATE ROW + 2, COL1: PRINT "Panels per Section"; 818: LOCATE ROW + 2, COL2: PRINT USING "[ ## ]"; TOR.Panel; 819: 820: LOCATE ROW + 4, COL1: PRINT "Sections per Torus"; 821: LOCATE ROW + 4, COL2: PRINT USING "[ ## ]"; TOR.Sect; 822: 823: LOCATE ROW + 6, COL1: PRINT "Tilt around Horizontal Axis"; 824: LOCATE ROW + 6, COL2: PRINT USING "[ ### ]"; TOR.XDegree; 825: 826: LOCATE ROW + 8, COL1: PRINT "Tilt around Vertical Axis"; 827: LOCATE ROW + 8, COL2: PRINT USING "[ ### ]"; TOR.YDegree; 828: 829: LOCATE ROW + 10, COL1: PRINT "Tile Border"; 830: LOCATE ROW + 10, COL2: PRINT USING "[ & ] "; TOR.Bord; 831: 832: LOCATE ROW + 12, COL1: PRINT "Screen Mode"; 833: LOCATE ROW + 12, COL2: PRINT USING "[ ## ]"; VC.Scrn 834: 835: ' Skip field 10 if there's only one value 836: IF LEN(Available$) = 1 THEN Fields = 10 ELSE Fields = 12 837: 838: ' Update field values and position based on keystrokes 839: DO 840: ' Put cursor on field 841: LOCATE ROW + Fld, COL2 + 2 842: ' Get a key and strip null off if it's an extended code 843: DO 844: K$ = INKEY$ 845: LOOP WHILE K$ = "" 846: Ky = ASC(RIGHT$(K$, 1)) 847: 848: SELECT CASE Ky 849: CASE ESCAPE 850: ' End program 851: CLS : END 852: CASE UPARROW, DOWNARROW 853: ' Adjust field location 854: IF Ky = DOWNARROW THEN Inc = 2 ELSE Inc = -2 855: Fld = Rotated(0, Fields, Fld, Inc) 856: CASE RIGHTARROW, LEFTARROW 857: ' Adjust field 858: IF Ky = RIGHTARROW THEN Inc = 1 ELSE Inc = -1 859: SELECT CASE Fld 860: CASE 0 861: ' Thickness 862: TOR.Thick = Rotated(1, 9, INT(TOR.Thick), Inc) 863: PRINT USING "#"; TOR.Thick 864: CASE 2 865: ' Panels 866: TOR.Panel = Rotated(6, 20, TOR.Panel, Inc) 867: PRINT USING "##"; TOR.Panel 868: CASE 4 869: ' Sections 870: TOR.Sect = Rotated(6, 20, TOR.Sect, Inc) 871: PRINT USING "##"; TOR.Sect 872: CASE 6 873: ' Horizontal tilt 874: TOR.XDegree = Rotated(0, 345, TOR.XDegree, (15 * Inc)) 875: PRINT USING "###"; TOR.XDegree 876: CASE 8 877: ' Vertical tilt 878: TOR.YDegree = Rotated(0, 345, TOR.YDegree, (15 * Inc)) 879: PRINT USING "###"; TOR.YDegree 880: CASE 10 881: ' Border 882: IF VC.Atribs > 2 THEN 883: IF TOR.Bord = "YES" THEN 884: TOR.Bord = "NO" 885: ELSE 886: TOR.Bord = "YES" 887: END IF 888: END IF 889: PRINT TOR.Bord 890: CASE 12 891: ' Available screen modes 892: I = INSTR(Available$, HEX$(VC.Scrn)) 893: I = Rotated(1, LEN(Available$), I, Inc) 894: VC.Scrn = VAL("&h" + MID$(Available$, I, 1)) 895: PRINT USING "##"; VC.Scrn 896: CASE ELSE 897: END SELECT 898: CASE ELSE 899: END SELECT 900: ' Set configuration data for graphics mode 901: SetConfig VC.Scrn 902: ' Draw Torus if ENTER 903: LOOP UNTIL Ky = ENTER 904: 905: ' Remove cursor 906: LOCATE 1, 1, 0 907: 908: ' Set different delays depending on mode 909: SELECT CASE VC.Scrn 910: CASE 1 911: TOR.Delay = .3 912: CASE 2, 3, 10, 11, 13 913: TOR.Delay = 0 914: CASE ELSE 915: TOR.Delay = .05 916: END SELECT 917: 918: ' Get new random seed for this torus 919: RANDOMIZE TIMER 920: 921: END SUB 922: 923: ' =========================== TorusDraw ================================ 924: ' Draws each tile of the torus starting with the farthest and working 925: ' to the closest. Thus nearer tiles overwrite farther tiles to give 926: ' a three-dimensional effect. Notice that the index of the tile being 927: ' drawn is actually the index of an array of indexes. This is because 928: ' the array of tiles is not sorted, but the parallel array of indexes 929: ' is. See TorusSort for an explanation of how indexes are sorted. 930: ' ====================================================================== 931: ' 932: SUB TorusDraw (T() AS Tile, Index() AS INTEGER) 933: SHARED Max AS INTEGER 934: 935: FOR Til = 0 TO Max - 1 936: TileDraw T(Index(Til)) 937: NEXT 938: 939: END SUB 940: 941: ' =========================== TorusRotate ============================== 942: ' Rotates the Torus. This can be done more successfully in some modes 943: ' than in others. There are three methods: 944: ' 945: ' 1. Rotate the palette colors assigned to each attribute 946: ' 2. Draw, erase, and redraw the torus (two-color modes) 947: ' 3. Rotate between two palettes (CGA and MCGA screen 1) 948: ' 949: ' Note that for EGA and VGA screen 2, methods 1 and 2 are both used. 950: ' ====================================================================== 951: ' 952: SUB TorusRotate (First) STATIC 953: SHARED VC AS Config, TOR AS TORUS, Pal() AS LONG, Max AS INTEGER 954: SHARED T() AS Tile, Index() AS INTEGER, BestMode AS INTEGER 955: DIM Temp AS LONG 956: 957: ' For EGA and higher rotate colors through palette 958: IF VC.Colors THEN 959: 960: ' Argument determines whether to start at next color, first color, 961: ' or random color 962: SELECT CASE First 963: CASE RNDM 964: FirstClr = INT(RND * VC.Colors) 965: CASE START 966: FirstClr = 0 967: CASE ELSE 968: FirstClr = FirstClr - 1 969: END SELECT 970: 971: ' Set last color to smaller of last possible color or last tile 972: IF VC.Colors > Max - 1 THEN 973: LastClr = Max - 1 974: ELSE 975: LastClr = VC.Colors - 1 976: END IF 977: 978: ' If color is too low, rotate to end 979: IF FirstClr < 0 OR FirstClr >= LastClr THEN FirstClr = LastClr 980: 981: ' Set last attribute 982: IF VC.Atribs = 2 THEN 983: ' Last for two-color modes 984: LastAtr = VC.Atribs - 1 985: ELSE 986: ' Smaller of last color or next-to-last attribute 987: IF LastClr < VC.Atribs - 2 THEN 988: LastAtr = LastClr 989: ELSE 990: LastAtr = VC.Atribs - 2 991: END IF 992: END IF 993: 994: ' Cycle through attributes, assigning colors 995: Work = FirstClr 996: FOR Atr = LastAtr TO 1 STEP -1 997: PALETTE Atr, Pal(Work) 998: Work = Work - 1 999: IF Work < 0 THEN Work = LastClr 1000: NEXT 1001: 1002: END IF 1003: 1004: ' For two-color screens, the best we can do is erase and redraw the torus 1005: IF VC.Atribs = 2 THEN 1006: 1007: ' Set all tiles to color 1008: FOR I = 0 TO Max - 1 1009: T(I).TColor = Toggle 1010: NEXT 1011: ' Draw Torus 1012: TorusDraw T(), Index() 1013: ' Toggle between color and background 1014: Toggle = (Toggle + 1) MOD 2 1015: 1016: END IF 1017: 1018: ' For CGA or MCGA screen 1, toggle palettes using the COLOR statement 1019: ' (these modes do not allow the PALETTE statement) 1020: IF VC.Scrn = 1 AND (BestMode = CGA OR BestMode = MCGA) THEN 1021: COLOR , Toggle 1022: Toggle = (Toggle + 1) MOD 2 1023: EXIT SUB 1024: END IF 1025: 1026: END SUB 1027: 1028: ' ============================ TorusSort =============================== 1029: ' Sorts the tiles of the Torus according to their Z axis (distance 1030: ' from the "front" of the screen). When the tiles are drawn, the 1031: ' farthest will be drawn first, and nearer tiles will overwrite them 1032: ' to give a three-dimensional effect. 1033: ' 1034: ' To make sorting as fast as possible, the Quick Sort algorithm is 1035: ' used. Also, the array of tiles is not actually sorted. Instead a 1036: ' parallel array of tile indexes is sorted. This complicates things, 1037: ' but makes the sort much faster, since two-byte integers are swapped 1038: ' instead of 46-byte Tile variables. 1039: ' ====================================================================== 1040: ' 1041: SUB TorusSort (Low, High) 1042: SHARED T() AS Tile, Index() AS INTEGER 1043: DIM Partition AS SINGLE 1044: 1045: IF Low < High THEN 1046: ' If only one, compare and swap if necessary 1047: ' The SUB procedure only stops recursing when it reaches this point 1048: IF High - Low = 1 THEN 1049: IF T(Index(Low)).z1 > T(Index(High)).z1 THEN 1050: CountTiles High, Low 1051: SWAP Index(Low), Index(High) 1052: END IF 1053: ELSE 1054: ' If more than one, separate into two random groups 1055: RandIndex = INT(RND * (High - Low + 1)) + Low 1056: CountTiles High, Low 1057: SWAP Index(High), Index(RandIndex%) 1058: Partition = T(Index(High)).z1 1059: ' Sort one group 1060: DO 1061: I = Low: J = High 1062: ' Find the largest 1063: DO WHILE (I < J) AND (T(Index(I)).z1 <= Partition) 1064: I = I + 1 1065: LOOP 1066: ' Find the smallest 1067: DO WHILE (J > I) AND (T(Index(J)).z1 >= Partition) 1068: J = J - 1 1069: LOOP 1070: ' Swap them if necessary 1071: IF I < J THEN 1072: CountTiles High, Low 1073: SWAP Index(I), Index(J) 1074: END IF 1075: LOOP WHILE I < J 1076: 1077: ' Now get the other group and recursively sort it 1078: CountTiles High, Low 1079: SWAP Index(I), Index(High) 1080: IF (I - Low) < (High - I) THEN 1081: TorusSort Low, I - 1 1082: TorusSort I + 1, High 1083: ELSE 1084: TorusSort I + 1, High 1085: TorusSort Low, I - 1 1086: END IF 1087: END IF 1088: END IF 1089: 1090: END SUB 1091: |