3d форум по Blender

Другое => Программирование (любое) => Тема начата: Samovar от 15 Август 2016, 06:45:17

Название: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 15 Август 2016, 06:45:17
Пока поправил первый вариант из этой темы. http://www.freebasic.net/forum/viewtopic.php?f=7&t=15154
Потихоньку пытаюсь врубиться... Пишу комментарии... позже выложу.
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 16 Август 2016, 16:28:53
В общем, пока основное... врублюсь получше, выложу с более подробными комментариями.
Пока такой вариант.
Переключать рейтрейсинг, фотоны и режим просмотра фотонов можно клавишами 1,2,3
Escape - завершение работы. Скорость будет гораздо выше, если за комментировать строку  Sleep(100) в конце кода:
Код

' 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
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: sungreen от 16 Август 2016, 22:22:14
... вроде есть Operator Overloading в FreeBasic http://free-basic.ru/helprus/ProPgOperatorOverloading.html ...
... интересно было бы переопределить операции с векторами типа V0 = V1+V2 и т.п. ...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: sungreen от 16 Август 2016, 22:23:37
... кстати вот есть лаба http://ext.freebasic.net/dev-docs/files/ext/math/vector3-bi.html#Vector3 ...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 16 Август 2016, 23:00:19
fbc -w all "fbray.bas" (в каталоге: /home/leonid/workspace/programming/freebasic)
fbray.bas(27) error 14: Expected identifier, found 'boolean' in 'Dim Shared As boolean gPhotonMapping = true ' Фотонный маппинг включён - true, отключён - false'
fbray.bas(30) error 14: Expected identifier, found 'boolean' in 'Dim Shared As boolean gIntersect'
fbray.bas(35) error 14: Expected identifier, found 'boolean' in 'Dim Shared As boolean gEmpty = true'
fbray.bas(36) error 14: Expected identifier, found 'boolean' in 'Dim Shared As boolean gView3D'
fbray.bas(108) error 14: Expected identifier, found 'boolean' in 'd2 As REAL) As boolean'
fbray.bas(111) error 41: Variable not declared, false in 'If (d > d2) Then Return false'
fbray.bas(119) error 41: Variable not declared, true in 'Return true'
fbray.bas(138) error 41: Variable not declared, gIntersect in 'gIntersect = true'
Сборка завершилась с ошибкой.
fbray.bas(283) error 41: Variable not declared, gPhotonMapping in 'If (gPhotonMapping) Then'
fbray.bas(466) error 41: Variable not declared, gEmpty in 'gEmpty = false'
fbray.bas(466) error 132: Too many errors, exiting
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 16 Август 2016, 23:27:35
Дописал вначале:
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'
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: sungreen от 17 Август 2016, 02:39:16
... какая версия компилятора? ...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 17 Август 2016, 15:54:42
... вроде есть Operator Overloading в FreeBasic http://free-basic.ru/helprus/ProPgOperatorOverloading.html ...
... интересно было бы переопределить операции с векторами типа V0 = V1+V2 и т.п. ...
Озадачил :) Макросами  и массивами оно ещё как-то в голове укладывалось :) Ещё б понимать саму работу проги и шарить в векторной алгебре :)
Благодарю. Интересно. Теперь "курю"  в этом направлении:
http://free-basic.ru/overloadfunction.html
http://free-basic.ru/overloadoperator.html


Цитировать
... кстати вот есть лаба 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.05.0  x86   
В русской справке отсутствует инфа по типу boolean, но в справке от разработчиков есть: http://www.freebasic.net/wiki/wikka.php?wakka=KeyPgBoolean
так же присутствует и конвертер cbool http://www.freebasic.net/wiki/wikka.php?wakka=KeyPgCbool
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 17 Август 2016, 16:12:33
... какая версия компилятора? ...
1.00

