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ä.
Tuollahan voidaan päällystää esimerkiksi räjähdykset tai tulen, kun olet tehnyt ensin pohjan sen jälkeen päällystät sen väriliu'ulla. (musta->tummanpunainen->punainen->oranssi->keltainen->vaalean keltainen ja valkoinen)