Aika jännä funktio, mutta esimerkin kuvat oli auttamatta huonot. Teinpä esimerkin jossa funktiota käytetään korkeuskarttojen värittämisessä.
Code: Select all
SCREEN Int((2^8)*3),Int((2^8)*3)
Dim taulu(0, 0) As Float
taulukoko# = 256.0
boxsize = 4
cslide = Colorslideimage("10;0,0,30 0,0,80 0,80,150 0,115,255 252,248,82 80,230,30 50,157,13 35,100,03 80,114,20 111,84,57 73,67,65 120,124,122 166,164,164 255,255,255")
SetWindow "Korkeuskartan luonti, piirto ja väritys- ohjelma. Paina Enteriä luodaksesi uuden korkeuskartan."
Repeat
If KeyDown(cbkeyreturn) Then
ds2(Rnd(70.0),Rnd(70.0),Rnd(70.0),Rnd(70.0), 8, 255.0, 0.60)
If img Then DeleteImage img : img = 0
Img = MakeImage(int(taulukoko#),int(taulukoko#))
DrawToImage img
For y = 0 To Int(taulukoko#)
For x = 0 To Int(taulukoko#)
c = Min(Max(taulu(x, y),0),255)
Color c,c,c
Dot x,y
Next x
Next y
DrawToScreen
tempimg = PaintImage(img,cslide)
If img Then DeleteImage img : img = 0
img = tempimg
img = scaleimage(tempimg,ScreenWidth(),ScreenHeight())
EndIf
If img Then DrawImage img,0,0
DrawScreen
Until KeyHit(cbkeyexit)
//DiamondSquare3d by m1c
Function ds2(s1#, s2#, s3#, s4#, it, roughness#, multiplier#)
side = 2 ^ it //koko höskän sivun pituus
ReDim taulu(side, side) //muutetaan taulun koko (ja tyhjennetään)
taulu(0, 0) = s1# //asetetaan nurkat
taulu(side, 0) = s2#
taulu(0, side) = s3#
taulu(side, side) = s4#
block = side //osan koko joka prosessoidaan
For i = 1 To it
y = 0
While(y < side)
x = 0
While(x < side)
//TIMANGI
taulu(x + block / 2, y + block / 2) = (taulu(x, y) + taulu(x, y + block) + taulu(x + block, y) + taulu(x + block, y + block)) / 4
//NELIÖ
taulu(x + block / 2, y) = (taulu(x, y) + (y - block / 2 >= 0) * taulu(x + block / 2, Int(Max(0, y - block / 2))) + taulu(x + block, y) + taulu(x + block / 2, y + block / 2)) / (3 + (y - block / 2 >= 0)) + Rnd(-roughness#, roughness#)
taulu(x + block, y + block / 2) = (taulu(x + block / 2, y + block / 2) + taulu(x + block, y) + (x + 1.5 * block <= side) * taulu(Int(Min(side, x + 1.5 * block)), y + block / 2) + taulu(x + block, y + block)) / (3 + (x + 1.5 * block <= side)) + Rnd(-roughness#, roughness#)
taulu(x + block / 2, y + block) = (taulu(x, y + block) + taulu(x + block / 2, y + block / 2) + taulu(x + block, y + block) + (y + 1.5 * block <= side) * taulu(x + block / 2, Int(Min(side, y + 1.5 * block)))) / (3 + (y + 1.5 * block <= side)) + Rnd(-roughness#, roughness#)
taulu(x, y + block / 2) = ((x - block / 2 >= 0) * taulu(Int(Max(0, x - block / 2)), y + block / 2) + taulu(x, y) + taulu(x + block / 2, y + block / 2) + taulu(x, y + block)) / (3 + (x - block / 2 >= 0)) + Rnd(-roughness#, roughness#)
x = x + block //siirrytään osasen verran äksällä
Wend
y = y + block //siirrytään osasen verran yyllä
Wend
roughness# = roughness# * multiplier# //vähennetään terävyyttä iteraation mukaan
block = block / 2 //osa on puolet edellisen iteraation vastaavasta
Next i
Return 1 //miks ei voi olla palauttamatta mitää? :(
End Function
Function ScaleImage(_image, _width, _height)
gScaledImage = MakeImage(_width, _height)
_image_width = ImageWidth(_image)
_image_height= ImageHeight(_image)
// Tehdään temppikuva johon skaalataan ensin vain leveys
lTempImage = MakeImage(_width, ImageHeight(_image))
DrawToImage lTempImage
For x = 0 To _width - 1
sx# = Float(_image_width) / Float(_width) * Float(x)
DrawImageBox _image, x, 0, sx, 0, 1, _image_height, OFF,OFF
Next x
lTempImage_width = ImageWidth(lTempImage)
DrawToScreen
// Skaalataan myös pystysuunnassa
DrawToImage gScaledImage
For y = 0 To _height - 1
sy# = Float(_image_height) / Float(_height) * Float(y)
DrawImageBox lTempImage, 0, y, 0, sy, lTempImage_width, 1, OFF,OFF
Next y
DrawToScreen
DeleteImage lTempImage
DeleteImage _image
Return gScaledImage
End Function
Function PaintImage(image1,image2)
iw# = ImageWidth(image1)
ih# = ImageHeight(image1)
iw2# = ImageWidth(image2)
img = MakeImage(Int(iw),Int(ih))
Lock Image(image1)
DrawToImage img
For i = 0 To iw-1
For j = 0 To ih-1
PickImageColor2 image1,i,j
keskiarvo# = Float(getRGB(1) + getRGB(2) + getRGB(3))/3.0
DrawImageBox image2,i,j,Int(( Float(iw2-1)*keskiarvo#)/255.0),0,1,1
Next j
Next i
DrawToScreen
Unlock Image(image1)
Return img
EndFunction
Function ColorslideImage(dat$="10;255,255,255 0,0,0")
dotspercolor#=Float(GetWord(dat$,1,";"))
colors = Int(CountWords(dat$))
IMG = MakeImage(int((colors-1)*dotspercolor),1)
DrawToImage img
colordat$ = GetWord(GetWord(dat$,2,";"),(i+1)," ")
r# = Float(GetWord(colordat$,1,","))
g# = Float(GetWord(colordat$,2,","))
b# = Float(GetWord(colordat$,3,","))
For i=0 To colors-2
nextcolordat$ = GetWord(GetWord(dat$,2,";"),(i+2)," ")
newr# = Float(GetWord(nextcolordat$,1,","))
newg# = Float(GetWord(nextcolordat$,2,","))
newb# = Float(GetWord(nextcolordat$,3,","))
For o=0 To Int(dotspercolor)-1
cr = Int(r#*(dotspercolor#-1.0-Float(o))/dotspercolor#+newr#*Float(o)/dotspercolor)
cg = Int(g#*(dotspercolor#-1.0-Float(o))/dotspercolor#+newg#*Float(o)/dotspercolor)
cb = Int(b#*(dotspercolor#-1.0-Float(o))/dotspercolor#+newb#*Float(o)/dotspercolor)
Color cr,cg,cb
Dot o+i*dotspercolor,0
Next o
colordat$ = nextcolordat$
r# = newr#
g# = newg#
b# = newb#
Next i
DrawToScreen
Return img
End Function
Vuoristojen juurilla on ehkä vähän huono väritys, mutta en oikein löytänyt sopivaa sävyä.