' RayTracing versus PhotonMapping
Type REAL As Single ' Определение типа REAL как Single
' Параметры рендера (константы)
Const As Integer Dimension = 256*2 ' Размеры квадратного окна рендеринга (степень 2, иначе артефакты)
Const As Integer Types = 2 ' Количество типов объектов (от 0 до 2): плоскость, сфера, источник света
Const As Integer MaxPhotons = 3000 ' Максимальное количество фотонов
Const As Integer MaxRelections = 3 ' Максимальное количество отражений
Const As REAL gRadius2 = 0.7 ' Радиус сбора фотонов???
Const As REAL gExposure = 40 ' Экспозиция (большие значения затемняют картинку)
' Параметры сцены (глобальные переменные)
Dim Shared As Integer Objects(1) = {1,5} ' Количество объектов в сцене 1 сфера и 5 плоскостей
Dim Shared As REAL gAmbient = 0.2 ' Окружающий свет
Dim Shared As REAL gOrigin(2) = {0 ,0 , 0} ' Положение камеры
Dim Shared As REAL gLight(2) = {0,1.2,3} ' Положение источника света
Dim Shared As REAL gSphere(3) = { -0.5, -0.75, 4, 0.75} ' Положение сферы и её размер
Dim Shared As REAL gPlanes(4,1) = {{0, 1.5}, _ ' Oриентация и положение 5 плоскостей
{1, -1.5}, _
{0, -1.5}, _
{1, 1.5}, _
{2, 5.0}}
Dim Shared As boolean gPhotonMapping = true ' Фотонный маппинг включён - true, отключён - false
Dim Shared As Integer NumberOfPhotons(1,4)
Dim Shared As REAL gPhotons(1,4,MaxPhotons*5,2,2)
Dim Shared As boolean gIntersect
Dim Shared As Integer gType
Dim Shared As Integer gIndex
Dim Shared As REAL gDist2, gDist
Dim Shared As REAL gPoint(2)
Dim Shared As boolean gEmpty = true
Dim Shared As boolean gView3D
Dim Shared As Integer pRow, pCol, pIteration, pMax
' Декларация подпрограмм
Declare Sub GatherPhotons(r() As REAL, p() As REAL,typ As Integer, index As Integer)
Declare Sub GetColor(r() As REAL, rgbIn() As REAL, typ As Integer, index As Integer)
Declare Sub StorePhoton(typ As Integer,index As Integer, _
location() As REAL,direction() As REAL,energy() As REAL)
Declare Sub ShadowPhoton(ray() As REAL)
Declare Sub DrawPhoton(frgb() As REAL,p() As REAL)
Declare Sub ResetRender
Declare Sub Render
' Директивы препроцессора
#define min(a,b) IIf(a<b,a,b) ' Макрос минимум из a и b
#define max(a,b) IIf(a>b,a,b) ' Макрос максимум из a и b
#Macro NormalizeVec(r,v)
Scope
Dim As REAL L2 = v(0)*v(0)+v(1)*v(1)+v(2)*v(2)
If l2<>0 Then L2=1.0/Sqr(L2)
r(0)=v(0)*L2
r(1)=v(1)*L2
r(2)=v(2)*L2
End Scope
#EndMacro
#Macro SubVec(r,a,b)
r(0)=a(0)-b(0)
r(1)=a(1)-b(1)
r(2)=a(2)-b(2)
#EndMacro
#Macro AddVec(r,a,b)
r(0)=a(0)+b(0)
r(1)=a(1)+b(1)
r(2)=a(2)+b(2)
#EndMacro
#Macro MulScalarVec(r,a,b)
r(0)=a(0)*b
r(1)=a(1)*b
r(2)=a(2)*b
#EndMacro
#define DotProduct(a,b) (a(0)*b(0) + a(1)*b(1) + a(2)*b(2))
#define rnd2 (Rnd-Rnd)
#Macro RandomVec(r)
r(0)=Rnd-Rnd
r(1)=Rnd-Rnd
r(2)=Rnd-Rnd
#EndMacro
#define odd(xx) (xx And 1)
Function Distance2(a() As REAL, _
b() As REAL, _
d2 As REAL) As boolean
Dim As REAL c = a(0) - b(0)
Dim As REAL d = c*c
If (d > d2) Then Return false
c = a(1) - b(1)
d += c*c
If (d > d2) Then Return false
c = a(2) - b(2)
d += c*c
If (d > d2) Then Return false
gDist2 = d2
Return true
End Function
Sub RaySphere(idx As Integer,r() As REAL, o() As REAL)
Dim As REAL s(2)
SubVec(s,gSphere,o)
Dim As REAL radius = gSphere(3)
Dim As REAL A = DotProduct(r,r)
Dim As REAL B = -2.0 * DotProduct(s,r)
Dim As REAL C = DotProduct(s,s) - (radius*radius)
Dim As REAL D = B*B - 4*A*C
If (D < 0.0) Then Return
Dim As REAL sign = IIf(C < -0.00001,1,-1)
Dim As REAL l = (-B + sign*Sqr(D))/(2*A)
If (l<0) Or (l>gDist) Then Return
gType = 0
gIndex = idx
gDist = l
gIntersect = true
End Sub
Sub RayPlane(idx As Integer, r() As REAL,o() As REAL)
Dim As Integer axis = gPlanes(idx,0)
If r(axis)=0 Then Return
Dim As REAL l = (gPlanes(idx,1) - o(axis)) / r(axis)
If (l<0) Or (l>gDist) Then Return
gType = 1
gIndex = idx
gDist = l
gIntersect = true
End Sub
Sub RayObject(typ As Integer, idx As Integer, r()As REAL, o() As REAL)
If (typ = 0) Then
RaySphere(idx,r(),o())
Else
RayPlane(idx,r(),o())
End If
End Sub
Sub SphereNormal(r() As REAL,P() As REAL)
Dim As REAL v(2)
SubVec(v,P,gSphere)
NormalizeVec(r,v)
End Sub
Sub PlaneNormal(r() As REAL, idx As Integer, P() As REAL, O() As REAL)
Dim As Integer axis = gPlanes(idx,0)
Dim As REAL N(2)
N(axis) = O(axis) - gPlanes(idx,1)
NormalizeVec(r,N)
End Sub
Sub SurfaceNormal(r() As REAL, _
typ As Integer, _
idx As Integer, _
P() As REAL, _
Inside() As REAL)
If (typ = 0) Then
SphereNormal(r(),P())
Else
PlaneNormal(r(),idx,P(),Inside())
End If
End Sub
Sub MirrorVec(Ret() As REAL,_
Ray() As REAL, _
FromPoint() As REAL)
Dim As REAL N(2)=Any,tmp(2)=Any
SurfaceNormal(N(),gType, gIndex, gPoint(), fromPoint())
MulScalarVec(tmp,N,(2 * DotProduct(ray,N) ))
SubVec(tmp,ray,tmp)
NormalizeVec(Ret,tmp)
End Sub
'
' Освещение
'
Function LightDiffuse(N() As REAL,P() As REAL) As REAL
Dim As REAL L(2)=Any
SubVec(L,gLight,P)
NormalizeVec(L,L)
Return DotProduct(N,L)
End Function
Function LightObject(typ As Integer, _
idx As Integer, _
P() As REAL, _
Ambient As REAL ) As REAL
Dim As REAL N(2)=Any
SurfaceNormal(N(),typ, idx, P(), gLight())
Dim As REAL L = LightDiffuse(N() , P() )
Return min(1.0, max(L, Ambient))
End Function
'
' Рейтрейсинг (трассировка лучей)
'
Sub Raytrace(ray() As REAL,origin() As REAL)
gIntersect = false
gDist = 999999.9
For typ As Integer = 0 To Types-1
For idx As Integer = 0 To Objects(typ)-1
RayObject(typ,idx,ray(),origin())
Next idx
Next typ
End Sub
Sub AbsorbColor(ret() As REAL, _
rgbIn() As REAL, _
r As REAL,g As REAL,b As REAL) ' e.g. White Light Hits Red Wall
Dim As REAL rgbOut(2)={r,g,b}
For c As Integer =0 To 2
ret(c) = min(rgbOut(c),rgbIn(c))
Next
End Sub
Sub GetColor(r() As REAL, _
rgbIn() As REAL, _
typ As Integer, _
idx As Integer)
If (typ=0) Then ' сфера
AbsorbColor(r(),rgbIn(), 1, 1, 0.5)
ElseIf (typ=1) Then ' плоскость
If idx=0 Then
AbsorbColor(r(),rgbIn(), 1.0, 0, 0)
ElseIf idx=2 Then
AbsorbColor(r(),rgbIn(), 0, 1.0, 0)
Else
AbsorbColor(r(),rgbIn(), 1, 1, 1)
End If
End If
End Sub
Sub ComputePixelColor(prgb() As REAL,x As REAL,y As REAL)
Dim As REAL ray(2) = { x/Dimension - 0.5 , _
-(y/Dimension - 0.5), _
1.0}
Raytrace(ray(), gOrigin())
If (gIntersect) Then
MulScalarVec(gPoint,ray,gDist)
If (gType = 0) Then
MirrorVec(ray(),ray(),gOrigin())
Raytrace(ray(), gPoint())
If (gIntersect) Then
Dim As REAL tmp(2)=Any
MulScalarVec(tmp,ray,gDist)
AddVec(gPoint,tmp,gPoint)
End If
End If
If (gPhotonMapping) Then
GatherPhotons(prgb(),gPoint(),gType,gIndex)
Else
Dim As Integer tType = gType
Dim As Integer tIndex = gIndex
Dim As REAL a = gAmbient
Dim As REAL tmp(2)=Any
SubVec(tmp,gPoint,gLight)
Raytrace(tmp(),gLight())
If (tType = gType) And (tIndex = gIndex) Then
a = LightObject(gType, gIndex, gPoint(), gAmbient)
End If
prgb(0)=a:prgb(1)=a:prgb(2)=a
GetColor(prgb(),prgb(),tType,tIndex)
End If
End If
End Sub
'
' Фотонный маппинг
'
Sub GatherPhotons(energy() As REAL, _
p() As REAL, _
typ As Integer, _
idx As Integer)
Dim As REAL N(2)=Any
Dim As REAL tmp(2)=Any
Dim As REAL g(2)=Any
Dim As REAL weight=Any
Dim As REAL frgb(2)=Any
SurfaceNormal(N(), typ, idx, p(), gOrigin())
For i As Integer = 0 To NumberOfPhotons(typ,idx)-1
' положение
g(0)=gPhotons(typ,idx,i,0,0)
g(1)=gPhotons(typ,idx,i,0,1)
g(2)=gPhotons(typ,idx,i,0,2)
If (Distance2(p(),g(),gRadius2)) Then
' направление
g(0)=gPhotons(typ,idx,i,1,0)
g(1)=gPhotons(typ,idx,i,1,1)
g(2)=gPhotons(typ,idx,i,1,2)
weight = max(0.0, -DotProduct(N,g) )
weight *= (1.0 - Sqr(gDist2)) / gExposure
' энергия
g(0)=gPhotons(typ,idx,i,2,0)
g(1)=gPhotons(typ,idx,i,2,1)
g(2)=gPhotons(typ,idx,i,2,2)
MulScalarVec(tmp,g,weight)
AddVec(frgb,frgb,tmp)
End If
Next i
For j As Integer=0 To 2
energy(j)=max(0,min(1,frgb(j) ) )
Next j
End Sub
Sub EmitPhotons
Randomize 1
Dim As REAL frgb(2)=Any
Dim As REAL ray(2)=Any
Dim As REAL p(2)=Any
For typ As Integer = 0 To Types-1
For idx As Integer = 0 To Objects(typ)-1
NumberOfPhotons(typ,idx) = 0
Next idx
Next typ
For i As Integer = 0 To MaxPhotons-1
Dim As Integer bounces = 1
' белый цвет фотона
frgb(0)=1:frgb(1)=1:frgb(2)=1
RandomVec(ray)
NormalizeVec(ray,ray)
p(0) = gLight(0)
p(1) = gLight(1)
p(2) = gLight(2)
While (p(1) >= gLight(1))
Dim As REAL N(2)=Any
RandomVec(N)
NormalizeVec(N,N)
MulScalarVec(N,N,0.75)
AddVec(p,gLight,N)
Wend
Raytrace(ray(), p())
If Abs(p(0) > 1.5) Then Continue For
If Abs(p(1) > 1.5) Then Continue For
If Distance2(p(), gSphere(),gSphere(3)*gSphere(3)) Then Continue For
While (gIntersect<>0) And (bounces <= MaxRelections)
Dim As REAL tmp(2)=Any
MulScalarVec(tmp,ray,gDist)
AddVec(gPoint, tmp, p)
GetColor(frgb(),frgb(),gType,gIndex)
MulScalarVec(frgb,frgb, 1.0/Sqr(bounces))
StorePhoton(gType, gIndex, gPoint(), ray(),frgb())
DrawPhoton(frgb(), gPoint())
ShadowPhoton(ray())
MirrorVec(ray(),ray(),p())
Raytrace(ray(), gPoint())
p(0) = gPoint(0)
p(1) = gPoint(1)
p(2) = gPoint(2)
bounces+=1
Wend
Next i
End Sub
Sub StorePhoton(typ As Integer, _
idx As Integer, _
l() As REAL,_
d() As REAL, _
e() As REAL)
Dim As Integer Photon=NumberOfPhotons(typ,idx)
For i As Integer=0 To 2
gPhotons(typ,idx,Photon,0,i) = l(i) ' Положение
gPhotons(typ,idx,Photon,1,i) = d(i) ' Направление
gPhotons(typ,idx,Photon,2,i) = e(i) ' Энергия
Next
NumberOfPhotons(typ,idx)=Photon+1
End Sub
Sub ShadowPhoton(ray() As REAL)
Dim As REAL shadow(2) = {-0.25,-0.25,-0.25}
Dim As REAL tPoint(2) = {gPoint(0), gPoint(1),gPoint(2)}
Dim As Integer tType = gType ' Save State
Dim As Integer tIndex = gIndex
Dim As REAL BumpedPoint(2)
MulScalarVec(BumpedPoint,ray,0.000001)
AddVec(BumpedPoint,gPoint,BumpedPoint)
Raytrace(ray(), BumpedPoint())
Dim As REAL ShadowPoint(2)=Any
MulScalarVec(ShadowPoint,ray,gDist)
AddVec(ShadowPoint,ShadowPoint, BumpedPoint) ' 3D точка
StorePhoton(gType, gIndex, ShadowPoint(), ray(), shadow())
gPoint(0) = tPoint(0)
gPoint(1) = tPoint(1)
gPoint(2) = tPoint(2)
gType = tType
gIndex = tIndex
End Sub
'
' Рендеринг (визуализация)
'
Sub Render
Dim As Integer x,y,iterations = 0
Dim As Integer nruns
nruns=256
While (iterations < nruns)
nruns=max(pMax, 256)
If (pCol >= pMax) Then
pRow+=1
pCol = 0
If (pRow >= pMax) Then
pIteration+=1
pRow = 0
pMax = Int(2^pIteration)
End If
End If
Dim As Integer pNeedsDrawing = (pIteration = 1) Or odd(pRow) _
Or ( (odd(pRow)=0) And odd(pCol))
x = pCol * (Dimension/pMax)
y = pRow * (Dimension/pMax)
pCol+=1
If (pNeedsDrawing) Then
iterations+=1
Dim As REAL b(2)
ComputePixelColor(b(),x,y)
Dim As UInteger col=RGB(b(0)*255,b(1)*255,b(2)*255)
Line (x,y)-Step((Dimension/pMax)-1,(Dimension/pMax)-1),col,BF ' Возможность отрисовки увеличенного пикселя
'pset (x,y),col
End If
Wend
If (pRow = Dimension-1) Then
gEmpty = false
End If
End Sub
Sub ResetRender()
pRow=0
pCol=0
pIteration=1
pMax=2
gEmpty=true
If (gPhotonMapping And Not gView3D) Then
EmitPhotons()
End If
End Sub
Sub setup()
ScreenRes Dimension,Dimension,24
ResetRender
End Sub
Sub drawit()
If gPhotonMapping Then
WindowTitle "[1]Рейтрейсинг [3]Просмотр фотонов"
Else
WindowTitle "[2]Фотонная карта [3]Просмотр фотонов"
End If
If (gView3D) Then
If (gEmpty) Then
Cls
EmitPhotons()
gEmpty = false
End If
Else
If (gEmpty) Then
Render()
End If
End If
End Sub
Sub DrawPhoton(frgb() As REAL,p() As REAL)
If (gView3D=true) And cbool(p(2) > 0.0) Then
Dim As Integer x = (Dimension/2) + Int(Dimension * p(0)/p(2))
Dim As Integer y = (Dimension/2) + Int(Dimension * -p(1)/p(2))
If (y <= Dimension) Then
PSet (x,y),RGB(frgb(0)*255,frgb(1)*255,frgb(2)*255)
End If
End If
End Sub
Sub SwitchToMode(i As String)
If (i="1") Then
gView3D = false
gPhotonMapping = false
ResetRender()
ElseIf (i="2") Then
gView3D = false
gPhotonMapping = true
ResetRender()
ElseIf (i="3") Then
gView3D = true
ResetRender()
End If
End Sub
'
' Основная программа
'
Dim As String key ' Переменная символа нажатой клавиши
setup() ' Установка размеров окна и сброс рендера
While key<>Chr(27) ' Выполняет программу пока не нажата клавиша Esc
key=InKey
If key="1" Or key="2" Or key="3" Then
SwitchToMode(key)' Сброс рендера и переключение в режим отображения по символу нажатой клавиши
key=""
End If
drawit() ' Отрисовка заголовка окна и рендер 256 пикселей
Sleep(100) ' Пауза 100 миллисекунд
Wend
... вроде есть Operator Overloading в FreeBasic http://free-basic.ru/helprus/ProPgOperatorOverloading.html ...Озадачил :) Макросами и массивами оно ещё как-то в голове укладывалось :) Ещё б понимать саму работу проги и шарить в векторной алгебре :)
... интересно было бы переопределить операции с векторами типа V0 = V1+V2 и т.п. ...
... кстати вот есть лаба http://ext.freebasic.net/dev-docs/files/ext/math/vector3-bi.html#Vector3 ...Поставил... встала криво :( ...или я чего-то не так намутил... но векторы работают... Ещё раз спасибо! Полезная библиотека.
Дописал вначале:
Enum boolean
false = 0, true = Not false
End Enum
Осталась одна ошибка:
fbray.bas(514) error 41: Variable not declared, cbool in 'If (gView3D=true) And cbool(p(2) > 0.0) Then'
... какая версия компилятора? ...1.00
Это не прокатит... переменные, это ж не константы...У меня сейчас нет времени, но вчера, когда я пытался найти инфу об ошибках, вычитал, что с какой-то обновлённой версии начинается эта ерунда. Якобы, у фрибейсика нету, собственно, типа boolean
и шарить в векторной алгебре :)http://mathprofi.ru/matematika_dlya_chainikov.html
я хоть в что-то новое для себя пытаюсь врубиться, с твоей подачи, а ты, походу, вернулся к тому, с чего начал... :) или и не начинал... :-\Цитироватьи шарить в векторной алгебре :)http://mathprofi.ru/matematika_dlya_chainikov.html
... какая версия компилятора? ...1.00
Дописал вначале:Погорячился вчера. Не разобрался сразу. Это вполне работоспособно. Беру свои слова обратно.
Enum boolean
false = 0, true = Not false
End Enum
Осталась одна ошибка:
fbray.bas(514) error 41: Variable not declared, cbool in 'If (gView3D=true) And cbool(p(2) > 0.0) Then'
If (gView3D=true) And Int(p(2) > 0.0) Then
' RayTracing versus PhotonMapping
Type REAL As Single ' Определение типа REAL как Single
' Параметры рендера (константы)
Const As Integer Dimension = 256*2 ' Размеры квадратного окна рендеринга (степень 2, иначе артефакты)
Const As Integer Types = 2 ' Количество типов объектов (от 0 до 2): плоскость, сфера, источник света
Const As Integer MaxPhotons = 3000 ' Максимальное количество фотонов
Const As Integer MaxRelections = 3 ' Максимальное количесво отражений
Const As REAL gRadius2 = 0.7 ' Радиус сбора фотонов???
Const As REAL gExposure = 40 ' Экспозиция (большие значения затемняют картинку)
' Параметры сцены (глобальные переменные)
Dim Shared As Integer Objects(1) = {1,5} ' Количество объектов в сцене 1 сфера и 5 плоскостей
Dim Shared As REAL gAmbient = 0.2 ' Окружающий свет
Dim Shared As REAL gOrigin(2) = {0 ,0 , 0} ' Положение камеры
Dim Shared As REAL gLight(2) = {0,1.2,3} ' Положение источника света
Dim Shared As REAL gSphere(3) = { -0.5, -0.75, 4, 0.75} ' Положение сферы и её размер
Dim Shared As REAL gPlanes(4,1) = {{0, 1.5}, _ ' Oриентация и положение 5 плоскостей
{1, -1.5}, _
{0, -1.5}, _
{1, 1.5}, _
{2, 5.0}}
Dim Shared As Byte gPhotonMapping = 1 ' Фотонный маппинг включён - 1, отключён - 0
Dim Shared As Integer NumberOfPhotons(1,4)
Dim Shared As REAL gPhotons(1,4,MaxPhotons*5,2,2)
Dim Shared As Byte gIntersect
Dim Shared As Integer gType
Dim Shared As Integer gIndex
Dim Shared As REAL gDist2, gDist
Dim Shared As REAL gPoint(2)
Dim Shared As Byte gEmpty = 1
Dim Shared As Byte gView3D
Dim Shared As Integer pRow, pCol, pIteration, pMax
' Декларация подпрограмм
Declare Sub GatherPhotons(r() As REAL, p() As REAL,typ As Integer, index As Integer)
Declare Sub GetColor(r() As REAL, rgbIn() As REAL, typ As Integer, index As Integer)
Declare Sub StorePhoton(typ As Integer,index As Integer, _
location() As REAL,direction() As REAL,energy() As REAL)
Declare Sub ShadowPhoton(ray() As REAL)
Declare Sub DrawPhoton(frgb() As REAL,p() As REAL)
Declare Sub ResetRender
Declare Sub Render
' Директивы препроцессора
#define min(a,b) IIf(a<b,a,b) ' Макрос минимум из a и b
#define max(a,b) IIf(a>b,a,b) ' Макрос максимум из a и b
#Macro NormalizeVec(r,v)
Scope
Dim As REAL L2 = v(0)*v(0)+v(1)*v(1)+v(2)*v(2)
If l2<>0 Then L2=1.0/Sqr(L2)
r(0)=v(0)*L2
r(1)=v(1)*L2
r(2)=v(2)*L2
End Scope
#EndMacro
#Macro SubVec(r,a,b)
r(0)=a(0)-b(0)
r(1)=a(1)-b(1)
r(2)=a(2)-b(2)
#EndMacro
#Macro AddVec(r,a,b)
r(0)=a(0)+b(0)
r(1)=a(1)+b(1)
r(2)=a(2)+b(2)
#EndMacro
#Macro MulScalarVec(r,a,b)
r(0)=a(0)*b
r(1)=a(1)*b
r(2)=a(2)*b
#EndMacro
#define DotProduct(a,b) (a(0)*b(0) + a(1)*b(1) + a(2)*b(2))
#define rnd2 (Rnd-Rnd)
#Macro RandomVec(r)
r(0)=Rnd-Rnd
r(1)=Rnd-Rnd
r(2)=Rnd-Rnd
#EndMacro
#define odd(xx) (xx And 1)
Function Distance2(a() As REAL, _
b() As REAL, _
d2 As REAL) As Byte
Dim As REAL c = a(0) - b(0)
Dim As REAL d = c*c
If (d > d2) Then Return 0
c = a(1) - b(1)
d += c*c
If (d > d2) Then Return 0
c = a(2) - b(2)
d += c*c
If (d > d2) Then Return 0
gDist2 = d2
Return 1
End Function
Sub RaySphere(idx As Integer,r() As REAL, o() As REAL)
Dim As REAL s(2)
SubVec(s,gSphere,o)
Dim As REAL radius = gSphere(3)
Dim As REAL A = DotProduct(r,r)
Dim As REAL B = -2.0 * DotProduct(s,r)
Dim As REAL C = DotProduct(s,s) - (radius*radius)
Dim As REAL D = B*B - 4*A*C
If (D < 0.0) Then Return
Dim As REAL sign = IIf(C < -0.00001,1,-1)
Dim As REAL l = (-B + sign*Sqr(D))/(2*A)
If (l<0) Or (l>gDist) Then Return
gType = 0
gIndex = idx
gDist = l
gIntersect = 1
End Sub
Sub RayPlane(idx As Integer, r() As REAL,o() As REAL)
Dim As Integer axis = gPlanes(idx,0)
If r(axis)=0 Then Return
Dim As REAL l = (gPlanes(idx,1) - o(axis)) / r(axis)
If (l<0) Or (l>gDist) Then Return
gType = 1
gIndex = idx
gDist = l
gIntersect = 1
End Sub
Sub RayObject(typ As Integer, idx As Integer, r()As REAL, o() As REAL)
If (typ = 0) Then
RaySphere(idx,r(),o())
Else
RayPlane(idx,r(),o())
End If
End Sub
Sub SphereNormal(r() As REAL,P() As REAL)
Dim As REAL v(2)
SubVec(v,P,gSphere)
NormalizeVec(r,v)
End Sub
Sub PlaneNormal(r() As REAL, idx As Integer, P() As REAL, O() As REAL)
Dim As Integer axis = gPlanes(idx,0)
Dim As REAL N(2)
N(axis) = O(axis) - gPlanes(idx,1)
NormalizeVec(r,N)
End Sub
Sub SurfaceNormal(r() As REAL, _
typ As Integer, _
idx As Integer, _
P() As REAL, _
Inside() As REAL)
If (typ = 0) Then
SphereNormal(r(),P())
Else
PlaneNormal(r(),idx,P(),Inside())
End If
End Sub
Sub MirrorVec(Ret() As REAL,_
Ray() As REAL, _
FromPoint() As REAL)
Dim As REAL N(2)=Any,tmp(2)=Any
SurfaceNormal(N(),gType, gIndex, gPoint(), fromPoint())
MulScalarVec(tmp,N,(2 * DotProduct(ray,N) ))
SubVec(tmp,ray,tmp)
NormalizeVec(Ret,tmp)
End Sub
'
' Освещение
'
Function LightDiffuse(N() As REAL,P() As REAL) As REAL
Dim As REAL L(2)=Any
SubVec(L,gLight,P)
NormalizeVec(L,L)
Return DotProduct(N,L)
End Function
Function LightObject(typ As Integer, _
idx As Integer, _
P() As REAL, _
Ambient As REAL ) As REAL
Dim As REAL N(2)=Any
SurfaceNormal(N(),typ, idx, P(), gLight())
Dim As REAL L = LightDiffuse(N() , P() )
Return min(1.0, max(L, Ambient))
End Function
'
' Рейтрейсинг (трассировка лучей)
'
Sub Raytrace(ray() As REAL,origin() As REAL)
gIntersect = 0
gDist = 999999.9
For typ As Integer = 0 To Types-1
For idx As Integer = 0 To Objects(typ)-1
RayObject(typ,idx,ray(),origin())
Next idx
Next typ
End Sub
Sub AbsorbColor(ret() As REAL, _
rgbIn() As REAL, _
r As REAL,g As REAL,b As REAL) ' e.g. White Light Hits Red Wall
Dim As REAL rgbOut(2)={r,g,b}
For c As Integer =0 To 2
ret(c) = min(rgbOut(c),rgbIn(c))
Next
End Sub
Sub GetColor(r() As REAL, _
rgbIn() As REAL, _
typ As Integer, _
idx As Integer)
If (typ=0) Then ' сфера
AbsorbColor(r(),rgbIn(), 1, 1, 0.5)
ElseIf (typ=1) Then ' плоскость
If idx=0 Then
AbsorbColor(r(),rgbIn(), 1.0, 0, 0)
ElseIf idx=2 Then
AbsorbColor(r(),rgbIn(), 0, 1.0, 0)
Else
AbsorbColor(r(),rgbIn(), 1, 1, 1)
End If
End If
End Sub
Sub ComputePixelColor(prgb() As REAL,x As REAL,y As REAL)
Dim As REAL ray(2) = { x/Dimension - 0.5 , _
-(y/Dimension - 0.5), _
1.0}
Raytrace(ray(), gOrigin())
If (gIntersect) Then
MulScalarVec(gPoint,ray,gDist)
If (gType = 0) Then
MirrorVec(ray(),ray(),gOrigin())
Raytrace(ray(), gPoint())
If (gIntersect) Then
Dim As REAL tmp(2)=Any
MulScalarVec(tmp,ray,gDist)
AddVec(gPoint,tmp,gPoint)
End If
End If
If (gPhotonMapping) Then
GatherPhotons(prgb(),gPoint(),gType,gIndex)
Else
Dim As Integer tType = gType
Dim As Integer tIndex = gIndex
Dim As REAL a = gAmbient
Dim As REAL tmp(2)=Any
SubVec(tmp,gPoint,gLight)
Raytrace(tmp(),gLight())
If (tType = gType) And (tIndex = gIndex) Then
a = LightObject(gType, gIndex, gPoint(), gAmbient)
End If
prgb(0)=a:prgb(1)=a:prgb(2)=a
GetColor(prgb(),prgb(),tType,tIndex)
End If
End If
End Sub
'
' Фотонный маппинг
'
Sub GatherPhotons(energy() As REAL, _
p() As REAL, _
typ As Integer, _
idx As Integer)
Dim As REAL N(2)=Any
Dim As REAL tmp(2)=Any
Dim As REAL g(2)=Any
Dim As REAL weight=Any
Dim As REAL frgb(2)=Any
SurfaceNormal(N(), typ, idx, p(), gOrigin())
For i As Integer = 0 To NumberOfPhotons(typ,idx)-1
' положение
g(0)=gPhotons(typ,idx,i,0,0)
g(1)=gPhotons(typ,idx,i,0,1)
g(2)=gPhotons(typ,idx,i,0,2)
If (Distance2(p(),g(),gRadius2)) Then
' направление
g(0)=gPhotons(typ,idx,i,1,0)
g(1)=gPhotons(typ,idx,i,1,1)
g(2)=gPhotons(typ,idx,i,1,2)
weight = max(0.0, -DotProduct(N,g) )
weight *= (1.0 - Sqr(gDist2)) / gExposure
' энергия
g(0)=gPhotons(typ,idx,i,2,0)
g(1)=gPhotons(typ,idx,i,2,1)
g(2)=gPhotons(typ,idx,i,2,2)
MulScalarVec(tmp,g,weight)
AddVec(frgb,frgb,tmp)
End If
Next i
For j As Integer=0 To 2
energy(j)=max(0,min(1,frgb(j) ) )
Next j
End Sub
Sub EmitPhotons
Randomize 1
Dim As REAL frgb(2)=Any
Dim As REAL ray(2)=Any
Dim As REAL p(2)=Any
For typ As Integer = 0 To Types-1
For idx As Integer = 0 To Objects(typ)-1
NumberOfPhotons(typ,idx) = 0
Next idx
Next typ
For i As Integer = 0 To MaxPhotons-1
Dim As Integer bounces = 1
' белый цвет фотона
frgb(0)=1:frgb(1)=1:frgb(2)=1
RandomVec(ray)
NormalizeVec(ray,ray)
p(0) = gLight(0)
p(1) = gLight(1)
p(2) = gLight(2)
While (p(1) >= gLight(1))
Dim As REAL N(2)=Any
RandomVec(N)
NormalizeVec(N,N)
MulScalarVec(N,N,0.75)
AddVec(p,gLight,N)
Wend
Raytrace(ray(), p())
If Abs(p(0) > 1.5) Then Continue For
If Abs(p(1) > 1.5) Then Continue For
If Distance2(p(), gSphere(),gSphere(3)*gSphere(3)) Then Continue For
While (gIntersect<>0) And (bounces <= MaxRelections)
Dim As REAL tmp(2)=Any
MulScalarVec(tmp,ray,gDist)
AddVec(gPoint, tmp, p)
GetColor(frgb(),frgb(),gType,gIndex)
MulScalarVec(frgb,frgb, 1.0/Sqr(bounces))
StorePhoton(gType, gIndex, gPoint(), ray(),frgb())
DrawPhoton(frgb(), gPoint())
ShadowPhoton(ray())
MirrorVec(ray(),ray(),p())
Raytrace(ray(), gPoint())
p(0) = gPoint(0)
p(1) = gPoint(1)
p(2) = gPoint(2)
bounces+=1
Wend
Next i
End Sub
Sub StorePhoton(typ As Integer, _
idx As Integer, _
l() As REAL,_
d() As REAL, _
e() As REAL)
Dim As Integer Photon=NumberOfPhotons(typ,idx)
For i As Integer=0 To 2
gPhotons(typ,idx,Photon,0,i) = l(i) ' Положение
gPhotons(typ,idx,Photon,1,i) = d(i) ' Направление
gPhotons(typ,idx,Photon,2,i) = e(i) ' Энергия
Next
NumberOfPhotons(typ,idx)=Photon+1
End Sub
Sub ShadowPhoton(ray() As REAL)
Dim As REAL shadow(2) = {-0.25,-0.25,-0.25}
Dim As REAL tPoint(2) = {gPoint(0), gPoint(1),gPoint(2)}
Dim As Integer tType = gType ' Save State
Dim As Integer tIndex = gIndex
Dim As REAL BumpedPoint(2)
MulScalarVec(BumpedPoint,ray,0.000001)
AddVec(BumpedPoint,gPoint,BumpedPoint)
Raytrace(ray(), BumpedPoint())
Dim As REAL ShadowPoint(2)=Any
MulScalarVec(ShadowPoint,ray,gDist)
AddVec(ShadowPoint,ShadowPoint, BumpedPoint) ' 3D точка
StorePhoton(gType, gIndex, ShadowPoint(), ray(), shadow())
gPoint(0) = tPoint(0)
gPoint(1) = tPoint(1)
gPoint(2) = tPoint(2)
gType = tType
gIndex = tIndex
End Sub
'
' Рендеринг (визуализация)
'
Sub Render
Dim As Integer x,y,iterations = 0
Dim As Integer nruns
nruns=256
While (iterations < nruns)
nruns=max(pMax, 256)
If (pCol >= pMax) Then
pRow+=1
pCol = 0
If (pRow >= pMax) Then
pIteration+=1
pRow = 0
pMax = Int(2^pIteration)
End If
End If
Dim As Integer pNeedsDrawing = (pIteration = 1) Or odd(pRow) _
Or ( (odd(pRow)=0) And odd(pCol))
x = pCol * (Dimension/pMax)
y = pRow * (Dimension/pMax)
pCol+=1
If (pNeedsDrawing) Then
iterations+=1
Dim As REAL b(2)
ComputePixelColor(b(),x,y)
Dim As UInteger col=RGB(b(0)*255,b(1)*255,b(2)*255)
Line (x,y)-Step((Dimension/pMax)-1,(Dimension/pMax)-1),col,BF ' Возможность отрисовки увеличенного пикселя
'pset (x,y),col
End If
Wend
If (pRow = Dimension-1) Then
gEmpty = 0
End If
End Sub
Sub ResetRender()
pRow=0
pCol=0
pIteration=1
pMax=2
gEmpty=1
If (gPhotonMapping And Not gView3D) Then
EmitPhotons()
End If
End Sub
Sub setup()
ScreenRes Dimension,Dimension,24
ResetRender
End Sub
Sub drawit()
If gPhotonMapping Then
WindowTitle "[1]Рейтрейсинг [3]Просмотр фотонов"
Else
WindowTitle "[2]Фотонная карта [3]Просмотр фотонов"
End If
If (gView3D) Then
If (gEmpty) Then
Cls
EmitPhotons()
gEmpty = 0
End If
Else
If (gEmpty) Then
Render()
End If
End If
End Sub
Sub DrawPhoton(frgb() As REAL,p() As REAL)
If (gView3D=1) And Int(p(2) > 0.0) Then
Dim As Integer x = (Dimension/2) + Int(Dimension * p(0)/p(2))
Dim As Integer y = (Dimension/2) + Int(Dimension * -p(1)/p(2))
If (y <= Dimension) Then
PSet (x,y),RGB(frgb(0)*255,frgb(1)*255,frgb(2)*255)
End If
End If
End Sub
Sub SwitchToMode(i As String)
If (i="1") Then
gView3D = 0
gPhotonMapping = 0
ResetRender()
ElseIf (i="2") Then
gView3D = 0
gPhotonMapping = 1
ResetRender()
ElseIf (i="3") Then
gView3D = 1
ResetRender()
End If
End Sub
'
' Основная программа
'
Dim As String key ' Переменная символа нажатой клавиши
setup() ' Установка размеров окна и сброс рендера
While key<>Chr(27) ' Выполняет программу пока не нажата клавиша Esc
key=InKey
If key="1" Or key="2" Or key="3" Then
SwitchToMode(key) ' Сброс рендера и переключение в режим отображения по символу нажатой клавиши
key=""
End If
drawit() ' Отрисовка заголовка окна и рендер 256 пикселей
Sleep(100) ' Пауза 100 миллисекунд
Wend
Ланухумыч, уточную - машинный код, а каким образом он был скомпилирован, с помощью Ассемблера, Си, FB или Delphi (Паскаль) и т.д. это пофиг...Ну, так, если пофиг, то С и С++ имеют стандартные возможности обращения с питоном.
Да понял я... но Си для меня сложноват, потому что я на нём ничего не писал... хотя активно врубаюсь последние несколько месяцев... Как и писал тебе ранее FB использует тот же самый компилиятор GCC... так что разницы нет особой в принципе...А, что там врубаться одну функцию написать для быстрого счёта чего-то там?
Надо пробовать... ты прав...