Rem Attribute VBA_ModuleType=VBAFormModule
Option VBASupport 1
'############################################
'
' BitmapStrukturen
'
'############################################
Private Type bmpHeader
bfType As Integer
bfSize As Long
bfReserved As Long
bfOffBits As Long
End Type

Private Type bmpInfoHeader
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biColorUsed As Long
biColorImportant As Long
End Type

Private Type color
b As Byte
g As Byte
r As Byte
a As Byte
End Type

Private Type colorHDR
r As Double
g As Double
b As Double
a As Double
z As Double
End Type

Private Type imageBuffer
width As Long
height As Long
bbp As Long
colorData() As colorHDR
End Type

'############################################
'
'VektorStrukturen
'
'############################################

Private Type vector3
x As Double
y As Double
z As Double
End Type

Private Type material
clr As colorHDR
reflectVal As Double
refracIdx As Double
refracVal As Double
transparency As Double
End Type

Private Type plane
n As vector3
b As Double
mat As material
End Type

Private Type triangle
p1 As vector3
p2 As vector3
p3 As vector3
e As plane
tex1 As vector3
tex2 As vector3
tex3 As vector3
texIdx As Integer
End Type

Private Type ray
P As vector3
d As vector3
End Type

Private Type shpere
P As vector3
r As Double
mat As material
End Type

Private Type Light
pos As vector3
direction As vector3
clr As colorHDR
intensity As Double
castsShadows As Boolean
radius As Double
castPoints() As vector3
castPointsGenerated As Boolean
End Type

Private Type camera
dir As vector3
pos As vector3
up  As vector3
fov As Double
ration As Double
End Type

'############################################
'
'RaytracerStrukturen
'
'############################################
Private Type scene
nEbenen As Long
nKugeln As Long
nLichter As Long
nDreiecke As Long
ebenen() As plane
kugeln() As shpere
lichter() As Light
dreiecke() As triangle
End Type

Private Type renderSetup
renderReflections As Boolean
renderRefractions As Boolean
renderAA As Boolean
renderShadows As Boolean
AASamples As Integer
ReflectionSamples As Integer
shadowSamples As Integer
imageWidth As Long
imageHeight As Long
outputPath As String
maxTraceDepth As Integer
End Type

'############################################
'
'CodeAnalyseStrukturen
'
'############################################

Private Type FunctionCallCountVariables
arccos As Long
arccosTime As Double
arcsin As Long
arcsinTime As Double
cAdd As Long
cAddTime As Double
cMul As Long
cMulTime As Double
cMulS As Long
cMulSTime As Double
cSet As Long
cSetTime As Double
cSetC As Long
cSetCTime As Double
cSub As Long
cSubTime As Double
lightSurfaceColor As Long
lightSurfaceColorTime As Double
modulo As Long
RayHitsPlane As Long
RayHitsSphere As Long
RayHitsSphereTime As Double
RayHitsTriangle As Long
RayHitsTriangleTime As Double
shadowValue As Long
shadowValueTime As Double
traceRay As Long
traceRayTime As Double
vAdd As Long
vAddTime As Double
vCrossProduct As Long
vCrossProductTime As Double
vLen As Long
vLenTime As Double
vMul As Long
vMulTime As Double
vMulS As Long
vMulSTime As Double
vNormalize As Long
vNormalizeTime As Double
vSet As Long
vSetTime As Double
vSub As Long
vSubTime As Double
tmpTime As Double
End Type

'############################################
'############################################
'############################################
' GLOBALE VARIABLENDEFINITIONEN
'############################################
'############################################
'############################################
Dim world As scene
Dim textures() As imageBuffer
Dim renderConfig As renderSetup
Dim FunctionCallAnalysis As FunctionCallCountVariables


'############################################
'
'Bitmapfunktionen
'
'############################################

Private Sub convertImgBufferToTrueColor(buffer As imageBuffer, newData() As color)

ReDim newData(buffer.width - 1, buffer.height - 1)

For y = 0 To buffer.height - 1
    For x = 0 To buffer.width - 1
        If buffer.colorData(x, y).r > 1 Then newData(x, y).r = 255 Else
        If buffer.colorData(x, y).r < 0 Then newData(x, y).r = 0 Else
        newData(x, y).r = buffer.colorData(x, y).r * 255
        
        If buffer.colorData(x, y).g > 1 Then newData(x, y).g = 255 Else
        If buffer.colorData(x, y).g < 0 Then newData(x, y).g = 0 Else
        newData(x, y).g = buffer.colorData(x, y).g * 255
        
        If buffer.colorData(x, y).b > 1 Then newData(x, y).b = 255 Else
        If buffer.colorData(x, y).b < 0 Then newData(x, y).b = 0 Else
        newData(x, y).b = buffer.colorData(x, y).b * 255
        
        If buffer.colorData(x, y).a > 1 Then newData(x, y).a = 255 Else
        If buffer.colorData(x, y).a < 0 Then newData(x, y).a = 0 Else
        newData(x, y).a = buffer.colorData(x, y).a * 255
    Next x
Next y

End Sub


Private Sub writeImageBuffer(path As String, buffer As imageBuffer)
Dim fileNr
fileNr = FreeFile
Dim bmpFileHeader As bmpHeader, infoHeader As bmpInfoHeader

bmpFileHeader.bfType = 19778
bmpFileHeader.bfSize = 0
bmpFileHeader.bfReserved = 0
bmpFileHeader.bfOffBits = 54

infoHeader.biSize = 40
infoHeader.biWidth = buffer.width
infoHeader.biHeight = buffer.height
infoHeader.biPlanes = 1
infoHeader.biBitCount = buffer.bbp
infoHeader.biCompression = 0
infoHeader.biSizeImage = buffer.width * buffer.height * (buffer.bbp / 8)
infoHeader.biXPelsPerMeter = 0
infoHeader.biYPelsPerMeter = 0
infoHeader.biColorUsed = 0
infoHeader.biColorImportant = 0

Dim newData() As color
ReDim newData(buffer.width - 1, buffer.height - 1)

For y = 0 To buffer.height - 1
    For x = 0 To buffer.width - 1
        If buffer.colorData(x, y).r > 1 Then
        newData(x, y).r = 255
        ElseIf buffer.colorData(x, y).r < 0 Then
        newData(x, y).r = 0
        Else: newData(x, y).r = buffer.colorData(x, y).r * 255
        End If
        
        If buffer.colorData(x, y).g > 1 Then
        newData(x, y).g = 255
        ElseIf buffer.colorData(x, y).g < 0 Then newData(x, y).g = 0
        Else: newData(x, y).g = buffer.colorData(x, y).g * 255
        End If
        
        If buffer.colorData(x, y).b > 1 Then
        newData(x, y).b = 255
        ElseIf buffer.colorData(x, y).b < 0 Then newData(x, y).b = 0
        Else: newData(x, y).b = buffer.colorData(x, y).b * 255
        End If
        
        If buffer.colorData(x, y).a > 1 Then
        newData(x, y).a = 255
        ElseIf buffer.colorData(x, y).a < 0 Then newData(x, y).a = 0
        Else: newData(x, y).a = buffer.colorData(x, y).a * 255
        End If
    Next x
Next y

'Call convertImgBufferToTrueColor(buffer, newColorData)

Open path For Binary Access Write As #fileNr

Put #fileNr, , bmpFileHeader
Put #fileNr, , infoHeader
Put #fileNr, , newData

Close #fileNr
End Sub

Private Sub loadBmp(pfad As String, buffer As imageBuffer)
Dim fileNr
fileNr = FreeFile

Open pfad For Binary Access Read As #fileNr

Dim fileHeader As bmpHeader, infoHeader As bmpInfoHeader

Get fileNr, , fileHeader
Get fileNr, , infoHeader

'ReDim buffer.colorData(infoHeader.biWidth - 1, Abs(infoHeader.biHeight) - 1)
ReDim buffer.colorData(infoHeader.biWidth, Abs(infoHeader.biHeight))
buffer.width = infoHeader.biWidth
buffer.height = Abs(infoHeader.biHeight)
buffer.bbp = infoHeader.biBitCount

