The Antikythera mechanism

User projects written in or related to FreeBASIC.
Post Reply
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

The Antikythera mechanism

Post by angros47 »

I guess most of you know the Antikythera mechanism https://en.wikipedia.org/wiki/Antikythera_mechanism, the first "computer" ever realized.

In 2003, a developer who used the nickname Lysozyme made an interactive simulator of it, written in Blitz3D:

https://www.demonews.com/download/the-a ... mechanism/

Since the source code is included, I tried porting it to FreeBasic+OpenB3D. Here is the ported version:

Code: Select all

#include "openb3d.bi"
const Pi=3.14159265358

screenres 800,600,  32, , &h10002
   
Graphics3d 800,600,32,1,1

'TEXTURES
Dim shared as any ptr PolkaDotTex(7),BronzeGearTex(225) '225=Drive Wheel Texture
For a as integer=1 To 7
	PolkaDotTex(a)=LoadTexture("Textures\color"+str(a)+".jpg")
Next
Dim shared as any ptr BronzeTex: BronzeTex=LoadTexture("Textures\Bronze.jpg")
Dim shared as any ptr CrankTex: CrankTex=LoadTexture("Textures\Crank.jpg")
Dim shared as any ptr SunPointerTex: SunPointerTex=LoadTexture("Textures\Pointer Sun.jpg")
Dim shared as any ptr MoonPointerTex: MoonPointerTex=LoadTexture("Textures\Pointer Moon.jpg")
Dim shared as any ptr CrownGearTex: CrownGearTex=LoadTexture("Textures\Crown Gear.jpg")
Dim shared as any ptr FrontPanelTex: FrontPanelTex=LoadTexture("Textures\Front Panel.jpg")
Dim shared as any ptr RearPanelTex: RearPanelTex=LoadTexture("Textures\Rear Panel.jpg")
Dim shared as any ptr SmallDialTex: SmallDialTex=LoadTexture("Textures\Small Dial.jpg")
BronzeGearTex(15)=LoadTexture("Textures\15 Tooth Gear.jpg")
BronzeGearTex(16)=LoadTexture("Textures\16 Tooth Gear.jpg")
BronzeGearTex(20)=LoadTexture("Textures\20 Tooth Gear.jpg")
BronzeGearTex(24)=LoadTexture("Textures\24 Tooth Gear.jpg")
BronzeGearTex(30)=LoadTexture("Textures\30 Tooth Gear.jpg")
BronzeGearTex(32)=LoadTexture("Textures\32 Tooth Gear.jpg")
BronzeGearTex(36)=LoadTexture("Textures\36 Tooth Gear.jpg")
BronzeGearTex(38)=LoadTexture("Textures\38 Tooth Gear.jpg")
BronzeGearTex(48)=LoadTexture("Textures\48 Tooth Gear.jpg")
BronzeGearTex(54)=LoadTexture("Textures\54 Tooth Gear.jpg")
BronzeGearTex(60)=LoadTexture("Textures\60 Tooth Gear.jpg")
BronzeGearTex(64)=LoadTexture("Textures\64 Tooth Gear.jpg")
BronzeGearTex(96)=LoadTexture("Textures\96 Tooth Gear.jpg")
BronzeGearTex(127)=LoadTexture("Textures\127 Tooth Gear.jpg")
BronzeGearTex(192)=LoadTexture("Textures\192 Tooth Gear.jpg")
BronzeGearTex(222)=LoadTexture("Textures\222 Tooth Gear.jpg")
BronzeGearTex(225)=LoadTexture("Textures\Drive Wheel.jpg")

'GEARS (5 teeth=1 cm)
Dim shared as any ptr GearMesh: GearMesh=LoadMesh("Models\Flat Gear.b3d"):HideEntity GearMesh
Dim shared as any ptr CrankMesh: CrankMesh=LoadMesh("Models\Crank.b3d")
Dim shared Gear(50) as any ptr
dim shared NumGears as integer
Read NumGears
Gear(1)=LoadMesh("Models\Crown Gear.b3d")
Gear(2)=LoadMesh("Models\Drive Wheel.b3d")
Gear(3)=LoadMesh("Models\Drive Wheel.b3d")
For a as integer =4 To NumGears
	Gear(a)=CopyMesh(GearMesh)
Next

