(sorry for translated text, don't speak english)
The famous 3d demo "Juggler" from the Commodore AMIGA 500.
The original source code is available at "aminet".
https://archive.org/details/raytracer-1 ... de.adf.-7z
Inside the original A500 disk (ADF format) come three C files of which only RT1 and RT2 are needed, since RT3 was only for the Amiga's HAM graphics system.
I have converted both RT1,RT2 "C" to FB and used a couple of enhanced routines from:
http://www.etwright.org/cghist/juggler_rt.html
I have included two demos, one of spheres with the three possible modes DULL, BRIGHT and MIRROR and another demo of the famous "JUGGLER".
It is not very optimized, since it is thought for its operation in C, not in Basic, but it makes its function, that is what matters.
It uses too many pointers, which makes it complicated to understand and even more to modify.
The use of "DOUBLE" is mandatory, because of the way it makes the calculations. If you change it to "SINGLE", the "MIRROR" function calculates it wrong.
Eventually I want to implement also the possibility to create the animation that gives life to this demo.
Translated with www.DeepL.com/Translator (free version)
(Spanish, in case you do not understand the automatic translation well)
La famosa demo 3d "Juggler" del Commodore AMIGA 500.
El codigo fuente original esta disponible en "aminet"
https://archive.org/details/raytracer-1 ... de.adf.-7z
Dentro del disco original del A500 (formato ADF) vienen tres ficheros C de los cuales solo son necesario el RT1 y RT2, dado que el RT3 era solo para el sistema grafico HAM del Amiga.
He convertido ambos C a FB y utilizado un par de rutinas mejoradas de:
http://www.etwright.org/cghist/juggler_rt.html
He incluido dos demos , una de esferas con los tres modos posibles DULL, BRIGHT y MIRROR y otra demo del famoso "JUGGLER"
No esta muy optimizada, dado que esta pensada para su funcionamiento en C, no en Basic, pero hace su funcion, que es lo que importa.
Emplea demasiados punteros, lo que lo hace complicado de entender y mas aun de modificar.
Es obligatorio el uso de "DOUBLE", por la forma en la que hace los cálculos. SI se cambia a "SINGLE" , la funcion "MIRROR" la calcula mal.
Con el tiempo quiero implementar tambien la posibilidad de crear la animacion que da vida a esta demo.
Main RT1.BAS
Code: Select all
/' RT1.C Ray tracing program
Copyright 1987 Eric Graham
Permission is granted to copy and modify this file, provided
that this notice is retained.
FreeBasic Version By Jepalza_22 (gmail.com)
'/
#Include "defs.bi"
#Include "world.bi"
#Include "rt2.bas"
/' Do the raytracing '/
Sub raytrace(brite() As Double , lines As Double Ptr , w As world Ptr)
Dim As Double t,tmin,pos_(2)
Dim As Long k
Dim As patch ptch
Dim As sphere Ptr spnear=0
Dim As lamp Ptr lmpnear=0
tmin=_BIG
spnear=0 /' can we see some spheres '/
for k=0 To w->numsp -1
if (intsplin(@t,lines,@w->sp[k])) Then
if (t<tmin) Then tmin=t: spnear=@w->sp[k]
EndIf
Next
lmpnear=0 /' are we looking at a lamp '/
for k=0 To w->numlmp -1
if (intsplin(@t,lines,Cast(sphere Ptr,@w->lmp[k]) )) Then ' LMP necesita ser SPHERE para evitar advertencia
if (t < tmin) Then tmin=t: lmpnear=@w->lmp[k]
EndIf
Next
if (lmpnear) Then /' we see a lamp! '/
For k=0 To 2
brite(k)=lmpnear->color_(k)/(lmpnear->radius*lmpnear->radius)
Next
Exit Sub
EndIf
if (inthor(@t,lines)) Then /' do we see the ground? '/
If (t<tmin) Then
point_(@pos_(0),t,lines)
k=gingham(@pos_(0)) /' cheap vinyl '/
veccopy(@w->horizon(k).pos_(0),@pos_(0))
pixbrite(brite(), @w->horizon(k),w,0)
Exit sub
EndIf
EndIf
If (spnear<>0) Then /' we see a sphere '/
point_(@ptch.pos_(0),tmin,lines)
setnorm(@ptch,spnear)
colorcpy(@ptch.color_(0),@spnear->color_(0))
Select Case (spnear->type_) /' treat the surface type '/
Case _BRIGHT ' type 1
If glint_(brite(),@ptch,w,spnear,lines)=0 Then
pixbrite(brite(),@ptch,w,spnear) 'DULL
EndIf
Case _DULL ' type 0
pixbrite(brite(),@ptch,w,spnear)
Case _MIRROR ' type 2
mirror(brite(),@ptch,w,lines)
End Select
Exit Sub
EndIf
skybrite(brite(),lines,w) /' nothing else, must be sky '/
End Sub
/' calculate sky color '/
Sub skybrite(brite() As Double , lines As Double Ptr , w As world Ptr)
/' Blend a sky color from the zenith to the horizon '/
Dim As Double sin2,cos2
Dim As Long k
Sin2=lines[5]*lines[5]
Sin2/=(lines[1]*lines[1]+lines[3]*lines[3]+sin2)
Cos2=1.0-Sin2
for k=0 To 2
brite(k)=cos2*w->skyhor(k)+Sin2*w->skyzen(k)
Next
End Sub
/' calculate ray for pixel i,j '/
Sub pixline( lines As Double Ptr , o As observer Ptr , i As Long , j As Long)
Dim As Double x,y,tp(3)
Dim As Long k
y=(0.5*o->ny-j)*o->py
x=(i-0.5*o->nx)*o->px
for k=0 To 2
tp(k)=o->viewdir(k) * o->fl + y * o->vhat(k) + x * o->uhat(k) + o->obspos(k)
Next
genline(lines,@o->obspos(0),@tp(0)) /' generate equation of line '/
End Sub
/' a=b-c for vectors '/
Sub vecsub( a As Double Ptr , b As Double Ptr , c As Double Ptr)
Dim As Long k
for k=0 To 2
a[k]=b[k]-c[k]
Next
End Sub
/' intersection of sphere and line '/
Function intsplin( t As Double Ptr , lines As Double Ptr , sp As sphere Ptr) As Long
/' t returns the parameter for where on the line '/
Dim As Double a,b,c,d,p,q,tt
Dim As Long k /' the sphere is hit '/
a=0.0
b=0.0
c=sp->radius
c=-c*c
for k=0 To 2
p=*lines - sp->pos_(k):lines+=1
q=*lines:lines+=1
a=q*q+a
tt=q*p
b=tt+tt+b
c=p*p+c
Next
/' a,b,c are coefficients of quadratic equation for t '/
d=b*b-4.0*a*c
if (d <= 0) Then return 0 /' line misses sphere '/
d=Sqr(d)
*t=-(b+d)/(a+a)
if (*t<_SMALL) Then *t=(d-b)/(a+a)
return IIf(*t >_SMALL,1,0) /' is sphere is in front of us? '/
End Function
/' intersection of line with ground '/
Function inthor( t As Double Ptr , lines As Double Ptr) As Long
if (lines[5] = 0.0) Then return 0
*t=-lines[4]/lines[5]
return IIf(*t > _SMALL,1,0)
End Function
/' generate the equation of a line through the two points a and b '/
Sub genline( l As Double Ptr , a As Double Ptr , b As Double Ptr)
Dim As Long k
for k=0 To 2
*l=a[k]:l+=1
*l=b[k]-a[k]:l+=1
Next
End Sub
/' dot product of 2 vectors '/
Function dot( a As Double Ptr , b As Double Ptr) As Double
return a[0]*b[0] + a[1]*b[1] + a[2]*b[2]
End Function
/' calculate position of a point on the line with parameter t '/
Sub point_( pos_ As Double Ptr , t As Double , lines As Double Ptr)
Dim As Long k
Dim As Double a
for k=0 To 2
a=*lines:lines+=1
pos_[k]=a+(*lines)*t:lines+=1
Next
End Sub
' ----------------------------------------------
' solo llega cuando la esfera usa el modo BRIGHT
/' are we looking at a highlight? '/
Function glint_(brite() As Double , p As patch Ptr , w As world Ptr , spc_ As sphere Ptr ,incident As Double Ptr) As Long
Dim As Long k,lo,firstlite=1
Dim As Double minglint=0.95
Dim As Double lines(5),t,r,lp(2)
Dim As Double Ptr pp
Dim As Double Ptr ll
Dim As Double cosi
Dim As Double incvec(2),refvec(2),ref2
for lo=0 To w->numlmp -1
ll=@w->lmp[lo].pos_(0)
pp=@p->pos_(0)
vecsub(@lp(0),ll,pp)
cosi=dot(@lp(0),@p->normal(0))
if (cosi <= 0.0) Then continue For /' not with this lamp! '/
genline(@lines(0),pp,ll)
for k=0 To w->numsp -1
if (@w->sp[k] = spc_) Then Continue For
if (intsplin(@t,@lines(0),@w->sp[k])) Then goto cont
Next
if (firstlite) Then
incvec(0)=incident[1]
incvec(1)=incident[3]
incvec(2)=incident[5]
reflect(@refvec(0),@p->normal(0),@incvec(0))
ref2=dot(@refvec(0),@refvec(0))
firstlite=0
EndIf
r=dot(@lp(0),@lp(0))
t=dot(@lp(0),@refvec(0))
t*=t/(dot(@lp(0),@lp(0))*ref2)
if (t > minglint) Then /' it´s a highlight '/
for k=0 To 2
brite(k)=1.0
Next
return 1
EndIf
cont:
Next
return 0
End Function
' ----------------------------------------------
' solo llega cuando la esfera usa el modo MIRROR
/' bounce ray off mirror '/
Sub mirror(brite() As Double , p As patch Ptr , w As world Ptr , incident As Double Ptr)
Dim As Long k
Dim As Double lines(5),incvec(2),refvec(2),t
' lines origin
incvec(0)=incident[1]
incvec(1)=incident[3]
incvec(2)=incident[5]
t=dot(@p->normal(0),@incvec(0))
if (t >= 0) Then /' we´re inside a sphere, it´s dark '/
for k=0 To 2
brite(k)=0.0
Next
Exit Sub
EndIf
reflect(@refvec(0),@p->normal(0),@incvec(0))
' lines origin
lines(0)=p->pos_(0)
lines(2)=p->pos_(1)
lines(4)=p->pos_(2)
' lines dir
lines(1)=refvec(0)
lines(3)=refvec(1)
lines(5)=refvec(2)
Dim aa As Double=brite(0)
Dim bb As Double=brite(1)
Dim cc As Double=brite(2)
raytrace(brite(),@lines(0),w) /' recursion saves the day '/
for k=0 To 2
brite(k)=brite(k)*p->color_(k)
Next
End Sub
' llamado con el modo normal (DULL) y al calcular el suelo (GROUND)
/' how bright is the patch? '/
Sub pixbrite(brite() As Double , p As patch Ptr , w As world Ptr , spc_ As sphere Ptr)
Dim As Long k,lo
Dim As Double lines(5),t,r,lp(2)
Dim As Double Ptr pp
Dim As Double Ptr ll
Dim As Double cosi,diffuse
Dim As Double zenith(2)={0.0 ,0.0 ,1.0}
Dim As Double f1=1.5
Dim As Double f2=0.4
diffuse=(dot(@zenith(0),@p->normal(0))+f1)*f2
for k=0 To 2
brite(k)=diffuse*w->illum(k)*p->color_(k)
Next
'If (p<>0) And (w<>0) Then ' siempre existen P y W ?
for lo=0 To w->numlmp -1
ll=@w->lmp[lo].pos_(0)
pp=@p->pos_(0)
vecsub(@lp(0),ll,pp)
cosi=dot(@lp(0),@p->normal(0))
if (cosi <= 0.0) Then Continue For
genline(@lines(0),pp,ll)
For k=0 To w->numsp-1
If (@w->sp[k] = spc_) Then Continue For ' sphere can't shadow itself
if (intsplin(@t,@lines(0),@w->sp[k])) Then GoTo cont ' exit for: continue for
Next
r=Sqr(dot(@lp(0),@lp(0)))
cosi=cosi/(r*r*r)
For k=0 To 2
brite(k)=brite(k) + cosi * p->color_(k) * w->lmp[lo].color_(k)
Next
cont:
Next
'EndIf
End Sub
/' normal (radial) direction of sphere '/
Sub setnorm( p As patch Ptr , s As sphere Ptr)
' old from Eric Graham
'Dim As Double Ptr t
'Dim As Double a
'Dim As Long k
't=@p->normal(0)
'vecsub(t,@p->pos_(0),@s->pos_(0))
'a=1.0/s->radius
'for k=0 To 2
' *t=(*t)*a:t+=1
'Next
' new from http://www.etwright.org/cghist/juggler_rt.html
vecsub(@p->normal(0),@p->pos_(0),@s->pos_(0))
p->normal(0) /=s->radius
p->normal(1) /=s->radius
p->normal(2) /=s->radius
End Sub
/' a=b for colors '/
Sub colorcpy( a As Double Ptr , b As Double Ptr)
Dim As Long k
for k=0 To 2
a[k]=b[k]
Next
End Sub
/' a=b for vectors '/
Sub veccopy( a As Double Ptr , b As Double Ptr)
Dim As Long k
for k=0 To 2
a[k]=b[k]
Next
End Sub
' floor square tiles
/' are we on ´black´ or ´white´ tile? '/
Function gingham( pos_ As Double Ptr) As Long
/' tiles are 3 units wide '/
Dim As Double x,y
Dim As Long kx,ky
kx=0
ky=0
x=pos_[0]
y=pos_[1]
if (x < 0) Then
x=-x
kx+=1
EndIf
if (y < 0.0) Then
y=-y
ky+=1
EndIf
return ( cint((x+kx)\3) + cint((y+ky)\3) ) Mod 2
End Function
/' ======================================================================
reflect()
Calculate the reflection ray 'Y' (incoming ray x reflected about the surface normal n).
Eric's code had some wacky cross-product stuffgoing on, with a special case for x || n.
I've replaced it with the standard calculation.
See for example --> http://paulbourke.net/geometry/reflected/
====================================================================== '/
Sub reflect( y As Double Ptr , n As Double Ptr , x As Double Ptr)
Dim As Double xx(2),d
Dim As Long k
d=dot(x,n)
for k=0 To 2
y[k]=x[k] - 2 *d*n[k]
Next
End Sub
' ================================== MAIN ====================================
' read file with composition scene
Dim As String fichero,sa
fichero=Command
'fichero="robot.txt" ' demo
If fichero="" Then Print "Falta indicar el nombre del fichero con la escena":Sleep:End
Dim As Integer nlin
Open fichero For Input As 1
While Not (Eof(1))
Line Input #1,sa
scene(nlin)=sa
nlin+=1
Wend
' initiate world
Dim As Double lines(5),brite(2)
Dim As observer o
Dim As world w
Dim As Long ii,jj
Dim As Long si,sj
' create world from scene file
read_scene()
setup(@o,@w)
si=1+(o.nx-1)
sj=1+(o.ny-1)
ScreenRes si,sj,32
for jj=0 To o.ny -1
for ii=0 To o.nx -1
pixline(@lines(0),@o,ii,jj)
raytrace(brite(),@lines(0),@w)
ham(ii,jj,brite(),@o) ' HAM=Original High Resolution from Amiga 500 ;-)
Next
Next
Beep
Sleep
Code: Select all
/' RT2.C
Copyright 1987 Eric Graham
All rights reserved.
This file may not be copied, modified or uploaded to a bulletin
board system, except as provided below.
Permission is granted to make a reasonable number of backup copies,
in order that it may be used to generate executable code for use
on a Double computer system.
Permission is granted to modify this code and use the modified code
for non commercial use by the original purchaser of this software,
and provided that this notice is included in the modified version.
'/
/'This function is really a stub, you should, change it to suit your needs'/
Sub setup( o As observer Ptr , w As world Ptr)
Dim As Double alt,azm,degtorad
Dim As Long i,j,k
Dim As Double t,r,tp(2),lampfac,pmin(2),pmax(2)
degtorad=0.0174533 ' PI/180
for k=0 To 2
pmin(k)=_BIG
pmax(k)=-_BIG
Next
' ------------- WORLD DEFINITION ----------
' picture resolution
o->nx=scx
o->ny=scy
' pixels sizes ratio
o->px= 1.0/o->nx
o->py=0.75/o->ny
' observer position
o->obspos(0)=obsx
o->obspos(1)=obsy
o->obspos(2)=obsz
' altitude - azimuth
alt=obsalt * degtorad
azm=obsazm * degtorad
' focal length
o->fl=0.028*obsfl
' view point
o->viewdir(0)=cos(azm)*cos(alt)
o->viewdir(1)=sin(azm)*cos(alt)
o->viewdir(2)=sin(alt)
o->uhat(0)= Sin(azm)
o->uhat(1)=-cos(azm)
o->uhat(2)=0.0
o->vhat(0)=-cos(azm)*sin(alt)
o->vhat(1)=-sin(azm)*sin(alt)
o->vhat(2)= Cos(alt)
' define spheres
w->numsp=nspheres
w->sp=@rtspheres(0)
w->numlmp=nlamps
w->lmp=@rtlamps(0)
w->horizon(0).pos_(0)=rttiles(0).pos_(0)
w->horizon(0).pos_(1)=rttiles(0).pos_(1)
w->horizon(0).pos_(2)=rttiles(0).pos_(2)
w->horizon(1).pos_(0)=rttiles(1).pos_(0)
w->horizon(1).pos_(1)=rttiles(1).pos_(1)
w->horizon(1).pos_(2)=rttiles(1).pos_(2)
w->horizon(0).normal(0)=rttiles(0).normal(0)
w->horizon(0).normal(1)=rttiles(0).normal(1)
w->horizon(0).normal(2)=rttiles(0).normal(2)
w->horizon(1).normal(0)=rttiles(1).normal(0)
w->horizon(1).normal(1)=rttiles(1).normal(1)
w->horizon(1).normal(2)=rttiles(1).normal(2)
w->horizon(0).color_(0)=rttiles(0).color_(0)
w->horizon(0).color_(1)=rttiles(0).color_(1)
w->horizon(0).color_(2)=rttiles(0).color_(2)
w->horizon(1).color_(0)=rttiles(1).color_(0)
w->horizon(1).color_(1)=rttiles(1).color_(1)
w->horizon(1).color_(2)=rttiles(1).color_(2)
w->illum(0)=rtambient.r
w->illum(1)=rtambient.g
w->illum(2)=rtambient.b
w->skyzen(0)=rtskyzen.r
w->skyzen(1)=rtskyzen.g
w->skyzen(2)=rtskyzen.b
w->skyhor(0)=rtskyhor.r
w->skyhor(1)=rtskyhor.g
w->skyhor(2)=rtskyhor.b
lampfac=_BIG /' modify the lamp brightness so as to '/
for i=0 To w->numsp -1 /' get the right exposure '/
for j=0 To w->numlmp -1
vecsub(@tp(0),@w->sp[i].pos_(0),@w->lmp[j].pos_(0))
r=Sqr(dot(@tp(0),@tp(0)))
r-=w->sp[i].radius
for k=0 To 2
t=w->sp[i].color_(k)*w->lmp[j].color_(k)/(r*r)
if (t = 0.0) Then Continue For
t=(1.0-w->sp[i].color_(k)*w->illum(k))/t
if (t<lampfac) Then lampfac=t
Next
Next
Next
for j=0 To w->numlmp -1
For k=0 To 2
w->lmp[j].color_(k)*=lampfac
Next
Next
'print "lampfac=";lampfac
End Sub
Function MAX(a As Double, b As Double) As Double
Return IIf(a>b,a,b)
End Function
Function MIN(a As Double, b As Double) As Double
Return IIf(a<b,a,b)
End Function
' HAM!!! HAHA!!
Sub ham(i As Long , j As Long , brite() As Double, o As observer Ptr)
Dim As Integer d,ch,level,pix(2)
d=4*(j*o->nx+i)
For ch=0 To 2
level=CInt(MAX(MIN(brite(ch)*255,255),0))
pix(ch)=level
Next
PSet(i,j),RGB(pix(0),pix(1),pix(2))
End Sub
Code: Select all
#define _BIG 1.0e10
#define _SMALL 1.0e-5 ' correccion mejora sombras Ernie Wright --> http://www.etwright.org/cghist/juggler_rt.html
#define _DULL 0
#define _BRIGHT 1
#define _MIRROR 2
Type light
As Double r
As Double g
As Double b
End Type
Type lamp 'Field=4
As Double pos_(2) /' position of lamp '/
As Double color_(2) /' color of lamp '/
As Double radius /' size of lamp '/
End Type
Type sphere 'Field=4
As Double pos_(2) /' position of sphere '/
As Double color_(2) /' color of sphere '/
As Double radius /' size of sphere '/
As Long type_ /' type of surface, DULL, BRIGHT or MIRROR '/
End Type
Type patch 'Field=4 /' As a small bit of something visible '/
As Double pos_(2) /' position '/
As Double normal(2) /' direction 90 degrees to surface '/
As Double color_(2) /' color of patch '/
End Type
Type world 'Field=4 /' As everything in the universe, except observer '/
As Long numsp /' number of spheres '/
As sphere Ptr sp /' array of spheres '/
As Long numlmp /' number of lamps '/
As lamp Ptr lmp /' array of lamps '/
As patch horizon(1) /' alternate squares on the ground '/
As Double illum(2) /' background diffuse illumination '/
As Double skyhor(2) /' sky color at horizon '/
As Double skyzen(2) /' sky color overhead '/
End Type
Type observer 'Field=4 /' As now the observer '/
As Double obspos(2) /' his position '/
As Double viewdir(2) /' direction he is looking '/
As Double uhat(2) /' left to right in view plane '/
As Double vhat(2) /' down to up in view plane '/
As Double fl,px,py /' focal length and pixel sizes '/
As Long nx,ny /' number of pixels '/
End Type
' RT1
Declare Function dot( a As Double Ptr , b As Double Ptr) As Double /' Vector dot product '/
Declare Function intsplin( t As Double Ptr , lines As Double Ptr , sp As sphere Ptr) As Long
Declare Function inthor( t As Double Ptr , lines As Double Ptr) As Long
Declare Function gingham( pos_ As Double Ptr) As Long
Declare Function glint_(brite() As Double , p As patch Ptr , w As world Ptr , spc_ As sphere Ptr , incident As Double Ptr) As Long
Declare Sub point_( pos_ As Double Ptr , t As Double , lines As Double Ptr)
Declare Sub veccopy( a As Double Ptr , b As Double Ptr)
Declare sub reflect( y As Double Ptr , n As Double Ptr , x As Double Ptr)
Declare Sub colorcpy( a As Double Ptr , b As Double Ptr)
Declare Sub setnorm(p As patch Ptr , s As sphere Ptr)
Declare Sub pixbrite(brite() As Double , p As patch Ptr , w As world Ptr , spc_ As sphere Ptr)
Declare Sub skybrite(brite() As Double , lines As Double Ptr , w As world Ptr)
Declare sub mirror(brite() As Double , p As patch Ptr , w As world Ptr , incident As Double Ptr)
Declare Sub pixline( lines As Double Ptr , o As observer Ptr , i As Long , j As Long)
Declare Sub vecsub( a As Double Ptr , b As Double Ptr , c As Double Ptr)
Declare Sub genline( l As Double Ptr , a As Double Ptr , b As Double Ptr)
' RT2
Declare Sub setup( o As observer Ptr , w As world Ptr)
Declare Sub ham(i As Long , j As Long , brite() As Double, o As observer Ptr)
Code: Select all
#Define MAXLINES 1000 ' max 1000 lines of scene. is it enough??? >:-?
#Define MAXSPHERES 10000 ' max 10000 spheres , enough???
Dim Shared As String scene(MAXLINES) ' to load scene file
Dim Shared As Long nspheres=MAXSPHERES
Dim Shared As sphere rtspheres(nspheres-1)
Dim Shared As Integer scx,scy ' screen resolution
Dim Shared As double obsx,obsy,obsz ' observer position
Dim Shared As Integer obsalt,obsazm ' altitude, azimut
Dim Shared As Integer obsfl ' focal lenght
Dim Shared As Double ambient(8) ' ambient color
Dim Shared As Double lights(10,6) ' ambient lights (one or more, max 10)
Dim Shared As Integer nlamps=9
Dim Shared As lamp rtlamps(nlamps) ' max ten(0-9)
Dim Shared As patch rttiles(1) ' floor tiles colors (x2) in chess mode
Dim Shared As light rtambient ' ambient color
Dim Shared As light rtskyzen ' sky zenith color
Dim Shared As light rtskyhor ' sky horizon color
Sub read_scene()
Dim As Integer a,f,g
Dim As string sa,sb
' in order to avoid format errors, reformat it
Dim As String temp(MAXLINES)
g=0
For f=0 To MAXLINES
sa=scene(f)
a=1
While a
a=InStr(sa,Chr(9)) ' eliminate CHR(9) (tab)
If a Then Mid(sa,a)=" "
Wend
sa=Trim(sa) ' eliminate spaces
If Left(sa,1)=";" Then sa="" ' eliminate comments
a=InStr(sa,";")
If a Then
sa=Left(sa,a-1)
EndIf
If sa<>"" Then temp(g)=Trim(sa):g+=1 ' eliminate empty lines
Next
g-=1
'For f=0 To g
' Print temp(f)
'Next
' create world
For f=0 To g
sa=temp(f)
sa=Trim(sa)
If sa="" Then Continue For
If sa="[RESOLUTION]" Then
sa=temp(f+1)
scx=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
scy=Val(sa)
f+=1
EndIf
If sa="[OBSERVER]" Then
sa=temp(f+1)
obsx=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
obsy=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
obsz=Val(sa)
f+=1
EndIf
If sa="[ALTITUDE]" Then
sa=temp(f+1)
obsalt=Val(sa)
f+=1
EndIf
If sa="[AZIMUT]" Then
sa=temp(f+1)
obsazm=Val(sa)
f+=1
EndIf
If sa="[FOCAL]" Then
sa=temp(f+1)
obsfl=Val(sa)
f+=1
EndIf
If sa="[TILES]" Then
' primer azulejo
sa=temp(f+1)
a=InStr(sa,"(") ' --------- position XYZ
sa=Mid(sa,a+1)
rttiles(0).pos_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).pos_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).pos_(2)=Val(sa)
'----------
a=InStr(sa,"(") ' --------- normal UVW
sa=Mid(sa,a+1)
rttiles(0).normal(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).normal(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).normal(2)=Val(sa)
'----------
a=InStr(sa,"<") ' --------- color RGB
sa=Mid(sa,a+1)
rttiles(0).color_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).color_(1)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(0).color_(2)=Val(sa)
' segundo azulejo
sa=temp(f+2)
a=InStr(sa,"(") ' --------- position XYZ
sa=Mid(sa,a+1)
rttiles(1).pos_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).pos_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).pos_(2)=Val(sa)
'----------
a=InStr(sa,"(") ' --------- normal UVW
sa=Mid(sa,a+1)
rttiles(1).normal(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).normal(1)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).normal(2)=Val(sa)
'----------
a=InStr(sa,"<") ' --------- color RGB
sa=Mid(sa,a+1)
rttiles(1).color_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).color_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rttiles(1).color_(2)=Val(sa)
f+=2
EndIf
If sa="[AMBIENT]" Then
sa=temp(f+1)
a=InStr(sa,"<") ' --------- ambient color RGB
sa=Mid(sa,a+1)
rtambient.r=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtambient.g=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtambient.b=Val(sa)
'----------
a=InStr(sa,"<") ' --------- sky zenith color
sa=Mid(sa,a+1)
rtskyzen.r=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtskyzen.g=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtskyzen.b=Val(sa)
'----------
a=InStr(sa,"<") ' --------- sky horizon color
sa=Mid(sa,a+1)
rtskyhor.r=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtskyhor.g=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtskyhor.b=Val(sa)
f+=1
EndIf
If sa="[LIGHTS]" Then
nlamps=0 ' start with '0'
sa=temp(f+1)
While Left(sa,1)<>"[" ' look for all lights (min. 1)
a=InStr(sa,"(") ' --------- light position XYZ
sa=Mid(sa,a+1)
rtlamps(nlamps).pos_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtlamps(nlamps).pos_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtlamps(nlamps).pos_(2)=Val(sa)
'----------
a=InStr(sa,":") ' --------- light radius
sa=Mid(sa,a+1)
rtlamps(nlamps).radius=Val(sa)
'-----------
a=InStr(sa,"<") ' --------- light color RGB
sa=Mid(sa,a+1)
rtlamps(nlamps).color_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtlamps(nlamps).color_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtlamps(nlamps).color_(2)=Val(sa)
'-----------
nlamps+=1 ' lamp created
If nlamps=10 Then Exit While ' max 10 lights
sa=temp(f+1+nlamps)
Wend
f+=nlamps
EndIf
If sa="[SCENE]" Then
' calculo de repeticiones de esferas en casos de lineas usando el comando "#"
Dim As single x1,x2,x3,y1,y2,y3,z1,z2,z3,r1,r2,r3 ' uso SINGLE temporalmente, luego guardo como DOUBLE
Dim As Integer repeticiones,primeraesfera=0
Dim As Integer esferaactual
nspheres=0 ' start with '0'
f+=1
sa=temp(f)
While 1 ' infinito, ya no sale, dado que es la ultima entidad a tratar
' si lleva "#" delante, es una repeticion (linea de esferas)
If Left(sa,1)="#" Then
'Print "inicio:";sa
esferaactual=nspheres-1 ' esfera anterior para repetir su color y tipo
'---------- color_
a=InStr(sa,"#") ' --------- repeticiones
sa=Mid(sa,a+1)
repeticiones=Val(Trim(sa))
a=InStr(sa,"(") ' --------- sphere position XYZ
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(2)=Val(sa)
a=InStr(sa,":") ' --------- sphere radius
sa=Mid(sa,a+1)
rtspheres(nspheres).radius=Val(sa)
' guardo los datos de la esfera destino (hacia donde queremos llegar)
x2=rtspheres(nspheres).pos_(0)
y2=rtspheres(nspheres).pos_(1)
z2=rtspheres(nspheres).pos_(2)
r2=rtspheres(nspheres).radius
' obtengo el factor de escala para llegar de la esfera 1 a la espera 2
x3=(x2-x1)/repeticiones
y3=(y2-y1)/repeticiones
z3=(z2-z1)/repeticiones
r3=(r2-r1)/repeticiones
' y ahora la magia: creamos "n" esferas entre la 1 y la 2
For g=1 To repeticiones
x1=x1+x3
y1=y1+y3
z1=z1+z3
r1=r1+r3
rtspheres(nspheres).pos_(0)=x1
rtspheres(nspheres).pos_(1)=y1
rtspheres(nspheres).pos_(2)=z1
rtspheres(nspheres).radius =r1
' el color y el tipo de esfera es el de la esfera inicial
rtspheres(nspheres).color_(0)=rtspheres(esferaactual).color_(0)
rtspheres(nspheres).color_(1)=rtspheres(esferaactual).color_(1)
rtspheres(nspheres).color_(2)=rtspheres(esferaactual).color_(2)
rtspheres(nspheres).type_ =rtspheres(esferaactual).type_
nspheres+=1
Next
'nspheres-=1
'f+=1
'Print "sig:";temp(f):sleep
GoTo cont
EndIf
primeraesfera=0
a=InStr(sa,"<") ' --------- sphere color RGB
sa=Mid(sa,a+1)
rtspheres(nspheres).color_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).color_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).color_(2)=Val(sa)
'---------- color_
a=InStr(sa,">") ' --------- sphere type: 0=DULL, 1=BRIGHT, 2=MIRROR
sa=Mid(sa,a+1)
rtspheres(nspheres).type_=Val(Trim(sa))
'----------
a=InStr(sa,"(") ' --------- sphere position XYZ
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(0)=Val(sa)
a=InStr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(1)=Val(sa)
a=Instr(sa,",")
sa=Mid(sa,a+1)
rtspheres(nspheres).pos_(2)=Val(sa)
a=InStr(sa,":") ' --------- sphere radius
sa=Mid(sa,a+1)
rtspheres(nspheres).radius=Val(sa)
'----------
'If primeraesfera=0 Then
' primeraesfera=1
' la primera esfera guardamos su posicion y radio
x1=rtspheres(nspheres).pos_(0)
y1=rtspheres(nspheres).pos_(1)
z1=rtspheres(nspheres).pos_(2)
r1=rtspheres(nspheres).radius
'EndIf
nspheres+=1 ' sphere created
cont:
If nspheres=MAXSPHERES Then Exit While ' max 100000 spheres
f+=1
sa=temp(f)'+nspheres)
If sa="" Then f=10000: Exit While' end , no more data
Wend
EndIf
Next
Print "screen resolution:";scx;" , ";scy
Print "observer position:";obsx;" , ";obsy;" , ";obsz
Print "altitude, azimut :";obsalt;" , ";obsazm
Print "focal lenght :";obsfl
Print
Print "pos TILE 0:";rttiles(0).pos_(0) ;" , ";rttiles(0).pos_(1) ;" , ";rttiles(0).pos_(2)
Print "normal TILE 0:";rttiles(0).normal(0);" , ";rttiles(0).normal(1);" , ";rttiles(0).normal(2)
Print "color TILE 0:";rttiles(0).color_(0);" , ";rttiles(0).color_(1);" , ";rttiles(0).color_(2)
Print
Print "pos TILE 1:";rttiles(1).pos_(0) ;" , ";rttiles(1).pos_(1) ;" , ";rttiles(1).pos_(2)
Print "normal TILE 1:";rttiles(1).normal(0);" , ";rttiles(1).normal(1);" , ";rttiles(1).normal(2)
Print "color TILE 1:";rttiles(1).color_(0);" , ";rttiles(1).color_(1);" , ";rttiles(1).color_(2)
Print
Print "ambient :";rtambient.r;" , ";rtambient.g;" , ";rtambient.b
Print
Print "sky zenith :";rtskyzen.r;" , ";rtskyzen.g;" , ";rtskyzen.b
Print
Print "sky horizont:";rtskyhor.r;" , ";rtskyhor.g;" , ";rtskyhor.b
Print
For f=0 To nlamps-1
Print "Light pos";f;":";rtlamps(f).pos_(0);" , ";rtlamps(f).pos_(1);" , ";rtlamps(f).pos_(2)
Print "Light rad";f;":";rtlamps(f).radius
Print "Light col";f;":";rtlamps(f).color_(1);" , ";rtlamps(f).color_(0);" , ";rtlamps(f).color_(2)
Next
End Sub