Grafisch programmeerprobleempie onder Vbasic

[prisselada]

Voor een programma wat ik voor mn werk in elkaar wil klussen zit ik met een probleem. Ik zal eerst even uitleggen wat de bedoeling is:

Op een bepaald punt (X1, Y1) hangt een luidspreker die een bepaalde geluidsdruk produceert. Op een punt (X2, Y2) wil ik de geluidsdruk met een kleurtje weergeven. Als alles klaar zou zijn heb ik dus een veld (in mijn geval 120 breed en 50 hoog) met allemaal kleuren erin. Helemaal links hangt dan die luidspreker en naarmate je verder van de luidspreker komt, des te lager de geluidsdruk zal zijn (en zal je dus een verloop moeten zien van -bijvoorbeeld- felrood bij de luidspreker, via oranje en geel naar het "farfield" (ver van de luidspreker af) ).

Ik wil dus op een bepaald punt een stip (of een gebiedje, mag ook) zetten met een bepaalde kleur (afhankelijk van de geluidsdruk). Ik heb al diverse naslagwerken erbij gehad, maar ik kan het nergens vinden. Hoe kan ik dit programmeren in Visual Basic ?!?

[prisselada]

Als dit te moeilijk word kan ik er ook best mee leven als ik isobaren zie. Met andere woorden: een lijn in dat vlak voor 120dB, een andere lijn voor 110dB, weer een andere lijn voor 100dB etc. Dan maar zonder kleuren, is op zich wel beter ook naar klanten toe in verband met uitprinten van het hele zaakje (zwart/wit is voor het toepassingsgebied beter).

Ik lees het wel als iemand een idee heeft!

[Verwijderd]

Je kan toch gewoon met Circle(), Line() en PSet() werken? Dan kan je met PictureBox1.ForeColor de kleur instellen. Of begrijp ik je nu verkeerd

[Verwijderd]

Tsja, hoe moeilijk wil je het jezelf maken? Je kan in DirectDraw werken, of met DIB sections en blitters of je gebruikt de standaard api functies :-)

Check bijvoorbeeld de API functie Rectangle. If you check it on MSDN then you will also find the other functions used for drawing and quite some examples.

[prisselada]

Als ik iets programmeer doe ik het voornamelijk in C++ of C++Builder. Visual Basic is redelijk nieuw voor mij dus. Maarre thanks guys, ik zal es ff kijken of ik met dat Line() iets kan doen, dat Directdraw lijkt me ook wel wat...

[Verwijderd]

[offtopic]zo, kan ik gelijk even dit forumpje bekijken in de Opera-browser/offtopic]

Lijkt me simpel:
Circels tekenen kun je op de volgende manier doen...

'aannemen dat er een picture box staat,
met ScaleMode in Pixels (ipv Twips) en AutoRedraw=True

dim i as integer
X1=20:Y1=30
for i=0 to 130 step 10:Picture1.circle(X1,Y1),i:next

Je zit alleen met het verloop, maar dat zoek je zelf maar uit
Kleur is ook leuk:

for x=0 to 119
for y=0 to 49

dx=(X1-x)
dy=(Y1-y)
r=sqr(dx*dx+dy*dy)/130 ' verloopt in dit blok maximaal van 0..1

' herbereken de r naar gelang je isobaar verloop

'Sin/cos functies zijn het makkelijkste op RGB verloop te krijgen
clrR=255*(1+2.25*cos((r+0/3)*2*3.14159265)) 'de 1+2.25x bedenk ik even ter plekke
clrG=255*(1+2.25*cos((r+1/3)*2*3.14159265))
clrB=255*(1+2.25*cos((r+2/3)*2*3.14159265))

if clrR<0 then clrR=0
if clrG<0 then clrG=0
if clrB<0 then clrB=0

Picture1.pset(x,y),RGB(clrR,clrG,clrB) ' En zo zet je dus een puntje in een bepaalde RGB kleur

next y,x


Maar dan heb je dus gekleurde circel fragmenten.. Het lijkt me niet echt fraai maar goed (En hoe zit het met reflectie aan de wanden trouwens?)

Maar post even je resultaat...

[prisselada]