'SPRITES
Dim shared as any ptr GearToothCountSprite(225),ToothCount(300)
GearToothCountSprite(15)=LoadSprite("Sprites\15.jpg")
GearToothCountSprite(16)=LoadSprite("Sprites\16.jpg")
GearToothCountSprite(20)=LoadSprite("Sprites\20.jpg")
GearToothCountSprite(24)=LoadSprite("Sprites\24.jpg")
GearToothCountSprite(30)=LoadSprite("Sprites\30.jpg")
GearToothCountSprite(32)=LoadSprite("Sprites\32.jpg")
GearToothCountSprite(36)=LoadSprite("Sprites\36.jpg")
GearToothCountSprite(38)=LoadSprite("Sprites\38.jpg")
GearToothCountSprite(45)=LoadSprite("Sprites\45.jpg")
GearToothCountSprite(48)=LoadSprite("Sprites\48.jpg")
GearToothCountSprite(54)=LoadSprite("Sprites\54.jpg")
GearToothCountSprite(60)=LoadSprite("Sprites\60.jpg")
GearToothCountSprite(64)=LoadSprite("Sprites\64.jpg")
GearToothCountSprite(96)=LoadSprite("Sprites\96.jpg")
GearToothCountSprite(127)=LoadSprite("Sprites\127.jpg")
GearToothCountSprite(192)=LoadSprite("Sprites\192.jpg")
GearToothCountSprite(222)=LoadSprite("Sprites\222.jpg")
GearToothCountSprite(225)=LoadSprite("Sprites\225.jpg")
dim shared as any ptr SunAndMoonSprite: SunAndMoonSprite=LoadSprite("Sprites\Sun and Moon.png",3)
dim shared as any ptr SynodicMonthSprite: SynodicMonthSprite=LoadSprite("Sprites\Synodic Month.png",3)
dim shared as any ptr FourYearSprite: FourYearSprite=LoadSprite("Sprites\Four Year Dial.png",3)
For a as integer=1 To 225
	If GearToothCountSprite(a)<>0 Then HideEntity GearToothCountSprite(a)
Next

'AXLES
Dim shared as any ptr Axle(15)
Dim shared as any ptr AxleMesh: AxleMesh=LoadMesh("Models\Axle.b3d"):HideEntity AxleMesh
For a as integer=1 To 11:Axle(a)=CopyEntity(AxleMesh):EntityTexture Axle(a),BronzeTex:Next

'SMALL DIALS
Dim shared as any ptr AuxiliaryDialMesh:AuxiliaryDialMesh=LoadMesh("Models\Small Dial.b3d")
Dim shared as any ptr LunarYearDialMesh:LunarYearDialMesh=CopyMesh(AuxiliaryDialMesh)
EntityTexture AuxiliaryDialMesh,SmallDialTex
EntityTexture LunarYearDialMesh,SmallDialTex

'POINTERS
Dim shared as any ptr SunPointerMesh:SunPointerMesh=LoadMesh("Models\pointer.b3d")
Dim shared as any ptr MoonPointerMesh:MoonPointerMesh=CopyMesh(SunPointerMesh)
Dim shared as any ptr FourYearPointerMesh:FourYearPointerMesh=CopyMesh(SunPointerMesh)
Dim shared as any ptr SynodicMonthPointerMesh:SynodicMonthPointerMesh=CopyMesh(SunPointerMesh)
EntityTexture SunPointerMesh,SunPointerTex
EntityTexture MoonPointerMesh,MoonPointerTex
EntityTexture FourYearPointerMesh,BronzeTex
EntityTexture SynodicMonthPointerMesh,BronzeTex

'PANELS
Dim shared as any ptr FrontPanelMesh:FrontPanelMesh=LoadMesh("Models\Panel1.b3d")
Dim shared as any ptr RearPanelMesh:RearPanelMesh=CopyMesh(FrontPanelMesh)
Dim shared as any ptr SidePanelLongMesh1:SidePanelLongMesh1=LoadMesh("Models\Panel2.b3d")
Dim shared as any ptr SidePanelLongMesh2:SidePanelLongMesh2=CopyMesh(SidePanelLongMesh1)
Dim shared as any ptr SidePanelShortMesh1:SidePanelShortMesh1=CopyMesh(SidePanelLongMesh1)
Dim shared as any ptr SidePanelShortMesh2:SidePanelShortMesh2=CopyMesh(SidePanelLongMesh1)
Dim shared as any ptr BasePlateMesh:BasePlateMesh=CopyMesh(SidePanelLongMesh1)
EntityTexture FrontPanelMesh,FrontPanelTex
EntityTexture RearPanelMesh,RearPanelTex
EntityTexture SidePanelLongMesh1,RearPanelTex
EntityTexture SidePanelLongMesh2,RearPanelTex
EntityTexture SidePanelShortMesh1,RearPanelTex
EntityTexture SidePanelShortMesh2,RearPanelTex
EntityTexture BasePlateMesh,RearPanelTex

