RAY CASTING

General FreeBASIC programming questions.
bluatigro
Posts: 652
Joined: Apr 25, 2012 10:35
Location: netherlands

RAY CASTING

Postby bluatigro » Sep 03, 2014 14:40

this is a try at a ray-caster

i got a set of errors

i dont know what is the right way whit the errors

Code: Select all

''bluatigro
''raycater strart : 3 aug 2014
type t3d
public :
  dim as double x , y , z
  declare constructor ( x as double = 0 _
  , y as double = 0 , z as double = 0 )
  declare sub fill( x as double , y as double , z as double )
  declare function dot( r as t3d ) as double
  declare function ad( r as t3d ) as t3d
  declare function cross( r as t3d ) as t3d
end type
constructor t3d( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end constructor
sub t3d.fill( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end sub
function t3d.dot( r as t3d ) as double
  return x * r.x + y * r.y + z * r.z
end function
function t3d.ad( r as t3d ) as t3d
  return type( x + r.x , y + r.y , z + r.z )
end function
function t3d.cross( r as t3d ) as t3d
  return type( y * r.z - z * r.y _
             , z * r.x - x * r.z _
             , x * r.y - y * r.x )
end function
operator -( r as t3d ) as t3d
  return type( -r.x , -r.y , -r.z )
end operator

type tray
public :
  dim as t3d origin , direction
  declare constructor( o as t3d , d as t3d )
end type
constructor tray( o as t3d , d as t3d )
  origin = o
  direction = d
end constructor

type tcolor
public :
  dim as double red , green , blue , special
  declare constructor ( r as double = 0.0 _
  , g as double = 0.0 , b as double = 0.0 _
  , s as double = 0.0 )
  declare function toInt() as integer
end type
constructor tcolor( r as double , g as double _
, b as double , s as double )
  red = r
  green = g
  blue = b
  special = s
end constructor
function tcolor.toInt() as integer
  return rgb( red * 255 , green * 255 , blue * 255 )
end function

type tlight
public :
  dim position as t3d
  dim kleur as tcolor
end type

''type tshape
''public :
''  dim kleur as tcolor
''  declare function getNormal( p as t3d ) as t3d
''  declare function hit( ray as tray ) as double
''end type

type tsphere ''( tshape )
  dim position as t3d
  dim radius as double
  dim kleur as tcolor
  declare constructor ()
  declare constructor ( p as t3d , r as double , kl as tcolor )
  declare function getNormal( p as t3d ) as t3d
  declare function hit( ray as tray ) as double
end type
constructor tsphere()
  position = type<t3d>( 0.0 , 0.0 , 0.0 )
  radius = 100.0
  kleur = type<tcolor>( 1.0 , 1.0 , 1.0 , 0.0 )
end constructor
constructor tsphere( p as t3d , r as double , kl as tcolor )
  position = p
  radius = r
  kleur = kl
end constructor
function tsphere.getNormal( p as t3d ) as t3d
  return position.ad( -p )
end function
function tsphere.hit( ray as tray ) as double
  dim as t3d o , d , s
  o = ray.origin
  d = ray.direction
  s = position
  dim as double a = 1.0 , b , c
  b = ( 2 * ( o.x - s.x ) * d.x ) _
    + ( 2 * ( o.y - s.y ) * d.y ) _
    + ( 2 * ( o.z - s.z ) * d.z )
  c = ( o.x - s.x ) ^ 2.0  _
    + ( o.y - s.y ) ^ 2.0  _
    + ( o.z - s.z ) ^ 2.0  _
    - ( radius * radius )
   dim as double dis = b * b - 4 * a * c
  if ( dis > 0.0 ) then
    dim as double root1 = ( -b - sqr( dis ) ) / 2 - 1e-10
    if ( root1 > 0.0 ) then
      return root1
    else
      return ( -b + sqr( dis ) ) / 2 + 1e-10
    end if
  else
    return -1
  end if
end function

type tcamera
public :
  dim as t3d position , direction , rechts , down
  declare constructor( p as t3d , d as t3d , r as t3d , u as t3d )
end type

function range( low as double , high as double ) as double
  return rnd * ( high - low ) + low
end function

function winner_index( a() as double , tel as integer ) as integer
  if tel = 0 then return -1
  if tel = 1 then
    if a( 0 ) < 0 then
      return -1
    else
      return 0
    end if
  else
    dim as integer i , t , f
    dim as double min = 1e13
    t = 0
    for i = 0 to tel
      if min > a( i ) then
        min = a( i )
        t = t + 1
        f = i
      end if
    next i
    if t = 0 then
      return -1
    else
      return f
    end if
  end if
end function
     

declare sub test

test
sleep

end
sub test
dim as integer winx , winy , wind
screen 20 , 32
screeninfo winx , winy , wind

dim as tsphere spheres( 10 )
dim as integer i , spheremax = 0
for i = 0 to 10
  spheres(i).position.x = range( -500.0 , 500.0 )
  spheres(i).position.y = range( -300.0 , 300.0 )
  spheres(i).position.z = range( 200.0 , 1000.0 )
  spheres(i).radius = range( 10.0 , 200.0 )
  spheres(i).kleur = type<tcolor>( rnd , rnd , rnd , 0.0 )
next i
dim as double x , y , a( 10 )

for x = -winx/2 to winx/2
  for y = -winy/2 to winy/2
    dim as t3d o , d
    o.fill x , y , 0.0
    d.fill x / winx , y / winx , 1.0
    dim as tray ray( o , d )
    for i = 0 to 10
      a( i ) = spheres( i ).hit( ray )
    next i
    i = winner_index( a , 10 )
    if i < 0 then
      pset( winx / 2 + x , winy / 2 - y ) , 0
    else
      pset( winx / 2 + x , winy / 2 - y ) _
      , spheres( i ).kleur.toInt()
    end if
  next y
next x

end sub
fxm
Posts: 9994
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: RAY CASTING

Postby fxm » Sep 03, 2014 16:19

[193] dim as tray ray = tray( o , d )
[197] i = winner_index( a() , 10 )
D.J.Peters
Posts: 8189
Joined: May 28, 2005 3:28
Contact:

Re: RAY CASTING

Postby D.J.Peters » Sep 04, 2014 1:42

To get it working I changed winner_index() and for speed tsphere.hit()
you can pre calculated for all spheres the position dot product (PDot) and Radius squared (R2)
and of course Ray.Origin dot product (ray.ODot) also.

Happy ray tracing :-)

Joshy

Code: Select all

''bluatigro
''raycater strart : 3 aug 2014
type t3d
public :
  as double x , y , z
  declare constructor (x as double = 0, y as double = 0, z as double = 0)
  declare sub fill( x as double , y as double , z as double )
  declare function dot( r as t3d ) as double
  declare function ad( r as t3d ) as t3d
  declare function cross( r as t3d ) as t3d
end type

constructor t3d( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end constructor

sub t3d.fill( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end sub

function t3d.dot( r as t3d ) as double
  return x * r.x + y * r.y + z * r.z
end function

function t3d.ad( r as t3d ) as t3d
  return type( x + r.x , y + r.y , z + r.z )
end function

function t3d.cross( r as t3d ) as t3d
  return type( y * r.z - z * r.y _
             , z * r.x - x * r.z _
             , x * r.y - y * r.x )
end function

operator -( r as t3d ) as t3d
  return type( -r.x , -r.y , -r.z )
end operator

type tray
  as t3d origin
  as t3d direction
  as double ODot
  as double DDot
  declare constructor(o as t3d, d as t3d)
end type
constructor tray(o as t3d, d as t3d)
  origin    = o
  direction = d
  ODot=origin.x*origin.x+origin.y*origin.y+origin.z*origin.z
  DDot=Direction.x*Direction.x+Direction.y*Direction.y+Direction.z*Direction.z
end constructor

type tcolor
  as double red , green , blue , special
  declare constructor (r as double = 0.0, g as double = 0.0 , b as double = 0.0, s as double = 0.0)
  declare function toInt() as integer
end type
constructor tcolor( r as double , g as double, b as double, s as double)
  red = r : green = g : blue = b : special = s
end constructor
function tcolor.toInt() as integer
  return rgb( red * 255 , green * 255 , blue * 255 )
end function

type tlight
  as t3d    position
  as tcolor kleur
end type

''type tshape
''public :
''  dim kleur as tcolor
''  declare function getNormal( p as t3d ) as t3d
''  declare function hit( ray as tray ) as double
''end type

type tsphere ''( tshape )
  as t3d position
  as double PDot
  as double radius,r2
  as tcolor kleur
  declare constructor ()
  declare constructor ( p as t3d , r as double , kl as tcolor )
  declare function getNormal( p as t3d ) as t3d
  declare function hit( ray as tray ) as double
end type
constructor tsphere()
  position = type<t3d>( 0.0 , 0.0 , 0.0 )
  PDot=0
  radius = 100.0
  r2=radius*radius
  kleur = type<tcolor>( 1.0 , 1.0 , 1.0 , 0.0 )
end constructor

constructor tsphere( p as t3d , r as double , kl as tcolor )
  position = p
  ' pre caluculate position dot product
  PDot=position.x*position.x+ _
       position.y*position.y+ _
       position.z*position.z
  radius = r
  ' pre calculate radius squared
  r2=r*r
  kleur = kl
end constructor

function tsphere.getNormal( p as t3d ) as t3d
  return position.ad( -p )
end function

function tsphere.hit( ray as tray ) as double
  dim as double L=Ray.DDot
  If L = 0 Then return -1
  dim as double M=2 * Ray.Direction.X * (Ray.Origin.X-Position.X) _
                 +2 * Ray.Direction.Y * (Ray.Origin.Y-Position.Y) _
                 +2 * Ray.Direction.Z * (Ray.Origin.Z-Position.Z)
  dim as double N =PDot+Ray.ODot
  N=N - 2 * (Position.x*Ray.Origin.x + _
             Position.y*Ray.Origin.y + _
             Position.z*Ray.Origin.z) - R2
  dim as double T = M * M - 4 * L * N
  if (T<0) then return -1
  L*=2
  if (T=0) then
    T = -M / L
    if (T<=0) then
      return -1
    else
      return T
    end if
  else ' two hit points
    T=sqr(T)
    dim as double T1 = (-M - t)/L
    dim as double T2 = (-M + t)/L
    If (T1 < 0.001) Then T1 = 0
    If (T2 < 0.001) Then T2 = 0
    ' no hits
    If (T1 = 0) And (T2 = 0) Then return -1
    ' both are ok
    If (T1 > 0) And (T2 > 0) Then
      If T1 < T2 Then
        return T1
      else
        return T2
      end if
    Else ' one are ok
      If (T1 > 0) Then
        return T1
      Else
        return T2
      end if
    End If
  End If

end function

type tcamera
public :
  dim as t3d position , direction , rechts , down
  declare constructor( p as t3d , d as t3d , r as t3d , u as t3d )
end type

function range( low as double , high as double ) as double
  return rnd * ( high - low ) + low
end function

function winner_index( a() as double , tel as integer ) as integer
  dim as integer found=-1 ,i
  dim as double min = 1e13
  for i = 0 to tel
    if a(i)>0 then
      if a(i)<min then
        min = a(i) :found=i
      end if
    end if
  next
  return found
end function

sub test
  dim as integer winx , winy , wind
  screeninfo winx , winy , wind
  dim as tsphere spheres( 10 )
  dim as integer i , spheremax = 0
  for i = 0 to 10
    spheres(i).position.x = range( -500.0 , 500.0 )
    spheres(i).position.y = range( -300.0 , 300.0 )
    spheres(i).position.z = range( 200.0 , 1000.0 )
    ' pre calculate position dot product
    spheres(i).PDot=spheres(i).position.x*spheres(i).position.x _
                   +spheres(i).position.y*spheres(i).position.y _
                   +spheres(i).position.z*spheres(i).position.z
    spheres(i).radius = range( 10.0 , 200.0 )
    ' pre calculate radius squared
    spheres(i).r2=spheres(i).radius*spheres(i).radius
    spheres(i).kleur = type<tcolor>( rnd , rnd , rnd , 0.0 )
  next i
  dim as double x , y , a( 10 )
 
  for x = -winx/2 to winx/2
    for y = -winy/2 to winy/2
      dim as t3d o , d
      o.fill x , y , 0.0
      d.fill x / winx , y / winx , 1.0
      dim as TRAY ray = TRAY( o , d )
      for i = 0 to 10
        a(i) = spheres(i).hit(ray)
      next i
      i = winner_index( a() , 10 )
      if (i<0) then
        pset( winx/2 + x , winy/2 - y ) ,0
      else
        pset( winx/2 + x , winy/2 - y ) , spheres(i).kleur.toInt()
      end if
    next
  next
end sub



'
' main
'
screen 20 , 32
randomize timer
while inkey()=""
  test
wend
bluatigro
Posts: 652
Joined: Apr 25, 2012 10:35
Location: netherlands

Re: RAY CASTING

Postby bluatigro » Sep 05, 2014 9:50

@ fxm , d.j.peters :
- tanks for help

update :
- shading added

error :
- my screen stays black

Code: Select all

''bluatigro
''raycater : start :  3 aug 2014
''update : shadow  :  6 aug 2014
type t3d
public :
  dim as double x , y , z
  declare constructor (x as double = 0, y as double = 0, z as double = 0)
  declare sub fill( x as double , y as double , z as double )
  declare function dot( r as t3d ) as double
  declare function ad( r as t3d ) as t3d
  declare function cross( r as t3d ) as t3d
  declare function angle( r as t3d ) as double
  declare function length() as double
end type

constructor t3d( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end constructor

sub t3d.fill( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end sub

function t3d.dot( r as t3d ) as double
  return x * r.x + y * r.y + z * r.z
end function

function t3d.ad( r as t3d ) as t3d
  return type( x + r.x , y + r.y , z + r.z )
end function

function t3d.cross( r as t3d ) as t3d
  return type( y * r.z - z * r.y _
             , z * r.x - x * r.z _
             , x * r.y - y * r.x )
end function

function t3d.angle( r as t3d ) as double
  return acos( dot( r ) / ( length() * r.length() ) )
end function

function t3d.length() as double
  return sqr( x ^ 2 + y ^ 2 + z ^ 2 )
end function

operator * ( l as t3d , f as double ) as t3d
  return type( l.x * f , l.y * f , l.z * f )
end operator

operator -( r as t3d ) as t3d
  return type( -r.x , -r.y , -r.z )
end operator



type tray
  as t3d origin
  as t3d direction
  as double ODot
  as double DDot
  declare constructor(o as t3d, d as t3d)
end type

constructor tray(o as t3d, d as t3d)
  origin    = o
  direction = d
  ODot=origin.x*origin.x+origin.y*origin.y+origin.z*origin.z
  DDot=Direction.x*Direction.x+Direction.y*Direction.y+Direction.z*Direction.z
end constructor



type tcolor
  as double red , green , blue , special
  declare constructor (r as double = 0.0, g as double = 0.0 , b as double = 0.0, s as double = 0.0)
  declare function toInt() as integer
end type

constructor tcolor( r as double , g as double, b as double, s as double)
  red = r : green = g : blue = b : special = s
end constructor

function tcolor.toInt() as integer
  return rgb( red * 255 , green * 255 , blue * 255 )
end function

operator * ( kl as tColor , f as double ) as tColor
  return type( kl.red * f , kl.green * f , kl.blue * f )
end operator



type tlight
  as t3d    position
  as tcolor kleur
end type

''type tshape
''public :
''  dim kleur as tcolor
''  declare function getNormal( p as t3d ) as t3d
''  declare function hit( ray as tray ) as double
''end type



type tsphere ''( tshape )
  as t3d position
  as double PDot
  as double radius,r2
  as tcolor kleur
  declare constructor ()
  declare constructor ( p as t3d , r as double , kl as tcolor )
  declare function getNormal( p as t3d ) as t3d
  declare function hit( ray as tray ) as double
end type

constructor tsphere()
  position = type<t3d>( 0.0 , 0.0 , 0.0 )
  PDot=0
  radius = 100.0
  r2=radius*radius
  kleur = type<tcolor>( 1.0 , 1.0 , 1.0 , 0.0 )
end constructor

constructor tsphere( p as t3d , r as double , kl as tcolor )
  position = p
  ' pre caluculate position dot product
  PDot=position.x*position.x+ _
       position.y*position.y+ _
       position.z*position.z
  radius = r
  ' pre calculate radius squared
  r2=r*r
  kleur = kl
end constructor

function tsphere.getNormal( p as t3d ) as t3d
  return position.ad( -p )
end function

function tsphere.hit( ray as tray ) as double
  dim as double L=Ray.DDot
  If L = 0 Then return -1
  dim as double M=2 * Ray.Direction.X * (Ray.Origin.X-Position.X) _
                 +2 * Ray.Direction.Y * (Ray.Origin.Y-Position.Y) _
                 +2 * Ray.Direction.Z * (Ray.Origin.Z-Position.Z)
  dim as double N =PDot+Ray.ODot
  N=N - 2 * (Position.x*Ray.Origin.x + _
             Position.y*Ray.Origin.y + _
             Position.z*Ray.Origin.z) - R2
  dim as double T = M * M - 4 * L * N
  if (T<0) then return -1
  L*=2
  if (T=0) then
    T = -M / L
    if (T<=0) then
      return -1
    else
      return T
    end if
  else ' two hit points
    T=sqr(T)
    dim as double T1 = (-M - t)/L
    dim as double T2 = (-M + t)/L
    If (T1 < 0.001) Then T1 = 0
    If (T2 < 0.001) Then T2 = 0
    ' no hits
    If (T1 = 0) And (T2 = 0) Then return -1
    ' both are ok
    If (T1 > 0) And (T2 > 0) Then
      If T1 < T2 Then
        return T1
      else
        return T2
      end if
    Else ' one are ok
      If (T1 > 0) Then
        return T1
      Else
        return T2
      end if
    End If
  End If
end function



type tcamera
public :
  dim as t3d position , direction , rechts , down
  declare constructor( p as t3d , d as t3d , r as t3d , u as t3d )
end type



function range( low as double , high as double ) as double
  return rnd * ( high - low ) + low
end function

function winner_index( a() as double , tel as integer ) as integer
  dim as integer found = -1 ,i
  dim as double min = 1e13
  for i = 0 to tel
    if a(i)>0 then
      if a(i)<min then
        min = a(i) :found=i
      end if
    end if
  next
  return found
end function

sub test
  dim as integer winx , winy , wind
  screeninfo winx , winy , wind
  dim as tlight light
  dim as tsphere spheres( 10 )
  dim as integer i , spheremax = 0
  for i = 0 to 10
    spheres(i).position.x = range( -500.0 , 500.0 )
    spheres(i).position.y = range( -300.0 , 300.0 )
    spheres(i).position.z = range( 200.0 , 1000.0 )
    ' pre calculate position dot product
    spheres(i).PDot=spheres(i).position.x*spheres(i).position.x _
                   +spheres(i).position.y*spheres(i).position.y _
                   +spheres(i).position.z*spheres(i).position.z
    spheres(i).radius = range( 10.0 , 200.0 )
    ' pre calculate radius squared
    spheres(i).r2=spheres(i).radius*spheres(i).radius
    spheres(i).kleur = type<tcolor>( rnd , rnd , rnd , 0.0 )
  next i
  dim as double x , y , a( 10 ) , angle
  dim as tColor kl
 
  for x = -winx/2 to winx/2
    for y = -winy/2 to winy/2
      dim as t3d o , d
      o.fill x , y , 0.0
      d.fill x / winx , y / winx , 1.0
      dim as TRAY ray = TRAY( o , d )
      for i = 0 to 10
        a(i) = spheres(i).hit(ray)
      next i
      i = winner_index( a() , 10 )
      if (i<0) then
        pset( winx/2 + x , winy/2 - y ) ,0
      else
        dim as t3d p = ray.direction * ( 1 / ray.direction.length() ) * a( i )
        angle = spheres(i).getNormal( p ).angle( light.position )
        kl = spheres( i ).kleur
        kl = kl * ( cos( angle ) / 2 + 0.5 )
        pset( winx/2 + x , winy/2 - y ) , kl.toInt()
      end if
    next
  next
end sub

'
' main
'
screen 20 , 32
randomize timer
while inkey()=""
  test
wend

fxm
Posts: 9994
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: RAY CASTING

Postby fxm » Sep 05, 2014 11:40

- At line:
[254] angle = spheres(i).getNormal( p ).angle( light.position )
'light.position' is never initialized.

- That induces a division by '0':
r.length() = light.position.length() = 0
in the method 't3d.angle()'.
dodicat
Posts: 6727
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: RAY CASTING

Postby dodicat » Sep 07, 2014 23:37

Here's my puny effort at shading spheres:

Code: Select all

 

dim as integer xres,yres
Screen 19,32
screeninfo xres,yres
Dim As Any Ptr im=Imagecreate(800,600,Rgb(0,0,200))
Type V3
    As Single x,y,z
    Declare Property length As Single
    Declare Property unit As V3
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
End Type

Operator -(Byref v1 As v3,Byref v2 As v3) As v3
Return Type<V3>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator

Operator * (Byref v1 As v3,Byref v2 As v3) As Single 'dot
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator

Property v3.length As Single
Return Sqr(x*x+y*y+z*z)
End Property


Property v3.unit As v3
Dim n As Single=Sqr(x*x+y*y+z*z)
Return Type<V3>(x/n,y/n,z/n)
End Property

Type sphere Extends V3
    As Integer r
End Type

#macro insphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) < S.R*S.R
#endmacro

#macro onsphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) <= S.R*S.R Andalso _
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) > (S.R-1)*(S.R-1)
#endmacro

Dim As V3 p
Dim As sphere s=Type<sphere>(400,300,0,200),s2=Type<sphere>(250,400,90,100)

'to image fixed sphere
For x As Integer=s.x-s.r To s.x+s.r
    For y As Integer=s.y-s.r To s.y+s.r
        For z As Integer=s.z To s.z+s.r
            p=Type<V3>(x,y,z)
            If onsphere(s,p) Then
                Dim As v3 ctr=Type<V3>(s.x,s.y,s.r\2)
                Var dist=(p-ctr).length
                Dim As Integer cc=map(0,s.r,dist,250,50)
                Pset im,(p.x,p.y),Rgb(cc,0,0)
            End If
        Next z
    Next y
Next x
'=========================================================
Dim As Integer kx=1,ky=1
Var dirnx=(2+Rnd*5),dirny=(2+Rnd*5)
Do
    Screenlock
    Cls
    Put(0,0),im,Pset
    S2.x+=dirnx*kx
    S2.y+=dirny*ky
    If s2.x>xres-s2.r Or  s2.x<s2.r Then kx=-kx
    If s2.y>yres-s2.r Or  s2.y<s2.r Then ky=-ky
   
    For x As Integer=s2.x-s2.r To s2.x+s2.r
        For y As Integer=s2.y-s2.r To s2.y+s2.r
            For z As Integer=s2.z To s2.z+s2.r
                p=Type<V3>(x,y,z)
                If onsphere(s2,p) Then
                    If insphere(s,p)=0 Then
                        Var diff=(Type<V3>(s.x,s.y,s.z)-Type<V3>(s2.x,s2.y,s2.z)).unit
                        Var c=Type<V3>((s2.x-p.x)/s2.r,(s2.y-p.y)/s2.r,(s2.z-p.z)/s2.r)
                        Var dot=c*diff
                        Dim As Integer cc=map(1,-1,dot,50,250)
                        Pset(p.x,p.y),Rgb(0,cc,0)
                    End If
                End If
            Next z
        Next y
    Next x
   
    Screenunlock
    Sleep 1,1
Loop Until Len(Inkey)
imagedestroy im
Sleep

dodicat
Posts: 6727
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: RAY CASTING

Postby dodicat » Sep 08, 2014 2:04

A bit sharper:

Code: Select all

 

dim as integer xres,yres
Screen 20,32
screeninfo xres,yres
Dim As Any Ptr im=Imagecreate(xres,yres,Rgb(0,0,200))

Type V3
    As Single x,y,z
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
End Type

Type sphere Extends V3
    As Integer r
End Type

#macro insphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) < S.R*S.R
#endmacro

#macro onsphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) <= S.R*S.R Andalso _
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) > (S.R-1)*(S.R-1)
#endmacro

Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Dim As V3 p
Dim As sphere s=Type<sphere>(400,300,0,200),s2=Type<sphere>(250,400,90,100),s3=type<sphere>(500,500,100,60)

'to image fixed sphere
For x As Integer=s.x-s.r To s.x+s.r
    For y As Integer=s.y-s.r To s.y+s.r
        For z As Integer=s.z To s.z+s.r
            p=Type<V3>(x,y,z)
            If onsphere(s,p) Then
                var xx=(s.x-p.x)/s.r
                Dim As Integer cc=map(-1,1,xx,250,50)
                Pset im,(p.x,p.y),Rgb(cc,0,0)
            End If
        Next z
    Next y
Next x

'mobile ones
redim shared as V3 a(0),a1(0)
For x As Integer=s2.x-s2.r To s2.x+s2.r
        For y As Integer=s2.y-s2.r To s2.y+s2.r
            For z As Integer=s2.z To s2.z+s2.r
                p=Type<V3>(x,y,z)
                If onsphere(s2,p) Then
                    redim preserve a(1 to ubound(a)+1)
                    a(ubound(a))=type<V3>(x,y,z)
                End If
            Next z
        Next y
    Next x
   
  For x As Integer=s3.x-s3.r To s3.x+s3.r
        For y As Integer=s3.y-s3.r To s3.y+s3.r
            For z As Integer=s3.z To s3.z+s3.r
                p=Type<V3>(x,y,z)
                If onsphere(s3,p) Then
                    redim preserve a1(1 to ubound(a1)+1)
                    a1(ubound(a1))=type<V3>(x,y,z)
                End If
            Next z
        Next y
    Next x 
   

'=========================================================
Dim As Integer kx=1,ky=1,kx1=1,ky1=-1,fps
Var dirnx=(4+Rnd*5),dirny=(4+Rnd*5),dirnx1=(4+Rnd*5),dirny1=(4+Rnd*5)
Do
    Screenlock
    Cls
    Put(0,0),im,Pset
   draw string (20,20),"Framerate " & fps
   'move the sphere centres and check edge boundaries
        S2.x+=dirnx*kx
        S2.y+=dirny*ky
        If s2.x>xres-s2.r Or  s2.x<s2.r Then kx=-kx
        If s2.y>yres-s2.r Or  s2.y<s2.r Then ky=-ky
       
        S3.x+=dirnx1*kx1
        S3.y+=dirny1*ky1
        If s3.x>xres-s3.r Or  s3.x<s3.r Then kx1=-kx1
        If s3.y>yres-s3.r Or  s3.y<s3.r Then ky1=-ky1
       
    for n as integer=1 to ubound(a)'green one
        'move all the sphere points
        a(n).x+=dirnx*kx
        a(n).y+=dirny*ky
        If insphere(s,a(n))=0 Then
            Var c=(s2.x-a(n).x)/s2.r
            Dim As Integer cc=map(1,-1,c,50,250)
            Pset(a(n).x,a(n).y),Rgb(0,cc,0)
            end if
        next n
       
      for n as integer=1 to ubound(a1)'blue one
          'move all the sphere points
        a1(n).x+=dirnx1*kx1
        a1(n).y+=dirny1*ky1
        If insphere(s,a1(n))=0 and insphere(s2,a1(n))=0 Then
            Var c=(s3.x-a1(n).x)/s3.r
            Dim As Integer cc=map(1,-1,c,50,250)
            Pset(a1(n).x,a1(n).y),Rgb(50,0,cc)
            end if
        next n 
   
    Screenunlock
    Sleep regulate(40,fps),1
Loop Until Len(Inkey)
imagedestroy im
Sleep

 
dodicat
Posts: 6727
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: RAY CASTING

Postby dodicat » Sep 08, 2014 20:49

And my final:

Code: Select all


Dim As Integer xres,yres,pitch
Screeninfo xres,yres
Screenres xres,yres,32,,1
Dim As Any Ptr row=Screenptr
Dim As Uinteger Ptr pixel
Screeninfo xres,yres,,,pitch
Dim As Any Ptr im=Imagecreate(xres,yres,Rgb(0,0,200))

Type V3
    As Integer x,y,z
    As Uinteger col
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
End Type

Type sphere Extends V3
    As Single dx,dy,dz
    As Integer r
    As Any Ptr image
End Type

#macro insphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) < S.R*S.R
#endmacro

#macro onsphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) <= S.R*S.R Andalso _
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) > (S.R-1)*(S.R-1)
#endmacro

#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
*pixel=(colour)
#endmacro

#define onscreen(_x,_y) _x>0 and _x<xres-1 and _y>0 and _y<yres-1

#macro blue()
#ifdef __FB_WIN32__
Declare Function ScaleWindow Alias "MoveWindow"(As Any Ptr,As Integer=0,As Integer=0,As Integer,As Integer,As Integer=1) As Integer

scope
    dim as string s,t
    #macro rd(a)
    s=string(ubound(a)," ")
    for n as integer=1 to ubound(a)
        s[n-1]=a(n)
    next n
    t+=s
    #endmacro
    screen 0
dim as integer desktopW,desktopH,xres,yres
screeninfo desktopW,desktopH
screenres DesktopW/1.8,DesktopH/1.8,32,,64 or 8
color rgb(200,200,200),rgb(0,0,200)
cls
screeninfo xres,yres
width xres\8,yres\16
Dim As Integer I
Screencontrol(2,I)
ScaleWindow(Cast(Any Ptr,I),0,0,desktopW,desktopH)
dim as ubyte a1(1 to 68)={65,32,102,97,116,97,108,32,101,120,99,101,112,116,105,111,110,32,79,69,32,104,97,_
115,32,111,99,99,117,114,114,101,100,32,97,116,32,48,48,50,56,58,67,48,48,49,49,_
69,51,54,32,105,110,32,86,88,68,32,86,77,77,40,48,49,41,32,43,10}
dim as ubyte a2(1 to 58) ={32,32,32,32,48,48,48,49,48,69,51,54,46,32,84,104,101,32,99,117,114,114,101,110,116,32,97,112,_
112,108,105,99,97,116,105,111,110,32,119,105,108,108,32,98,101,32,116,101,114,109,_
105,110,97,116,101,100,46,10}
dim as ubyte a3(1 to 2)= {10,10}
dim as ubyte a4(1 to 57)= {32,32,32,32,42,32,80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,_
116,101,114,109,105,110,97,116,101,32,116,104,101,32,99,117,114,114,101,110,116,_
32,97,112,112,108,105,99,97,116,105,111,110,10}
dim as ubyte a5(1 to 69)= {32,32,32,32,42,32,80,114,101,115,115,32,67,84,82,76,32,43,32,65,76,84,32,43,32,68,_
69,76,32,97,103,97,105,110,32,116,111,32,114,101,115,116,97,114,116,32,121,111,_
117,114,32,99,111,109,112,117,116,101,114,46,89,111,117,32,119,105,108,108,10}
dim as ubyte a6(1 to 56)= { 32,32,32,32,32,32,108,111,111,115,101,32,97,110,121,32,117,110,115,97,118,101,100,_
32,105,110,102,111,114,109,97,116,105,111,110,32,105,110,32,97,108,108,32,97,112,_
112,108,105,99,97,116,105,111,110,115,46}
dim as ubyte a7(1 to 2)= {10,10}
dim as ubyte a8(1 to 56)= { 32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,32,_
80,114,101,115,115,32,97,110,121,32,107,101,121,32,116,111,32,99,111,110,116,105,_
110,117,101,32,95}
rd(a1):rd(a2):rd(a3):rd(a4):rd(a5):rd(a6):rd(a7):rd(a8)
locate 10,5
print t
sleep
end scope
#endif
 #endmacro   

Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Dim As V3 p

Dim As sphere s=Type<sphere>(200,200,0,0,(2+Rnd*3),(2+Rnd*3),0,200), _
s2=Type<sphere>(250,400,90,0,(3+Rnd*2),(3+Rnd*2),0,100), _
s3=Type<sphere>(500,500,100,0,(4+Rnd*5),(4+Rnd*5),0,80)'60
s.image=Imagecreate(2*s.r,2*s.r)

'background         
For n As Integer=0 To xres
    Dim As Integer rr=map(0,xres,n,0,100)
    Dim As Integer gg=map(0,xres,n,0,100)
    Line im,(n,0)-(n,yres),Rgb(rr,gg,255)
Next n

'to image red sphere
For x As Integer=s.x-s.r To s.x+s.r
    For y As Integer=s.y-s.r To s.y+s.r
        For z As Integer=s.z To s.z+s.r
            p=Type<V3>(x,y,z)
            If onsphere(s,p) Then
                Var xx=(s.x-p.x)/s.r
                Dim As Integer cc=map(-1,1,xx,250,50)
                Pset s.image,(p.x,p.y),Rgb(cc,0,0)
            End If
        Next z
    Next y
Next x

'mobile ones
Redim Shared As V3 a(0),a1(0)
For x As Integer=s2.x-s2.r To s2.x+s2.r
    For y As Integer=s2.y-s2.r To s2.y+s2.r
        For z As Integer=s2.z To s2.z+s2.r
            p=Type<V3>(x,y,z)
            If onsphere(s2,p) Then
                Redim Preserve a(1 To Ubound(a)+1)
                a(Ubound(a))=Type<V3>(x,y,z)
                Var c=(s2.x-a(Ubound(a)).x)/s2.r
                Dim As Integer cc=map(1,-1,c,50,250)
                a(Ubound(a)).col=Rgb(0,cc,0)
            End If
        Next z
    Next y
Next x

For x As Integer=s3.x-s3.r To s3.x+s3.r
    For y As Integer=s3.y-s3.r To s3.y+s3.r
        For z As Integer=s3.z To s3.z+s3.r
            p=Type<V3>(x,y,z)
            If onsphere(s3,p) Then
                Redim Preserve a1(1 To Ubound(a1)+1)
                a1(Ubound(a1))=Type<V3>(x,y,z)
                Var c=(s3.x-a1(Ubound(a1)).x)/s3.r
                Dim As Integer cc=map(1,-1,c,50,250)
                a1(Ubound(a1)).col=Rgb(50,0,cc)
            End If
        Next z
    Next y
Next x 

'=========================================================
Dim As Integer fps
Do
    Screenlock
    Cls
    'move the red sphere image
    S.x+=S.dx
    S.y+=S.dy
    If s.x>xres-s.r Or  s.x<s.r Then S.dx=-S.dx
    If s.y>yres-s.r Or  s.y<s.r Then S.dy=-S.dy
   
    Put(0,0),im,Pset
    Put(s.x-s.r,s.y-s.r),s.image,trans
   
    Draw String (20,20),"Framerate " & fps
    'move the sphere centres and check edge boundaries
    S2.x+=S2.dx
    S2.y+=S2.dy
    If s2.x>xres-s2.r-1 Or  s2.x<s2.r Then S2.dx=-S2.dx
    If s2.y>yres-s2.r-1 Or  s2.y<s2.r Then S2.dy=-S2.dy
   
    S3.x+=S3.dx
    S3.y+=S3.dy
    If s3.x>xres-s3.r-1 Or  s3.x<s3.r Then S3.dx=-S3.dx
    If s3.y>yres-s3.r-1 Or  s3.y<s3.r Then S3.dy=-S3.dy
   
    For n As Integer=1 To Ubound(a)'green one
        'move all the sphere points
        a(n).x+=S2.dx
        a(n).y+=S2.dy
        If insphere(s,a(n))=0 Then
            If onscreen(a(n).x,a(n).y) Then
                ppset(a(n).x,a(n).y,a(n).col)
            End If
        End If
    Next n
   
    For n As Integer=1 To Ubound(a1)'blue one
        'move all the sphere points
        a1(n).x+=S3.dx
        a1(n).y+=S3.dy
        If insphere(s,a1(n))=0 And insphere(s2,a1(n))=0 Then
            If onscreen(a1(n).x,a1(n).y) Then
                ppset(a1(n).x,a1(n).y,a1(n).col)
            End If
        End If
       
    Next n 
   
    Screenunlock
    Sleep regulate(40,fps),1
Loop Until Len(Inkey)
blue()
Imagedestroy s.image
Imagedestroy im
Sleep

 

 
BasicCoder2
Posts: 3598
Joined: Jan 01, 2009 7:03
Location: Australia

Re: RAY CASTING

Postby BasicCoder2 » Sep 08, 2014 20:58

@dodicat
Will just have to wait until I update to the latest FreeBasic as all I get are compiler errors starting with,
Syntax error, found 'Extends' in 'Type sphere Extends V3'
dodicat
Posts: 6727
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: RAY CASTING

Postby dodicat » Sep 08, 2014 21:13

Hi BasicCoder2.

Extends is OK with version .90 or even version 0.24.0
BasicCoder2
Posts: 3598
Joined: Jan 01, 2009 7:03
Location: Australia

Re: RAY CASTING

Postby BasicCoder2 » Sep 08, 2014 22:12

dodicat wrote:Hi BasicCoder2.

Extends is OK with version .90 or even version 0.24.0

@dodicat
As I haven't gotten around to learning to use the more advanced programming techniques I only need the later versions to run other people's code. I appear to have Version 0.23.0 at the moment.
dodicat
Posts: 6727
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: RAY CASTING

Postby dodicat » Sep 08, 2014 23:00

Thanks BasicCoder2.

Mind you, I think you should update.

You post quite a lot of code, and in your own words, you prefer to use basic methods, and they work well.
I have borrowed some of your techniques, for instance, moving a screen with the mouse, and some of your direct pixel routines.

Plus the fact that using version .91 you may come across some bugs.

Here is the previous code without extends and using lang fb or fblite.
I don't have version 23 any more, but fingers crossed.

By the way, the demo is absolutely stupid, just a joke really. bluatigro didn't fix his code, so I just made some stuff up.

Code: Select all

 
'#lang "fblite"

Dim As Integer xres,yres,pitch
Screeninfo xres,yres
Screenres xres,yres,32,,1
Dim As Any Ptr row=Screenptr
Dim As Uinteger Ptr pixel
Screeninfo xres,yres,,,pitch
Dim As Any Ptr im=Imagecreate(xres,yres,Rgb(0,0,200))

Type V3
    As Integer x,y,z
    As Uinteger col
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
End Type

Type sphere
    As Integer x,y,z
    As Single dx,dy,dz
    As Integer r
    As Any Ptr image
End Type

#macro insphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) < S.R*S.R
#endmacro

#macro onsphere(S,P)
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) <= S.R*S.R Andalso _
(S.x-P.x)*(S.x-P.x)+(S.y-P.y)*(S.y-P.y)+(S.z-P.z)*(S.z-P.z) > (S.R-1)*(S.R-1)
#endmacro

#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
*pixel=(colour)
#endmacro

#define onscreen(_x,_y) _x>0 and _x<xres-1 and _y>0 and _y<yres-1

Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
    Static As Double timervalue,lastsleeptime,t3,frames
    dim as double t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    dim as integer sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Dim As V3 p

Dim As sphere s=Type<sphere>(200,200,0,(2+Rnd*3),(2+Rnd*3),0,200), _
s2=Type<sphere>(250,400,90,(3+Rnd*2),(3+Rnd*2),0,100), _
s3=Type<sphere>(500,500,100,(4+Rnd*5),(4+Rnd*5),0,80)'60
s.image=Imagecreate(2*s.r,2*s.r)
dim as integer x,y,z,n
dim as single c,cc
'background         
For n =0 To xres
    Dim As Integer rr=map(0,xres,n,0,100)
    Dim As Integer gg=map(0,xres,n,0,100)
    Line im,(n,0)-(n,yres),Rgb(rr,gg,255)
Next n

'to image red sphere
For x =s.x-s.r To s.x+s.r
    For y =s.y-s.r To s.y+s.r
        For z =s.z To s.z+s.r
            p=Type<V3>(x,y,z)
            If onsphere(s,p) Then
                dim as single xx=(s.x-p.x)/s.r
                cc=map(-1,1,xx,250,50)
                Pset s.image,(p.x,p.y),Rgb(cc,0,0)
            End If
        Next z
    Next y
Next x

'mobile ones
Redim Shared As V3 a(0),a1(0)

For x =s2.x-s2.r To s2.x+s2.r
    For y =s2.y-s2.r To s2.y+s2.r
        For z =s2.z To s2.z+s2.r
            p=Type<V3>(x,y,z)
            If onsphere(s2,p) Then
                Redim Preserve a(1 To Ubound(a)+1)
                a(Ubound(a))=Type<V3>(x,y,z)
                 c=(s2.x-a(Ubound(a)).x)/s2.r
                cc=map(1,-1,c,50,250)
                a(Ubound(a)).col=Rgb(0,cc,0)
            End If
        Next z
    Next y
Next x

For x =s3.x-s3.r To s3.x+s3.r
    For y =s3.y-s3.r To s3.y+s3.r
        For z =s3.z To s3.z+s3.r
            p=Type<V3>(x,y,z)
            If onsphere(s3,p) Then
                Redim Preserve a1(1 To Ubound(a1)+1)
                a1(Ubound(a1))=Type<V3>(x,y,z)
                c=(s3.x-a1(Ubound(a1)).x)/s3.r
                 cc=map(1,-1,c,50,250)
                a1(Ubound(a1)).col=Rgb(50,0,cc)
            End If
        Next z
    Next y
Next x 

'=========================================================
Dim As Integer fps
Do
    Screenlock
    Cls
    'move the red sphere image
    S.x+=S.dx
    S.y+=S.dy
    If s.x>xres-s.r Or  s.x<s.r Then S.dx=-S.dx
    If s.y>yres-s.r Or  s.y<s.r Then S.dy=-S.dy
   
    Put(0,0),im,Pset
    Put(s.x-s.r,s.y-s.r),s.image,trans
   
    Draw String (20,20),"Framerate " & fps
    'move the sphere centres and check edge boundaries
    S2.x+=S2.dx
    S2.y+=S2.dy
    If s2.x>xres-s2.r-1 Or  s2.x<s2.r Then S2.dx=-S2.dx
    If s2.y>yres-s2.r-1 Or  s2.y<s2.r Then S2.dy=-S2.dy
   
    S3.x+=S3.dx
    S3.y+=S3.dy
    If s3.x>xres-s3.r-1 Or  s3.x<s3.r Then S3.dx=-S3.dx
    If s3.y>yres-s3.r-1 Or  s3.y<s3.r Then S3.dy=-S3.dy
   
    For n =1 To Ubound(a)'green one
        'move all the sphere points
        a(n).x+=S2.dx
        a(n).y+=S2.dy
        If insphere(s,a(n))=0 Then
            If onscreen(a(n).x,a(n).y) Then
                ppset(a(n).x,a(n).y,a(n).col)
            End If
        End If
    Next n
   
    For n =1 To Ubound(a1)'blue one
        'move all the sphere points
        a1(n).x+=S3.dx
        a1(n).y+=S3.dy
        If insphere(s,a1(n))=0 And insphere(s2,a1(n))=0 Then
            If onscreen(a1(n).x,a1(n).y) Then
                ppset(a1(n).x,a1(n).y,a1(n).col)
            End If
        End If
       
    Next n 
   
    Screenunlock
    Sleep regulate(40,fps),1
Loop Until Len(Inkey)
Imagedestroy s.image
Imagedestroy im
Sleep

 

 
BasicCoder2
Posts: 3598
Joined: Jan 01, 2009 7:03
Location: Australia

Re: RAY CASTING

Postby BasicCoder2 » Sep 09, 2014 4:35

dodicat wrote:You post quite a lot of code, and in your own words, you prefer to use basic methods, and they work well.
I have borrowed some of your techniques, for instance, moving a screen with the mouse, and some of your direct pixel routines.

Your code ran ok with the last version. Reminds me of those molecular models.
If I used a direct pixel routine it would have been written by someone else.
Last edited by BasicCoder2 on Sep 09, 2014 7:41, edited 1 time in total.
Roland Chastain
Posts: 948
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: RAY CASTING

Postby Roland Chastain » Sep 09, 2014 6:52

Very nice effect, dodicat.
bluatigro
Posts: 652
Joined: Apr 25, 2012 10:35
Location: netherlands

Re: RAY CASTING

Postby bluatigro » Sep 13, 2014 16:18

update :
- try at shading

error :
- i get only 1 sphere whit a color background
- i dont get shading

Code: Select all

''bluatigro
''raycater strart : 3 aug 2014
type t3d
public :
  dim as double x , y , z
  declare constructor ( x as double = 0 _
  , y as double = 0 , z as double = 0 )
  declare sub fill( x as double , y as double , z as double )
  declare function length() as double
end type
constructor t3d( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end constructor
sub t3d.fill( a as double , b as double , c as double )
  x = a
  y = b
  z = c
end sub
function dot( l as t3d , r as t3d ) as double
  return l.x * r.x + l.y * r.y + l.z * r.z
end function
function cross( l as t3d , r as t3d ) as t3d
  return type( l.y * r.z - l.z * r.y _
             , l.z * r.x - l.x * r.z _
             , l.x * r.y - l.y * r.x )
end function
function t3d.length() as double
  return sqr( x ^ 2 + y ^ 2 + z ^ 2 )
end function
function angle( l as t3d , r as t3d ) as double
  return dot( l , r ) / ( l.length() * r.length() )
end function
operator + ( l as t3d , r as t3d ) as t3d
  return type( l.x + r.x , l.y + r.y , l.z + r.z )
end operator
operator * ( q as t3d , d as double ) as t3d
  return type( q.x * d , q.y * d , q.z * d )
end operator
operator - ( r as t3d ) as t3d
  return type( -r.x , -r.y , -r.z )
end operator

type tray
public :
  dim as t3d origin , direction
  declare constructor( o as t3d , d as t3d )
end type
constructor tray( o as t3d , d as t3d )
  origin = o
  direction = d
end constructor

type tcolor
public :
  dim as double red , green , blue , special
  declare constructor ( r as double = 0.0 _
  , g as double = 0.0 , b as double = 0.0 _
  , s as double = 0.0 )
  declare function toInt() as integer
end type
constructor tcolor( r as double , g as double _
, b as double , s as double )
  red = r
  green = g
  blue = b
  special = s
end constructor
function tcolor.toInt() as integer
  return rgb( red * 255 , green * 255 , blue * 255 )
end function
operator * ( kl as tcolor , d as double ) as tcolor
  return type( kl.red * d , kl.green * d , kl.blue * d )
end operator

type tlight
public :
  dim position as t3d
  dim kleur as tcolor
  declare constructor()
end type
constructor tLight()
  position.fill 0 , 100 , 0
  kleur = type<tcolor>( 1.0 , 1.0 , 1.0 , 0.0 )
end constructor

''type tshape
''public :
''  dim kleur as tcolor
''  declare function getNormal( p as t3d ) as t3d
''  declare function hit( ray as tray ) as double
''end type

type tsphere ''( tshape )
  dim position as t3d
  dim as double radius , r2
  dim kleur as tcolor
  declare constructor ()
  declare constructor ( p as t3d , r as double , kl as tcolor )
  declare function getNormal( p as t3d ) as t3d
  declare function hit( ray as tray ) as double
end type
constructor tsphere()
  position = type<t3d>( 0.0 , 0.0 , 0.0 )
  radius = 100.0
  r2 = radius ^ 2
  kleur = type<tcolor>( 1.0 , 1.0 , 1.0 , 0.0 )
end constructor
constructor tsphere( p as t3d , r as double , kl as tcolor )
  position = p
  radius = r
  r2 = radius ^ 2
  kleur = kl
end constructor
function tsphere.getNormal( p as t3d ) as t3d
  return position + ( -p )
end function
function tsphere.hit( ray as tray ) as double
  dim as t3d o , d , s
  o = ray.origin
  d = ray.direction
  s = position
  dim as double a = 1.0 , b , c
  b = ( 2 * ( o.x - s.x ) * d.x ) _
    + ( 2 * ( o.y - s.y ) * d.y ) _
    + ( 2 * ( o.z - s.z ) * d.z )
  c = ( o.x - s.x ) ^ 2.0  _
    + ( o.y - s.y ) ^ 2.0  _
    + ( o.z - s.z ) ^ 2.0  _
    - ( r2 )
   dim as double dis = b * b - 4 * a * c
  if ( dis > 0.0 ) then
    dim as double root1 = ( -b - sqr( dis ) ) / 2 - 1e-10
    if ( root1 > 0.0 ) then
      return root1
    else
      return ( -b + sqr( dis ) ) / 2 + 1e-10
    end if
  else
    return -1
  end if
end function

type tcamera
public :
  dim as t3d position , direction , rechts , down
  declare constructor( p as t3d , d as t3d , r as t3d , u as t3d )
end type

function range( low as double , high as double ) as double
  return rnd * ( high - low ) + low
end function

function winner_index( a() as double , tel as integer ) as integer
  if tel = 0 then return -1
  if tel = 1 then
    if a( 0 ) < 0 then
      return -1
    else
      return 0
    end if
  else
    dim as integer i , t , f
    dim as double min = 1e13
    t = 0
    for i = 0 to tel
      if min > a( i ) then
        min = a( i )
        t = t + 1
        f = i
      end if
    next i
    if t = 0 then
      return -1
    else
      return f
    end if
  end if
end function
     
sub test
  dim as integer winx , winy , wind
  screen 20 , 32
  screeninfo winx , winy , wind

  dim as tlight light
  dim as tsphere spheres( 10 )
  dim as integer i , spheremax = 0
  dim as t3d p , n
  dim as tcolor kleur
  dim as double r , angl
  for i = 0 to 10
    p.fill range( -500.0 , 500.0 ) _
         , range( -300.0 , 300.0 ) _
         , range( 200.0 , 1000.0 )
    r = range( 10.0 , 10.0 )
    kleur = type<tcolor>( rnd , rnd , rnd , 0.0 )
    spheres( i ) = tsphere( p , r , kleur )
  next i
  dim as double x , y , a( 10 )

  for x = -winx/2 to winx/2
    for y = -winy/2 to winy/2
      dim as t3d o , d
      o.fill x , y , 0.0
      d.fill x / winx , y / winx , 1.0
      dim as tray ray = tray( o , d )
      for i = 0 to 10
        a( i ) = spheres( i ).hit( ray )
      next i
      i = winner_index( a() , 10 )
      if i < 0 then
        pset( winx / 2 + x , winy / 2 - y ) , 0
      else
        kleur = spheres( i ).kleur
        p = ray.origin + ray.direction _
        * ( a(i) / ray.direction.length() )
        angl = angle( spheres(i).getNormal( p ) , light.position )
        kleur = kleur * ( cos( angl ) / 2 + .5 )
        pset( winx / 2 + x , winy / 2 - y ) _
        , kleur.toInt()
      end if
    next y
  next x

end sub

while inkey() = ""
  test
  sleep 1000
wend

end
 

Return to “General”

Who is online

Users browsing this forum: No registered users and 12 guests