Liren Large Software Subsidy 10

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

/ Liren Large Software Subsidy 10 / 10.iso / l / l391 / 2.ddi / TORDRAW.BA$ / TORDRAW.bin

Wrap

Text File | 1992-08-19 | 30.2 KB | 971 lines

' ------------------------------------------------------------------------ ' Visual Basic for MS-DOS Torus Program Support Module ' ' Provides routines for creating and drawing graphic ' Torus figure. ' ' Copyright (C) 1982-1992 Microsoft Corporation ' ' You have a royalty-free right to use, modify, reproduce ' and distribute the sample applications and toolkits provided with ' Visual Basic for MS-DOS (and/or any modified version) ' in any way you find useful, provided that you agree that ' Microsoft has no warranty, obligations or liability for ' any of the sample applications or toolkits. ' ------------------------------------------------------------------------ DEFINT A-Z '$FORM frmTorus DECLARE SUB CountTiles (T1%, T2%) DECLARE FUNCTION DegToRad! (Degrees%) DECLARE SUB Delay (Seconds!) DECLARE FUNCTION Inside% (T AS ANY) DECLARE FUNCTION Rotated% (Lower%, Upper%, Current%, Inc%) DECLARE SUB SetConfig (mode AS INTEGER) DECLARE SUB SetPalette () DECLARE SUB TileDraw (T AS ANY) DECLARE SUB TorDraw () DECLARE SUB TorusCalc (T() AS ANY) DECLARE SUB TorusColor (T() AS ANY) DECLARE SUB TorusDefine () DECLARE SUB TorusDraw (T() AS ANY, Index() AS INTEGER) DECLARE SUB TorusRotate (First%) DECLARE SUB TorusSort (Low%, High%) ' General purpose constants CONST PI = 3.14159 CONST TRUE = -1, FALSE = 0 CONST BACK = 0 CONST BORD_YES = 1 ' 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 ' 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 ' Video configuration DIM SHARED VC AS Config ' Torus to be drawn DIM SHARED Tor AS Torus ' Number of pieces to draw DIM SHARED Max AS INTEGER ' A palette of colors to paint with DIM SHARED Pal(0 TO 300) AS LONG ' Array for indexes DIM SHARED Index() AS INTEGER ' Array for tiles DIM SHARED T() AS tile ' Best graphics screen mode. DIM SHARED BestMode AS INTEGER ' ============================ CountTiles ============================== ' Displays number of the tiles currently being calculated or sorted. ' ====================================================================== ' STATIC SUB CountTiles (T1, T2) ' If positive then display else erase IF T1 > 0 AND T2 > 0 THEN ' Show numbers inside form frmTorus.lblCalc.Caption = FORMAT$(T1) + " " + FORMAT$(T2) ELSE frmTorus.lblCalc.Caption = "" END IF END SUB ' ============================ DegToRad ================================ ' Convert degrees to radians, since BASIC trigonometric functions ' require radians. ' ====================================================================== ' STATIC FUNCTION DegToRad! (Degrees) 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. ' ====================================================================== ' STATIC SUB Delay (Seconds!) 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 () ' Assume best possible screen mode BestMode = VGA Available$ = "12789BCD" ON LOCAL 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 LOCAL ERROR GOTO EGAErr IF BestMode = EGA256 THEN SCREEN 8, , 1 ON ERROR GOTO 0 ' Reset text mode SCREEN 0, , 0 WIDTH 80, 25 FOR tmp% = 1 TO LEN(Available$) ScrnVal = VAL("&H" + MID$(Available$, tmp%, 1)) frmTorus.CboScrn.ADDITEM FORMAT$(ScrnVal) IF ScrnVal = BestMode THEN frmTorus.CboScrn.ListIndex = tmp% - 1 NEXT EXIT SUB ' 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 "Graphics support not available. Cannot run Torus sample program." END END SELECT RESUME ' Trap to detect 64K EGA EGAErr: BestMode = EGA64 Available$ = "12789" RESUME NEXT 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. ' ====================================================================== ' STATIC FUNCTION Inside (T AS tile) 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 ' ============================ 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. ' ====================================================================== ' STATIC SUB SetConfig (mode 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. ' ====================================================================== ' STATIC SUB SetPalette () ' 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. ' ====================================================================== ' STATIC SUB TileDraw (T AS tile) '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 ' ============================ TorDraw ================================ ' Draw and rotate torus while waiting for user input to continue. ' ====================================================================== ' SUB TorDraw () ' 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() ' Show an exit message LOCATE VC.TROW - 1, 1 PRINT "Press any key to continue"; ' Rotate the torus by rotating the color palette DO WHILE INKEY$ = "" Delay (Tor.Delay) TorusRotate CONTINUE LOOP SCREEN 0 WIDTH 80 END SUB ' ============================ TorMain ================================ ' Create torus from user input then display it. ' ====================================================================== ' SUB TorMain () ' 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 LOCAL ERROR GOTO MemErr ' Array for tiles REDIM T(0 TO Max - 1) AS tile 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 frmTorus.lblCalcMsg.Caption = "Calculating..." TorusCalc T() frmTorus.lblCalcMsg.Caption = "" ' Color each tile in the torus. TorusColor T() ' Sort the tiles by their "distance" from the screen frmTorus.lblCalcMsg.Caption = "Sorting..." TorusSort 0, Max - 1 frmTorus.lblCalcMsg.Caption = "" screen.HIDE ' Hide option form before displaying graphics. CALL TorDraw ' Display the torus. screen.SHOW ' Show option form again. EXIT SUB ' Trap to detect insufficient memory and other errors. MemErr: MSGBOX ERROR$ + ". Cannot create Torus." + CHR$(13) + "Try reducing number of sections and panels.", 0, "Torus" EXIT SUB END SUB DEFSNG A-Z ' =========================== TorusCalc ================================ ' Calculates the x and y coordinates for each tile. ' ====================================================================== ' STATIC SUB TorusCalc (T() AS tile) 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. ' ====================================================================== ' STATIC SUB TorusColor (T() AS tile) ' 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. ' ====================================================================== ' STATIC SUB TorusDefine () Tor.Thick = VAL(frmTorus.txtThick.Text) IF frmTorus.chkBord.Value = BORD_YES THEN Tor.Bord = "YES" ELSE Tor.Bord = "NO" END IF Tor.Panel = VAL(frmTorus.TxtPanel.Text) Tor.Sect = VAL(frmTorus.TxtSection.Text) Tor.XDegree = VAL(frmTorus.TxtXDegree.Text) Tor.YDegree = VAL(frmTorus.TxtYDegree.Text) VC.Scrn = VAL(frmTorus.CboScrn.Text) ' Set configuration data for graphics mode SetConfig VC.Scrn ' 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) 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. ' ====================================================================== ' STATIC SUB TorusRotate (First) 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) 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 CountTiles -1, -1 END SUB