hello everyone i thought after all this time i better blow the dust off so here is something ive been tinkering with for a couple of days nothing amazing really just a good old tunnel. its something i always wanted too do but could never get right.
i was rustier than first expected, myself and the function sin has had a major falling out with me blaming failure on it, And it calling me an illiterate idiot that should have went to school more often..
its actually coded for a demo im working on but while its still in this stage i thought id post it up if anyone has ideas to improve please post.. as it is right now its just coded the way i thought it could be achieved i know there is probably a thousand better ways of doing it.
#Include "Tinyptc_ext.Bi"
#Include "Windows.Bi"
Const XRes = 800
Const YRes = 600
Dim Shared As Double WndOrgX = XRes/2
Dim Shared As Double WndOrgY = YRes/2
RANDOMIZE TIMER
Type TimerType
Frequency As LARGE_INTEGER
LiStart As LARGE_INTEGER
LiStop As LARGE_INTEGER
LlTimeDiff As LONGLONG
MDuration As Double
End Type
Type RingPoints
Z As Double
X As Double
Y As Double
End Type
Type RingEntity
CurrentRingId As Integer
Rad As Double
XScale As Integer
YScale As Integer
SinAngle As Double
CosAngle As Double
XPos As Double
YPos As Double
ZPos As Double
Rpoint As RingPoints Ptr
End Type
Declare Sub MyLine( byval x1 as integer, byval y1 as integer, byval x2 as integer, byval y2 as integer, ByVal Col As Integer )
Declare Sub PtcOpen()
Declare Sub CleanUpTunnel()
Declare Sub SetUpTunnel()
Declare Sub AnimateTunnel( EntityPtr As RingEntity Ptr )
Declare Sub RenderTunnel()
Declare Sub CreatePoints( EntityPtr As RingEntity Ptr )
Declare Sub DeleteRing( Ring As RingEntity Ptr )
Declare Sub StartTimer( TempTimer As TimerType Ptr )
Declare Sub DestroyTimer( TempTimer As TimerType Ptr )
Declare Function NewRing() As RingEntity Ptr
Declare Function NewTimer() As TimerType Ptr
Declare Function GetTimerMs( TempTimer As TimerType Ptr ) As Double
Declare Function GetTimerSec( TempTimer As TimerType Ptr ) As Double
Dim Shared As Integer Buffer( XRes * YRes )
Dim Shared As Double NoOfRings = 29
Dim Shared As Double NoOfPoints = 12
Dim Shared As Double CamZ = 10
Dim Shared As Double Z, TempPointX( NoOfPoints ), TempPointY( NoOfPoints )
Dim Shared As Double Pre = 0
Dim Shared As TimerType Ptr FrameTimer
Dim Shared As RingEntity Ptr TunnelRing( NoOfRings )
FrameTimer = NewTimer()
PtcOpen()
SetUpTunnel()
While ( GetAsyncKeyState( VK_ESCAPE ) <> -32767 )
StartTimer( FrameTimer )
RenderTunnel()
Ptc_Update( @Buffer(0) )
For X = 0 To XRes*YRes
Buffer(x)=0
next
do
Loop While ( GetTimerMs( FrameTimer ) <= 1000.0/60.0 )'60fps Clamp
Wend
CleanUpTunnel()
Sub SetUpTunnel()
Dim As Integer X
TempPointX( 0 ) = 0
TempPointY( 0 ) = -3
TempPointX( 1 ) = +2
TempPointY( 1 ) = -2
TempPointX( 2 ) = +3
TempPointY( 2 ) = 0
TempPointX( 3 ) = +2
TempPointY( 3 ) = +2
TempPointX( 4 ) = 0
TempPointY( 4 ) = +3
TempPointX( 5 ) = -2
TempPointY( 5 ) = +2
TempPointX( 6 ) = -3
TempPointY( 6 ) = 0
TempPointX( 7 ) = -2
TempPointY( 7 ) = -2
TempPointX( 8 ) = 0
TempPointY( 8 ) = -3
For X = 0 To NoOfRings - 1
TunnelRing( X ) = NewRing()
TunnelRing( X )->Rad = 100
TunnelRing( X )->XScale = 100
TunnelRing( X )->YScale = 100
TunnelRing( X )->ZPos = ( 2+X )
pre += 0.01
TunnelRing( X )->Xpos += 6*sin(pre/12)
TunnelRing( X )->Ypos -= 9*Cos(pre/12)
Next
End Sub
Sub CleanUpTunnel()
Dim As Integer X
For X = 0 To NoOfRings
DeleteRing( TunnelRing( X ) )
Next
End Sub
Sub CreatePoints( EntityPtr As RingEntity Ptr )
Dim Dia As Double
Dim Z As Double
Dim As Double ReciP
Dim TempY As Integer
Dim As Double CircaX, CircaY
if EntityPtr->Rad < 0 then Return
ReciP = 1.0 / ( ( EntityPtr->Zpos ) * 0.2 )
Dia = ( EntityPtr->Rad )
For Z = 0 To NoOfPoints - 1
CircaX = TempPointX( z )*Dia
CirCaY = TempPointY( z )*Dia
If ( Z < NoOfPoints - 1 ) Then
EntityPtr->Rpoint[ Z ]->X = ( ( EntityPtr->Xpos + CircaX ) * ReciP ) + WndOrgX
EntityPtr->Rpoint[ Z ]->Y = ( ( EntityPtr->Ypos + CircaY ) * ReciP ) + WndOrgY
End If
Next
End Sub
Sub AnimateTunnel( EntityPtr As RingEntity Ptr )
Dim As Integer X
Dim As RingEntity Ptr T1sorter, T2sorter
T1sorter = NewRing()
T2sorter = NewRing()
EntityPtr->Zpos -= 0.11
If TunnelRing( 0 )->Zpos < 1.0 Then
T1sorter->Zpos = TunnelRing( 0 )->Zpos
For X = 0 To NoofRings-2
T2sorter->Xpos = TunnelRing( X+1 )->Xpos
T2sorter->Ypos = TunnelRing( X+1 )->Ypos
T2sorter->Zpos = TunnelRing( X+1 )->Zpos
TunnelRing( X )->Zpos = T2Sorter->Zpos
TunnelRing( X )->Xpos = T2Sorter->Xpos
TunnelRing( X )->Ypos = T2Sorter->Ypos
Next
TunnelRing( NoOfRings - 2 )->ZPos = T1sorter->Zpos + NoOfRings
TunnelRing( NoOfRings - 2 )->XPos = T1sorter->Xpos
TunnelRing( NoOfRings - 2 )->YPos = T1sorter->Ypos
End If
DeleteRing( T1sorter )
DeleteRing( T2sorter )
End Sub
Sub RenderTunnel()
Dim As Integer Ind = 0, Ind2 = 0
Dim As Integer X = 0
Dim As Double Xpoint( 4 ) ,Ypoint( 4 ), ClipX, ClipY, Temp = 0
For Ind = 0 to noOfrings-2
pre += 0.01
TunnelRing( ind )->Xpos += 6*sin(pre/12)
TunnelRing( ind )->Ypos -= 9*Cos(pre/12)
next
For X=0 To NoOfRings -1
CreatePoints( TunnelRing( X ) )
AnimateTunnel( TunnelRing( X ) )
Next
Dim As Integer ColSwitch = 0
Dim col As Integer
Col = 0
For X = ( NoOfRings - 1 ) To 1 Step - 1
If Col < 160 And ColSwitch = 0 Then
Col += 4
If Col > 70 Then ColSwitch = 1
End If
If ColSwitch = 1 Then Col -= 2
If Col < 0 Then Col = 0
' Col = 255
For Ind = 0 To 7
Xpoint( 0 ) = TunnelRing( X )->Rpoint[ Ind ]->X
Ypoint( 0 ) = TunnelRing( X )->Rpoint[ Ind ]->Y
Xpoint( 1 ) = TunnelRing( X )->Rpoint[ Ind+1 ]->X
Ypoint( 1 ) = TunnelRing( X )->Rpoint[ Ind+1 ]->Y
Xpoint( 2 ) = TunnelRing( X-1 )->Rpoint[ Ind ]->X
Ypoint( 2 ) = TunnelRing( X-1 )->Rpoint[ Ind ]->Y
Xpoint( 3 ) = TunnelRing( X-1 )->Rpoint[ Ind+1 ]->X
Ypoint( 3 ) = TunnelRing( X-1 )->Rpoint[ Ind+1 ]->Y
MyLine( Xpoint( 0 ) , Ypoint( 0 ), Xpoint( 1 ), Ypoint( 1 ), Rgb(Col,col,col) )
MyLine( Xpoint( 2 ) , Ypoint( 2 ), Xpoint( 3 ), Ypoint( 3 ), Rgb(Col,Col,Col) )
Temp = TunnelRing( X )->Zpos - TunnelRing( X-1 )->Zpos
If Temp > 0.9 Then
MyLine( Xpoint(0) , Ypoint(0), Xpoint( 2 ), Ypoint( 2 ), Rgb(col,col,col))
MyLine( Xpoint(1) , Ypoint(1), Xpoint( 3 ), Ypoint( 3 ), Rgb(col,col,col))
EndIf
Next
Next
End Sub
Sub PtcOpen()
Ptc_AllowClose(0)
Ptc_SetDialog(1,"NinosFirstTunnel"+CHR$(13)+"FullScreen",0)
Ptc_SetFlip(1)
If ( Ptc_Open( "Tunnel", XRes, YRes ) = 0 ) Then
End - 1
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'infamous line algorythm found years ago some where in google world'
'ported From c '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MyLine( byval x1 as integer, byval y1 as integer, byval x2 as integer, byval y2 as integer, ByVal Col As Integer )
dim i, deltax, deltay, numpixels as integer
dim d, dinc1, dinc2 as integer
dim x, xinc1, xinc2 as integer
dim y, yinc1, yinc2 as integer
'If X1 < 1 Then X1 = 1
'If X1 > Xres Then X1 = Xres-1
'If X2 < 1 Then X2 = 1
'If X2 > Xres Then X2 = Xres-1
'If Y1 < 1 Then Y1 = 1
'If Y1 > Yres Then Y1 = Yres-1
'If Y2 < 1 Then Y2 = 1
'If Y2 > Yres Then Y2 = Yres-1
'calculate deltaX and deltaY
deltax = abs(Cast(integer,x2 - x1))
deltay = abs(Cast(integer,y2 - y1))
'initialize
if ( deltax >= deltay ) then
'If x is independent variable
numpixels = deltax + 1
d = ( 2 * deltay ) - deltax
dinc1 = deltay shl 1
dinc2 = ( deltay - deltax ) shl 1
xinc1 = 1
xinc2 = 1
yinc1 = 0
yinc2 = 1
else
'if y is independent variable
numpixels = deltay + 1
d = ( 2 * deltax ) - deltay
dinc1 = deltax shl 1
dinc2 = ( deltax - deltay ) shl 1
xinc1 = 0
xinc2 = 1
yinc1 = 1
yinc2 = 1
endif
'move the right direction
if ( int(x1) > int(x2) ) then
xinc1 = -xinc1
xinc2 = -xinc2
endif
if ( int(y1) > int(y2) ) then
yinc1 = -yinc1
yinc2 = -yinc2
endif
X = Cast(Integer,X1)
Y = Cast(Integer,Y1)
'draw the pixels
For I = 1 To NumPixels
If Y > 2 And Y < Yres - 2 Then
If X > 2 and X < Xres - 2 Then
Buffer( Y*Xres+X ) = Col
End If
End If
If ( d < 0 ) Then
d = d + dinc1
x = x + xinc1
y = y + yinc1
Else
d = d + dinc2
x = x + xinc2
y = y + yinc2
EndIf
Next
End Sub
Function NewTimer() As TimerType Ptr
Dim As TimerType Ptr TempTimer
TempTimer = CAllocate( SizeOf( TimerType ) )
QueryPerformanceFrequency( @TempTimer->Frequency )
NewTimer = TempTimer
End Function
Sub StartTimer( TempTimer As TimerType Ptr )
QueryPerformanceCounter( @TempTimer->LiStart )
End Sub
Function GetTimerMs( TempTimer As TimerType Ptr ) As Double
QueryPerformanceCounter( @TempTimer->LiStop )
TempTimer->LlTimeDiff = TempTimer->LiStop.QuadPart - TempTimer->LiStart.QuadPart
TempTimer->MDuration = Cast( Double, TempTimer->LlTimeDiff ) * 1000.0 / Cast( Double , TempTimer->Frequency.QuadPart )
GetTimerMs = TempTimer->MDuration
End Function
Function GetTimerSec( TempTimer As TimerType Ptr ) As Double
QueryPerformanceCounter( @TempTimer->LiStop )
TempTimer->LlTimeDiff = TempTimer->LiStop.QuadPart - TempTimer->LiStart.QuadPart
TempTimer->MDuration = Cast( Double, TempTimer->LlTimeDiff ) * 1000.0 / Cast( Double , TempTimer->Frequency.QuadPart )
GetTimerSec = TempTimer->MDuration/1000.0
End Function
Sub DestroyTimer( TempTimer As TimerType Ptr )
If ( TempTimer ) Then
DeAllocate( TempTimer )
EndIf
End Sub
Function NewRing() As RingEntity Ptr
Dim As RingEntity Ptr TempRingEntity
TempRingEntity = Callocate( SizeOf( RingEntity ) )
TempRingEntity->Rpoint = Callocate( NoOfPoints*SizeOf( RingEntity ) )
NewRing = TempRingEntity
End Function
Sub DeleteRing( Ring As RingEntity Ptr )
If ( Ring ) Then
If ( Ring->RPoint ) Then
DeAllocate( Ring->Rpoint )
EndIf
DeAllocate( Ring )
End If
End Sub