Ik ga er vanuit dat de vloer, muren, het meubilair en de bezoekers de reflectie tegenhouden. Als ik dit niet zou doen word het wel erg veel rekenwerk namelijk. Maar ik ben al druk aan t programmeren, als 't werkt knal ik m online (zal wel een paar daagjes duren denk ik...).

[Verwijderd]

Sja, ik heb hier een paar simpele boxjes in de kamer, en die staan onder een bepaalde hoek ten opzichte van de muur.. Zo hoor ik een kanaal aan de ene kant wel, en aan de andere kant niet, terwijl je het toch nog stereo hoord. Beetje spiegelend Links/Rechts ideetje... Zo hoor ik het geluid iets anders als ik achter de PC hang, dan wanneer ik op de bank zit. En ze staan op een dusdanige wijze dat het verloop niet irritant is (geen surround systeem dus).

edit:
als je toch bezig bent

Dat zou ik dat ook wel graag gesimuleerd zien. Inclusief de boxjes in mn keuken...

[MisterData]

prisselada schreef op 15 oktober 2002 @ 21:30:
Als ik iets programmeer doe ik het voornamelijk in C++ of C++Builder. Visual Basic is redelijk nieuw voor mij dus. Maarre thanks guys, ik zal es ff kijken of ik met dat Line() iets kan doen, dat Directdraw lijkt me ook wel wat...

Dan ken je de Windows API ook vast wel Die kun je toch ook vanuit VB aanspreken Dus ook de GDI-functies hiervoor

[prisselada]

Ik ben druk bezig met programmeren, zowel in Excel (wat eerst de bedoeling was), nu dus in VBasic en tegelijkertijd ook nog ff in C++Builder Als t nou niet lukt dan weet ik het ook niet meer... Maar als je zoiets voor thuis wilt gebruiken moet je wel met een speciaal meetprogramma de respons van je speakertjes zowel horizontaal als verticaal meten (2x360 graden dus). Ik kan het wel allemaal gaan uitleggen, maar dan dwalen we af en daar is dit topic niet voor bedoeld. Wil je het toch allemaal een keertje leren/lezen, kijk dan eens op www.monkeyforest.de

[Verwijderd]

zoiets?

[Verwijderd]

Die box ziet er HEEL erg gaaf uit...heb je die afbeelding ergens vandaan, of is hij gemaakt door een applicatie die jij ontwikkeld hebt?

Inquiring minds want to know

[Verwijderd]

Naar aanleiding van het topic probleempje werd ik zelf geprikkeld...
Dus even wat snel in elkaar getweaked in VB..

Ik weet nu in iedergeval hoe ik een diametrisch-geprojecteerde-ruimte moet afscannen (leuk scrabble woord btw )
Alleen gaat het niet helemaal goed (zie de streepvormingen), en heb het ook niet voor niets 20% verkleind..

Het doorzichtig maken van bepaalde "lucht" lagen is behoorlijk tricky, en de berekening ontzettend traag; PSet() enzo

Met twee bronnen wordt er een ellipsoide in de ruimte gevormd hmm....

Komt waarschijnlijk ook omdat de sferen liniair zijn toegepast in plaats van een kwadratische verzwakking (ofzoiets)

Al met al, ziet er misschien leuk en mooi uit, maar technische en wetenschappelijk van weinig waarde...

edit:
toevoeging

Heb ook weerkaatsingen proberen toe te passen, maar gaven een waardeloos visueel effect.

Het liefst zou ik de sferen zien kaatsen tegen de muren alsof het watergolfjes zijn..
Misschien probeer ik het later nog eens als ik tijd en zin heb.

[Verwijderd]

Maar die bovenstaande doos in de afbeelding heb jij gemaakt met VB?

[prisselada]

Marchello!!! Doe eens source-code!!! Ziet er heel erg strak uit !!!

[Verwijderd]

Wat ik zei... code is snel in elkaar getweaked, dus het verdient geen schoonheidsprijs or what-so-ever. Ik zou zeggen kiek maar ff, misschien is het toch nog nuttig... en dan die snelheid.... aaargh. Maar ok, kom maar met de opmerking, misschien leer ik nog wat

Men neme 1 Form, 1 Picturebox en 3 Commandbuttons
en pleure deze code erin.

code:

Option Explicit

