Microsoft Programmer's Library 1.3

home *** CD-ROM | disk | FTP | other *** search

/ Microsoft Programmer's Library 1.3 / Microsoft-Programers-Library-v1.3.iso / sampcode / basic / torus.bas < prev next >

Wrap

BASIC Source File | 1989-11-09 | 34.3 KB | 1,092 lines

' ====================================================================== ' TORUS ' This program draws a Torus figure. The program accepts user input ' to specify various TORUS parameters. It checks the current system ' configuration and takes appropriate action to set the best possible ' initial mode. ' ====================================================================== DEFINT A-Z DECLARE SUB GetConfig () DECLARE SUB SetPalette () DECLARE SUB TorusDefine () DECLARE SUB TorusCalc (T() AS ANY) DECLARE SUB TorusColor (T() AS ANY) DECLARE SUB TorusSort (Low, High) DECLARE SUB TorusDraw (T() AS ANY, Index()) DECLARE SUB TileDraw (T AS ANY) DECLARE SUB TorusRotate (First) DECLARE SUB Delay (Seconds!) DECLARE SUB CountTiles (T1, T2) DECLARE SUB Message (Text$) DECLARE SUB SetConfig (mode) DECLARE FUNCTION Inside (T AS ANY) DECLARE FUNCTION DegToRad! (Degrees) DECLARE FUNCTION Rotated (Lower, Upper, Current, Inc) ' General purpose constants CONST PI = 3.14159 CONST TRUE = -1, FALSE = 0 CONST BACK = 0 CONST TROW = 24, TCOL = 60 ' Rotation flags CONST RNDM = -1 CONST START = 0 CONST CONTINUE = 1 ' Constants for best available screen mode CONST VGA = 12 CONST MCGA = 13 CONST EGA256 = 9 CONST EGA64 = 8 CONST MONO = 10 CONST HERC = 3 CONST CGA = 1 ' User-defined type for tiles - an array of these make a torus TYPE Tile x1 AS SINGLE x2 AS SINGLE x3 AS SINGLE x4 AS SINGLE y1 AS SINGLE y2 AS SINGLE y3 AS SINGLE y4 AS SINGLE z1 AS SINGLE xc AS SINGLE yc AS SINGLE TColor AS INTEGER END TYPE ' User-defined type to hold information about the mode TYPE Config Scrn AS INTEGER Colors AS INTEGER Atribs AS INTEGER XPix AS INTEGER YPix AS INTEGER TCOL AS INTEGER TROW AS INTEGER END TYPE DIM VC AS Config ' User-defined type to hold information about current Torus TYPE TORUS Panel AS INTEGER Sect AS INTEGER Thick AS SINGLE XDegree AS INTEGER YDegree AS INTEGER Bord AS STRING * 3 Delay AS SINGLE END TYPE DIM TOR AS TORUS, Max AS INTEGER ' A palette of colors to paint with DIM Pal(0 TO 300) AS LONG ' Error variables to check screen type DIM InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING ' The code of the module-level program begins here ' Initialize defaults TOR.Thick = 3: TOR.Bord = "YES" TOR.Panel = 8: TOR.Sect = 14 TOR.XDegree = 60: TOR.YDegree = 165 ' Get best configuration and set initial graphics mode to it GetConfig VC.Scrn = BestMode DO WHILE TRUE ' Loop forever (exit is from within a SUB) ' Get Torus definition from user TorusDefine ' Dynamically dimension arrays DO Tmp = TOR.Panel Max = TOR.Panel * TOR.Sect ' Array for indexes REDIM Index(0 TO Max - 1) AS INTEGER ' Turn on error trap for insufficient memory ON ERROR GOTO MemErr ' Array for tiles REDIM T(0 TO Max - 1) AS Tile ON ERROR GOTO 0 LOOP UNTIL Tmp = TOR.Panel ' Initialize array of indexes FOR Til = 0 TO Max - 1 Index(Til) = Til NEXT ' Calculate the points of each tile on the torus Message "Calculating" TorusCalc T() ' Color each tile in the torus. TorusColor T() ' Sort the tiles by their "distance" from the screen Message "Sorting" TorusSort 0, Max - 1 ' Set the screen mode SCREEN VC.Scrn ' Mix a palette of colors SetPalette ' Set logical window with variable thickness ' Center is 0, up and right are positive, down and left are negative WINDOW (-(TOR.Thick + 1), -(TOR.Thick + 1))-(TOR.Thick + 1, TOR.Thick + 1) ' Draw and paint the tiles, the farthest first and nearest last TorusDraw T(), Index() ' Rotate the torus by rotating the color palette DO WHILE INKEY$ = "" Delay (TOR.Delay) TorusRotate CONTINUE LOOP SCREEN 0 WIDTH 80 LOOP ' Restore original rows WIDTH 80, InitRows END ' Error trap to make torus screen independent VideoErr: SELECT CASE BestMode ' Fall through until something works CASE VGA BestMode = MCGA Available = "12BD" CASE MCGA BestMode = EGA256 Available = "12789" CASE EGA256 BestMode = CGA Available = "12" CASE CGA BestMode = MONO Available = "A" CASE MONO BestMode = HERC Available = "3" CASE ELSE PRINT "Sorry. Graphics not available. Can't run Torus." END END SELECT RESUME ' Trap to detect 64K EGA EGAErr: BestMode = EGA64 Available = "12789" RESUME NEXT ' Trap to detect insufficient memory for large Torus MemErr: LOCATE 22, 1 PRINT "Out of memory" PRINT "Reducing panels from"; TOR.Panel; "to"; TOR.Panel - 1 PRINT "Reducing sections from"; TOR.Sect; "to"; TOR.Sect - 1; DO WHILE INKEY$ = "": LOOP TOR.Panel = TOR.Panel - 1 TOR.Sect = TOR.Sect - 1 RESUME NEXT ' Trap to determine initial number of rows so they can be restored RowErr: IF InitRows = 50 THEN InitRows = 43 RESUME ELSE InitRows = 25 RESUME NEXT END IF ' ============================ CountTiles ============================== ' Displays number of the tiles currently being calculated or sorted. ' ====================================================================== ' SUB CountTiles (T1, T2) STATIC ' Erase previous LOCATE TROW - 1, TCOL: PRINT SPACE$(19); ' If positive, display - give negative values to erase IF T1 > 0 AND T2 > 0 THEN LOCATE TROW - 1, TCOL PRINT "Tile "; PRINT USING " ###"; T1; PRINT USING " ###"; T2; END IF END SUB ' ============================ DegToRad ================================ ' Convert degrees to radians, since BASIC trigonometric functions ' require radians. ' ====================================================================== ' FUNCTION DegToRad! (Degrees) STATIC DegToRad! = (Degrees * 2 * PI) / 360 END FUNCTION ' =============================== Delay ================================ ' Delay based on time so that wait will be the same on any processor. ' Notice the check for negative numbers so that the delay won't ' freeze at midnight when the delay could become negative. ' ====================================================================== ' SUB Delay (Seconds!) STATIC Begin! = TIMER DO UNTIL (TIMER - Begin! > Seconds!) OR (TIMER - Begin! < 0) LOOP END SUB ' ============================ GetConfig =============================== ' Get the starting number of lines and the video adapter. ' ====================================================================== ' SUB GetConfig STATIC SHARED InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING ' Assume 50 line display and fall through error ' until we get the actual number InitRows = 50 ON ERROR GOTO RowErr LOCATE InitRows, 1 ' Assume best possible screen mode BestMode = VGA Available = "12789BCD" ON ERROR GOTO VideoErr ' Fall through error trap until a mode works SCREEN BestMode ' If EGA, then check pages to see whether more than 64K ON ERROR GOTO EGAErr IF BestMode = EGA256 THEN SCREEN 8, , 1 ON ERROR GOTO 0 ' Reset text mode SCREEN 0, , 0 WIDTH 80, 25 END SUB ' ============================== Inside ================================ ' Finds a point, T.xc and T.yc, that is mathematically within a tile. ' Then check to see if the point is actually inside. Because of the ' jagged edges of tiles, the center point is often actually inside ' very thin tiles. Such tiles will not be painted, This causes ' imperfections that are often visible at the edge of the Torus. ' ' Return FALSE if a center point is not found inside a tile. ' ====================================================================== ' FUNCTION Inside (T AS Tile) STATIC SHARED VC AS Config DIM Highest AS SINGLE, Lowest AS SINGLE Border = VC.Atribs - 1 ' Find an inside point. Since some tiles are triangles, the ' diagonal center isn't good enough. Instead find the center ' by drawing a diagonal from the center of the outside to ' a bottom corner. T.xc = T.x2 + ((T.x3 + (T.x4 - T.x3) / 2 - T.x2) / 2) T.yc = T.y2 + ((T.y3 + (T.y4 - T.y3) / 2 - T.y2) / 2) ' If we're on a border, no need to fill IF POINT(T.xc, T.yc) = Border THEN Inside = FALSE EXIT FUNCTION END IF ' Find highest and lowest Y on the tile Highest = T.y1 Lowest = T.y1 IF T.y2 > Highest THEN Highest = T.y2 IF T.y2 < Lowest THEN Lowest = T.y2 IF T.y3 > Highest THEN Highest = T.y3 IF T.y3 < Lowest THEN Lowest = T.y3 IF T.y4 > Highest THEN Highest = T.y4 IF T.y4 < Lowest THEN Lowest = T.y4 ' Convert coordinates to pixels X = PMAP(T.xc, 0) YU = PMAP(T.yc, 1) YD = YU H = PMAP(Highest, 1) L = PMAP(Lowest, 1) ' Search for top and bottom tile borders until we either find them ' both, or check beyond the highest and lowest points. IsUp = FALSE IsDown = FALSE DO YU = YU - 1 YD = YD + 1 ' Search up IF NOT IsUp THEN IF POINT(T.xc, PMAP(YU, 3)) = Border THEN IsUp = TRUE END IF ' Search down IF NOT IsDown THEN IF POINT(T.xc, PMAP(YD, 3)) = Border THEN IsDown = TRUE END IF ' If top and bottom are found, we're inside IF IsUp AND IsDown THEN Inside = TRUE EXIT FUNCTION END IF LOOP UNTIL (YD > L) AND (YU < H) Inside = FALSE END FUNCTION ' ============================= Message ================================ ' Displays a status message followed by blinking dots. ' ====================================================================== ' SUB Message (Text$) STATIC SHARED VC AS Config LOCATE TROW, TCOL: PRINT SPACE$(19); LOCATE TROW, TCOL COLOR 7 ' White PRINT Text$; COLOR 23 ' Blink PRINT " . . ."; COLOR 7 ' White END SUB ' ============================ Rotated ================================= ' Returns the Current value adjusted by Inc and rotated if necessary ' so that it falls within the range of Lower and Upper. ' ====================================================================== ' FUNCTION Rotated (Lower, Upper, Current, Inc) ' Calculate the next value Current = Current + Inc ' Handle special cases of rotating off top or bottom IF Current > Upper THEN Current = Lower IF Current < Lower THEN Current = Upper Rotated = Current END FUNCTION ' ============================ SetConfig =============================== ' Sets the correct values for each field of the VC variable. They ' vary depending on Mode and on the current configuration. ' ====================================================================== ' SUB SetConfig (mode AS INTEGER) STATIC SHARED VC AS Config, BestMode AS INTEGER SELECT CASE mode CASE 1 ' Four-color graphics for CGA, EGA, VGA, and MCGA IF BestMode = CGA OR BestMode = MCGA THEN VC.Colors = 0 ELSE VC.Colors = 16 END IF VC.Atribs = 4 VC.XPix = 319 VC.YPix = 199 VC.TCOL = 40 VC.TROW = 25 CASE 2 ' Two-color medium-res graphics for CGA, EGA, VGA, and MCGA IF BestMode = CGA OR BestMode = MCGA THEN VC.Colors = 0 ELSE VC.Colors = 16 END IF VC.Atribs = 2 VC.XPix = 639 VC.YPix = 199 VC.TCOL = 80 VC.TROW = 25 CASE 3 ' Two-color high-res graphics for Hercules VC.Colors = 0 VC.Atribs = 2 VC.XPix = 720 VC.YPix = 348 VC.TCOL = 80 VC.TROW = 25 CASE 7 ' 16-color medium-res graphics for EGA and VGA VC.Colors = 16 VC.Atribs = 16 VC.XPix = 319 VC.YPix = 199 VC.TCOL = 40 VC.TROW = 25 CASE 8 ' 16-color high-res graphics for EGA and VGA VC.Colors = 16 VC.Atribs = 16 VC.XPix = 639 VC.YPix = 199 VC.TCOL = 80 VC.TROW = 25 CASE 9 ' 16- or 4-color very high-res graphics for EGA and VGA VC.Colors = 64 IF BestMode = EGA64 THEN VC.Atribs = 4 ELSE VC.Atribs = 16 VC.XPix = 639 VC.YPix = 349 VC.TCOL = 80 VC.TROW = 25 CASE 10 ' Two-color high-res graphics for EGA or VGA monochrome VC.Colors = 0 VC.Atribs = 2 VC.XPix = 319 VC.YPix = 199 VC.TCOL = 80 VC.TROW = 25 CASE 11 ' Two-color very high-res graphics for VGA and MCGA ' Note that for VGA screens 11, 12, and 13, more colors are ' available, depending on how the colors are mixed. VC.Colors = 216 VC.Atribs = 2 VC.XPix = 639 VC.YPix = 479 VC.TCOL = 80 VC.TROW = 30 CASE 12 ' 16-color very high-res graphics for VGA VC.Colors = 216 VC.Atribs = 16 VC.XPix = 639 VC.YPix = 479 VC.TCOL = 80 VC.TROW = 30 CASE 13 ' 256-color medium-res graphics for VGA and MCGA VC.Colors = 216 VC.Atribs = 256 VC.XPix = 639 VC.YPix = 479 VC.TCOL = 40 VC.TROW = 25 CASE ELSE VC.Colors = 16 VC.Atribs = 16 VC.XPix = 0 VC.YPix = 0 VC.TCOL = 80 VC.TROW = 25 VC.Scrn = 0 EXIT SUB END SELECT VC.Scrn = mode END SUB ' ============================ SetPalette ============================== ' Mixes palette colors in an array. ' ====================================================================== ' SUB SetPalette STATIC SHARED VC AS Config, Pal() AS LONG ' Mix only if the adapter supports color attributes IF VC.Colors THEN SELECT CASE VC.Scrn CASE 1, 2, 7, 8 ' Red, green, blue, and intense in four bits of a byte ' Bits: 0000irgb ' Change the order of FOR loops to change color mix Index = 0 FOR Bs = 0 TO 1 FOR Gs = 0 TO 1 FOR Rs = 0 TO 1 FOR Hs = 0 TO 1 Pal(Index) = Hs * 8 + Rs * 4 + Gs * 2 + Bs Index = Index + 1 NEXT NEXT NEXT NEXT CASE 9 ' EGA red, green, and blue colors in 6 bits of a byte ' Capital letters repesent intense, lowercase normal ' Bits: 00rgbRGB ' Change the order of FOR loops to change color mix Index = 0 FOR Bs = 0 TO 1 FOR Gs = 0 TO 1 FOR Rs = 0 TO 1 FOR HRs = 0 TO 1 FOR HGs = 0 TO 1 FOR HBs = 0 TO 1 Pal(Index) = Rs * 32 + Gs * 16 + Bs * 8 + HRs * 4 + HGs * 2 + HBs Index = Index + 1 NEXT NEXT NEXT NEXT NEXT NEXT CASE 11, 12, 13 ' VGA colors in 6 bits of 3 bytes of a long integer ' Bits: 000000000 00bbbbbb 00gggggg 00rrrrrr ' Change the order of FOR loops to change color mix ' Decrease the STEP and increase VC.Colors to get more colors Index = 0 FOR Rs = 0 TO 63 STEP 11 FOR Bs = 0 TO 63 STEP 11 FOR Gs = 0 TO 63 STEP 11 Pal(Index) = (65536 * Bs) + (256 * Gs) + Rs Index = Index + 1 NEXT NEXT NEXT CASE ELSE END SELECT ' Assign colors IF VC.Atribs > 2 THEN TorusRotate RNDM END IF END SUB ' ============================ TileDraw ================================ ' Draw and optionally paint a tile. Tiles are painted if there are ' more than two atributes and if the inside of the tile can be found. ' ====================================================================== ' SUB TileDraw (T AS Tile) STATIC SHARED VC AS Config, TOR AS TORUS 'Set border Border = VC.Atribs - 1 IF VC.Atribs = 2 THEN ' Draw and quit for two-color modes LINE (T.x1, T.y1)-(T.x2, T.y2), T.TColor LINE -(T.x3, T.y3), T.TColor LINE -(T.x4, T.y4), T.TColor LINE -(T.x1, T.y1), T.TColor EXIT SUB ELSE ' For other modes, draw in the border color ' (which must be different than any tile color) LINE (T.x1, T.y1)-(T.x2, T.y2), Border LINE -(T.x3, T.y3), Border LINE -(T.x4, T.y4), Border LINE -(T.x1, T.y1), Border END IF ' See if tile is large enough to be painted IF Inside(T) THEN 'Black out the center to make sure it isn't paint color PRESET (T.xc, T.yc) ' Paint tile black so colors of underlying tiles can't interfere PAINT STEP(0, 0), BACK, Border ' Fill with the final tile color. PAINT STEP(0, 0), T.TColor, Border END IF ' A border drawn with the background color looks like a border. ' One drawn with the tile color doesn't look like a border. IF TOR.Bord = "YES" THEN Border = BACK ELSE Border = T.TColor END IF ' Redraw with the final border LINE (T.x1, T.y1)-(T.x2, T.y2), Border LINE -(T.x3, T.y3), Border LINE -(T.x4, T.y4), Border LINE -(T.x1, T.y1), Border END SUB DEFSNG A-Z ' =========================== TorusCalc ================================ ' Calculates the x and y coordinates for each tile. ' ====================================================================== ' SUB TorusCalc (T() AS Tile) STATIC SHARED TOR AS TORUS, Max AS INTEGER DIM XSect AS INTEGER, YPanel AS INTEGER ' Calculate sine and cosine of the angles of rotation XRot = DegToRad(TOR.XDegree) YRot = DegToRad(TOR.YDegree) CXRot = COS(XRot) SXRot = SIN(XRot) CYRot = COS(YRot) SYRot = SIN(YRot) ' Calculate the angle to increment between one tile and the next. XInc = 2 * PI / TOR.Sect YInc = 2 * PI / TOR.Panel ' First calculate the first point, which will be used as a reference ' for future points. This point must be calculated separately because ' it is both the beginning and the end of the center seam. FirstY = (TOR.Thick + 1) * CYRot ' Starting point is x1 of 0 section, 0 panel last 0 T(0).x1 = FirstY ' +------+------+ ' Also x2 of tile on last section, 0 panel ' | | | last T(TOR.Sect - 1).x2 = FirstY ' | x3|x4 | ' Also x3 of last section, last panel ' +------+------+ T(Max - 1).x3 = FirstY ' | x2|x1 | 0 ' Also x4 of 0 section, last panel ' | | | T(Max - TOR.Sect).x4 = FirstY ' +------+------+ ' A similar pattern is used for assigning all points of Torus ' Starting Y point is 0 (center) T(0).y1 = 0 T(TOR.Sect - 1).y2 = 0 T(Max - 1).y3 = 0 T(Max - TOR.Sect).y4 = 0 ' Only one z coordinate is used in sort, so other three can be ignored T(0).z1 = -(TOR.Thick + 1) * SYRot ' Starting at first point, work around the center seam of the Torus. ' Assign points for each section. The seam must be calculated separately ' because it is both beginning and of each section. FOR XSect = 1 TO TOR.Sect - 1 ' X, Y, and Z elements of equation sx = (TOR.Thick + 1) * COS(XSect * XInc) sy = (TOR.Thick + 1) * SIN(XSect * XInc) * CXRot sz = (TOR.Thick + 1) * SIN(XSect * XInc) * SXRot ssx = (sz * SYRot) + (sx * CYRot) T(XSect).x1 = ssx T(XSect - 1).x2 = ssx T(Max - TOR.Sect + XSect - 1).x3 = ssx T(Max - TOR.Sect + XSect).x4 = ssx T(XSect).y1 = sy T(XSect - 1).y2 = sy T(Max - TOR.Sect + XSect - 1).y3 = sy T(Max - TOR.Sect + XSect).y4 = sy T(XSect).z1 = (sz * CYRot) - (sx * SYRot) NEXT ' Now start at the first seam between panel and assign points for ' each section of each panel. The outer loop assigns the initial ' point for the panel. This point must be calculated separately ' since it is both the beginning and the end of the seam of panels. FOR YPanel = 1 TO TOR.Panel - 1 ' X, Y, and Z elements of equation sx = TOR.Thick + COS(YPanel * YInc) sy = -SIN(YPanel * YInc) * SXRot sz = SIN(YPanel * YInc) * CXRot ssx = (sz * SYRot) + (sx * CYRot) ' Assign X points for each panel ' Current ring, current side T(TOR.Sect * YPanel).x1 = ssx ' Current ring minus 1, next side T(TOR.Sect * (YPanel + 1) - 1).x2 = ssx ' Current ring minus 1, previous side T(TOR.Sect * YPanel - 1).x3 = ssx ' Current ring, previous side T(TOR.Sect * (YPanel - 1)).x4 = ssx ' Assign Y points for each panel T(TOR.Sect * YPanel).y1 = sy T(TOR.Sect * (YPanel + 1) - 1).y2 = sy T(TOR.Sect * YPanel - 1).y3 = sy T(TOR.Sect * (YPanel - 1)).y4 = sy ' Z point for each panel T(TOR.Sect * YPanel).z1 = (sz * CYRot) - (sx * SYRot) ' The inner loop assigns points for each ring (except the first) ' on the current side. FOR XSect = 1 TO TOR.Sect - 1 ' Display section and panel CountTiles XSect, YPanel ty = (TOR.Thick + COS(YPanel * YInc)) * SIN(XSect * XInc) tz = SIN(YPanel * YInc) sx = (TOR.Thick + COS(YPanel * YInc)) * COS(XSect * XInc) sy = ty * CXRot - tz * SXRot sz = ty * SXRot + tz * CXRot ssx = (sz * SYRot) + (sx * CYRot) T(TOR.Sect * YPanel + XSect).x1 = ssx T(TOR.Sect * YPanel + XSect - 1).x2 = ssx T(TOR.Sect * (YPanel - 1) + XSect - 1).x3 = ssx T(TOR.Sect * (YPanel - 1) + XSect).x4 = ssx T(TOR.Sect * YPanel + XSect).y1 = sy T(TOR.Sect * YPanel + XSect - 1).y2 = sy T(TOR.Sect * (YPanel - 1) + XSect - 1).y3 = sy T(TOR.Sect * (YPanel - 1) + XSect).y4 = sy T(TOR.Sect * YPanel + XSect).z1 = (sz * CYRot) - (sx * SYRot) NEXT NEXT ' Erase message CountTiles -1, -1 END SUB DEFINT A-Z ' =========================== TorusColor =============================== ' Assigns color atributes to each tile. ' ====================================================================== ' SUB TorusColor (T() AS Tile) STATIC SHARED VC AS Config, Max AS INTEGER ' Skip first and last atributes LastAtr = VC.Atribs - 2 Atr = 1 ' Cycle through each attribute until all tiles are done FOR Til = 0 TO Max - 1 IF (Atr >= LastAtr) THEN Atr = 1 ELSE Atr = Atr + 1 END IF T(Til).TColor = Atr NEXT END SUB ' ============================ TorusDefine ============================= ' Define the attributes of a Torus based on information from the ' user, the video configuration, and the current screen mode. ' ====================================================================== ' SUB TorusDefine STATIC SHARED VC AS Config, TOR AS TORUS, Available AS STRING ' Constants for key codes and column positions CONST ENTER = 13, ESCAPE = 27 CONST DOWNARROW = 80, UPARROW = 72, LEFTARROW = 75, RIGHTARROW = 77 CONST COL1 = 20, COL2 = 50, ROW = 9 ' Display key instructions LOCATE 1, COL1 PRINT "UP .............. Move to next field" LOCATE 2, COL1 PRINT "DOWN ........ Move to previous field" LOCATE 3, COL1 PRINT "LEFT ......... Rotate field value up" LOCATE 4, COL1 PRINT "RIGHT ...... Rotate field value down" LOCATE 5, COL1 PRINT "ENTER .... Start with current values" LOCATE 6, COL1 PRINT "ESCAPE .................. Quit Torus" ' Block cursor LOCATE ROW, COL1, 1, 1, 12 ' Display fields LOCATE ROW, COL1: PRINT "Thickness"; LOCATE ROW, COL2: PRINT USING "[ # ]"; TOR.Thick; LOCATE ROW + 2, COL1: PRINT "Panels per Section"; LOCATE ROW + 2, COL2: PRINT USING "[ ## ]"; TOR.Panel; LOCATE ROW + 4, COL1: PRINT "Sections per Torus"; LOCATE ROW + 4, COL2: PRINT USING "[ ## ]"; TOR.Sect; LOCATE ROW + 6, COL1: PRINT "Tilt around Horizontal Axis"; LOCATE ROW + 6, COL2: PRINT USING "[ ### ]"; TOR.XDegree; LOCATE ROW + 8, COL1: PRINT "Tilt around Vertical Axis"; LOCATE ROW + 8, COL2: PRINT USING "[ ### ]"; TOR.YDegree; LOCATE ROW + 10, COL1: PRINT "Tile Border"; LOCATE ROW + 10, COL2: PRINT USING "[ & ] "; TOR.Bord; LOCATE ROW + 12, COL1: PRINT "Screen Mode"; LOCATE ROW + 12, COL2: PRINT USING "[ ## ]"; VC.Scrn ' Skip field 10 if there's only one value IF LEN(Available$) = 1 THEN Fields = 10 ELSE Fields = 12 ' Update field values and position based on keystrokes DO ' Put cursor on field LOCATE ROW + Fld, COL2 + 2 ' Get a key and strip null off if it's an extended code DO K$ = INKEY$ LOOP WHILE K$ = "" Ky = ASC(RIGHT$(K$, 1)) SELECT CASE Ky CASE ESCAPE ' End program CLS : END CASE UPARROW, DOWNARROW ' Adjust field location IF Ky = DOWNARROW THEN Inc = 2 ELSE Inc = -2 Fld = Rotated(0, Fields, Fld, Inc) CASE RIGHTARROW, LEFTARROW ' Adjust field IF Ky = RIGHTARROW THEN Inc = 1 ELSE Inc = -1 SELECT CASE Fld CASE 0 ' Thickness TOR.Thick = Rotated(1, 9, INT(TOR.Thick), Inc) PRINT USING "#"; TOR.Thick CASE 2 ' Panels TOR.Panel = Rotated(6, 20, TOR.Panel, Inc) PRINT USING "##"; TOR.Panel CASE 4 ' Sections TOR.Sect = Rotated(6, 20, TOR.Sect, Inc) PRINT USING "##"; TOR.Sect CASE 6 ' Horizontal tilt TOR.XDegree = Rotated(0, 345, TOR.XDegree, (15 * Inc)) PRINT USING "###"; TOR.XDegree CASE 8 ' Vertical tilt TOR.YDegree = Rotated(0, 345, TOR.YDegree, (15 * Inc)) PRINT USING "###"; TOR.YDegree CASE 10 ' Border IF VC.Atribs > 2 THEN IF TOR.Bord = "YES" THEN TOR.Bord = "NO" ELSE TOR.Bord = "YES" END IF END IF PRINT TOR.Bord CASE 12 ' Available screen modes I = INSTR(Available$, HEX$(VC.Scrn)) I = Rotated(1, LEN(Available$), I, Inc) VC.Scrn = VAL("&h" + MID$(Available$, I, 1)) PRINT USING "##"; VC.Scrn CASE ELSE END SELECT CASE ELSE END SELECT ' Set configuration data for graphics mode SetConfig VC.Scrn ' Draw Torus if ENTER LOOP UNTIL Ky = ENTER ' Remove cursor LOCATE 1, 1, 0 ' Set different delays depending on mode SELECT CASE VC.Scrn CASE 1 TOR.Delay = .3 CASE 2, 3, 10, 11, 13 TOR.Delay = 0 CASE ELSE TOR.Delay = .05 END SELECT ' Get new random seed for this torus RANDOMIZE TIMER END SUB ' =========================== TorusDraw ================================ ' Draws each tile of the torus starting with the farthest and working ' to the closest. Thus nearer tiles overwrite farther tiles to give ' a three-dimensional effect. Notice that the index of the tile being ' drawn is actually the index of an array of indexes. This is because ' the array of tiles is not sorted, but the parallel array of indexes ' is. See TorusSort for an explanation of how indexes are sorted. ' ====================================================================== ' SUB TorusDraw (T() AS Tile, Index() AS INTEGER) SHARED Max AS INTEGER FOR Til = 0 TO Max - 1 TileDraw T(Index(Til)) NEXT END SUB ' =========================== TorusRotate ============================== ' Rotates the Torus. This can be done more successfully in some modes ' than in others. There are three methods: ' ' 1. Rotate the palette colors assigned to each attribute ' 2. Draw, erase, and redraw the torus (two-color modes) ' 3. Rotate between two palettes (CGA and MCGA screen 1) ' ' Note that for EGA and VGA screen 2, methods 1 and 2 are both used. ' ====================================================================== ' SUB TorusRotate (First) STATIC SHARED VC AS Config, TOR AS TORUS, Pal() AS LONG, Max AS INTEGER SHARED T() AS Tile, Index() AS INTEGER, BestMode AS INTEGER DIM Temp AS LONG ' For EGA and higher rotate colors through palette IF VC.Colors THEN ' Argument determines whether to start at next color, first color, ' or random color SELECT CASE First CASE RNDM FirstClr = INT(RND * VC.Colors) CASE START FirstClr = 0 CASE ELSE FirstClr = FirstClr - 1 END SELECT ' Set last color to smaller of last possible color or last tile IF VC.Colors > Max - 1 THEN LastClr = Max - 1 ELSE LastClr = VC.Colors - 1 END IF ' If color is too low, rotate to end IF FirstClr < 0 OR FirstClr >= LastClr THEN FirstClr = LastClr ' Set last attribute IF VC.Atribs = 2 THEN ' Last for two-color modes LastAtr = VC.Atribs - 1 ELSE ' Smaller of last color or next-to-last attribute IF LastClr < VC.Atribs - 2 THEN LastAtr = LastClr ELSE LastAtr = VC.Atribs - 2 END IF END IF ' Cycle through attributes, assigning colors Work = FirstClr FOR Atr = LastAtr TO 1 STEP -1 PALETTE Atr, Pal(Work) Work = Work - 1 IF Work < 0 THEN Work = LastClr NEXT END IF ' For two-color screens, the best we can do is erase and redraw the torus IF VC.Atribs = 2 THEN ' Set all tiles to color FOR I = 0 TO Max - 1 T(I).TColor = Toggle NEXT ' Draw Torus TorusDraw T(), Index() ' Toggle between color and background Toggle = (Toggle + 1) MOD 2 END IF ' For CGA or MCGA screen 1, toggle palettes using the COLOR statement ' (these modes do not allow the PALETTE statement) IF VC.Scrn = 1 AND (BestMode = CGA OR BestMode = MCGA) THEN COLOR , Toggle Toggle = (Toggle + 1) MOD 2 EXIT SUB END IF END SUB ' ============================ TorusSort =============================== ' Sorts the tiles of the Torus according to their Z axis (distance ' from the "front" of the screen). When the tiles are drawn, the ' farthest will be drawn first, and nearer tiles will overwrite them ' to give a three-dimensional effect. ' ' To make sorting as fast as possible, the Quick Sort algorithm is ' used. Also, the array of tiles is not actually sorted. Instead a ' parallel array of tile indexes is sorted. This complicates things, ' but makes the sort much faster, since two-byte integers are swapped ' instead of 46-byte Tile variables. ' ====================================================================== ' SUB TorusSort (Low, High) SHARED T() AS Tile, Index() AS INTEGER DIM Partition AS SINGLE IF Low < High THEN ' If only one, compare and swap if necessary ' The SUB procedure only stops recursing when it reaches this point IF High - Low = 1 THEN IF T(Index(Low)).z1 > T(Index(High)).z1 THEN CountTiles High, Low SWAP Index(Low), Index(High) END IF ELSE ' If more than one, separate into two random groups RandIndex = INT(RND * (High - Low + 1)) + Low CountTiles High, Low SWAP Index(High), Index(RandIndex%) Partition = T(Index(High)).z1 ' Sort one group DO I = Low: J = High ' Find the largest DO WHILE (I < J) AND (T(Index(I)).z1 <= Partition) I = I + 1 LOOP ' Find the smallest DO WHILE (J > I) AND (T(Index(J)).z1 >= Partition) J = J - 1 LOOP ' Swap them if necessary IF I < J THEN CountTiles High, Low SWAP Index(I), Index(J) END IF LOOP WHILE I < J ' Now get the other group and recursively sort it CountTiles High, Low SWAP Index(I), Index(High) IF (I - Low) < (High - I) THEN TorusSort Low, I - 1 TorusSort I + 1, High ELSE TorusSort I + 1, High TorusSort Low, I - 1 END IF END IF END IF END SUB