Fractal Mountain

Share your advanced PureBasic knowledge/code with the community.
Post Reply
Thomas
Enthusiast
Enthusiast
Posts: 112
Joined: Sat Apr 26, 2003 8:45 pm

Fractal Mountain

Post by Thomas »

Code updated For 5.20+

Code: Select all

; Fractal Mountain  -  Ported from GFA-Basic Amiga
width = GetSystemMetrics_(0)
height = GetSystemMetrics_(1)
Map = height / 4
; Declare Triangle(x1,y1,x2,y2,x3,y3,col)
Procedure Triangle(x1.l,y1.l,x2.l,y2.l,x3.l,y3.l,col.l)
  Dim Array.Point(2)
  Array(0)\x = x1
  Array(0)\y = y1
  Array(1)\x = x2
  Array(1)\y = y2
  Array(2)\x = x3
  Array(2)\y = y3
  FrontColor(col)
  Polygon_(hdc,@Array(),3)
  SetPolyFillMode_(hdc,#ALTERNATE)
EndProcedure
Declare getshade()
Define .f
Global Dim lv(Map + 32,Map + 32)
Global hdc.l
max = 1.0
OpenWindow(0,0,0,width,height,"",#PB_Window_BorderLess)
hdc = StartDrawing(WindowOutput(0))
Box(0,0,width,height)
Dim a.l(32)
For i.l = 0 To 15
  a(i) = RGB(i * 16 + 15,(i * 16 + 15) / 1.6,(i * 16 + 15) / 3.3)
  a(i + 16) = RGB(i * 16 + 15,i * 16 + 15,i * 16 + 15)
Next
a(16) = RGB(0,64,128)
maxlv = 0
For iter.l = 6 To 1 Step -1
  sk = Pow(2,iter)
  hl.l = sk / 2
  y.l = 0
  While y <= Map
    x.l = hl
    While x <= Map
      ran.f = (Random(1000) / 1000 - 0.5) * max * sk
      old = (lv(x - hl,y) + lv(x + hl,y)) / 2
      lv(x,y) = old + ran
      x = x + sk
    Wend
    y = y + sk
  Wend
  x = 0
  While x <= Map
    y = hl
    While y <= Map
      ran = (Random(1000) / 1000 - 0.5) * max * sk
      old = (lv(x,y - hl) + lv(x,y + hl)) / 2
      lv(x,y) = old + ran
      y = y + sk
    Wend
    x = x + sk
  Wend
  x = hl
  While x <= Map
    y = hl
    While y <= Map
      ran = (Random(1000) / 1000 - 0.5) * max * sk
      old1 = (lv(x + hl,y - hl) + lv(x - hl,y + hl)) / 2
      old2 = (lv(x - hl,y - hl) + lv(x + hl,y + hl)) / 2
      old = (old1 + old2) / 2
      lv(x,y) = old + ran
      If lv(x,y) > maxlv 
        maxlv = lv(x,y)
      EndIf
      y = y + sk
    Wend
    x = x + sk
  Wend
Next
snowline = maxlv - maxlv / 4
xm = (width / height) * 3
ym = 3
xshift = 1
yp = 100
For x = 0 To Map
  If lv(x,0) < 0
    lv(x,0) = 0
  EndIf
Next
For y = 0 To Map - 1
  If lv(0,y) < 0
    lv(0,y) = 0
  EndIf
  For x = 0 To Map - 1
    If lv (x + 1,y + 1) < 0
      lv(x + 1,y + 1) = 0
    EndIf
    lv = lv(x,y) + lv(x + 1,y) + lv(x,y + 1)
    lv = (lv + lv(x + 1,y + 1)) / 4
    a.l = x
    b.l = y
    rx1 = xm * a + xshift * b
    ry1 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade1.l = shade
    a = x + 1
    rx2 = xm * a + xshift * b
    ry2 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade2.l = shade
    a = x
    b = y + 1
    rx3 = xm * a + xshift * b
    ry3 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade3.l = shade
    a = x + 1
    rx4 = xm * a + xshift * b
    ry4 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade4.l = shade
    af = x + 0.5
    bf = y + 0.5
    rx = xm * af + xshift * bf
    ry = ym * bf + yp
    a = x
    b = y
    ry = ry - lv
    Triangle(rx,ry,rx1,ry1,rx2,ry2,a(shade1))
    Triangle(rx,ry,rx2,ry2,rx4,ry4,a(shade2))
    Triangle(rx,ry,rx1,ry1,rx3,ry3,a(shade3))
    Triangle(rx,ry,rx3,ry3,rx4,ry4,a(shade4))
  Next
Next
StopDrawing()
Repeat
  WindowEvent()
Until GetAsyncKeyState_(27)
End

getshade:
c.l = x + 1 - (b - y)
d.l = y + (a - x)
xc = x + 0.5
yc = y + 0.5
xrun1 = xc - a
xrun2 = xc - c
yrun1 = yc - b
yrun2 = yc - d
rise1 = lv - lv(a, b)
rise2 = lv - lv(c, d)
yrise = Abs(rise1 * xrun2 - rise2 * xrun1)
yrun = Abs(yrun1 * xrun2 - xrun1 * yrun2)
If yrun = yrise
  yrun = 1
  yrise = 1
EndIf
xrise = Abs(rise1 * yrun2 - rise2 * yrun1)
xrun = Abs(xrun1 * yrun2 - yrun1 * xrun2)
If xrun = xrise
  xrun = 1
  xrise = 1
EndIf
xrise = xrise / 2
yrise = yrise / 2
xshade = 1 - Abs(xrise / (xrun + xrise))
yshade = 1 - Abs(yrise / (yrun + yrise))
shade = 14 * xshade * yshade + 1
If lv > snowline
  shade = shade + 16
EndIf
If lv < = 0
  shade = 16
EndIf
Return
Last edited by Thomas on Wed Feb 22, 2006 9:15 am, edited 2 times in total.
Top
User avatar
Joakim Christiansen
Addict
Addict
Posts: 2452
Joined: Wed Dec 22, 2004 4:12 pm
Location: Norway
Contact:
Contact Joakim Christiansen

Post by Joakim Christiansen »

I get array index out of bound at line 29... (using PB4 here)
Top
va!n
Addict
Addict
Posts: 1104
Joined: Wed Apr 20, 2005 12:48 pm

Post by va!n »

nice one!
btw. works fine here with v4 beta3
va!n aka Thorsten

Intel i7-980X Extreme Edition, 12 GB DDR3, Radeon 5870 2GB, Windows7 x64,
Top
Fred
Administrator
Administrator
Posts: 18252
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:
Contact Fred

Post by Fred »

Nice one ! To avoid refresh problem, you can use an image and an imagegadget() (or a windowedscreen).
Top
Dare2
Moderator
Moderator
Posts: 3321
Joined: Sat Dec 27, 2003 3:55 am
Location: Great Southern Land

Post by Dare2 »

Very nice!
@}--`--,-- A rose by any other name ..
Top
User avatar
Joakim Christiansen
Addict
Addict
Posts: 2452
Joined: Wed Dec 22, 2004 4:12 pm
Location: Norway
Contact:
Contact Joakim Christiansen

Post by Joakim Christiansen »

It works now...
Top
Thomas
Enthusiast
Enthusiast
Posts: 112
Joined: Sat Apr 26, 2003 8:45 pm

Fractal Mountain

Post by Thomas »

Code updated For 5.20+

Here the high-res version with massive mountain sites. Press Space for a new picture or Esc to quit.

Code: Select all

; Fractal Mountain  -  Ported from GFA-Basic Amiga
width = GetSystemMetrics_(0)
height = GetSystemMetrics_(1)
Map = height / 0.75
; Declare Triangle(x1,y1,x2,y2,x3,y3,col)
Procedure Triangle(x1.l,y1.l,x2.l,y2.l,x3.l,y3.l,col.l)
  Dim Array.Point(2)
  Array(0)\x = x1
  Array(0)\y = y1
  Array(1)\x = x2
  Array(1)\y = y2
  Array(2)\x = x3
  Array(2)\y = y3
  FrontColor(col)
  Polygon_(hdc,@Array(),3)
  SetPolyFillMode_(hdc,#ALTERNATE)
EndProcedure
Declare getshade()
Define .f
Global Dim lv(Map + 256,Map + 256)
Global hdc.l
max = 1.0
OpenWindow(0,0,0,width,height,"",#PB_Window_BorderLess)
Dim a.l(32)
For i.l = 0 To 15
  a(i) = RGB(i * 16 + 15,(i * 16 + 15) / 1.6,(i * 16 + 15) / 3.3)
  a(i + 16) = RGB(i * 16 + 15,i * 16 + 15,i * 16 + 15)
Next
a(16) = RGB(0,32,64)
start:
hdc = StartDrawing(WindowOutput(0))
Box(0,0,width,height)
maxlv = 0
For iter.l = 9 To 1 Step -1
  sk = Pow(2,iter)
  hl.l = sk / 2
  y.l = 0
  While y <= Map
    x.l = hl
    While x <= Map
      ran.f = (Random(1000) / 1000 - 0.5) * max * sk
      old = (lv(x - hl,y) + lv(x + hl,y)) / 2
      lv(x,y) = old + ran
      x = x + sk
    Wend
    y = y + sk
  Wend
  x = 0
  While x <= Map
    y = hl
    While y <= Map
      ran = (Random(1000) / 1000 - 0.5) * max * sk
      old = (lv(x,y - hl) + lv(x,y + hl)) / 2
      lv(x,y) = old + ran
      y = y + sk
    Wend
    x = x + sk
  Wend
  x = hl
  While x <= Map
    y = hl
    While y <= Map
      ran = (Random(1000) / 1000 - 0.5) * max * sk
      old1 = (lv(x + hl,y - hl) + lv(x - hl,y + hl)) / 2
      old2 = (lv(x - hl,y - hl) + lv(x + hl,y + hl)) / 2
      old = (old1 + old2) / 2
      lv(x,y) = old + ran
      If lv(x,y) > maxlv 
        maxlv = lv(x,y)
      EndIf
      y = y + sk
    Wend
    x = x + sk
  Wend
Next
snowline = maxlv - maxlv / 2
xm = width / height
ym = 1
xshift = 0
yp = 150
For y = 0 To 74
  Line(0,y,width,0,RGB(y+75,100-y,150-y))
Next
For y = 75 To 149
  Line(0,y,width,0,RGB(y+75,y-50,150-y))
Next
For x = 0 To Map
  If lv(x,0) < 0
    lv(x,0) = 0
  EndIf
Next
For y = 0 To Map - 1
  If lv(0,y) < 0
    lv(0,y) = 0
  EndIf
  For x = 0 To Map - 1
    If lv (x + 1,y + 1) < 0
      lv(x + 1,y + 1) = 0
    EndIf
    lv = lv(x,y) + lv(x + 1,y) + lv(x,y + 1)
    lv = (lv + lv(x + 1,y + 1)) / 4
    a.l = x
    b.l = y
    rx1 = xm * a + xshift * b
    ry1 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade1.l = shade
    a = x + 1
    rx2 = xm * a + xshift * b
    ry2 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade2.l = shade
    a = x
    b = y + 1
    rx3 = xm * a + xshift * b
    ry3 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade3.l = shade
    a = x + 1
    rx4 = xm * a + xshift * b
    ry4 = ym * b + yp - lv(a,b) * ym
    Gosub getshade
    shade4.l = shade
    af = x + 0.5
    bf = y + 0.5
    rx = xm * af + xshift * bf
    ry = ym * bf + yp
    a = x
    b = y
    ry = ry - lv
    Triangle(rx,ry,rx1,ry1,rx2,ry2,a(shade1))
    Triangle(rx,ry,rx2,ry2,rx4,ry4,a(shade2))
    Triangle(rx,ry,rx1,ry1,rx3,ry3,a(shade3))
    Triangle(rx,ry,rx3,ry3,rx4,ry4,a(shade4))
  Next
Next
StopDrawing()
Repeat
  WindowEvent()
  If GetAsyncKeyState_(27)
    End
  EndIf
Until GetAsyncKeyState_(32)
Goto start

getshade:
c.l = x + 1 - (b - y)
d.l = y + (a - x)
xc = x + 0.5
yc = y + 0.5
xrun1 = xc - a
xrun2 = xc - c
yrun1 = yc - b
yrun2 = yc - d
rise1 = lv - lv(a, b)
rise2 = lv - lv(c, d)
yrise = Abs(rise1 * xrun2 - rise2 * xrun1)
yrun = Abs(yrun1 * xrun2 - xrun1 * yrun2)
If yrun = yrise
  yrun = 1
  yrise = 1
EndIf
xrise = Abs(rise1 * yrun2 - rise2 * yrun1)
xrun = Abs(xrun1 * yrun2 - yrun1 * xrun2)
If xrun = xrise
  xrun = 1
  xrise = 1
EndIf
xrise = xrise / 2
yrise = yrise / 2
xshade = 1 - Abs(xrise / (xrun + xrise))
yshade = 1 - Abs(yrise / (yrun + yrise))
shade = 14 * xshade * yshade + 1
If lv > snowline
  shade = shade + 16
EndIf
If lv < = 0
  shade = 16
EndIf
Return
Top
Post Reply

Return to “Tricks 'n' Tips”