' RayTracing versus PhotonMappingType 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 gIntersectDim Shared As Integer gTypeDim Shared As Integer gIndexDim Shared As REAL gDist2, gDistDim Shared As REAL gPoint(2)Dim Shared As boolean gEmpty = trueDim Shared As boolean gView3DDim 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 ResetRenderDeclare 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 trueEnd FunctionSub 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 = trueEnd SubSub 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 SubSub 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 IfEnd SubSub SphereNormal(r() As REAL,P() As REAL) Dim As REAL v(2) SubVec(v,P,gSphere) NormalizeVec(r,v)End SubSub 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 SubSub 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 IfEnd SubSub 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 FunctionFunction 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 typEnd SubSub 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)) NextEnd SubSub 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 IfEnd SubSub 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 IfEnd 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 jEnd SubSub 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 iEnd SubSub 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+1End SubSub 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 = tIndexEnd 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 IfEnd SubSub ResetRender() pRow=0 pCol=0 pIteration=1 pMax=2 gEmpty=true If (gPhotonMapping And Not gView3D) Then EmitPhotons() End IfEnd SubSub setup() ScreenRes Dimension,Dimension,24 ResetRenderEnd SubSub 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 IfEnd SubSub 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 IfEnd SubSub 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 IfEnd 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 falseEnd EnumОсталась одна ошибка:fbray.bas(514) error 41: Variable not declared, cbool in 'If (gView3D=true) And cbool(p(2) > 0.0) Then'
... какая версия компилятора? ...
Это не прокатит... переменные, это ж не константы...
и шарить в векторной алгебре
Цитироватьи шарить в векторной алгебре http://mathprofi.ru/matematika_dlya_chainikov.html
Цитата: sungreen от 17 Август 2016, 02:39:16... какая версия компилятора? ...1.00
If (gView3D=true) And Int(p(2) > 0.0) Then
' RayTracing versus PhotonMappingType 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 gIntersectDim Shared As Integer gTypeDim Shared As Integer gIndexDim Shared As REAL gDist2, gDistDim Shared As REAL gPoint(2)Dim Shared As Byte gEmpty = 1Dim Shared As Byte gView3DDim 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 ResetRenderDeclare 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 1End FunctionSub 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 = 1End SubSub 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 SubSub 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 IfEnd SubSub SphereNormal(r() As REAL,P() As REAL) Dim As REAL v(2) SubVec(v,P,gSphere) NormalizeVec(r,v)End SubSub 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 SubSub 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 IfEnd SubSub 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 FunctionFunction 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 typEnd SubSub 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)) NextEnd SubSub 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 IfEnd SubSub 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 IfEnd 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 jEnd SubSub 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 iEnd SubSub 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+1End SubSub 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 = tIndexEnd 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 IfEnd SubSub ResetRender() pRow=0 pCol=0 pIteration=1 pMax=2 gEmpty=1 If (gPhotonMapping And Not gView3D) Then EmitPhotons() End IfEnd SubSub setup() ScreenRes Dimension,Dimension,24 ResetRenderEnd SubSub 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 IfEnd SubSub 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 IfEnd SubSub 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 IfEnd 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