Цитировать
Это не прокатит... переменные, это ж не константы...
У меня сейчас нет времени, но вчера, когда я пытался найти инфу об ошибках, вычитал, что с какой-то обновлённой версии начинается эта ерунда. Якобы, у фрибейсика нету, собственно, типа boolean
http://freebasic.net/forum/viewtopic.php?t=23488
http://www.freebasic.net/forum/viewtopic.php?t=20913
Сам костыль взял отсюда:
http://freebasic.net/forum/viewtopic.php?t=14445


Цитировать
и шарить в векторной алгебре :)
http://mathprofi.ru/matematika_dlya_chainikov.html
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 17 Август 2016, 16:35:04
Почему у тебя не работает: https://sourceforge.net/p/fbc/news/?source=navbar
Начиная с FreeBASIC 1.04.0 released
Если надо совсем последнюю сборку, то лучше глядеть на немецком сайте: http://users.freebasic-portal.de/stw/builds/

Цитировать
Цитировать
и шарить в векторной алгебре :)
http://mathprofi.ru/matematika_dlya_chainikov.html
я хоть в что-то новое для себя пытаюсь врубиться, с твоей подачи, а ты, походу, вернулся к тому, с чего начал... :)  или и не начинал... :-\
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: sungreen от 17 Август 2016, 17:01:04
... какая версия компилятора? ...
1.00

... повышай, поскольку cbool был введен позднее ...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 18 Август 2016, 13:17:07
Дописал вначале:
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'
Погорячился вчера. Не разобрался сразу. Это вполне работоспособно. Беру свои слова обратно.
За ссылку на сайт по алгебре спасибо.


Попробуй обойтись без cbool, переписав строку так:

Код

  If (gView3D=true) And Int(p(2) > 0.0) Then


Можешь и без boolean обойтись, заменив все true единицами, а false нулями, а вместо типа boolean использовать тип Byte


Код

' 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
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 18 Август 2016, 21:48:48
Нашёл более понятную статью по векторам в компьютерной графике: https://habrahabr.ru/post/131931/
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 11 Декабрь 2016, 10:13:47
Samovar, ну ты разобрался, как из питона запускать код на бейсике?
Тогда ты бы смог замутить постобработку интерналовской картинки, дорисовывающую каустику.
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 11 Декабрь 2016, 10:43:41
Пока не разобрался... :(  Сначала заморочался на историю с Дедом Морозом... потом на освещение в интерьере...
Ланухумыч, уточную - машинный код, а каким образом он был скомпилирован, с помощью Ассемблера,  Си, FB или Delphi (Паскаль) и т.д. это пофиг...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 11 Декабрь 2016, 11:48:25
Ланухумыч, уточную - машинный код, а каким образом он был скомпилирован, с помощью Ассемблера,  Си, FB или Delphi (Паскаль) и т.д. это пофиг...
Ну, так, если пофиг, то С и С++ имеют стандартные возможности обращения с питоном.
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 11 Декабрь 2016, 11:52:17
Да понял я... но Си для меня сложноват, потому что я на нём ничего не писал... хотя активно врубаюсь последние несколько месяцев... Как и писал тебе ранее FB использует тот же самый компилиятор GCC... так что разницы нет особой в принципе...
Надо пробовать... ты прав...
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: LanuHum от 11 Декабрь 2016, 13:16:29
Да понял я... но Си для меня сложноват, потому что я на нём ничего не писал... хотя активно врубаюсь последние несколько месяцев... Как и писал тебе ранее FB использует тот же самый компилиятор GCC... так что разницы нет особой в принципе...
Надо пробовать... ты прав...
А, что там врубаться одну функцию написать для быстрого счёта чего-то там?
Название: Re: Рейтрейсер на FB (FreeBasic)
Отправлено: Samovar от 11 Декабрь 2016, 13:20:39
Не гони коней, Ланухумыч... разберусь потихоньку... я тож тормоз как Python :) ...и страдаю "жирафостью"... до меня долго доходит... потерпи, пожалуйста... я тебе обязательно напишу по этой теме, но позже...