'2D STUFF
'Global TitleScreenImg=LoadImage("Sprites\Title Screen.jpg")

'CAMERA
Dim shared as any ptr CameraPivot:CameraPivot=CreatePivot()
Dim shared as any ptr Camera:Camera=CreateCamera()
CameraProjMode Camera,1

'LIGHTS
Dim shared as any ptr Light1:Light1=CreateLight(1)
Dim shared as any ptr Light2:Light2=CreateLight(1)

'VARIABLES
Dim shared GearTurned(50) as integer,GearLoc(50,3) as single,GearAng(50,3) as single,GearTeeth(50) as integer,GearPolkaDot(50) as integer,AxlePolkaDot(50) as integer,GearLink(50,4) as integer,GearLinkDir(50,4) as integer,GearAmtTurned(50) as single  '1=same dir, -1=opp dir  2=Linked (same speed, same dir)
dim shared CurrGear as integer,TargetGear as integer,BronzeTexture as integer,TurnSpeed as integer
Dim shared AlphaValue(6) as single, AlphaToggle(6) as integer





'Teeth,Polka Dot x,y,x, ax,ay,az, link/dir x 4
Data 33
'1
Data 45,2,		-3,0,0,				0,0,-90,	2,1,	3,-1,	0,0,	0,0
Data 225,1,		35.81,7.16,0,		0,0,0,		1,1,	0,0,	0,0,	0,0
Data 225,5,		35.81,-7.16,0,		0,0,0,		1,-1,	4,2,	0,0,	0,0
Data 64,5,		35.81,-15,0,		0,0,0,		3,2,	5,2,	11,-1,	0,0
Data 32,5,		35.81,-20,0,		0,0,0,		4,2,	6,-1,	18,-1,	0,0
'6
Data 38,3,		38.24,-15,16,		0,0,0,		4,-1,	7,2,	0,0,	0,0
Data 48,3,		38.24,-17,16,		0,0,0,		6,2,	8,-1,	0,0,	0,0
Data 24,7,		47.8,-17,22.2,		0,0,0,		7,-1,	9,2,	0,0,	0,0
Data 127,7,		47.8,-25,22.2,		0,0,0,		8,2,	10,-1,	0,0,	0,0
Data 32,4,		35.81,-25,0,		0,0,0,		9,-1,	25,-1,	0,0,	0,0
'11
Data 36,3,		26.2,-15,-12.4,		0,0,0,		4,-1,	12,2,	0,0,	0,0
Data 54,3,		26.2,-17,-12.4,		0,0,0,		11,2,	13,-1,	0,0,	0,0
Data 96,1,		38.9,-17,-32.6,		0,0,0,		12,-1,	14,2,	0,0,	0,0
Data 16,1,		38.9,-25,-32.6,		0,0,0,		13,2,	15,-1,	0,0,	0,0
Data 64,5,		35.81,-25,-44.9,	0,0,0,		14,-1,	16,-1,	0,0,	0,0
'16
Data 32,7,		50.84,-25,-42.4,	0,0,0,		17,2,	15,-1,	0,0,	0,0
Data 48,7,		50.84,-29,-42.4,	0,0,0,		16,2,	0,0,	0,0,	0,0
Data 32,3,		27.23,-20,5.3,		0,0,0,		5,-1,	19,2,	0,0,	0,0
Data 48,3,		27.23,-38,5.3,		0,0,0,		18,2,	0,0,	0,0,	0,0  
'20-22 (moving differential gears)
Data 48,1,		13.85,-38,-1.9,		0,0,0,		0,0,	21,2,	0,0,	0,0  
Data 32,1,		13.85,-32,-1.9,		0,0,0,		20,2,	22,-1,	0,0,	0,0  
Data 64,5,		14.4,-32,13.4,		0,0,0,		26,-1,	21,-1,	0,0,	0,0  
'23-24 (differential turntable)
Data 222,6,		27.23,-34,5.3,		0,0,0,		24,2,	0,0,	0,0,	0,0
Data 192,6,		27.23,-36,5.3,		0,0,0,		23,2,	27,-1,	0,0,	0,0
'25-26
Data 32,2,		27.23,-25,5.3,		0,0,0,		10,-1,	26,2,	0,0,	0,0		
Data 32,2,		27.23,-32,5.3,		0,0,0,		25,2,	22,-1,	0,0,	0,0   
'data 27
Data 48,3,		21.8,-36,43.1,		0,0,0,		24,-1,	28,2,	0,0,	0,0
Data 30,3,		21.8,-38,43.1,		0,0,0,		27,2,	29,-1,	0,0,	0,0
Data 60,4,		35.91,-38,45.3,		0,0,0,		28,-1,	30,2,	0,0,	0,0
Data 20,4,		35.91,-40,45.3,		0,0,0,		29,2,	31,-1,	0,0,	0,0
Data 60,5,		48.2,-40,47.4,		0,0,0,		30,-1,	32,2,	0,0,	0,0
Data 15,5,		48.2,-42,47.4,		0,0,0,		31,2,	33,-1,	0,0,	0,0
Data 60,2,		55.2,-42,37.9,		0,0,0,		32,-1,	0,0,	0,0,	0,0