Dim tr As Byte, tg As Byte, tb As Byte, ta As Byte
Dim x As Long, y As Long
Dim a() As Byte, idx As Long


If infoHeader.biCompression = 0 Then
If infoHeader.biBitCount = 24 Then

    ReDim a(3 * (buffer.width) * (buffer.height))
    Get fileNr, , a

        For y = 0 To buffer.height - 1
            For x = 0 To buffer.width - 1
                'Get fileNr, , tb
                'Get fileNr, , tg
                'Get fileNr, , tr
                'buffer.colorData(x, buffer.height - 1 - y).r = tr / 255
                'buffer.colorData(x, buffer.height - 1 - y).g = tg / 255
                'buffer.colorData(x, buffer.height - 1 - y).b = tb / 255
                'buffer.colorData(x, buffer.height - 1 - y).a = 1
                idx = (x + buffer.width * y) * 3
                buffer.colorData(x, buffer.height - 1 - y).r = a(idx + 2) / 255
                buffer.colorData(x, buffer.height - 1 - y).g = a(idx + 1) / 255
                buffer.colorData(x, buffer.height - 1 - y).b = a(idx + 0) / 255
            Next x
        Next y

        ReDim a(0)
        buffer.bbp = 32

End If

If infoHeader.biBitCount = 32 Then
    For y = 0 To buffer.height - 1
        For x = 0 To buffer.width - 1
            Get fileNr, , tb
            Get fileNr, , tg
            Get fileNr, , tr
            Get fileNr, , ta
            buffer.colorData(x, buffer.height - 1 - y).r = tr / 255
            buffer.colorData(x, buffer.height - 1 - y).g = tg / 255
            buffer.colorData(x, buffer.height - 1 - y).b = tb / 255
            buffer.colorData(x, buffer.height - 1 - y).a = ta / 255
        Next x
    Next y

    buffer.bbp = 32
End If
End If

Close #fileNr

End Sub

Private Function cMulS(a As colorHDR, b As Double) As colorHDR

cMulS = a
cMulS.r = a.r * b
cMulS.g = a.g * b
cMulS.b = a.b * b
cMulS.z = a.z * b

FunctionCallAnalysis.cMulS = FunctionCallAnalysis.cMulS + 1
End Function

Private Function cMul(a As colorHDR, b As colorHDR) As colorHDR

cMul.a = a.a * b.a
cMul.r = a.r * b.r
cMul.g = a.g * b.g
cMul.b = a.b * b.b
cMul.z = a.z * b.z

FunctionCallAnalysis.cMul = FunctionCallAnalysis.cMul + 1
End Function

Private Function zMul(a As colorHDR, b As Double) As colorHDR
zMul = a
zMul.z = a.z * b
End Function

Private Function cAdd(a As colorHDR, b As colorHDR) As colorHDR

cAdd.r = a.r + b.r
cAdd.g = a.g + b.g
cAdd.b = a.b + b.b
cAdd.z = a.z + b.z

FunctionCallAnalysis.cAdd = FunctionCallAnalysis.cAdd + 1
End Function


Private Function cSub(a As colorHDR, b As colorHDR) As colorHDR

cSub.r = a.r - b.r
cSub.g = a.g - b.g
cSub.b = a.b - b.b
cSub.z = a.z - b.z
cSub.a = a.a - b.a

FunctionCallAnalysis.cSub = FunctionCallAnalysis.cSub + 1
End Function

Private Function cNormalize(a As colorHDR) As colorHDR
' Länge berechnen
Dim length As Double
length = Sqr((a.r * a.r) + (a.g * a.g) + (a.b * a.b))
If length > 0 Then
    cNormalize = cMulS(a, 1 / length)
End If
End Function