Const MaxX = 60
Const MaxY = 40
Const MaxZ = 25

Dim Room(MaxX, MaxY, MaxZ, 4) As Single '(LxBxH,v) in dm

'waarden voor room-values (type declaratie is mooier)
Const vDruk = 0
Const vClrR = 1
Const vClrG = 2
Const vClrB = 3
Const vOpac = 4

Dim MinDruk As Single ' globaal voor het gemak
Dim MaxDruk As Single ' globaal voor het gemak
'------------------------------------------------

Private Function GetRGB(r As Single, ByRef cr As Single, ByRef cg As Single, ByRef cb As Single, ByRef co As Single) As Long
Dim p As Single
    ' HSL is misschien iets beter
    p = 8 * Atn(1)
    cr = 255 * (1 + 1.45 * Cos((0 / 3 - r + 0.35) * p)) 'de 1+2.25x bedenk ik even ter plekke
    cg = 255 * (1 + 1.45 * Cos((1 / 3 - r + 0.35) * p))
    cb = 255 * (1 + 1.45 * Cos((2 / 3 - r + 0.35) * p))

    co = (0 + 0.55 * Sin(r * 6 * p))
    If co > 0 Then co = co ^ 8

    If cr < 0 Then cr = 0
    If cg < 0 Then cg = 0
    If cb < 0 Then cb = 0
    If co < 0 Then co = 0 Else If co > 1 Then co = 1
End Function

Private Function GetClr(r As Single, ByRef opac As Single) As Long
Dim cr As Single
Dim cg As Single
Dim cb As Single
    GetRGB r, cr, cg, cb, opac
    GetClr = RGB(cr, cg, cb)
End Function

'------------------------------------------------

Private Sub ClearArray()
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim v As Integer
    ' redim werkt sneller... maar array is klein genoeg
    For x = 0 To MaxX
    For y = 0 To MaxY
    For z = 0 To MaxZ
    For v = 0 To 4
        Room(x, y, z, v) = 0
    Next v, z, y, x
    
    MinDruk = 10000000
    MaxDruk = 0
End Sub

Private Function getPunt(px As Integer, py As Integer, pz As Integer, ByRef x As Single, ByRef y As Single, ByRef z As Single) As Boolean
Dim inRoom As Boolean
Dim persp As Single
    'px= x*0.900 - y*0.307 + z*0.000
    'py= x*0.111 + y*0.275 - z*1.000
    
    'px.min= 0*0.900 -40*0.307+25*0.000 = -12.28
    'px.max=60*0.900 - 0*0.307+25*0.000 = +54.00
    
    'py.min= 0*0.111 + 0*0.275-25*1.000 = -25.00
    'py.max=60*0.111 +40*0.275- 0*1.000 = +17.66
    
    'dus:
    'px= x*9.00 - y*3.07  + 125
    'py= x*1.11 + y*2.75 - z*10 + 250
    ' Range (x1,y1)-(x2,y2) = ( 2.55, 10)-( 665, 426.6)
    
    'pz=x+y*2.5
    'pz.max=60+40*2.5=160
    
    'even wat meer perspectief
    
    y = (pz * 9 - px + 125) / (3.07 + 2.5 * 9)
    x = pz - y * 2.5
    z = (x * 1.11 + y * 2.75 + 250 - py) / 10
    
        'Even een Empirisch Verdwijnpunt
        'persp = (160 + 900 - pz) / 900#
        'x = x * persp
        'y = y * persp
        'z = z * persp
    
    inRoom = True
    If (x < 0) Or (x >= MaxX) Then inRoom = False
    If (y < 0) Or (y >= MaxY) Then inRoom = False
    If (z < 0) Or (z >= MaxZ) Then inRoom = False
    
    getPunt = inRoom
End Function

Private Function GetPuntClr(x As Single, y As Single, z As Single, ByRef cr As Single, ByRef cg As Single, ByRef cb As Single, ByRef co As Single)
    ' Bicubic interpolatie is mooier