Data 4,5,4,2,5,7,1,7,2,3,1



Sub ScaleMeshToBox(Mesh as any ptr,x as single,y as single,z as single)
	FitMesh Mesh,0,0,0,x,y,z
	PositionMesh Mesh,-x/2,-y/2,-z/2
End Sub

Sub SetUpScene()
	For a as integer=1 To 5:AlphaValue(a)=1:AlphaToggle(a)=1:Next:AlphaToggle(6)=0
	CurrGear=1:TargetGear=5:BronzeTexture=True:TurnSpeed=1
	For a as integer=1 To NumGears
		Read GearTeeth(a),GearPolkaDot(a)
		For b as integer=1 To 3:Read GearLoc(a,b):Next
		For b as integer=1 To 3:Read GearAng(a,b):Next
		For b as integer=1 To 4:Read GearLink(a,b),GearLinkDir(a,b):Next
	Next
	
	For a as integer=1 To 11:Read AxlePolkaDot(a):Next
	
	For a as integer=1 To NumGears
		PositionEntity Gear(a),GearLoc(a,1),GearLoc(a,2),GearLoc(a,3)
		RotateEntity Gear(a),GearAng(a,1),GearAng(a,2),GearAng(a,3)
		dim sc as single=GearTeeth(a)/Pi:dim h as single=2
		If a=1 Then h=6
		ScaleMeshToBox Gear(a),sc,h,sc
		EntityAlpha Gear(a),1
	Next
	
	dim as integer n=0
	'Position Tooth Counts
	For a as integer=1 To NumGears
		For b as integer=1 To 4
			n=n+1:ToothCount(n)=CopyEntity(GearToothCountSprite(GearTeeth(a)))
			dim as single x,y,z,sc, xx,yy,zz
			x=EntityX(Gear(a)):y=EntityY(Gear(a)):z=EntityZ(Gear(a)):sc=(GearTeeth(a)/Pi)/2+1
			If a=1 Then
				If b=1 Then yy=y+sc:zz=z
				If b=2 Then yy=y-sc:zz=z
				If b=3 Then yy=y:zz=z+sc
				If b=4 Then yy=y:zz=z-sc
				xx=x			
			Else
				If b=1 Then xx=x+sc:zz=z
				If b=2 Then xx=x-sc:zz=z
				If b=3 Then xx=x:zz=z+sc
				If b=4 Then xx=x:zz=z-sc
				yy=y
			EndIf
			PositionEntity ToothCount(n),xx,yy,zz
			EntityParent ToothCount(n),Gear(a)
		Next
	Next
	
	
	EntityParent Gear(21),Gear(23)
	EntityParent Gear(20),Gear(23)
	EntityParent Gear(22),Gear(23)

	ScaleMeshToBox CrankMesh,24,24,24
	RotateEntity CrankMesh,0,180,90:PositionEntity CrankMesh,-17.5,0,0:EntityParent CrankMesh,Gear(1)

	PositionEntity SunPointerMesh,35.81,15,0:ScaleEntity SunPointerMesh,0.13,0.20,0.13
	PositionEntity MoonPointerMesh,35.81,17,0:ScaleEntity MoonPointerMesh,0.09,0.20,0.09
	PositionEntity FourYearPointerMesh,35.81,-51,-44.9:ScaleEntity FourYearPointerMesh,0.11,0.20,0.11
	PositionEntity SynodicMonthPointerMesh,35.91,-51,45.3:ScaleEntity SynodicMonthPointerMesh,0.11,0.20,0.11
	RotateEntity SunPointerMesh,0,90,0
	RotateEntity MoonPointerMesh,0,90,0
	RotateEntity FourYearPointerMesh,0,90,0
	RotateEntity SynodicMonthPointerMesh,0,90,0
	
	PositionEntity SunAndMoonSprite,35.81,25,0:ScaleSprite SunAndMoonSprite,10,10
	PositionEntity FourYearSprite,35.81,-61,-44.9:ScaleSprite FourYearSprite,10,10
	PositionEntity SynodicMonthSprite,35.81,-61,45.3:ScaleSprite SynodicMonthSprite,10,10
	
	EntityParent SunPointerMesh,Gear(2):EntityParent MoonPointerMesh,Gear(10)
	EntityParent FourYearPointerMesh,Gear(15):EntityParent SynodicMonthPointerMesh,Gear(30)

	PositionEntity AuxiliaryDialMesh,EntityX(Gear(17)),-48,EntityZ(Gear(17)):ScaleMeshToBox AuxiliaryDialMesh,15,2,15
	PositionEntity LunarYearDialMesh,EntityX(Gear(33)),-48,EntityZ(Gear(33)):ScaleMeshToBox LunarYearDialMesh,15,2,15
	EntityParent AuxiliaryDialMesh,Gear(17):EntityParent LunarYearDialMesh,Gear(33)
	
	PositionEntity FrontPanelMesh,35.81,12,0:ScaleMeshToBox FrontPanelMesh,90,1,180
	PositionEntity RearPanelMesh,35.81,-48,0:ScaleMeshToBox RearPanelMesh,90,1,180
	PositionEntity BasePlateMesh,35.81,-22,0:ScaleMeshToBox BasePlateMesh,90,1,180
	
	ScaleMeshToBox SidePanelLongMesh1,60,1,180:PositionEntity SidePanelLongMesh1,-9.5,-18,0:RotateEntity SidePanelLongMesh1,0,0,90
	ScaleMeshToBox SidePanelLongMesh2,60,1,180:PositionEntity SidePanelLongMesh2,81,-18,0:RotateEntity SidePanelLongMesh2,0,0,90
	ScaleMeshToBox SidePanelShortMesh1,60,1,90:PositionEntity SidePanelShortMesh1,35.81,-18,-90:RotateEntity SidePanelShortMesh1,0,90,90
	ScaleMeshToBox SidePanelShortMesh2,60,1,90:PositionEntity SidePanelShortMesh2,35.81,-18,90:RotateEntity SidePanelShortMesh2,0,90,90
	
	PositionEntity Axle(1),EntityX(Gear(10)),EntityY(Gear(10)),EntityZ(Gear(10)):ScaleEntity Axle(1),1,42,1
	PositionEntity Axle(2),EntityX(Gear(5)),EntityY(Gear(5)),EntityZ(Gear(5)):ScaleEntity Axle(2),2,13,2
	PositionEntity Axle(3),EntityX(Gear(30)),EntityY(Gear(30)),EntityZ(Gear(30)):RotateEntity Axle(3),180,0,0:ScaleEntity Axle(3),1,10,1
	PositionEntity Axle(4),EntityX(Gear(33)),EntityY(Gear(33)),EntityZ(Gear(33)):RotateEntity Axle(4),180,0,0:ScaleEntity Axle(4),1,6,1
	PositionEntity Axle(5),EntityX(Gear(15)),EntityY(Gear(15)),EntityZ(Gear(15)):RotateEntity Axle(5),180,0,0:ScaleEntity Axle(5),1,25,1
	PositionEntity Axle(6),EntityX(Gear(16)),EntityY(Gear(16)),EntityZ(Gear(16)):RotateEntity Axle(6),180,0,0:ScaleEntity Axle(6),1,22,1
	PositionEntity Axle(7),EntityX(Gear(14)),EntityY(Gear(14)),EntityZ(Gear(14)):ScaleEntity Axle(7),1,8.5,1
	PositionEntity Axle(8),EntityX(Gear(9)),EntityY(Gear(9)),EntityZ(Gear(9)):ScaleEntity Axle(8),1,8.5,1
	PositionEntity Axle(9),EntityX(Gear(26)),EntityY(Gear(26)),EntityZ(Gear(26)):ScaleEntity Axle(9),2,7,2
	PositionEntity Axle(10),EntityX(Gear(19)),EntityY(Gear(19)),EntityZ(Gear(19)):ScaleEntity Axle(10),1,18,1
	PositionEntity Axle(11),EntityX(Gear(2)),EntityY(Gear(2)),EntityZ(Gear(2)):ScaleEntity Axle(11),2,8.5,2
	
	EntityParent Axle(1),Gear(10)
	EntityParent Axle(2),Gear(5)
	EntityParent Axle(3),Gear(30)
	EntityParent Axle(4),Gear(33)
	EntityParent Axle(5),Gear(15)
	EntityParent Axle(6),Gear(17)
	EntityParent Axle(7),Gear(14)
	EntityParent Axle(8),Gear(8)
	EntityParent Axle(9),Gear(26)
	EntityParent Axle(10),Gear(19)
	EntityParent Axle(11),Gear(2)
	
	PositionEntity Camera,20,0,-200
	PositionEntity CameraPivot,EntityX(Gear(5)),EntityY(Gear(5)),EntityZ(Gear(5)):PointEntity Camera,CameraPivot
	EntityParent Camera,CameraPivot
	RotateEntity CameraPivot,-20,0,0
	
	PositionEntity Light1,0,-100,0:RotateEntity Light1,-90,0,0
	PositionEntity Light2,0,100,0:RotateEntity Light2,90,0,0
