Seminar Simulation stochastischer Modelle

5. Zwei Dimensionen in Realbasic

Ähnlich dem R Programm, aber mit Querschnittanzeige und etwas Farbe. Allerdings wird für die Gauss Normalverteilung nur eine einfache Näherung verwendet.

Quellcode in R

Window1.Recalc:
Protected Sub Recalc()
  dim p as Picture
  dim r as RGBSurface
  dim c as color
  dim n,i,j,x,y as integer
  dim g as Graphics
  dim f(500,500) as integer
  dim ff(500) as integer
  dim factor as Double
  dim m,e,px,py as Double
  
  p=NewPicture(500,500,32)
  g=p.Graphics
  g.ForeColor=rgb(0,0,0)
  g.FillRect 0,0,g.Width,g.Height
  
  pberg=p
  pschnitt=nil
  
  r=p.RGBSurface
  f(500,500)=0
  
  j=val(iAnzahl.text)
  for n=1 to j
    px=250
    py=250
    for x=0 to 499
      
      m=rnd*3.14*2
      e=rnd*rnd*10
      
      px=px+sin(m)*e
      py=py+cos(m)*e
      
      try
        f(px,py)=f(px,py)+1
      catch ex as OutOfBoundsException
        'ignore
      end Try
    next
  next
  
  
  for y=0 to 499
    for x=0 to 499
      i=f(x,y)
      if i>ff(x) then
        ff(x)=i
      end if
    next
  next
  
  j=0
  for x=10 to 499
    i=ff(x)
    if i>j then
      j=i
    end if
  next
  
  factor=255.0/j
  
  for y=0 to 499
    for x=0 to 499
      i=f(x,y)*factor
      if i>10 then
        n=255
      else
        n=0
      end if
      if i>100 then
        j=255
      else
        j=0
      end if
      r.Pixel(x,y)=rgb(i,j,n)
    next
  next
  
End Sub

Window1.Schneiden:
Protected Sub Schneiden()
  dim p as Picture
  dim r as RGBSurface
  dim c as color
  dim n,i,j,x,y as integer
  dim g as Graphics
  dim f(500,500) as integer
  
  p=NewPicture(500,500,32)
  g=p.Graphics
  g.ForeColor=rgb(0,0,0)
  g.FillRect 0,0,g.Width,g.Height
  
  pschnitt=p
  r=pberg.RGBSurface
  
  g.ForeColor=rgb(255,255,255)
  for y=0 to 499
    c=r.Pixel(selection,y)
    
    g.drawline y,250,y,250-c.red*2
  next
  
  g.ForeColor=rgb(255,255,255)
  for y=0 to 499
    c=r.Pixel(y,selection)
    
    g.drawline y,500,y,500-c.red*2
  next
  
End Sub

Window1.KeyDown:
Function KeyDown(Key As String) As Boolean
  if asc(key)=32 then
    Recalc
    Refresh
    Return true
  end if
End Function

Window1.Open:
Sub Open()
  Selection=-1
  left=12
  Recalc
End Sub

Window1.Berg.MouseDown:
Function MouseDown(X As Integer, Y As Integer) As Boolean
  selection=x
  Schneiden
  Schnitt.Graphics.DrawPicture pschnitt,0,0
End Function

Window1.Berg.Paint:
Sub Paint(g As Graphics)
  g.DrawPicture pberg,0,0
End Sub

Window1.Schnitt.Paint:
Sub Paint(g As Graphics)
  g.DrawPicture pschnitt,0,0
End Sub

Window1.iAnzahl.KeyDown:
Function KeyDown(Key As String) As Boolean
  if asc(key)=13 then
    Recalc
    Refresh
  end if
End Function

Downloads

Brown2D.rb.sit (8 KB)
Brown2D.rb.zip (8 KB)
Brown2D.sit (812 KB)
Brown2D.exe.zip (640 KB)
(Linux wäre technisch möglich, aber ein Tester fehlt.)

Screenshot

Links
MBS REAL studio Chart Plugins - Nachhilfe in Andernach