Dim x0 As Single
Dim x1 As Single
Dim y0 As Single
Dim y1 As Single
Dim z0 As Single
Dim z1 As Single

    If 1 = 2 Then
        cr = Room(x, y, z, vClrR)
        cg = Room(x, y, z, vClrG)
        cb = Room(x, y, z, vClrB)
        co = Room(x, y, z, vOpac)
    Else ' toch maar en Tri-Cubic proberen dan :)
    
        If Int(x) = MaxX Then x = MaxX - 0.00001
        If Int(y) = MaxY Then y = MaxY - 0.00001
        If Int(z) = MaxZ Then z = MaxZ - 0.00001
    
        x1 = x - Int(x): x0 = 1 - x1
        y1 = y - Int(y): y0 = 1 - y1
        z1 = z - Int(z): z0 = 1 - z1
        
        x = Int(x)
        y = Int(y)
        z = Int(z)
        
    
        cr = _
            z0 * ((Room(x, y + 0, z + 0, vClrR) * x0 + Room(x + 1, y + 0, z + 0, vClrR) * x1) * y0 _
                + (Room(x, y + 1, z + 0, vClrR) * x0 + Room(x + 1, y + 1, z + 0, vClrR) * x1) * y1) _
            + _
            z1 * ((Room(x, y + 0, z + 1, vClrR) * x0 + Room(x + 1, y + 0, z + 1, vClrR) * x1) * y0 _
                + (Room(x, y + 1, z + 1, vClrR) * x0 + Room(x + 1, y + 1, z + 1, vClrR) * x1) * y1)
            
        cg = _
            z0 * ((Room(x, y + 0, z + 0, vClrG) * x0 + Room(x + 1, y + 0, z + 0, vClrG) * x1) * y0 _
                + (Room(x, y + 1, z + 0, vClrG) * x0 + Room(x + 1, y + 1, z + 0, vClrG) * x1) * y1) _
            + _
            z1 * ((Room(x, y + 0, z + 1, vClrG) * x0 + Room(x + 1, y + 0, z + 1, vClrG) * x1) * y0 _
                + (Room(x, y + 1, z + 1, vClrG) * x0 + Room(x + 1, y + 1, z + 1, vClrG) * x1) * y1)
            
        cb = _
            z0 * ((Room(x, y + 0, z + 0, vClrB) * x0 + Room(x + 1, y + 0, z + 0, vClrB) * x1) * y0 _
                + (Room(x, y + 1, z + 0, vClrB) * x0 + Room(x + 1, y + 1, z + 0, vClrB) * x1) * y1) _
            + _
            z1 * ((Room(x, y + 0, z + 1, vClrB) * x0 + Room(x + 1, y + 0, z + 1, vClrB) * x1) * y0 _
                + (Room(x, y + 1, z + 1, vClrB) * x0 + Room(x + 1, y + 1, z + 1, vClrB) * x1) * y1)
            
        co = _
            z0 * ((Room(x, y + 0, z + 0, vOpac) * x0 + Room(x + 1, y + 0, z + 0, vOpac) * x1) * y0 _
                + (Room(x, y + 1, z + 0, vOpac) * x0 + Room(x + 1, y + 1, z + 0, vOpac) * x1) * y1) _
            + _
            z1 * ((Room(x, y + 0, z + 1, vOpac) * x0 + Room(x + 1, y + 0, z + 1, vOpac) * x1) * y0 _
                + (Room(x, y + 1, z + 1, vOpac) * x0 + Room(x + 1, y + 1, z + 1, vOpac) * x1) * y1)
        
    End If
End Function

Private Sub ShowRoom()
Dim i As Integer
Dim j As Integer
Dim k As Integer

Dim cr As Single
Dim cg As Single
Dim cb As Single
Dim co As Single

Dim Tcr As Single
Dim Tcg As Single
Dim Tcb As Single
Dim Tco As Single

Dim x As Single
Dim y As Single
Dim z As Single

Dim T As Single

    T = Timer

    For i = 0 To Pic.ScaleWidth - 1
        If (Timer - T) > 1 Then DoEvents: T = Timer
    For j = 0 To Pic.ScaleHeight - 1
        Tcr = 0
        Tcg = 0
        Tcb = 0
        Tco = 0
        For k = 0 To 160 'Step 7
            If getPunt(i, j, k, x, y, z) Then
                GetPuntClr x, y, z, cr, cg, cb, co
                If co > 0.0001 Then
                    Tcr = Tcr * (1 - co) + cr * co
                    Tcg = Tcg * (1 - co) + cg * co
                    Tcb = Tcb * (1 - co) + cb * co
                End If
            End If
        Next k
        Pic.PSet (i, j), RGB(Tcr, Tcg, Tcb)
    Next j, i
