Post by tsh73 on Mar 17, 2024 21:44:06 GMT
So I took that Microsoft demo
and made it work in JB.
I remember running it in some QB back then
but this version was probably converted to brand new QB64 so I did not managed to run it as is (with software I had).
I did not managed to find more old version (it sure should not mention QB64 in comments)
Some Windows API (FloodFill) would make it draw faster
(actually QB used FloodFill. And used some weird function Inside(T) to determine if tile is big enough for FloodFill.
FillPoligon will be better, no need to check that)
but for JB it's good.
It uses FastFilledTriangles of AndyAmaya - that's why sometimes diagonal line is visible (tile filled as two triangles).
Many things left from initial program, commented
Color stuff should be made much simpler
(now it is complex, used only about 1/3 of code, and likely still wrong - I see colors drop then rotated)
As for now, default "14" segments along torus makes whole segment use same color, looks nice
Colors are randomised (not actually colors but starting point in the palette), different runs shows different colors.
Probably I will clean it up, removing vast areas of comments and unused branches (for different video modes of source program)
1) There was Microsoft QBASIC code demo
Here it is at QB64 site
qb64.com/samples/torus-demo/
Here it is at QB64 site
qb64.com/samples/torus-demo/
and made it work in JB.
I remember running it in some QB back then
but this version was probably converted to brand new QB64 so I did not managed to run it as is (with software I had).
I did not managed to find more old version (it sure should not mention QB64 in comments)
Some Windows API (FloodFill) would make it draw faster
(actually QB used FloodFill. And used some weird function Inside(T) to determine if tile is big enough for FloodFill.
FillPoligon will be better, no need to check that)
but for JB it's good.
It uses FastFilledTriangles of AndyAmaya - that's why sometimes diagonal line is visible (tile filled as two triangles).
Many things left from initial program, commented
Color stuff should be made much simpler
(now it is complex, used only about 1/3 of code, and likely still wrong - I see colors drop then rotated)
As for now, default "14" segments along torus makes whole segment use same color, looks nice
Colors are randomised (not actually colors but starting point in the palette), different runs shows different colors.
Probably I will clean it up, removing vast areas of comments and unused branches (for different video modes of source program)
'from qb64.com/samples/torus-demo/
'conversion to JB by tsh73
'March 2024
'-----------------------------------------------------------------------------------------------------
' 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.
'-----------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------
' These are some metacommands and compiler options for QB64 to write modern & type-strict code
'-----------------------------------------------------------------------------------------------------
' This will disable prefixing all modern QB64 calls using a underscore prefix.
'''$NoPrefix
' Whatever indentifiers are not defined, should default to signed longs (ex. constants and functions).
'''DefInt A-Z
' All variables must be defined.
'''Option Explicit
' All arrays must be defined.
'''Option ExplicitArray
' Array lower bounds should always start from 1 unless explicitly specified.
' This allows a(4) as integer to have 4 members with index 1-4.
'''Option Base 1
' All arrays should be static by default. Allocate dynamic array using ReDim
'$Static
' This allows the executable window & it's contents to be resized.
'''$Resize:Smooth
'''FullScreen SquarePixels , Smooth
'''Title "Torus"
'-----------------------------------------------------------------------------------------------------
global FALSE, TRUE, BACK, TROW, TCOL
global C.RNDM, C.START, C.CONTINUE
global VGA, MCGA, EGA256, EGA64, MONO, HERC, CGA
'Sub GetConfig
global InitRows, BestMode, Available$
'Sub TorusDefine
global TOR.Thick, TOR.Bord$, TOR.Panel, TOR.Sect, TOR.XDegree, TOR.YDegree, TOR.Delay
'Sub SetConfig
global VC.Colors, VC.Atribs, VC.XPix, VC.YPix, VC.TCOL, VC.TROW, VC.Scrn
global QuitRequested, Pi
'Sub TileDraw
Global T.x1,T.x2,T.x3,T.x4,T.y1,T.y2,T.y3,T.y4,T.z1,T.xc,T.yc,T.TColor
'Sub TorusCalc
'indices for columns in T(tile, column)
Global Ix1, Ix2, Ix3, Ix4, Iy1, Iy2, Iy3, Iy4, Iz1, Ixc, Iyc, ITColor
Dim T(10, 12) 'to be redimmed
Ix1=1:Ix2=2:Ix3=3:Ix4=4:Iy1=5:Iy2=6:Iy3=7:Iy4=8:Iz1=9:Ixc=10:Iyc=11:ITColor=12
'Sub TorusColor
global Max
'Sub TorusRotate , to preserve between calls
global FirstClr
Pi=acs(-1)
' General purpose constants
FALSE = 0: TRUE = Not( FALSE)
BACK = 0
TROW = 24: TCOL = 60
' Rotation flags
C.RNDM = -1: C.START = 0: C.CONTINUE = 1
' Constants for best Available$ screen mode
VGA = 12
MCGA = 13
EGA256 = 9
EGA64 = 8
MONO = 10
HERC = 3
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(300) 'As Long
'added to use with JB
Dim Pal$(300)
Dim Colr$(300)
' 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
''Dim As Integer Tmp, Til
' 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
call GetConfig
VC.Scrn = BestMode
Do While TRUE ' Loop forever (exit is from within a SUB)
' Get Torus definition from user
call TorusDefine
' Dynamically dimension arrays
Do
Tmp = TOR.Panel
Max = TOR.Panel * TOR.Sect
' Array for indexes
ReDim Index(Max - 1)
' Turn on error trap for insufficient memory
''On Error GoTo MemErr
' Array for tiles
ReDim T(Max - 1, 12) ''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
call Message "Calculating"
call TorusCalc '' T() 'now T$(), and arrays are global in JB
' For Til = 0 To Max - 1
' print Til,
' for i = 1 to 12
' print T(Til, i);" ";
' next
' print
' next
' Color each tile in the torus.
call initQBcolors 'or some color are left undefined
call TorusColor ''T()
' Sort the tiles by their "distance" from the screen
call Message "Sorting"
call TorusSort 0, Max - 1
' Set the screen mode
'Screen VC.Scrn
'open corresponding gr window
'ajust for borders
UpperLeftX = 20
UpperLeftY = 20
WindowWidth = 200 '100 seems to be too much - works different
WindowHeight = 100
open "Ajusting..." for graphics_nsb_nf as #gr
#gr, "home ; down ; posxy x y"
'x, y give us width, height
width = 2*x : height = 2*y
close #gr
slackX = 200-width
slackY = 100-height
desiredWidth = VC.XPix+1
desiredHeight = VC.YPix+1
WindowWidth = desiredWidth + slackX
WindowHeight = desiredHeight + slackY
UpperLeftX=int((DisplayWidth-WindowWidth)/2)
UpperLeftY=int((DisplayHeight-WindowHeight)/2)
open "Torus" for graphics_nsb_nf as #gr
#gr, "trapclose [quit]"
#gr, "down; fill black"
#gr, "flush"
' Mix a palette of colors
call 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)
global width, minX, maxX, height, minY, maxY
width=VC.XPix+1
minX=0-(TOR.Thick + 1)
maxX=TOR.Thick + 1
height=VC.YPix+1
minY=0-(TOR.Thick + 1)
maxY=TOR.Thick + 1
' Draw and paint the tiles, the farthest first and nearest last
call Message "Drawing"
call TorusDraw ''T(), Index()
'#gr, "flush"
'wait
' Rotate the torus by rotating the color palette
Do While 1''InKey$ = ""
SCAN
call Delay TOR.Delay
#gr, "discard"
call TorusRotate C.CONTINUE
call Message "Drawing"
call TorusDraw
''Limit 30 '???
Loop
'Screen 0
'Width 80
Loop
[quit]
timer 0
close #gr
end
' ============================ CountTiles ==============================
' Displays number of the tiles currently being calculated or sorted.
' ======================================================================
'
Sub CountTiles T1, T2
Print "Tile ";
Print Using (" ###", T1);
Print Using (" ###", T2)
End Sub
' ============================ DegToRad ================================
' Convert degrees to radians, since BASIC trigonometric functions
' require radians.
' ======================================================================
'
Function DegToRad (Degrees)
DegToRad = (Degrees * 2 * Pi) / 360
End Function
' ============================ 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.
' ======================================================================
'
''!!! not used as of now, at all
Function Inside (T) '' As Tile)
'Shared VC As Config
'Dim Highest As Single, Lowest As Single
'Dim As Integer Border, X, YU, YD, H, L, IsUp, IsDown
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
'this supposed to get pixel color
'If Point(T.xc, T.yc) = Border Then
If 0 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$
Print "-";
print time$();".";time$("ms") mod 1000;
print "-------------------------"
'Print "-22:17:30.421-------------------------"
Print Text$
Print "--------------------------------------"
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 ''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
''Dim As Integer Index, Bs, Gs, Rs, Hs, HRs, HGs, HBs
' 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
Pal$(Index)=Rs*4;" ";Gs*4;" ";Bs*4
Index = Index + 1
Next
Next
Next
Case Else
End Select
' Assign colors
If VC.Atribs > 2 Then call TorusRotate C.RNDM
End If
' print "--- SetPalette -----"
' print "VC.Colors",VC.Colors
' print "VC.Scrn",VC.Scrn
' print "Index", Index
' for i = 0 to Index
' print i, Pal(i), Pal$(i)
' next
' print "--- //SetPalette ---"
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
''Dim As Integer Border
''call unpackT T$
'copyToGlobT is called before
'Set border
Border = VC.Atribs - 1
If VC.Atribs = 2 Then
' Draw and quit for two-color modes
#gr "color ";Colr$(T.TColor)
'Line (T.x1, T.y1)-(T.x2, T.y2), T.TColor
#gr "line ";T.x1;" ";T.y1;" ";T.x2;" ";T.y2
'Line -(T.x3, T.y3), T.TColor
#gr "goto ";T.x3;" ";T.y3
'Line -(T.x4, T.y4), T.TColor
#gr "goto ";T.x4;" ";T.y4
'Line -(T.x1, T.y1), T.TColor
#gr "goto ";T.x1;" ";T.y1
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
#gr "color ";Colr$(Border)
#gr "line ";sx(T.x1);" ";sy(T.y1);" ";sx(T.x2);" ";sy(T.y2)
#gr "goto ";sx(T.x3);" ";sy(T.y3)
#gr "goto ";sx(T.x4);" ";sy(T.y4)
#gr "goto ";sx(T.x1);" ";sy(T.y1)
' print "color ";Colr$(Border)
' print "line ";sx(T.x1);" ";sy(T.y1);" ";sx(T.x2);" ";sy(T.y2)
' print "goto ";sx(T.x3);" ";sy(T.y3)
' print "goto ";sx(T.x4);" ";sy(T.y4)
' print "goto ";sx(T.x1);" ";sy(T.y1)
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
#gr "color ";Colr$(T.TColor)
call fillTriangle "#gr",sx(T.x1),sy(T.y1),sx(T.x2),sy(T.y2),sx(T.x3),sy(T.y3)
call fillTriangle "#gr",sx(T.x1),sy(T.y1),sx(T.x4),sy(T.y4),sx(T.x3),sy(T.y3)
' 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
#gr "color ";Colr$(Border)
#gr "line ";sx(T.x1);" ";sy(T.y1);" ";sx(T.x2);" ";sy(T.y2)
#gr "goto ";sx(T.x3);" ";sy(T.y3)
#gr "goto ";sx(T.x4);" ";sy(T.y4)
#gr "goto ";sx(T.x1);" ";sy(T.y1)
End Sub
' =========================== TorusCalc ================================
' Calculates the x and y coordinates for each tile.
' ======================================================================
'
Sub TorusCalc ''(T() As Tile) Static 'now use T(tile, column)
' Shared TOR As TORUS, Max As Integer
' Dim XSect As Integer, YPanel As Integer
' Dim As Single XRot, YRot, CXRot, SXRot, CYRot, SYRot, XInc, YInc, FirstY
' Dim As Single sx, sy, sz, ssx, ty, tz
' 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,Ix1) = FirstY ' +------+------+
' Also x2 of tile on last section, 0 panel ' | | | last
T(TOR.Sect - 1,Ix2) = FirstY ' | x3|x4 |
' Also x3 of last section, last panel ' +------+------+
T(Max - 1,Ix3) = FirstY ' | x2|x1 | 0
' Also x4 of 0 section, last panel ' | | |
T(Max - TOR.Sect,Ix4) = FirstY ' +------+------+
' A similar pattern is used for assigning all points of Torus
' Starting Y point is 0 (center)
T(0,Iy1) = 0
T(TOR.Sect - 1,Iy2) = 0
T(Max - 1,Iy3) = 0
T(Max - TOR.Sect,Iy4) = 0
' Only one z coordinate is used in sort, so other three can be ignored
T(0,Iz1) = 0-(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,Ix1) = ssx
T(XSect - 1,Ix2) = ssx
T(Max - TOR.Sect + XSect - 1,Ix3) = ssx
T(Max - TOR.Sect + XSect,Ix4) = ssx
T(XSect,Iy1) = sy
T(XSect - 1,Iy2) = sy
T(Max - TOR.Sect + XSect - 1,Iy3) = sy
T(Max - TOR.Sect + XSect,Iy4) = sy
T(XSect,Iz1) = (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 = 0-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,Ix1) = ssx
' Current ring minus 1, next side
T(TOR.Sect * (YPanel + 1) - 1,Ix2) = ssx
' Current ring minus 1, previous side
T(TOR.Sect * YPanel - 1,Ix3) = ssx
' Current ring, previous side
T(TOR.Sect * (YPanel - 1),Ix4) = ssx
' Assign Y points for each panel
T(TOR.Sect * YPanel,Iy1) = sy
T(TOR.Sect * (YPanel + 1) - 1,Iy2) = sy
T(TOR.Sect * YPanel - 1,Iy3) = sy
T(TOR.Sect * (YPanel - 1),Iy4) = sy
' Z point for each panel
T(TOR.Sect * YPanel,Iz1) = (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
call 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,Ix1) = ssx
T(TOR.Sect * YPanel + XSect - 1,Ix2) = ssx
T(TOR.Sect * (YPanel - 1) + XSect - 1,Ix3) = ssx
T(TOR.Sect * (YPanel - 1) + XSect,Ix4) = ssx
T(TOR.Sect * YPanel + XSect,Iy1) = sy
T(TOR.Sect * YPanel + XSect - 1,Iy2) = sy
T(TOR.Sect * (YPanel - 1) + XSect - 1,Iy3) = sy
T(TOR.Sect * (YPanel - 1) + XSect,Iy4) = sy
T(TOR.Sect * YPanel + XSect,Iz1) = (sz * CYRot) - (sx * SYRot)
Next
Next
' Erase message
call CountTiles -1, -1
End Sub
' =========================== TorusColor ===============================
' Assigns color atributes to each tile.
' ======================================================================
'
Sub TorusColor ''(T() As Tile) Static
' Shared VC As Config, Max As Integer
' Dim As Integer LastAtr, Atr, Til
' 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,ITColor) = Atr
print "Colr",Til, 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
WindowWidth = 328
WindowHeight = 260
UpperLeftX=int((DisplayWidth-WindowWidth)/2)
UpperLeftY=int((DisplayHeight-WindowHeight)/2)
statictext #main.statictext1, "Thickness", 22, 16, 144, 20
textbox #main.txtThick, 190, 11, 100, 25
statictext #main.statictext3, "Panels per Section", 22, 41, 144, 20
textbox #main.txt.Panel, 190, 36, 100, 25
statictext #main.statictext5, "Sections per Torus", 22, 66, 144, 20
textbox #main.txt.Sect, 190, 61, 100, 25
statictext #main.statictext7, "Tilt around Horizontal Axis", 22, 91, 144, 20
textbox #main.txtXDegree, 190, 86, 100, 25
statictext #main.statictext9, "Tilt around Vertical Axis", 22, 116, 144, 20
textbox #main.txtYDegree, 190, 111, 100, 25
statictext #main.statictext11, "Tile Border", 22, 141, 144, 20
textbox #main.txtBord, 190, 136, 100, 25
statictext #main.statictext13, "Screen Mode", 22, 166, 144, 20
statictext #main.lblScrn, "12 (640x480)", 190, 166, 144, 20
button #main.button16, "Start", [btnStartClick], UL, 22, 191, 122, 25
button #main.button17, "Quit", [btnQuitClick], UL, 174, 191, 122, 25
open "Torus" for window_nf as #main
print #main, "trapclose [quit.main]"
print #main, "font ms_sans_serif 10"
#main.txtThick TOR.Thick
#main.txt.Panel TOR.Panel
#main.txt.Sect TOR.Sect
#main.txtXDegree TOR.XDegree
#main.txtYDegree TOR.YDegree
#main.txtBord TOR.Bord$
' #main.lblScrn VC.Scrn
#main.button16, "!setfocus"
wait
[quit.main]
Close #main
END
[btnStartClick]
'get data and return
errList$=chr$(13)
#main.txtThick "!contents? TOR.Thick" '1, 9
errList$=errList$+chkRange$("TOR.Thick", TOR.Thick, 1, 9)
#main.txt.Panel "!contents? TOR.Panel" '6, 20
errList$=errList$+chkRange$("TOR.Panel", TOR.Panel, 6, 20)
#main.txt.Sect "!contents? TOR.Sect" '6, 20
errList$=errList$+chkRange$("TOR.Sect", TOR.Sect, 6, 20)
#main.txtXDegree "!contents? TOR.XDegree" '0, 345, by 15deg
errList$=errList$+chkRange$("TOR.XDegree", TOR.XDegree, 0, 345)
#main.txtYDegree "!contents? TOR.YDegree" '0, 345, by 15deg
errList$=errList$+chkRange$("TOR.YDegree", TOR.YDegree, 0, 345)
#main.txtBord "!contents? TOR.Bord$" 'YES NO
if (TOR.Bord$<>"YES") and (TOR.Bord$<>"NO") then
errList$=errList$+"TOR.Bord$ value (";TOR.Bord$;") should be YES or NO"
end if
if trim$(errList$)<>"" then
notice "Errors found: ";errList$
wait
end if
Close #main
call SetConfig VC.Scrn
' Set different delays depending on mode
'Case Else
TOR.Delay = 1 '.05 'drawing torus take lots of time
' Get new random seed for this torus
''Randomize Timer
exit sub
wait
[btnQuitClick] 'Perform action for the button named 'button17'
goto [quit.main]
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
' Dim Til As Integer
For Til = 0 To Max - 1
call copyToGlobT Til 'T(Index(Til)) - >T.*
'print "Tile ",Til
call 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 '' As Integer) 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 As Integer FirstClr, LastClr, LastAtr, Work, Atr, i, Toggle
' 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 C.RNDM
FirstClr = Int(Rnd(0) * VC.Colors)
Case C.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)
Pal$(Atr) = Pal$(Work)
Colr$(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
call TorusDraw ''T(), Index()
' Toggle between color and background
Toggle = (Toggle + 1) Mod 2 '0..1
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
' Dim As Integer RandIndex, i, j
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),Iz1) > T(Index(High),Iz1) Then
call CountTiles High, Low
'Swap Index(Low), Index(High)
call swapIndex Low,High
End If
Else
' If more than one, separate into two random groups
RandIndex = Int(Rnd * (High - Low + 1)) + Low
call CountTiles High, Low
'Swap Index(High), Index(RandIndex%)
call swapIndex High, RandIndex
Partition = T(Index(High),Iz1)
' Sort one group
Do
i = Low: j = High
' Find the largest
Do While (i < j) And (T(Index(i),Iz1) <= Partition)
i = i + 1
Loop
' Find the smallest
Do While (j > i) And (T(Index(j),Iz1) >= Partition)
j = j - 1
Loop
' Swap them if necessary
If i < j Then
call CountTiles High, Low
'Swap Index(i), Index(j)
call swapIndex i, j
End If
Loop While i < j
' Now get the other group and recursively sort it
call CountTiles High, Low
'Swap Index(i), Index(High)
call swapIndex i, High
If (i - Low) < (High - i) Then
call TorusSort Low, i - 1
call TorusSort i + 1, High
Else
call TorusSort i + 1, High
call TorusSort Low, i - 1
End If
End If
End If
End Sub
'- aux funcs by tsh73, for TileDraw ------------------------------
'should be global
'Global T.x1,T.x2,T.x3,T.x4,T.y1,T.y2,T.y3,T.y4,T.z1,T.xc,T.yc,T.TColor
sub unpackT T$
T.x1=val(word$(T$,1))
T.x2=val(word$(T$,2))
T.x3=val(word$(T$,3))
T.x4=val(word$(T$,4))
T.y1=val(word$(T$,5))
T.y2=val(word$(T$,6))
T.y3=val(word$(T$,7))
T.y4=val(word$(T$,8))
T.z1=val(word$(T$,9))
T.xc=val(word$(T$,10))
T.yc=val(word$(T$,11))
T.TColor=val(word$(T$,12))
end sub
sub copyToGlobT Til
T.x1=T(Index(Til), Ix1)
T.x2=T(Index(Til), Ix2)
T.x3=T(Index(Til), Ix3)
T.x4=T(Index(Til), Ix4)
T.y1=T(Index(Til), Iy1)
T.y2=T(Index(Til), Iy2)
T.y3=T(Index(Til), Iy3)
T.y4=T(Index(Til), Iy4)
T.z1=T(Index(Til), Iz1)
T.xc=T(Index(Til), Ixc)
T.yc=T(Index(Til), Iyc)
T.TColor=T(Index(Til), ITColor)
end sub
function packT$()
packT$=T.x1;" ";T.x2;" ";T.x3;" ";T.x4;" ";T.y1;" ";T.y2;" ";T.y3;" ";T.y4;" ";T.z1;" ";T.xc;" ";T.yc;" ";T.TColor
end function
'- aux func by Tsh73, for new Sub TorusDefine -------------------
function chkRange$(varName$, varVal, mn, mx)
if (varVal < mn) or (varVal > mx) then
chkRange$=varName$;" value (";varVal;") is out of range [";mn;", ";mx;"]"+chr$(13)
end if
end function
sub Delay sec 'now after pause you can check if QuitRequested
t=time$("ms")
while time$("ms")<t+sec*1000
scan
wend
exit sub
[quit]
QuitRequested=1
end sub
sub swapIndex idx1, idx2
tmp=Index(idx1):Index(idx1)=Index(idx2):Index(idx2)=tmp
end sub
sub initQBcolors
'thanks Andy Amaya
Colr$( 0) = " 0 0 0" 'black
Colr$( 1) = " 0 0 128" 'blue
Colr$( 2) = " 8 128 8" 'green
Colr$( 3) = " 0 128 128" 'cyan
Colr$( 4) = "128 0 0" 'red
Colr$( 5) = "128 0 128" 'magenta
Colr$( 6) = "128 64 32" 'brown
Colr$( 7) = "168 168 168" 'white
Colr$( 8) = "128 128 128" 'grey
Colr$( 9) = " 84 84 252" 'light blue
Colr$(10) = " 42 252 42" 'light green
Colr$(11) = " 0 220 220" 'light cyan
Colr$(12) = "255 0 0" 'light red
Colr$(13) = "255 84 255" 'light magenta
Colr$(14) = "255 255 0" 'yellow
Colr$(15) = "255 255 255" 'bright white
end sub
'conversions (logical coords to screen)
function sx(x)
'screen X. Depends on width, minX, maxX
sx = int((x- minX)/(maxX-minX) * width)
end function
function sy(y)
'screen Y. Depends on height, minY, maxY. Upside down.
sy = int((1-(y- minY)/(maxY-minY)) * height)
end function
'- Fast Filled Triangle sub by Andy Amaya ------------
Sub fillTriangle h$,x1, y1, x2, y2, x3, y3
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then x = x2 : y = y2 : x2 = x1 : y2 = y1 : x1 = x : y1 = y
'swap x1, y1, with x3, y3
If x3 < x1 Then x = x3 : y = y3 : x3 = x1 : y3 = y1 : x1 = x : y1 = y
'swap x2, y2 with x3, y3
If x3 < x2 Then x = x3 : y = y3 : x3 = x2 : y3 = y2 : x2 = x : y2 = y
If x1 <> x3 Then slope1 = (y3-y1)/(x3-x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2-y1)/(x2-x1)
For x = 0 To length
'if X is not integer, using INT on then will improve timing
#h$ "Line ";int(x+x1);" ";int(x*slope1+y1);" ";int(x+x1);" ";int(x*slope2+y1)
'#h$ "Line ";x+x1;" ";int(x*slope1+y1);" ";x+x1;" ";int(x*slope2+y1)
Next
End If
'draw the second half of the triangle
y = length*slope1+y1 : length = x3-x2
If length <> 0 Then
slope3 = (y3-y2)/(x3-x2)
For x = 0 To length
#h$ "Line ";int(x+x2);" ";int(x*slope1+y);" ";int(x+x2);" ";int(x*slope3+y2)
'#h$ "Line ";x+x2;" ";int(x*slope1+y);" ";x+x2;" ";int(x*slope3+y2)
Next
End If
End Sub