End Sub

Sub SetUpBronzeGearTextures()
	EntityTexture CrankMesh,CrankTex
	EntityTexture Gear(1),CrownGearTex
	For g as integer=2 To 33
		EntityTexture Gear(g),BronzeGearTex(GearTeeth(g))
	Next
	For a as integer=1 To 11:EntityTexture Axle(a),BronzeTex:Next
End Sub

Sub SetUpPolkaDotTextures()
	For g as integer=1 To 33
		EntityTexture Gear(g),PolkaDotTex(GearPolkaDot(g))
	Next
	For a as integer=1 To 11
		EntityTexture Axle(a),PolkaDotTex(AxlePolkaDot(a))
	Next
End Sub

Sub UpdateTransparencies()
	For a as integer=1 To 6
		If AlphaToggle(a)=1 Then
			AlphaValue(a)=AlphaValue(a)+0.025
			If AlphaValue(a)>1 Then AlphaValue(a)=1
		Else
			AlphaValue(a)=AlphaValue(a)-0.025
			If AlphaValue(a)<0 Then AlphaValue(a)=0
		EndIf
		'Side Panels
		If a=1 Then
			EntityAlpha SidePanelLongMesh1,AlphaValue(a)
			EntityAlpha SidePanelLongMesh2,AlphaValue(a)
			EntityAlpha SidePanelShortMesh1,AlphaValue(a)
			EntityAlpha SidePanelShortMesh2,AlphaValue(a)
		EndIf
		'Front/Back Panels
		If a=2 Then
			EntityAlpha FrontPanelMesh,AlphaValue(a)
			EntityAlpha RearPanelMesh,AlphaValue(a)
		EndIf
		'Base Plate
		If a=3 Then
			EntityAlpha BasePlateMesh,AlphaValue(a)
		EndIf
		'Gears+Pointers
		If a=4 Then
			For g as integer=1 To 33
				EntityAlpha Gear(g),AlphaValue(a)
			Next
			EntityAlpha SunPointerMesh,AlphaValue(a)
			EntityAlpha MoonPointerMesh,AlphaValue(a)
			EntityAlpha FourYearPointerMesh,AlphaValue(a)
			EntityAlpha SynodicMonthPointerMesh,AlphaValue(a)
		EndIf
		'Axles
		If a=5 Then
			For g as integer=1 To 11
				EntityAlpha Axle(g),AlphaValue(a)
			Next
		EndIf
		If a=6 Then
			For tc as integer=1 To 132
				EntityAlpha ToothCount(tc),AlphaValue(a)
			Next
			EntityAlpha SunAndMoonSprite,AlphaValue(a)
			EntityAlpha SynodicMonthSprite,AlphaValue(a)
			EntityAlpha FourYearSprite,AlphaValue(a)
		EndIf
	Next