End Sub

Private Sub SetBorders()
Dim x As Integer
Dim y As Integer
Dim z As Integer

    
    For x = 0 To MaxX
        Room(x, 0, 0, vClrR) = 255
        Room(x, 0, 0, vClrG) = 255
        Room(x, 0, 0, vClrB) = 255
        Room(x, 0, 0, vOpac) = 1
        
        Room(x, 0, MaxZ, vClrR) = 255
        Room(x, 0, MaxZ, vClrG) = 255
        Room(x, 0, MaxZ, vClrB) = 255
        Room(x, 0, MaxZ, vOpac) = 1
        
        Room(x, MaxY, MaxZ, vClrR) = 255
        Room(x, MaxY, MaxZ, vClrG) = 255
        Room(x, MaxY, MaxZ, vClrB) = 255
        Room(x, MaxY, MaxZ, vOpac) = 1
        
        Room(x, MaxY, 0, vClrR) = 255
        Room(x, MaxY, 0, vClrG) = 255
        Room(x, MaxY, 0, vClrB) = 255
        Room(x, MaxY, 0, vOpac) = 1
    Next x
    
    For y = 0 To MaxY
        Room(0, y, 0, vClrR) = 255
        Room(0, y, 0, vClrG) = 255
        Room(0, y, 0, vClrB) = 255
        Room(0, y, 0, vOpac) = 1
        
        Room(0, y, MaxZ, vClrR) = 255
        Room(0, y, MaxZ, vClrG) = 255
        Room(0, y, MaxZ, vClrB) = 255
        Room(0, y, MaxZ, vOpac) = 1
        
        Room(MaxX, y, MaxZ, vClrR) = 255
        Room(MaxX, y, MaxZ, vClrG) = 255
        Room(MaxX, y, MaxZ, vClrB) = 255
        Room(MaxX, y, MaxZ, vOpac) = 1
        
        Room(MaxX, y, 0, vClrR) = 255
        Room(MaxX, y, 0, vClrG) = 255
        Room(MaxX, y, 0, vClrB) = 255
        Room(MaxX, y, 0, vOpac) = 1
    Next y
    
    For z = 0 To MaxZ
        Room(0, 0, z, vClrR) = 255
        Room(0, 0, z, vClrG) = 255
        Room(0, 0, z, vClrB) = 255
        Room(0, 0, z, vOpac) = 1
        
        Room(0, MaxY, z, vClrR) = 255
        Room(0, MaxY, z, vClrG) = 255
        Room(0, MaxY, z, vClrB) = 255
        Room(0, MaxY, z, vOpac) = 1
        
        Room(MaxX, MaxY, z, vClrR) = 255
        Room(MaxX, MaxY, z, vClrG) = 255
        Room(MaxX, MaxY, z, vClrB) = 255
        Room(MaxX, MaxY, z, vOpac) = 1
        
        Room(MaxX, 0, z, vClrR) = 255
        Room(MaxX, 0, z, vClrG) = 255
        Room(MaxX, 0, z, vClrB) = 255
        Room(MaxX, 0, z, vOpac) = 1
    Next z
End Sub

Private Sub PaintSide()
Dim x As Integer
Dim y As Integer
Dim z As Integer
        
    z = 0
    For x = 0 To MaxX
    For y = 0 To MaxY
        Room(x, y, z, vOpac) = (1 + Room(x, y, z, vOpac) * 9) / 10
    Next y, x
    
    y = 0
    For x = 0 To MaxX
    For z = 0 To MaxZ
        Room(x, y, z, vOpac) = (1 + Room(x, y, z, vOpac) * 9) / 10
    Next z, x
    
    x = 0
    For y = 0 To MaxY
    For z = 0 To MaxZ
        Room(x, y, z, vOpac) = (1 + Room(x, y, z, vOpac) * 9) / 10
    Next z, y
End Sub

Private Sub DoBounce(OrigX As Single, OrigY As Single, OrigZ As Single, Druk As Single)

Dim BounceCount As Integer

