Mandelbrot Orbits - Printable Version

Code: (Select All)
_Title "Mandelbrot Orbits" ' dcromley

Option _Explicit

DefLng I

Screen _NewImage(1024, 768, 256)



Const xlo = -2.4, xhi = .8, ylo = -1.2, yhi = 1.2

Dim Shared imx, imy, imDn, imClk, imEnd, iImgSave

Dim mx, my



doCreate ' create the image

iImgSave = _CopyImage(0) ' save

Do ' wait for mouse input

  _Limit 30

  MouseCk

  uv2xy imx, imy, mx, my

  Color 15, 8

  Locate 2, 3: Print "mx,my:  ";: Print Using "##.##,##.##"; mx; my

  Locate , 3: Print "Black:  Mandelbrot set (remains local)"

  Locate , 3: Print "Gray:   Not Mandelbrot (goes to infinity)"

  Locate , 3: Print "Yellow: Not Mandelbrot (almost remains local)"

  Locate , 3: Print "Press left button to get orbit"

  Locate , 3: Print "ESC to exit"

  If imClk Then doOrbit ' upon Click, show orbit

  If InKey$ = Chr$(27) Then System

Loop



Sub doCreate () ' draw mandelbrot set

  Dim i, iu, iv, x0, y0, x, y, xx, yy, ic

  For iv = 0 To 766 ' screen horiz

    For iu = 0 To 1023 ' screen vert

      uv2xy iu, iv, x0, y0 ' get x0,y0

      x = 0: y = 0 ' start at 0, 0

      For i = 0 To 1000 ' 1000 max iterations

        xx = x * x - y * y + x0 ' (x, y) squared + (x0, y0)

        yy = 2 * x * y + y0

        If xx * xx + yy * yy > 4 Then Exit For ' not in set

        x = xx: y = yy ' for next iteration

      Next i

      ic = 8 ' not in set

      If i > 20 Then ic = 14 ' yellow, almost in set

      If i = 1001 Then ic = 0 ' black, in set

      PSet (iu, iv), ic

    Next iu

  Next iv

End Sub



Sub doOrbit () ' show orbit

  Dim i, x0, y0, x, y, xx, yy, iu, iv

  PSet (imx, imy), 15 ' orbit start

  uv2xy imx, imy, x0, y0 ' get x0,y0

  x = 0: y = 0 ' start at 0, 0

  For i = 0 To 1000 ' 1000 max iterations

    _Limit 30

    MouseCk

    If imEnd Then GoTo zreset

    xx = x * x - y * y + x0 ' (x, y) squared + (x0, y0)

    yy = 2 * x * y + y0

    xy2uv xx, yy, iu, iv

    Line -(iu, iv), 15

    If xx * xx + yy * yy > 50 Then Exit For ' not in set

    x = xx: y = yy ' for next iteration

  Next i

  Do: _Limit 30: MouseCk: Loop Until imEnd

  zreset:

  _PutImage , iImgSave, 0 ' reset

End Sub



Sub uv2xy (iu, iv, x, y) ' screen u, v to world x, y

  x = lerplh(xlo, xhi, iu, 0, 1023)

  y = lerplh(ylo, yhi, iv, 766, 0)

End Sub



Sub xy2uv (x, y, iu, iv) ' world x, y to screen u, v

  iu = lerplh(0, 1023, x, xlo, xhi)

  iv = lerplh(766, 0, y, ylo, yhi)

End Sub



Function lerplh (xlo, xhi, y, ylo, yhi) ' linear interpolation

  Dim k01: k01 = (y - ylo) / (yhi - ylo) ' get k01

  lerplh = xlo * (1 - k01) + xhi * k01

End Function



Sub MouseCk () ' Mouse routine

  Static imPrev ' previous time Down?

  imClk = 0: imEnd = 0 ' down, up edges

  Do While _MouseInput: Loop ' clear

  imx = _MouseX: imy = _MouseY: imDn = _MouseButton(1) ' now

  If imDn Then

    If Not imPrev Then imClk = -1 ' down edge

  Else

    If imPrev Then imEnd = -1 ' up edge

  End If

  imPrev = imDn ' for next time

End Sub