End Sub

Sub UpdateGear(g as integer,direction as single)  ' negative direction is clockwise
If direction=0 Then Return
For l as integer=1 To 4
	If GearLink(g,l)<>0 And GearTurned(GearLink(g,l))=False Then
		dim a1 as single=GearTeeth(g): dim a2 as single=GearTeeth(GearLink(g,l)):dim ratio as single=a1/a2
		GearAmtTurned(GearLink(g,l))=direction*GearLinkDir(g,l)*ratio 
		If GearLinkDir(g,l)=2 Then GearAmtTurned(GearLink(g,l))=direction
		TurnEntity Gear(GearLink(g,l)),0,GearAmtTurned(GearLink(g,l)),0
		GearTurned(GearLink(g,l))=True
	EndIf
Next
End Sub

Sub TurnGears(InputGear as integer,direction as single) 'negative direction is clockwise
	For a as integer=1 To 50:GearTurned(a)=False:GearAmtTurned(a)=0:Next
	
	TurnEntity Gear(InputGear),0,direction,0:GearTurned(InputGear)=True:GearAmtTurned(InputGear)=direction
	'links to input gear
	
	For g2 as integer=1 To Numgears
		For g as integer=1 To NumGears
			UpdateGear(g,GearAmtTurned(g))
		Next
		If g2=6 Then UpdateGear(23,(GearAmtTurned(26)+GearAmtTurned(19))/2)
	Next
