home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / QBAS / QB4GRAF.ZIP / TORUS.BAS < prev    next >
BASIC Source File  |  1989-05-16  |  35KB  |  1,092 lines
  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.  
  1092.