Epicycles

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

Epicycles

Post by Linuxbob »

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

Post Reply