Suggestions and constructive criticism are welcome.
Code: Select all
'-- Program: Epicycles
'-- Purpose: A demonstration of two-orbit epicycles
#Lang "fb"
Const As Double PI2 = 3.14159265 * 2
'Handy color constants
Enum COLORS
DARKGRAY = RGB(64,64,64)
BLUE = RGB(100,100,255)
GREEN = RGB(64,255,64)
CYAN = RGB(64,255,255)
RED = RGB(255,64,64)
MAGENTA = RGB(255,64,255)
YELLOW = RGB(255,255,0)
WHITE = RGB(255,255,255)
End Enum
Type ScreenPoint
x As Integer
y As Integer
End Type
Type ScreenType
h As Integer 'height
w As Integer 'width
c As Integer 'color depth
End Type
Dim As Integer ix
Dim As ScreenType st, su 'parameters of the video screen
Dim As Integer MaxC, MaxR 'parameters of the text grid
Dim As Integer MinX, MinY, MaxX, Maxy 'coordinates of the window
Dim As Integer r1, r2, r3 'radii of the circles
Dim As Integer rot1, rot2, rot3 'rotation direction of the radii
Dim As Integer step1, step2, step3 'rotation speed of the radii
Dim As ScreenPoint sp1, sp2, sp3 'centers of the circles
Dim As Double Angle1, Angle2, Angle3, AngleStep(1 To 3)
Dim As String sx
Declare Function FindCirclePoint(r As Integer, a As Double) As ScreenPoint
Declare Sub DrawExamples(sx As ScreenType, n As Integer)
Declare Function GetScreenParameters() as ScreenType
'-- initialize stuff
st = GetScreenParameters()
If Screenres(st.w, st.h, st.c, 3, &h08) Then '&h08 starts a window with no frame (GFX_NO_FRAME)
Print "Unable to start up graphics mode."
Print "The program will end."
Print "Press any key..."
Sleep
End
EndIf
'-- welcome and instructions
'initialize text mode grid
ix = Width()
MaxC = Loword(ix): MaxR = Hiword(ix) \ 2
Width MaxC, MaxR
'initialize graphics display to Cartesian coordinates with the origin at the center
Screenset 0, 0
MinX = -(st.w\2): MinY = -(st.h\2): MaxX = st.w\2: MaxY = st.h\2
Window (MinX, MinY) - (MaxX, MaxY)
Color MAGENTA: Print "Epicycles Demonstration 1.2"
Color CYAN: Print "Screen resolution is "; st.w; " wide x "; st.h; " high.": Print
Do
Locate 3,1: Print "Number of epicycles (1 or 2)";
Input ix
Loop Until (ix = 1) Or (ix = 2)
DrawExamples(st, ix)
Do
r1 = -1 'clear to an invalid value
Locate 3,1: Color CYAN: Print "Enter a value for the main circle radius r1 (0 to " & Str(MaxY * 0.5) & ")"
Print "Or 0 to quit."
Input r1
If r1 = 0 Then End
If r1 > 0 And r1 <= (MaxY * 0.5) Then Exit Do
Locate 5,1: Print " " 'clear the input
Color RED: Locate 6,1: Print "Try again please."
Loop
Do
Locate 6,1: Color CYAN: Print "Rotate clockwise (CW) or counterclockwise (CCW)"
Input sx
Select case sx
Case "CW", "cw":
rot1 = -1
Exit Do
Case "CCW", "ccw"
rot1 = 1
Exit Do
Case Else
Locate 7,1: Print " " 'clear the input
Color RED: Locate 8,1: Print "Try again please."
End Select
Loop
Do
Locate 8,1:Color CYAN: Print "Rotational speed (1, 2 or 3)?"
Input sx
Select Case sx
Case "1"
step1 = 1
Exit Do
Case "2"
step1 = 2
Exit Do
Case "3"
step1 = 3
Exit Do
Case Else
Locate 9,1: Print " " 'clear the input
Color RED: Locate 10,1: Print "Try again please."
End Select
Loop
Do
r2 = -1 'clear to an invalid value
Locate 10,1: Color CYAN: Print "Enter a value for the orbiting circle radius r2 (0 to " & Str(MaxY * 0.50) & ")"
Input r2
If r2 > 0 And r2 <= (MaxY * 0.50) Then Exit Do
Locate 11,1: Print " "
Color RED: Locate 12,1: Print "Try again please."
Loop
Do
Locate 12,1: Color CYAN: Print "Rotate clockwise (CW) or counterclockwise (CCW)"
Input sx
Select case sx
Case "CW", "cw":
rot2 = -1
Exit Do
Case "CCW", "ccw"
rot2 = 1
Exit Do
Case Else
Locate 13,1: Print " " 'clear the input
Color RED: Locate 14,1: Print"Try again please."
End Select
Loop
Do
Locate 14,1: Color CYAN: Print "Rotational speed (1, 2 or 3)?"
Input sx
Select Case sx
Case "1"
step2 = 1
Exit Do
Case "2"
step2 = 2
Exit Do
Case "3"
step2 = 3
Exit Do
Case Else
Locate 15,1: Print " " 'clear the input
Color RED: Locate 16,1: Print "Try again please."
End Select
Loop
If (ix = 2) Then
Do
r3 = -1 'clear to an invalid value
Locate 16,1: Color CYAN: Print "Enter a value for the orbiting circle radius r2 (0 to " & Str(MaxY * 0.25) & ")"
Input r3
If r3 > 0 And r3 <= (MaxY * 0.25) Then Exit Do
Locate 17,1: Print " "
Color RED: Locate 18,1: Print "Try again please."
Loop
Do
Locate 18,1: Color CYAN: Print "Rotate clockwise (CW) or counterclockwise (CCW)"
Input sx
Select Case sx
Case "CW", "cw":
rot3 = -1
Exit Do
Case "CCW", "ccw"
rot3 = 1
Exit Do
Case Else
Locate 19,1: Print " " 'clear the input
Color RED: Locate 20,1: Print"Try again please."
End Select
Loop
Do
Locate 20,1:Color CYAN: Print "Rotational speed (1, 2 or 3)?"
Input sx
Select Case sx
Case "1"
step3 = 1
Exit Do
Case "2"
step3 = 2
Exit Do
Case "3"
step3 = 3
Exit Do
Case Else
Locate 21,1: Print " " 'clear the input
Color RED: Locate 22,1: Print "Try again please."
End Select
Loop
EndIf
Print "Press any key to begin."
Sleep
'-- now the fun stuff
'Use the horizontal screen size as the step size to orbit the satellite.
'use the vertical screen size to orbit the epicycle
AngleStep(1) = PI2 / st.w
AngleStep(2) = PI2 / st.h
AngleStep(3) = AngleStep(1) * 3
Angle1 = Angle2 = Angle3 = 0
'set up the video page for tracking the end point
Screenset 2, 0: Cls
Do
While Inkey <> "": Wend 'clear the key buffer
Screencopy 2, 1
Screenset 1, 0
Color CYAN: Locate 1,1: Print "Press any key to exit."
Angle1 = Angle1 + AngleStep(step1) * rot1
If Angle1 > PI2 Then Angle1 = 0 'gone around one full revolution
sp1 = FindCirclePoint(r1, Angle1)
Angle2 = Angle2 + AngleStep(step2) * rot2
If Angle2 > PI2 Then Angle2 = 0 'gone around one full revolution
sp2 = FindCirclePoint(r2, Angle2)
sp2.x += sp1.x: sp2.y += sp1.y
Angle3 = Angle3 + AngleStep(step3) * rot3
If Angle3 > PI2 Then Angle3 = 0 'gone around one full revolution
sp3 = FindCirclePoint(r3, Angle3)
sp3.x += sp2.x: sp3.y += sp2.y
'Axes
Line (MinX, 0)-(MaxX, 0), DARKGRAY
Line (0, MinY)-(0 ,MaxY), DARKGRAY
'Circles
' Circle (0,0), r1, RED
Circle (0,0), 2, WHITE
' Circle (sp1.x, sp1.y), r2, BLUE
Circle (sp1.x, sp1.y), 2, WHITE
Circle (sp2.x, sp2.Y), 2, WHITE
Circle (sp3.x, sp3.y), 2, WHITE
'Pointer lines
Line (0,0) - (sp1.x,sp1.y), MAGENTA
Line (sp1.x, sp1.y) - (sp2.x, sp2.y), YELLOW
Line (sp2.x, sp2.y) - (sp3.x, sp3.y), GREEN
'track the epicycle
Screenset 2, 0
Pset (sp3.x, sp3.y), BLUE
Screencopy 1, 0
' Sleep 2
Loop While Inkey = ""
End
Function FindCirclePoint(r As Integer, a As Double) As Screenpoint
'-- Function calculates point on a circle, given the center point,
'-- the radius from the center point and the rotation angle.
'-- Assumes the circle center is at the origin.
Dim sp As ScreenPoint
'-- Using the classic trig equations x = r cos theta and y = r sin theta
sp.x = Int(r * Cos(a))
sp.y = Int(r * Sin(a))
Return sp
End Function
Sub DrawExamples(st As Screentype, n As Integer)
Dim As ScreenPoint sp2, sp3
'-- draw the example circles
Circle (0, 0), 2, WHITE,,,,F 'center of main circle
Circle (0, 0), st.h\4, RED 'main circle
sp2 = FindCirclePoint(st.h\4, PI2 / 8.0)
Circle (sp2.x, sp2.y), 2, WHITE,,,,F 'center of orbiting circle
Circle (sp2.x, sp2.y), st.h\6, RED 'orbiting circle
sp3 = FindCirclePoint(st.h\12, PI2 - PI2 / 8.0)
sp3.x += sp2.x +st.h\6: sp3.y += sp2.y
Circle (sp2.x + st.h\6, sp2.y), 2, WHITE,,,,F 'center of orbiting circle
Line (0,0)-(sp2.x,sp2.y), MAGENTA 'main circle radius
Line (sp2.x,sp2.y)-((sp2.x + st.h\6),sp2.y), YELLOW 'orbiting circle radius
Draw String (20,0), "Main circle radius r1", WHITE
Draw String (sp2.x + 10, sp2.y + 20), "Orbiting circle radius r2", WHITE
If (n = 2) Then
Circle (sp2.x + st.h\6, sp2.y), st.h\12, RED 'orbiting cirle
Line (sp2.x + st.h\6, sp2.y)-(sp3.x, sp3.y), GREEN 'orbiting circle radius
Draw String (sp3.x + 10, sp3.y), "Orbiting Circle raduis r3", WHITE
EndIf
End Sub
Function GetScreenParameters() as ScreenType
'-- Returns the highest resolution and color depth available on the monitor
Dim As Integer mode
Dim As ScreenType st
'see if 24/32 bit is supported
mode = ScreenList(32)
If mode Then
st.c = 32
While (mode)
st.w = HiWord(mode)
st.h = LoWord(mode)
mode = ScreenList
Wend
'done reading modes
Return st
EndIf
'see if 15/16 bit is supported
mode = ScreenList(16)
If mode Then
st.c = 16
While (mode)
st.w = HiWord(mode)
st.h = LoWord(mode)
mode = ScreenList
Wend
'done reading modes
Return st
EndIf
'8 bit is supported for certain
mode = ScreenList(8)
st.c = 8
While (mode)
st.w = HiWord(mode)
st.h = LoWord(mode)
mode = ScreenList
Wend
'done reading modes
Return st
End Function