2

« **on:** November 17, 2016 »
Dot tunnels gave me fits trying to figure out. So here's one for the lulz, maybe it will help (or hinder) someone else!

`'''''''''''''''''''''''''''''''''''''''''''''''''''''''`

' DOT TUNNEL

' by boogop

' The c# logic from my entry for the Amiga

' demo a year or so ago

' - now in glorious lo-res!

'

' For me, dot tunnels were the hardest effect

' to figure out. There didn't seem to be many

' examples (before I found dbfinteractive, on

' which there are several) and the ones I could

' find on the intarnets or hornet archive were

' frequently not very good. Some of them

' weren't tunnels at all, they were tubes with the

' rings fixed in place. The best one I ever saw

' was Crystal2 BBS addy by Xography but they never

' released the source, and I haven't been able to

' figure out how they were handling the movement path

'''''''''''''''''''''''''''''''''''''''''''''''''''''''

#include "tinyptc_ext.bi"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' screen dimensions & put_pixel routine

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

const screenWidth = 320

const screenHeight = 200

const SCR_SIZE as integer = screenWidth*screenHeight

dim shared buffer( 0 to SCR_SIZE-1 ) as integer

dim shared as uinteger ptr pntr

dim shared as integer ptr p

declare sub put_pixel(buffer() as integer, byval x as integer, byval y as integer, byval col as integer)

' this may be Shockwave's routine!

sub put_pixel(buffer() as integer, byval x as integer, byval y as integer, byval col as integer)

if(y < screenHeight -1 and y > 1) then

if( x < screenWidth-1 and x > 1 ) then

PNTR = @buffer(y * screenWidth + x)

asm

mov eax, dword ptr[col]

mov edi, [pntr]

stosd

end asm

end if

end if

end sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' declare variables

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

type colors

dim as integer r,g,b

end type

dim shared as colors colArray(256)

const _pointsPerCircle = 20

const _numCircles = 35

dim shared as double zDistance = 8

' named star because I lifted it from my 3d starfield code :)

type star

dim as double xpos, ypos, speed, zpos

dim as double origX, origY, origZ

dim as integer oldx,oldy

end type

dim shared as star circles(_numCircles, _pointsPerCircle)

dim shared as double maxZ = 0

dim shared as double diam = 50

dim shared as double xp,yp,zp,increment, px, py, skew, skewCount

dim shared as integer angle = 0

dim shared as double zPos = 1

dim shared as integer angleAdder = int(360 / _pointsPerCircle)

dim shared as double zPosAdder

dim shared as double midWidth = screenWidth / 2

dim shared as double midHeight = screenHeight / 2

dim as integer i,j, xpathcount

dim as double rad = 3.1416 / 180.0

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' set initial values

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

skewCount = .0001

zPosAdder = zDistance / _numCircles

for j = 0 to _numCircles

for i = 0 to _pointsPerCircle

dim as double Y = diam * Sin(angle * rad)

dim as double X = 2 * diam * Cos(angle * rad) ' make it oval shaped for the lulz

circles(j, i).xpos = X

circles(j, i).ypos = Y

circles(j, i).speed = .0025

circles(j, i).zpos = zPos

circles(j, i).origX = X

circles(j, i).origY = Y

circles(j, i).oldx = 0

circles(j, i).oldy = 0

angle += angleAdder

next i

zPos += zPosAdder

next j

maxZ = 0

' figure out the largest z value

for j = 0 to _numCircles

for i = 0 to _pointsPerCircle

if circles(j, i).zpos > maxZ then

maxZ = circles(j, i).zpos

end if

next i

next j

increment = 0

' fill color array

i = 0

while i < 256

dim as single red = 1 + Cos(i * 3.14 / 128)

dim as single grn = 1 + Cos((i - 85) * 3.14 / 128)

dim as single blu = 1 + Cos((i + 85) * 3.14 / 128)

colArray(i).r = int(red * 127) mod 256

colArray(i).g = int(grn * 127) mod 256

colArray(i).b = int(blu * 127) mod 256

i = i+1

wend

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' run the thing

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'ptc_setdialog(1,"FullScreen?",0,0)

if( ptc_open( "freeBASIC - tinyPTC Dot Tunnel", screenWidth, screenHeight ) = 0 ) then

end -1

end if

while inkey() <> chr(27)

if skew <= 1 then

skew = skew + skewcount

end if

for i = 0 to _numCircles

for j = 0 to _pointsPerCircle

' erase the last point

put_pixel Buffer(),circles(i, j).oldx,circles(i, j).oldy,0

put_pixel Buffer(),circles(i, j).oldx+1,circles(i, j).oldy,0

' bring each circle towards the viewer

circles(i, j).zpos -= circles(i, j).speed

' if a circle is close enough to the viewer, send it to the back

' using the maximum z value

if circles(i, j).zpos < 2 then

circles(i, j).xpos = circles(i, j).origX

circles(i, j).ypos = circles(i, j).origY

circles(i, j).zpos = maxZ

end if

' most compilers will perform some kind of bounds checks, and those

' will really bog an app down. Cast the array to vars so any bounds

' checking only has to happen once

xp = circles(i, j).xpos

yp = circles(i, j).ypos

zp = circles(i, j).zpos

' kludgey color fader lol

dim as double cc = 1 - Abs(zp / (maxZ * .8))

if (cc < 0) then

cc = 0

end if

if (cc > 1) then

cc = 1

end if

dim as integer c = int(300 * cc)

if c > 255 then

c = 255

end if

dim as integer co = rgb(colArray(c).b,colArray(c).r,colArray(c).g)

if zp > int(maxZ * .6) then

co = rgb(colArray(c).b/2,c,c)

end if

' zpos isn't quite right and doesn't bring the circles as close

' as it should but I don't feel like fixing it!

dim as double z = zp - 1.5

' path of the tunnel

px = 50 * Sin(z * skew * sin(increment))

py = 40 * Cos(z * skew * cos(increment))

' calculate perspective, add path, align to center screen

dim as double sx = (xp / z) + px + midWidth

dim as double sy = (yp / z) - py + midHeight

dim as integer ix = int(sx)

dim as integer iy = int(sy)

put_pixel Buffer(),ix,iy,co

put_pixel Buffer(),ix+1,iy,co

' save the current pos so we can erase it in the next iteration

circles(i, j).oldx = ix

circles(i, j).oldy = iy

next j

next i

increment +=.0005

ptc_update @buffer(0)

wend