Dim BounceX As Integer
Dim BounceY As Integer
Dim BounceZ As Integer
Dim BounceDemping As Single

Dim Demping As Single

Dim x As Integer
Dim y As Integer
Dim z As Integer

Dim px As Integer
Dim py As Integer
Dim pz As Integer

Dim dx As Single
Dim dy As Single
Dim dz As Single

Dim r2 As Single

Dim LocalDruk As Single

    BounceCount = 0 ' Reflecteer aantal
    Demping = 0.4   ' Drukgolf word voor 60% geabsorbeerd
    
    For BounceX = -BounceCount To BounceCount ' Reflectie
    For BounceY = -BounceCount To BounceCount
    For BounceZ = -BounceCount To BounceCount
        BounceDemping = Demping ^ (Abs(BounceX) + Abs(BounceY) + Abs(BounceZ))
        
        'Scan ruimte
        
        For x = 0 To MaxX
            px = x + BounceX * MaxX
            dx = px - OrigX
        For y = 0 To MaxY
            py = y + BounceY * MaxY
            dy = py - OrigY
        For z = 0 To MaxZ
            pz = z + BounceZ * MaxZ
            dz = pz - OrigZ
            
            r2 = dx * dx + dy * dy + dz * dz '+ 10
            r2 = r2 ^ 0.333
            LocalDruk = BounceDemping * Druk * r2
            ' is hier eigenlijk een richtingsvector nodig?
            Room(x, y, z, vDruk) = Room(x, y, z, vDruk) + LocalDruk
            
            If Room(x, y, z, vDruk) > MaxDruk Then
                MaxDruk = Room(x, y, z, vDruk)
            ElseIf Room(x, y, z, vDruk) < MinDruk Then
                MinDruk = Room(x, y, z, vDruk)
            End If
        Next z, y, x
        
    Next BounceZ, BounceY, BounceX
End Sub

Private Sub Druk2Color()
Dim x As Integer
Dim y As Integer
Dim z As Integer

Dim cr As Single
Dim cg As Single
Dim cb As Single
Dim co As Single

        For x = 0 To MaxX
        For y = 0 To MaxY
        For z = 0 To MaxZ
            GetRGB (Room(x, y, z, vDruk) - MinDruk) / (MaxDruk - MinDruk), cr, cg, cb, co
            
            Room(x, y, z, vClrR) = cr
            Room(x, y, z, vClrG) = cg
            Room(x, y, z, vClrB) = cb
            Room(x, y, z, vOpac) = co
        Next z, y, x
End Sub
'------------------------------------------------

Private Sub Command1_Click()
' Test routine voor kleurgebruik
Dim i As Integer
Dim w As Integer
Dim co As Single
    w = Pic.ScaleWidth - 1
    For i = 0 To w
        'Kleuren laten zien
        Pic.Line (i, 0)-(i, Pic.ScaleHeight / 2), GetClr(i / w, co)
        ' doorzichtigheid laten zien
        co = co * 255
        Pic.Line (i, Pic.ScaleHeight / 2)-(i, Pic.ScaleHeight), RGB(co, co, co)
    Next
End Sub


Private Sub Command2_Click()
' Test routine voor kamer
Dim x As Integer
Dim y As Integer
Dim z As Integer

Dim p As Single
    ClearArray
    
    'Teken de wanden in een kleur
    
    z = 0
    For x = 0 To MaxX
    For y = 0 To MaxY
        p = (((x \ 10) + (y \ 10) + 1) Mod 2) / 4# + 0.1
        Room(x, y, z, vClrR) = 255 * x / MaxX
        Room(x, y, z, vClrG) = 255 * y / MaxY
        Room(x, y, z, vClrB) = 255 * p
        Room(x, y, z, vOpac) = 1
    Next y, x
    
    y = 0
    For x = 0 To MaxX
    For z = 0 To MaxZ
        p = (((x \ 10) + (z \ 10) + 1) Mod 2) / 4# + 0.1
        Room(x, y, z, vClrR) = 255 * x / MaxX
        Room(x, y, z, vClrG) = 255 * p
        Room(x, y, z, vClrB) = 255 * z / MaxZ
        Room(x, y, z, vOpac) = 1
    Next z, x
    
    x = 0
    For y = 0 To MaxY
    For z = 0 To MaxZ
        p = (((y \ 10) + (z \ 10) + 1) Mod 2) / 4# + 0.1
        Room(x, y, z, vClrR) = 255 * p
        Room(x, y, z, vClrG) = 255 * y / MaxY
        Room(x, y, z, vClrB) = 255 * z / MaxZ
        Room(x, y, z, vOpac) = 1
    Next z, y

    SetBorders
    ShowRoom
       