End Sub





SetUpScene
SetUpBronzeGearTextures

setmouse 400,300,0

While Not MultiKey(1)
	dim kk as integer=asc(inkey)
	if kk=asc("1") then AlphaToggle(1)=1-AlphaToggle(1)
	if kk=asc("2") then AlphaToggle(2)=1-AlphaToggle(2)
	if kk=asc("3") then AlphaToggle(3)=1-AlphaToggle(3)
	if kk=asc("4") then AlphaToggle(4)=1-AlphaToggle(4)
	if kk=asc("5") then AlphaToggle(5)=1-AlphaToggle(5)
	if kk=asc("6") then AlphaToggle(6)=1-AlphaToggle(6)

	If kk=asc("G") Or kk=asc("g") Then
		TargetGear=TargetGear+1
		If TargetGear>33 Then TargetGear=1
		PositionEntity CameraPivot,EntityX(Gear(TargetGear)),EntityY(Gear(TargetGear)),EntityZ(Gear(TargetGear))
	EndIf
	If kk=asc("B") Or kk=asc("b") Then
		If BronzeTexture=True Then BronzeTexture=False Else BronzeTexture=True
		If BronzeTexture=True Then SetUpBronzeGearTextures Else SetUpPolkaDotTextures
	EndIf
	If kk=Asc("T") Or kk=Asc("t") Then 
		TurnSpeed=TurnSpeed+1
		If TurnSpeed>3 Then TurnSpeed=1
	EndIf

	'MOUSE CONTROLS
	dim mx as integer, my as integer, mousedown as integer
	getmouse mx, my, ,mousedown
	mx-=400: my-=300
	if mousedown=0 then
		TurnEntity CameraPivot,-my,-mx,0
	else
		MoveEntity Camera,0,0,-my
		If EntityDistance(Camera,CameraPivot)<5 Or EntityDistance(Camera,CameraPivot)>200 Then MoveEntity Camera,0,0,my
	end if

	setmouse 400,300,0


	If MultiKey(&h4d) Then TurnGears(1,-1*(TurnSpeed^2)) 'right arrow, clockwise
	If MultiKey(&h4b) Then TurnGears(1,TurnSpeed^2)  'left arrow,  counterclockwise

	Dim c as integer=0
	If kk=Asc("q") Then c=1
	If kk=Asc("a") Then c=-1
	If c<>0 Then
		EntityAlpha Gear(CurrGear),1
		CurrGear=CurrGear+c
		If Currgear>NumGears Then CurrGear=1
		If CurrGear<1 Then CurrGear=NumGears
		EntityAlpha Gear(CurrGear),1
	EndIf

	UpdateTransparencies
	UpdateWorld
	RenderWorld
	sleep 1
	flip
Wend

It requires my library OpenB3D that can be downloaded from https://sourceforge.net/projects/minib3d/files/
It also requires the 3d models and the textures from the original package (it is freeware, but since there is no license file I prefer not to republish it)
Post Reply