Private Function cSet(r As Double, g As Double, b As Double, Optional a As Double = 1#) As colorHDR
cSet.r = r
cSet.g = g
cSet.b = b
cSet.a = a
cSet.z = 0

FunctionCallAnalysis.cSet = FunctionCallAnalysis.cSet + 1
End Function

Private Sub cSetC(target As colorHDR, Source As colorHDR)
target.r = Source.r
target.g = Source.g
target.b = Source.b
target.a = Source.a
target.z = Source.z

FunctionCallAnalysis.cSetC = FunctionCallAnalysis.cSetC + 1
End Sub

Private Sub kontur(sourceBuffer As imageBuffer, konturBuffer As imageBuffer)
' die Aufgabe der Konturfuntion ist es die Pixel ausfindig zu machen, die
' übersampelt werden müssen. Hierzu soll zwischen Horizontalem und vertikalem
' Übersampling unterschieden werden. Horizontal wird im Grün-Kanal und Vertikal im Rot-Kanal
' gespeichert.
' Es soll bei hohem Farbkontrast übersampelt werden
' Berechnung:
'dP1 dP2  dP1 dP2    dP1 dP2
' \         \ /         /
'  \                   /
'Soll 0      1           0 ergeben

ReDim konturBuffer.colorData(sourceBuffer.width, sourceBuffer.height)
konturBuffer.width = sourceBuffer.width
konturBuffer.height = sourceBuffer.height
konturBuffer.bbp = sourceBuffer.bbp

Dim dXLeft As colorHDR, dYUp As colorHDR, dXRight As colorHDR, dYDown As colorHDR, dFinal As Double


For x = 1 To sourceBuffer.width - 2
    For y = 1 To sourceBuffer.height - 2
        
        ' Steigungen von Pixel(x,y) zu den Nachbarpixeln berechnen
        dXLeft = cSub(sourceBuffer.colorData(x, y), sourceBuffer.colorData(x - 1, y))
        dXRight = cSub(sourceBuffer.colorData(x + 1, y), sourceBuffer.colorData(x, y))
        dYUp = cSub(sourceBuffer.colorData(x, y + 1), sourceBuffer.colorData(x, y))
        dYDown = cSub(sourceBuffer.colorData(x, y), sourceBuffer.colorData(x, y - 1))
        
        Dim q As colorHDR
        
        ' Vertikale Steigungsänderung berechnen ( m1-m2 )
        Dim vertSteigung As Double
        vertSteigung = Sqr((dYUp.r - dYDown.r) * (dYUp.r - dYDown.r) + (dYUp.g - dYDown.g) * (dYUp.g - dYDown.g) + (dYUp.b - dYDown.b) * (dYUp.b - dYDown.b)) / 3.46410161513775
        
        
        ' horizontale Steigungsänderung berechnen ( m1-m2 )
        Dim horSteigung As Double
        horSteigung = Sqr((dXLeft.r - dXRight.r) * (dXLeft.r - dXRight.r) + (dXLeft.g - dXRight.g) * (dXLeft.g - dXRight.g) + (dXLeft.b - dXRight.b) * (dXLeft.b - dXRight.b)) / 3.46410161513775
        
        
        'q = cAdd(dYDown, cAdd(dYUp, cAdd(dXLeft, dXRight)))
        
        'dFinal = (Abs(q.r) + Abs(q.g) + Abs(q.b)) / 3
        
        
        
        'Jeder Tiefenversatz, der größer als 0.25 ist
        ' soll übersampled werden
        'If dFinal < 0.25 Then dFinal = 0
        'If dFinal > 0.25 Then dFinal = 1
        
        konturBuffer.colorData(x, y) = cSet(vertSteigung, horSteigung, 0)
        'Call cSetC(konturBuffer.colorData(x, y), cMul(dFinal, dFinal))
    Next y
Next x
End Sub



'############################################
'
'Vektorfunktionen
'
'############################################

Private Function vAdd(a As vector3, b As vector3) As vector3
FunctionCallAnalysis.vAddTime = FunctionCallAnalysis.vAddTime - Timer
FunctionCallAnalysis.vAdd = FunctionCallAnalysis.vAdd + 1
vAdd.x = a.x + b.x
vAdd.y = a.y + b.y
vAdd.z = a.z + b.z
FunctionCallAnalysis.vAddTime = FunctionCallAnalysis.vAddTime + Timer
End Function

Private Function vSub(a As vector3, b As vector3) As vector3
FunctionCallAnalysis.vSubTime = FunctionCallAnalysis.vSubTime - Timer
FunctionCallAnalysis.vSub = FunctionCallAnalysis.vSub + 1
Dim c As vector3
c.x = a.x - b.x
c.y = a.y - b.y
c.z = a.z - b.z
vSub = c
FunctionCallAnalysis.vSubTime = FunctionCallAnalysis.vSubTime - Timer
End Function

Private Function vMulS(a As vector3, b As Double) As vector3
FunctionCallAnalysis.vMulSTime = FunctionCallAnalysis.vMulSTime - Timer
FunctionCallAnalysis.vMulS = FunctionCallAnalysis.vMulS + 1
Dim c As vector3
c.x = a.x * b
c.y = a.y * b
c.z = a.z * b
vMulS = c
FunctionCallAnalysis.vMulSTime = FunctionCallAnalysis.vMulSTime + Timer
End Function

Private Function vMul(a As vector3, b As vector3) As Double
FunctionCallAnalysis.vMulTime = FunctionCallAnalysis.vMulTime - Timer
FunctionCallAnalysis.vMul = FunctionCallAnalysis.vMul + 1
vMul = a.x * b.x + a.y * b.y + a.z * b.z
FunctionCallAnalysis.vMulTime = FunctionCallAnalysis.vMulTime + Timer
End Function

Private Function vSet(x As Double, y As Double, z As Double) As vector3
FunctionCallAnalysis.vSetTime = FunctionCallAnalysis.vSetTime - Timer
FunctionCallAnalysis.vSet = FunctionCallAnalysis.vSet + 1
Dim a As vector3
a.x = x
a.y = y
a.z = z
vSet = a
FunctionCallAnalysis.vSetTime = FunctionCallAnalysis.vSetTime + Timer
End Function

Private Function vLen(v As vector3) As Double
FunctionCallAnalysis.vLenTime = FunctionCallAnalysis.vLenTime - Timer
FunctionCallAnalysis.vLen = FunctionCallAnalysis.vLen + 1
vLen = Sqr(v.x * v.x + v.y * v.y + v.z * v.z)
FunctionCallAnalysis.vLenTime = FunctionCallAnalysis.vLenTime + Timer
End Function

Private Function vNormalize(v As vector3) As vector3
FunctionCallAnalysis.vNormalizeTime = FunctionCallAnalysis.vNormalizeTime - Timer
FunctionCallAnalysis.vNormalize = FunctionCallAnalysis.vNormalize + 1
Dim a As vector3, tmp As Double
tmp = vLen(v)
If tmp = 0 Then
    vNormalize = vSet(0, 0, 0)
Else
    a.x = v.x / tmp
    a.y = v.y / tmp
    a.z = v.z / tmp
    vNormalize = a
End If
FunctionCallAnalysis.vNormalizeTime = FunctionCallAnalysis.vNormalizeTime + Timer
End Function

Private Function vCrossProduct(a As vector3, b As vector3) As vector3
FunctionCallAnalysis.vCrossProductTime = FunctionCallAnalysis.vCrossProductTime - Timer
FunctionCallAnalysis.vCrossProduct = FunctionCallAnalysis.vCrossProduct + 1
vCrossProduct.x = a.y * b.z - a.z * b.y
vCrossProduct.y = a.z * b.x - a.x * b.z
vCrossProduct.z = a.x * b.y - a.y * b.x
FunctionCallAnalysis.vCrossProductTime = FunctionCallAnalysis.vCrossProductTime + Timer
End Function

Private Function modulo(a, b)
modulo = Int(a) - Int(a / b) * Int(b)

FunctionCallAnalysis.modulo = FunctionCallAnalysis.modulo + 1
End Function

Private Function arccos(a As Double) As Double
FunctionCallAnalysis.arccosTime = FunctionCallAnalysis.arccosTime - Timer
    If (a = 1) Then
        arccos = 0
    Else
        arccos = Atn(-a / Sqr(-a * a + 1)) + 2 * Atn(1)
    End If
FunctionCallAnalysis.arccos = FunctionCallAnalysis.arccos + 1
FunctionCallAnalysis.arccosTime = FunctionCallAnalysis.arccosTime + Timer
End Function

Private Function arcsin(a As Double) As Double
FunctionCallAnalysis.arcsinTime = FunctionCallAnalysis.arcsinTime - Timer
    arcsin = Atn(a / Sqr(-a * a + 1))
    
FunctionCallAnalysis.arcsin = FunctionCallAnalysis.arcsin + 1
FunctionCallAnalysis.arcsinTime = FunctionCallAnalysis.arcsinTime + Timer
End Function



Private Function lightSurfaceColor(SurfacePoint As vector3, SurfaceNormale As vector3, surfaceMaterial As material, lght As Light, Optional triangleIndex As Integer = -1, Optional u As Double, Optional v As Double) As colorHDR
FunctionCallAnalysis.lightSurfaceColorTime = FunctionCallAnalysis.lightSurfaceColorTime - Timer
FunctionCallAnalysis.lightSurfaceColor = FunctionCallAnalysis.lightSurfaceColor + 1

    Dim lightDir As vector3, clrMul As Double, cosine As Double, tmpClrVal As Long, tmpClrValLight As Long, tmpClrValSurface As Long
    Dim returnColor As colorHDR
    Dim tmpColor As colorHDR
    tmpColor = surfaceMaterial.clr
    
    '##########
    ' Texturen für Dreiecke
    '##########
    Dim tri As triangle
    
    ' Falls es sich um ein Dreieck handelt, welches texturiert werden soll
    If (triangleIndex > -1) Then
        tri = world.dreiecke(triangleIndex)
        
        If tri.texIdx > 0 Then
            'tri = world.dreiecke(triangleIndex)
            ' U- und V-Koordinate des Schnittpunktes berechnen
            'Dim u As Double, v As Double
            'Dim a As vector3, b As vector3
            'a = vSub(tri.p2, tri.p1)
            'b = vSub(tri.p3, tri.p1)
                        
            ' U-Koordinate
            'Dim q As vector3
            'q = vCrossProduct(vNormalize(b), tri.e.n)
            'u = vMul(vSub(SurfacePoint, tri.p1), q) / vMul(a, q)
            
            ' V-Koordinate
            'Dim P As vector3
            'P = vCrossProduct(vNormalize(a), tri.e.n)
            'v = vMul(vSub(SurfacePoint, tri.p1), P) / vMul(b, P)
            
            ' Punkt auf der Textur berechnen
            Dim vU As vector3, vV As vector3, vP As vector3
            vU = vSub(tri.tex2, tri.tex1)
            vV = vSub(tri.tex3, tri.tex1)
            vP = tri.tex1
            
            Dim h As vector3
            h = vAdd(vP, vAdd(vMulS(vU, u), vMulS(vV, v)))
            h.x = h.x * (textures(tri.texIdx).width)
            h.y = h.y * (textures(tri.texIdx).height)
            
            ' X- und Y- werte als Double und dann als Pixelpaare berechnen
            Dim X1 As Double, X2 As Double, tmpX As Double
            Dim Y1 As Double, Y2 As Double, tmpY As Double
            
            tmpX = h.x
            X1 = modulo(Int(tmpX), textures(tri.texIdx).width)
            X2 = modulo(Int(tmpX + 1), textures(tri.texIdx).width)
            
            tmpY = h.y
            Y1 = modulo(Int(tmpY), textures(tri.texIdx).height)
            Y2 = modulo(Int(tmpY + 1), textures(tri.texIdx).height)
            
            tmpX = (tmpX - Int(tmpX))
            tmpY = (tmpY - Int(tmpY))
                        
            ' Falls X2 nicht außerhalb des Bildes liegt
            'If X1 < textures(tri.texIdx).width And Y1 < textures(tri.texIdx).height Then
            
            ' Horizontal interpolieren
            Dim cX1Y1 As colorHDR, cX2Y1 As colorHDR, cX1Y2 As colorHDR, cX2Y2 As colorHDR
            cX1Y1 = textures(tri.texIdx).colorData(X1, Y1)
            cX1Y2 = textures(tri.texIdx).colorData(X1, Y2)
            cX2Y1 = textures(tri.texIdx).colorData(X2, Y1)
            cX2Y2 = textures(tri.texIdx).colorData(X2, Y2)
            
            'cX1Y1 = (tmpX - X1) * cX1Y1 + (X2 - tmpX) * cX2Y1
            'cX1Y2 = (tmpX - X1) * cX1Y2 + (X2 - tmpX) * cX2Y2
            'tmpColor = (tmpY - Y1) * cX1Y1 + (Y2 - tmpY) * cX1Y2
            
            cX1Y1 = cAdd(cMulS(cX2Y1, tmpX), cMulS(cX1Y1, 1 - tmpX))
            cX1Y2 = cAdd(cMulS(cX2Y2, tmpX), cMulS(cX1Y2, 1 - tmpX))
            tmpColor = cAdd(cMulS(cX1Y2, tmpY), cMulS(cX1Y1, 1 - tmpY))
            'tmpColor = textures(tri.texIdx).colorData(X1, Y1)
            'End If
            
        End If
    End If
    '##########
    ' Ende Texturierung für Dreiecke
    '##########
    
    '##########
    ' Lambert-Shading
    '##########
    'Winkel zwischen dem Einfallenden Licht und der Normalen berechnen
    lightDir = vSub(lght.pos, SurfacePoint)
    cosine = vMul(SurfaceNormale, lightDir) / (vLen(SurfaceNormale) * vLen(lightDir))
    
    ' quadrat des abstandes von der Lichtquelle
    Dim squareDist As Double
    'squareDist = lightDir.x * lightDir.x + lightDir.y * lightDir.y + lightDir.z * lightDir.z
    squareDist = vLen(lightDir)
    
    ' Falls der Winkel größer 0 und kleiner 90 grad ist
    If cosine > 0 Then
        clrMul = lght.intensity * cosine * 10 / squareDist
        
        returnColor.r = lght.clr.r * tmpColor.r * clrMul
        returnColor.g = lght.clr.g * tmpColor.g * clrMul
        returnColor.b = lght.clr.b * tmpColor.b * clrMul
    Else
        returnColor = cSet(0, 0, 0)
    End If
    '##########
    ' Ende Lambert-Shading
    '##########
    
    lightSurfaceColor = returnColor
    FunctionCallAnalysis.lightSurfaceColorTime = FunctionCallAnalysis.lightSurfaceColorTime + Timer
    
End Function

Private Function shadowValue(itsPoint As vector3, lightIndex As Integer, w As scene) As Double
FunctionCallAnalysis.shadowValueTime = FunctionCallAnalysis.shadowValueTime - Timer
FunctionCallAnalysis.shadowValue = FunctionCallAnalysis.shadowValue + 1
    ' N SCHATTENSTRAHLEN BERECHNEN UND DEN DURCHSCHNITT ZURÜCKGEBEN
    ' shadowValue = 0 => Liegt nicht im Schatten
    ' shadowValue = 1 => Liegt vollständig im Schatten
    
    Dim radius As Double
    radius = w.lichter(lightIndex).radius
    
    ' falls der Radius 0 ist, wird nicht mehr als 1 sample benötigt
    Dim shadowSamples As Integer
    If (radius = 0) Then
        shadowSamples = 1
    Else
        shadowSamples = renderConfig.shadowSamples
    End If
    
    ' FALLS NOCH KEINE SAMPELPUNKTE BESTIMMT WURDEN
    ' SOLLEN DIESE GENERIERT WERDEN
    Dim iX As Integer, iY As Integer, dPos As vector3
    If (w.lichter(lightIndex).castPointsGenerated = False) Then
        Dim lightNormal As vector3
        lightNormal = vMulS(w.lichter(lightIndex).direction, -1)
        
        ' zwei vektoren bestimmen, die senkrecht zur Lichtquelle stehen
        Dim vX As vector3, vY As vector3, vUp As vector3
        vUp = vSet(1, 1, 1)
        vX = vCrossProduct(lightNormal, vUp)
        
        vY = vCrossProduct(vX, lightNormal)
        vY = vNormalize(vY)
        
        vX = vCrossProduct(lightNormal, vY)
        vX = vNormalize(vX)
        
        ' Array des Lichtes angleichen
        ReDim w.lichter(lightIndex).castPoints(shadowSamples, shadowSamples)
            
        ' n² sampelpoints erstellen und in dem Array des Lichtes speichern
        For iY = 0 To shadowSamples - 1
            For iX = 0 To shadowSamples - 1
                
                ' Abweichung von Lichtmittelpunkt berechnen
                If (shadowSamples = 1) Then
                    dPos = vSet(0, 0, 0)
                Else
                    dPos = vAdd(vMulS(vX, radius * (iX / (shadowSamples - 1) * 2 - 1)), vMulS(vY, radius * (iY / (shadowSamples - 1) * 2 - 1)))
                End If
                
                'Punkt berechnen und in die Liste eintragen
                w.lichter(lightIndex).castPoints(iX, iY) = vAdd(w.lichter(lightIndex).pos, dPos)
                    
            Next iX
        Next iY
            
        ' Zum Schluss noch "castPointsGenerated" auf TRUE setzen
        w.lichter(lightIndex).castPointsGenerated = True
    End If
            
            
            
    ' n² shadowsamples schießen
    ' Treffer aufsummieren und durch n² teilen
    Dim shRay As ray, t As Double
    Dim tmpShadowValue As Double
    'Dim objHit As Boolean
    
    For iY = 0 To shadowSamples - 1
        For iX = 0 To shadowSamples - 1
        
            'objHit = False
            ' Schattenstrahl berechnen
            ' schattenstrahl NICHT NORMALISIEREN!!
            ' da 0 <= t <= 1 !!
            shRay.d = vSub(w.lichter(lightIndex).castPoints(iX, iY), itsPoint)
            shRay.P = vAdd(itsPoint, vMulS(shRay.d, 0.00001))
            
            t = 1.79769313486231E+308
            ' Alle ebenen testen
            For i = 0 To w.nEbenen - 1
                If (RayHitsPlane(shRay, w.ebenen(i), t)) Then
                    If t > 0 And t < 1 Then
                        tmpShadowValue = tmpShadowValue + 1
                        'objHit = True
                        Exit For
                    End If
                End If
            Next i
            
            ' Falls schon ein Objekt getroffen wurde
            ' nächsten Schleifendurchlauf starten
            'If objHit = False Then
                t = 1.79769313486231E+308
                'Alle Kugeln testen
                For i = 0 To w.nKugeln - 1
                    If (RayHitsSphere(shRay, w.kugeln(i), t)) Then
                        If t > 0 And t < 1 Then
                            tmpShadowValue = tmpShadowValue + 1
                            'objHit = True
                            Exit For
                        End If
                    End If
                Next i
            'End If
            
            'If objHit = False Then
                t = 1.79769313486231E+308
                'Alle Dreiecke testen
                For i = 0 To w.nDreiecke - 1
                    If (RayHitsTriangle(shRay, w.dreiecke(i), t)) Then
                        If t > 0 And t < 1 Then
                            tmpShadowValue = tmpShadowValue + 1
                            'objHit = True
                            Exit For
                        End If
                    End If
                Next i
            'End If
            
        Next iX ' shoot shadow samples
    Next iY
    
    ' tmpShadowValue normalisieren

    shadowValue = tmpShadowValue / (shadowSamples * shadowSamples)
    FunctionCallAnalysis.shadowValueTime = FunctionCallAnalysis.shadowValueTime + Timer
    
End Function

Private Function RayHitsPlane(r As ray, b As plane, Optional t As Double) As Boolean
FunctionCallAnalysis.RayHitsPlane = FunctionCallAnalysis.RayHitsPlane + 1
'Ray gegen Plane Testen
    Dim h
    h = vMul(b.n, r.d)
    If (h <> 0) Then
        t = (b.b - vMul(b.n, r.P)) / h
        If t > 0 Then
            RayHitsPlane = True
            Exit Function
        End If
    End If
RayHitsPlane = False
End Function

Private Function RayHitsSphere(r As ray, s As shpere, Optional t As Double) As Boolean
    FunctionCallAnalysis.RayHitsSphereTime = FunctionCallAnalysis.RayHitsSphereTime - Timer
    FunctionCallAnalysis.RayHitsSphere = FunctionCallAnalysis.RayHitsSphere + 1
    
    Dim a As Double, b As Double, c As Double, diskriminante As Double, t1 As Double, t2 As Double
    
    a = vMul(r.d, r.d)
    b = 2 * vMul(r.d, vSub(r.P, s.P))
    c = -2 * vMul(r.P, s.P) + vMul(r.P, r.P) + vMul(s.P, s.P) - s.r * s.r
        
    diskriminante = b * b - 4 * a * c
      
    If (diskriminante >= 0) Then
        t1 = (-b - Sqr(diskriminante)) / (2 * a)
        t2 = (-b + Sqr(diskriminante)) / (2 * a)
        
        t = t1
        
        If (t2 >= 0) And (t1 < 0) Then
            t = t2
        End If
        
        RayHitsSphere = True
        FunctionCallAnalysis.RayHitsSphereTime = FunctionCallAnalysis.RayHitsSphereTime + Timer
        Exit Function
    End If
    
    RayHitsSphere = False
    FunctionCallAnalysis.RayHitsSphereTime = FunctionCallAnalysis.RayHitsSphereTime + Timer
    
End Function

Private Function CreateTrianglePlane(l As triangle) ' As plane
Dim u As vector3, v As vector3
u = vSub(l.p3, l.p1)
v = vSub(l.p2, l.p1)
l.e.n = vNormalize(vCrossProduct(u, v))
l.e.b = vMul(l.e.n, l.p1)
End Function

Private Function RayHitsTriangle(r As ray, l As triangle, Optional t As Double, Optional uKoord As Double, Optional vKoord As Double) As Boolean
FunctionCallAnalysis.RayHitsTriangleTime = FunctionCallAnalysis.RayHitsTriangleTime - Timer
FunctionCallAnalysis.RayHitsTriangle = FunctionCallAnalysis.RayHitsTriangle + 1
'Ebene Auf kollision testen
If (RayHitsPlane(r, l.e, t)) Then
    ' Falls der normalenvektor zur Kamera zeigt
    'If (vMul(l.e.n, r.d) < 0) Then
    
        'Falls Eine Kollision stattgefunden hat
        ' Kollisionspunkt errechnen
        Dim itsP As vector3
        itsP = vAdd(r.P, vMulS(r.d, t))
        
        'U und V koordinaten des Kollisionspunktes berechnen
        Dim k As vector3, u As vector3, v As vector3
        'Dim uKoord As Double, vKoord As Double
        
        u = vSub(l.p2, l.p1)
        v = vSub(l.p3, l.p1)
        
        k = vCrossProduct(u, l.e.n)
        vKoord = vMul(k, vSub(itsP, l.p1)) / vMul(k, v)
        
        k = vCrossProduct(v, l.e.n)
        uKoord = vMul(k, vSub(itsP, l.p1)) / vMul(k, u)
        
        If (uKoord + vKoord) <= 1 And uKoord >= 0 And vKoord >= 0 Then
            RayHitsTriangle = True
            FunctionCallAnalysis.RayHitsTriangleTime = FunctionCallAnalysis.RayHitsTriangleTime + Timer
            Exit Function
        End If
    
    'End If
End If

RayHitsTriangle = False
FunctionCallAnalysis.RayHitsTriangleTime = FunctionCallAnalysis.RayHitsTriangleTime + Timer

End Function

Private Function traceRay(r As ray, world As scene, Optional maxDepth As Integer = 3, Optional depth As Integer = 0, Optional lastObjHit As Integer = -1, Optional lastObjHitIdx As Integer = -1) As colorHDR
FunctionCallAnalysis.traceRayTime = FunctionCallAnalysis.traceRayTime - Timer
FunctionCallAnalysis.traceRay = FunctionCallAnalysis.traceRay + 1
Dim returnColor As colorHDR, dist As Double

'#################
' Beginn der Kollisionberechnung
'#################

dist = 100000
If depth >= maxDepth Then
    FunctionCallAnalysis.traceRayTime = FunctionCallAnalysis.traceRayTime + Timer
    Exit Function
End If

Dim objectHit As Integer, objectHitIndex As Integer
Dim t As Double
objectHit = -1
objectHitIndex = -1

For i = 0 To world.nEbenen - 1
    'Ray gegen Ebene testen
    If (RayHitsPlane(r, world.ebenen(i), t)) = True Then
        If t < dist And t >= 0 Then
            dist = t
            objectHit = 1
            objectHitIndex = i
        End If
    End If
            
Next i

For i = 0 To world.nKugeln - 1
    'Ray gegen Shpere Testen
    If (RayHitsSphere(r, world.kugeln(i), t) = True) Then
        If t < dist And t >= 0 Then
            dist = t
            objectHit = 2
            objectHitIndex = i
        End If
    End If
Next i

' Gelieferte U und V koordinaten speichern um Neuberechnung zu vermeiden
Dim u As Double, v As Double
For i = 0 To world.nDreiecke - 1
    'Ray gegen Dreiecke Testen
    If (RayHitsTriangle(r, world.dreiecke(i), t, u, v) = True) Then
        If t < dist And t >= 0 Then
            dist = t
            objectHit = 3
            objectHitIndex = i
        End If
    End If
Next i
'#################
' Ende der Kollisionberechnung
'#################


'#################
' Beginn des Shadings
'#################

Dim DiffuseColor As colorHDR, ReflectionColor As colorHDR, RefractionColor As colorHDR
Dim colorAtItsP As colorHDR, tmpColor As colorHDR
returnColor = cSet(0, 0, 0)

' Normale, Kollisionspunkt und Material der getroffenen Geometrie bestimmen
Dim itsP As vector3, normale As vector3, mat As material
itsP = vAdd(vMulS(r.d, dist), r.P)

'Dreieck
If objectHit = 3 Then
    normale = world.dreiecke(objectHitIndex).e.n
    mat = world.dreiecke(objectHitIndex).e.mat
End If

'Kugel
If objectHit = 2 Then
    normale = vSub(itsP, world.kugeln(objectHitIndex).P)
    mat = world.kugeln(objectHitIndex).mat
End If

If (objectHitIndex > -1) Then

normale = vNormalize(normale)
                    
    ' Für jedes Licht Farbe und Schatten berechnen
    Dim j As Integer, lightDir As vector3
    For j = 0 To world.nLichter - 1
    
        ' Prüfen, ob der Schnittpunkt überhaupt vor dem Licht liegt
        lightDir = vNormalize(vSub(world.lichter(j).pos, itsP))
        If (vMul(lightDir, normale) > 0) Then
        
            ' Farbe der Kombination Material/Light(j) berechnen
            If (objectHit = 3) Then
                colorAtItsP = lightSurfaceColor(itsP, normale, mat, world.lichter(j), objectHitIndex, u, v)
            Else
                colorAtItsP = lightSurfaceColor(itsP, normale, mat, world.lichter(j))
            End If
            
            ' Falls schatten generiert werden sollen
            If renderConfig.renderShadows = True Then
            
                ' Falls das Licht überhaupt Schatten generiert
                If world.lichter(j).castsShadows = True Then
                
                    ' Intensität des Schatten berechnen
                    Dim shadowMultiplier As Double
                    shadowMultiplier = 1 - shadowValue(itsP, j, world)
                
                    DiffuseColor = cAdd(DiffuseColor, cMulS(colorAtItsP, shadowMultiplier))
                Else
                    DiffuseColor = cAdd(DiffuseColor, colorAtItsP)
                End If
            Else
                DiffuseColor = cAdd(DiffuseColor, colorAtItsP)
            End If
            
        End If 'Punkt vor Licht
    Next j
            
    'Reflektionen Berechnen
    'Reflektionsstrahl berechnen
    If renderConfig.renderReflections = True Then
        Dim reflRay As ray
        If (mat.reflectVal > 0) Then
            reflRay.P = vAdd(itsP, vMulS(normale, 0.0000000001))
            reflRay.d = vAdd(r.d, vMulS(normale, -2 * (vMul(normale, r.d))))
            reflRay.d = vNormalize(reflRay.d)
            'ReflectionColor = cAdd(ReflectionColor, cMulS(traceRay(reflRay, world, maxDepth, depth + 1, objectHit, objectHitIndex), mat.reflectVal))
            ReflectionColor = traceRay(reflRay, world, maxDepth, depth + 1, objectHit, objectHitIndex)
        End If
    End If ' Render reflections
    
    ' Refraktionen Berechnen
    ' Refraktionsstrahl berechnen
    If renderConfig.renderRefractions = True Then
        If (mat.transparency > 0) Then
        
            ' alpha berechnen
            r.d = vNormalize(r.d)
            Dim alpha As Double, cosAlpha As Double
            cosAlpha = -vMul(normale, r.d)
            If (cosAlpha > 0) Then
                alpha = arccos(cosAlpha)
            Else
                alpha = 3.141592653 - arccos(cosAlpha)
            End If
           
            'Y0 und X0 berechnen
            Dim Y0 As vector3, X0 As vector3
            Y0 = (vMulS(normale, vMul(normale, r.d)))
            X0 = vSub(r.d, Y0)
           
            'Beta berechnen
            Dim beta As Double
            If (cosAlpha >= 0) Then
                beta = arcsin(Sin(alpha) / mat.refracIdx)
            End If
           
            If ((Sin(alpha) < 1 / mat.refracIdx) And cosAlpha < 0) Then
                beta = arcsin(Sin(alpha) * mat.refracIdx)
            End If
           
            If ((Sin(alpha) > 1 / mat.refracIdx) And cosAlpha < 0) Then
                beta = 2 * 3.141592653 - alpha
            End If
           
            'RefractionRay aufsetzen
            Dim refracRay As ray
           
            ' Falls beta < 45°
            If (beta < 3.141592653 / 4) Then
                Dim X1 As vector3
                If (alpha <> 0) Then
                    X1 = vMulS(X0, Tan(beta) / Tan(alpha))
                Else
                    Y0 = vSet(0, 0, 0)
                    X1 = r.d
                End If
                refracRay.d = vAdd(Y0, X1)
            Else
                Dim Y1 As vector3
                If (beta <> 0) Then
                    Y1 = vMulS(Y0, Tan(alpha) / Tan(beta))
                Else
                    Y1 = Y0
                End If
                refracRay.d = vAdd(Y1, X0)
            End If
           
            refracRay.P = vAdd(itsP, vMulS(normale, vMul(normale, refracRay.d) * 0.00001))
           
           refracRay.d = vNormalize(refracRay.d)
           'RefractionColor = cAdd(returnColor, cMulS(traceRay(refracRay, world, maxDepth, depth + 1, objectHit, objectHitIndex), mat.refracVal))
           RefractionColor = traceRay(refracRay, world, maxDepth, depth + 1, objectHit, objectHitIndex)
           ' 'returnColor = traceRay(refracRay, world, maxDepth, depth + 1)
        End If 'Mat.refractionVal > 0
    End If 'RenderRefractions
    
'#################
' Ende des Shadings
'#################

End If


If mat.transparency > 0 Or mat.reflectVal > 0 Then
    returnColor = cAdd(cMulS(ReflectionColor, mat.reflectVal), cMulS(RefractionColor, (1 - mat.reflectVal)))
Else
    returnColor = DiffuseColor
End If
traceRay = returnColor
traceRay.z = dist
traceRay.a = 1
FunctionCallAnalysis.traceRayTime = FunctionCallAnalysis.traceRayTime + Timer
End Function
Private Function LogAddFunctionCallAnalysis(value, name As String, Optional value2) As String
LogAddFunctionCallAnalysis = "<tr> <td align=right>" + CStr(value) + "</td><td>" + name + "</td><td>" + CStr(value2) + "</td></tr>"
End Function

Private Function WriteFunctionCallAnalysis(path As String)
Dim fileNr
fileNr = FreeFile
Dim LogStart As String, LogEnd As String
LogStart = "<html><table border=1><tr bgcolor=#AAAAAA><td>Functioncalls</td></tr>"
LogEnd = "</table></html>"

Open path For Binary Access Write As #fileNr
'Open path For Output Access Write As #fileNr
'Write #fileNr, LogStart
'Write #fileNr, LogAddFunctionCallAnalysis(FunctionCallAnalysis.traceRay, "TraceRay")
'Write #fileNr, LogEnd
Put #fileNr, , LogStart
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.vAdd, "vAdd", FunctionCallAnalysis.vAddTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.vCrossProduct, "vCrossProduct", FunctionCallAnalysis.vCrossProductTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.vMul, "vMul", FunctionCallAnalysis.vMulTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.arccos, "arccos", FunctionCallAnalysis.arccosTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.arcsin, "arcsin", FunctionCallAnalysis.arcsinTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.lightSurfaceColor, "lightSurfaceColor", FunctionCallAnalysis.lightSurfaceColorTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.RayHitsSphere, "RayHitsSphere", FunctionCallAnalysis.RayHitsSphereTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.RayHitsTriangle, "RayHitsTriangle", FunctionCallAnalysis.RayHitsTriangleTime)
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.shadowValue, "shadowValue", FunctionCallAnalysis.shadowValueTime)
'Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.shadowValueTime, "Time shadowValue")
Put #fileNr, , LogAddFunctionCallAnalysis(FunctionCallAnalysis.vNormalize, "vNormalize", FunctionCallAnalysis.vNormalizeTime)
Put #fileNr, , LogEnd
Close #fileNr
End Function