End Sub

Private Sub Command3_Click()
    ClearArray
    
    DoBounce 20, 15, 5, 200
    DoBounce 55, 5, 20, 10
    
    Druk2Color
    
    SetBorders
    PaintSide
    ShowRoom
End Sub

'------------------------------------------------

Private Sub Form_Load()
    Pic.ScaleMode = 3     ' In pixels
    Pic.AutoRedraw = True 'Tekening wel laten staan als er een ander window overheen valt
    
    Command1.Caption = "KleurTest"
    Command2.Caption = "Kamer"
    Command3.Caption = "DrukGolf"
End Sub

[Verwijderd]

hehe zit me net te bedenken dat de wandbotsing (dat bounce gedoe) helemaal geen spiegeling kent, oeps

dit zou het op moeten lossen:

code:

...
Dim BLocX As Integer ' Bounce virtual Location..ofzoiets
Dim BLocY As Integer
Dim BLocZ As Integer
Dim mirX As Boolean
Dim mirY As Boolean
Dim MirZ As Boolean


    BounceCount = 1 ' Reflecteer aantal
    Demping = 0.4   ' Drukgolf word voor 60% geabsorbeerd
    
    'BLoc-patch zorgt dat de positioes gespiegeld worden bij oneven aantal botsingen
    
    For BounceX = -BounceCount To BounceCount ' Reflectie
        mirX = (((BounceX + BounceCount) Mod 2) = 0)
    For BounceY = -BounceCount To BounceCount
        mirY = (((BounceY + BounceCount) Mod 2) = 0)
    For BounceZ = -BounceCount To BounceCount
        MirZ = (((BounceZ + BounceCount) Mod 2) = 0)
        BounceDemping = Demping ^ (Abs(BounceX) + Abs(BounceY) + Abs(BounceZ))
        
        'Scan ruimte
        For x = 0 To MaxX
            If mirX Then BLocX = MaxX - x Else BLocX = x
            px = x + BounceX * MaxX
            dx = px - OrigX
        For y = 0 To MaxY
            If mirY Then BLocY = MaxY - y Else BLocY = y
            py = y + BounceY * MaxY
            dy = py - OrigY
        For z = 0 To MaxZ
            If MirZ Then BLocZ = MaxZ - z Else BLocZ = z
            pz = z + BounceZ * MaxZ
            dz = pz - OrigZ
            
            r2 = dx * dx + dy * dy + dz * dz '+ 10
            r2 = r2 ^ 0.333
            LocalDruk = BounceDemping * Druk * r2
            ' is hier eigenlijk een richtingsvector nodig?
            Room(BLocX, BLocY, BLocZ, vDruk) = Room(BLocX, BLocY, BLocZ, vDruk) + LocalDruk
            
            If Room(BLocX, BLocY, BLocZ, vDruk) > MaxDruk Then
                MaxDruk = Room(BLocX, BLocY, BLocZ, vDruk)
            ElseIf Room(BLocX, BLocY, BLocZ, vDruk) < MinDruk Then
                MinDruk = Room(BLocX, BLocY, BLocZ, vDruk)
            End If
...

Dat Ziet er dus nog steeds niet uit... 'kgeef op

[Sponge]

Ziet er wel leuk uit.. (ik zou het niet kunnen qua wiskunde ) ik denk dat vooral de 3dimensionale array het traag maakt, overigen kan je voor loops beter een long gebruiken. En misschien is SetPixel ook nog een idee

[Verwijderd]

Wiskunde stelt geen ruk voor, als je wat aanstipt, dan leg ik het je zo uit...

Als iemand mij even kan uitleggen hoe ik dit soort dingen sneller maak .. directX enzo dan zou ik wel heel tevreden zijn (en zonder veel overbodige rotooi)