## Epicycles

User projects written in or related to FreeBASIC.
Linuxbob
Posts: 60
Joined: Sep 01, 2010 1:03
Location: Ohio, USA

### Epicycles

So, I was interested in exploring a bit of FB animation and graphics programming. But, being a professional engineer, I also like mathematical applications.

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
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
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