Private Sub createBox(triList() As triangle, pos As vector3, size As vector3, XAxis As vector3, YAxis As vector3)

' Achsen normalisieren
XAxis = vNormalize(XAxis)
YAxis = vNormalize(YAxis)

' ZAchse berechnen
Dim ZAxis As vector3
ZAxis = vCrossProduct(YAxis, XAxis)

' Punkte definieren
Dim VOR As vector3, VOL As vector3, VUR As vector3, VUL As vector3, HOR As vector3, HOL As vector3, HUR As vector3, HUL As vector3

VOR = vAdd(vAdd(vSub(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
VOL = vAdd(vSub(vSub(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
VUR = vSub(vAdd(vSub(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
VUL = vSub(vSub(vSub(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))

HOR = vAdd(vAdd(vAdd(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
HOL = vAdd(vSub(vAdd(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
HUR = vSub(vAdd(vAdd(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))
HUL = vAdd(vSub(vAdd(pos, vMulS(ZAxis, size.z / 2)), vMulS(XAxis, size.x / 2)), vMulS(YAxis, size.y / 2))


'Hinten
world.dreiecke(0).p1 = HOL
world.dreiecke(0).p2 = HUL
world.dreiecke(0).p3 = HOR

world.dreiecke(1).p1 = HUL
world.dreiecke(1).p2 = HUR
world.dreiecke(1).p3 = HOR

'Rechts
world.dreiecke(2).p1 = VOR
world.dreiecke(2).p2 = VUR
world.dreiecke(2).p3 = HUR

world.dreiecke(3).p1 = VOR
world.dreiecke(3).p2 = HUR
world.dreiecke(3).p3 = HOR

'Oben
world.dreiecke(4).p1 = VOL
world.dreiecke(4).p2 = VOR
world.dreiecke(4).p3 = HOR

world.dreiecke(5).p1 = VOL
world.dreiecke(5).p2 = HOR
world.dreiecke(5).p3 = HOL

'Links
world.dreiecke(6).p1 = VOL
world.dreiecke(6).p2 = HUL
world.dreiecke(6).p3 = VUL

world.dreiecke(7).p1 = VOL
world.dreiecke(7).p2 = HOL
world.dreiecke(7).p3 = HUL

'Unten
world.dreiecke(8).p1 = VUR
world.dreiecke(8).p2 = VUL
world.dreiecke(8).p3 = HUR

world.dreiecke(9).p1 = VUL
world.dreiecke(9).p2 = HUL
world.dreiecke(9).p3 = HUR

'Vorne
world.dreiecke(10).p1 = VOR
world.dreiecke(10).p2 = VOL
world.dreiecke(10).p3 = VUL

world.dreiecke(11).p1 = VOR
world.dreiecke(11).p2 = VUL
world.dreiecke(11).p3 = VUR
End Sub

Private Sub setupRenderConfig()
renderConfig.renderAA = InputAA.value
renderConfig.AASamples = CInt(InputAASamples.Text)
renderConfig.renderReflections = InputReflections.value
renderConfig.ReflectionSamples = CInt(InputReflectionSamples.Text)
renderConfig.renderShadows = InputShadowCasting.value
renderConfig.shadowSamples = CInt(InputShadowSamples.Text)
renderConfig.imageWidth = CLng(InputWidth.Text)
renderConfig.imageHeight = CLng(InputHeight.Text)
renderConfig.outputPath = InputOutputPath.Text
renderConfig.maxTraceDepth = CInt(InputTracedepth.Text)
renderConfig.renderRefractions = InputRefractions.value
End Sub



Private Sub InputAspect169_Click()
InputHeight.Text = CInt(CDbl(InputWidth.Text) / 16 * 9)
End Sub

Private Sub InputAspect2351_Click()
InputHeight.Text = CInt(CDbl(InputWidth.Text) / 2.35)
End Sub

Private Sub InputAspect43_Click()
InputHeight.Text = CInt(CDbl(InputWidth.Text) / 4 * 3)
End Sub
Private Sub InputAspectUser_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Call LabelAspectUser_Click
End Sub

Private Sub InputAspectUserDefined_Click()
If InputAspectUser.Text <> "" Then
    InputHeight.Text = CInt(CDbl(InputWidth.Text) / CDbl(InputAspectUser.Text))
End If
End Sub

Private Sub InputWidth_Change()
' Prüfen, welches Seitenverhältnis gewählt wurde
Dim aspectRatio As Double
If InputAspect43.value = True Then aspectRatio = 4 / 3
If InputAspect169.value = True Then aspectRatio = 16 / 9
If InputAspect2351.value = True Then aspectRatio = 2.35
If InputAspectUserDefined.value = True Then aspectRatio = CDbl(InputAspectUser.Text)

If InputWidth.Text = "" Then
    InputHeight.Text = 0
Else
    InputHeight.Text = CInt(CDbl(InputWidth.Text) / aspectRatio)
End If
End Sub

Private Sub Label14_Click()

End Sub

Private Sub LabelAspect169_Click()
InputAspect169.value = True
Call InputAspect169_Click
End Sub

Private Sub LabelAspect2351_Click()
InputAspect2351.value = True
Call InputAspect2351_Click
End Sub

Private Sub LabelAspect43_Click()
InputAspect43.value = True
Call InputAspect43_Click
End Sub

Private Sub LabelAspectUser_Click()
InputAspectUserDefined.value = True
Call InputAspectUserDefined_Click
End Sub

'############################################
'
' MAIN
'
'############################################
Private Sub main_Click()

Dim startTime As Long, endTime As Long
startTime = Timer

Randomize

Call setupRenderConfig


Dim view As imageBuffer
view.width = renderConfig.imageWidth
view.height = renderConfig.imageHeight
view.bbp = 32
ReDim view.colorData(view.width - 1, view.height - 1)

Dim cam As camera
cam.dir = vSet(0, 0, 1)
cam.pos = vSet(0, 10, -19.9)
cam.up = vSet(0, 1, 0)
cam.fov = 26#
cam.ration = view.width / view.height


'ReDim textures(3)
'Call loadBmp("P:\gfx\WallRight.bmp", textures(1))
'Call loadBmp("P:\gfx\MyPattern.bmp", textures(2))

world.nEbenen = 0
world.nKugeln = 2
world.nLichter = 1
world.nDreiecke = 12
'ReDim world.ebenen(world.nEbenen - 1)
ReDim world.kugeln(world.nKugeln - 1)
ReDim world.lichter(world.nLichter - 1)
ReDim world.dreiecke(world.nDreiecke - 1)

'world.ebenen(0).n = vSet(0, 1, 0)
'world.ebenen(0).mat.clr = cSet(95, 210, 0)
'world.ebenen(0).mat.reflectVal = 0
'world.ebenen(0).b = 0

world.kugeln(0).P = vSet(4, 4, 8)
world.kugeln(0).mat.clr = cSet(0.82, 0.82, 0.82)
world.kugeln(0).r = 4
world.kugeln(0).mat.reflectVal = 0.125
world.kugeln(0).mat.transparency = 1#
world.kugeln(0).mat.refracIdx = 1.66
world.kugeln(0).mat.refracVal = 1

world.kugeln(1).P = vSet(-4, 5, 15.2)
world.kugeln(1).mat.clr = cSet(0.82, 0.82, 0.82)
world.kugeln(1).mat.reflectVal = 1
world.kugeln(1).mat.refracIdx = 1#
world.kugeln(1).mat.refracVal = 0
world.kugeln(1).r = 5

'world.lichter(0).pos = vSet(-7, 19, -13)
world.lichter(0).pos = vSet(0, 19.9, 6.1)
world.lichter(0).intensity = 1.2
world.lichter(0).clr = cSet(1, 0.94, 0.94)
world.lichter(0).castsShadows = True
world.lichter(0).direction = vSet(0, -1, 0)
world.lichter(0).radius = 0.25

'world.lichter(1).pos = vSet(0, 10, 10)
'world.lichter(1).intensity = 0.5
'world.lichter(1).clr = cSet(1, 1, 1)
'world.lichter(1).castsShadows = False
'world.lichter(1).direction = vSet(0, -1, 0)

'Hinten
world.dreiecke(0).p1 = vSet(-10, 0, 20)
world.dreiecke(0).p2 = vSet(10, 0, 20)
world.dreiecke(0).p3 = vSet(-10, 20, 20)
world.dreiecke(0).e.mat.clr = cSet(0.68, 0.68, 0.68)
world.dreiecke(0).tex1 = vSet(0, 1, 0)
world.dreiecke(0).tex2 = vSet(1, 1, 0)
world.dreiecke(0).tex3 = vSet(0, 0, 0)


world.dreiecke(1).p1 = vSet(10, 0, 20)
world.dreiecke(1).p2 = vSet(10, 20, 20)
world.dreiecke(1).p3 = vSet(-10, 20, 20)
world.dreiecke(1).e.mat.clr = cSet(0.68, 0.68, 0.68)
world.dreiecke(1).tex1 = vSet(1, 1, 0)
world.dreiecke(1).tex2 = vSet(1, 0, 0)
world.dreiecke(1).tex3 = vSet(0, 0, 0)

'Rechts
world.dreiecke(2).p1 = vSet(10, 0, 20)
world.dreiecke(2).p2 = vSet(10, 0, -20)
world.dreiecke(2).p3 = vSet(10, 20, -20)
world.dreiecke(2).e.mat.clr = cSet(0.85, 0.47, 0)
'world.dreiecke(2).texIdx = 1
world.dreiecke(2).tex1 = vSet(0, 1, 0)
world.dreiecke(2).tex2 = vSet(1, 1, 0)
world.dreiecke(2).tex3 = vSet(1, 0, 0)

world.dreiecke(3).p1 = vSet(10, 20, -20)
world.dreiecke(3).p2 = vSet(10, 20, 20)
world.dreiecke(3).p3 = vSet(10, 0, 20)
world.dreiecke(3).e.mat.clr = cSet(0.85, 0.47, 0)
'world.dreiecke(3).texIdx = 1
world.dreiecke(3).tex1 = vSet(1, 0, 0)
world.dreiecke(3).tex2 = vSet(0, 0, 0)
world.dreiecke(3).tex3 = vSet(0, 1, 0)

'Oben
world.dreiecke(4).p1 = vSet(-10, 20, 20)
world.dreiecke(4).p2 = vSet(10, 20, 20)
world.dreiecke(4).p3 = vSet(-10, 20, -20)
world.dreiecke(4).e.mat.clr = cSet(0.55, 0.55, 0.55)

world.dreiecke(5).p1 = vSet(10, 20, 20)
world.dreiecke(5).p2 = vSet(10, 20, -20)
world.dreiecke(5).p3 = vSet(-10, 20, -20)
world.dreiecke(5).e.mat.clr = cSet(0.55, 0.55, 0.55)

'Links
world.dreiecke(6).p1 = vSet(-10, 20, -20)
world.dreiecke(6).p2 = vSet(-10, 0, -20)
world.dreiecke(6).p3 = vSet(-10, 0, 20)
world.dreiecke(6).e.mat.clr = cSet(0.2, 0.62, 0.733)

world.dreiecke(7).p1 = vSet(-10, 0, 20)
world.dreiecke(7).p2 = vSet(-10, 20, 20)
world.dreiecke(7).p3 = vSet(-10, 20, -20)
world.dreiecke(7).e.mat.clr = cSet(0.2, 0.62, 0.733)

'Unten
world.dreiecke(8).p1 = vSet(-10, 0, 20)
world.dreiecke(8).p2 = vSet(10, 0, -20)
world.dreiecke(8).p3 = vSet(10, 0, 20)
world.dreiecke(8).e.mat.clr = cSet(0.55, 0.55, 0.55)
world.dreiecke(8).tex1 = vSet(0, 0, 0)
world.dreiecke(8).tex2 = vSet(5, 10, 0)
world.dreiecke(8).tex3 = vSet(5, 0, 0)
'world.dreiecke(8).texIdx = 2

world.dreiecke(9).p1 = vSet(-10, 0, 20)
world.dreiecke(9).p2 = vSet(-10, 0, -20)
world.dreiecke(9).p3 = vSet(10, 0, -20)
world.dreiecke(9).e.mat.clr = cSet(0.55, 0.55, 0.55)
world.dreiecke(9).tex1 = vSet(0, 0, 0)
world.dreiecke(9).tex2 = vSet(0, 10, 0)
world.dreiecke(9).tex3 = vSet(5, 10, 0)
'world.dreiecke(9).texIdx = 2

'Vorne
world.dreiecke(10).p1 = vSet(10, 0, -20)
world.dreiecke(10).p2 = vSet(-10, 0, -20)
world.dreiecke(10).p3 = vSet(-10, 20, -20)
world.dreiecke(10).e.mat.clr = cSet(0.5, 0.5, 0.5)

world.dreiecke(11).p1 = vSet(10, 20, -20)
world.dreiecke(11).p2 = vSet(10, 0, -20)
world.dreiecke(11).p3 = vSet(-10, 20, -20)
world.dreiecke(11).e.mat.clr = cSet(0.5, 0.5, 0.5)

'Dim pos As vector3, size As vector3, xAx As vector3, yAx As vector3
'size = vSet(2, 2, 4)
'xAx = vSet(Sin(1), 0, Cos(1))
'yAx = vSet(0, 1, 0)
'Call createBox(world.dreiecke, pos, size, xAx, yAx)


'For q = 0 To world.nKugeln - 1
'    world.kugeln(q).p = vSet(-15 + (q / (world.nKugeln - 1)) * 30, 3, 10)
'    world.kugeln(q).r = 3
'    world.kugeln(q).clr = cSet((q / (world.nKugeln - 1) * 255), Sqr(255# * 255# - (q * q / ((world.nKugeln - 1) * (world.nKugeln - 1)) * 255# * 255#)), 0)
'Next q

For q = 0 To world.nDreiecke - 1
    Call CreateTrianglePlane(world.dreiecke(q))
Next q

Dim r As ray, dist As Double, itsPoint As vector3

Dim x As Long, y As Long
Dim tmpColor As colorHDR
Dim nPixel As Long

nPixel = view.width * view.height

'Das Bild einmal komplett Sampeln
For y = 0 To view.height - 1
    For x = 0 To view.width - 1
        dist = 100000
        
        If (x = 200) And (y = 200) Then
            'Dim i As Integer
            i = 2
        End If
        
        ' Ray berechnen
        Dim xDirection As vector3
        
        xDirection = vNormalize(vCrossProduct(cam.up, cam.dir))
        r.P = cam.pos
        r.d = vNormalize(cam.dir)
        
        'ZVektor
        r.d = vMulS(r.d, 1 / (2 * Tan(cam.fov / 360 * 3.14159265358979)))
        'XVektor
        r.d = vAdd(r.d, vMulS(xDirection, (2 * x / view.width) - 1))
        'YVektor
        r.d = vAdd(r.d, vMulS(cam.up, (1 - (2 * y / view.height)) / cam.ration))
        view.colorData(x, view.height - 1 - y) = traceRay(r, world, renderConfig.maxTraceDepth)
        
        DoEvents
                
    Next x
Next y

'Die Konturen bestimmen, und die Pixel, die übersampelt werden sollen
Dim tmpBuffer As imageBuffer
Call kontur(view, tmpBuffer)

'Call writeImageBuffer("P:\gfx\raytracing_supersampeMap.bmp", tmpBuffer)

'Die zu übersampelnden Pixel sind in tmpBuffer mit r = g = b = 1 gekenntzeichnet
If renderConfig.renderAA = True Then
    Dim superSampling As Integer
    superSampling = renderConfig.AASamples
    
    For y = 0 To view.height - 1
        For x = 0 To view.width - 1
        
            'Falls der Pixel übersampelt werden soll
            Dim nx As Integer, ny As Integer, b As Double, a As Double
        
            a = Sqr(superSampling * superSampling - 1)
            b = (superSampling * superSampling) / (a * a) - 1
        
            ny = a * Sqr(tmpBuffer.colorData(x, y).r + b)
            nx = a * Sqr(tmpBuffer.colorData(x, y).g + b)
        
            'view.colorData(x, y) = cSet(((ny - 1) + (nx - 1)) / 2 / (superSampling - 1), ((ny - 1) + (nx - 1)) / 2 / (superSampling - 1), ((ny - 1) + (nx - 1)) / 2 / (superSampling - 1))
        
        
            If ny > 1 Or nx > 1 Then

                dist = 100000
                tmpColor = cSet(0, 0, 0)

                For iY = 0 To ny - 1
                    For iX = 0 To nx - 1
                        ' Ray berechnen
                        xDirection = vNormalize(vCrossProduct(cam.up, cam.dir))
                        r.P = cam.pos
                        r.d = vNormalize(cam.dir)
                    
                        'ZVektor
                        r.d = vMulS(r.d, 1 / (2 * Tan(cam.fov / 360 * 3.14159265358979)))
                        'XVektor
                        r.d = vAdd(r.d, vMulS(xDirection, 2 / view.width * (x + (iX + 1) / (nx + 1)) - 1))
                        'YVektor
                        r.d = vAdd(r.d, vMulS(cam.up, (2 / view.height * (y + (iY + 1) / (ny + 1)) - 1) / cam.ration))
                        
                        tmpColor = cAdd(tmpColor, traceRay(r, world, renderConfig.maxTraceDepth))
                    Next iX
                Next iY
                
                Call cSetC(view.colorData(x, y), cMulS(tmpColor, 1 / (nx * ny)))
                
            End If
            
        Next x
    Next y
End If '? AA Sample

Call writeImageBuffer(renderConfig.outputPath, view)
Call WriteFunctionCallAnalysis("P:\gfx\analysis.html")

endTime = Timer
timeElapsed.Caption = "Rendertime: " + CStr(endTime - startTime) + " s"
End Sub

Private Sub UserForm_Click()

End Sub