Efektit
Re: Efektit
Kyllä jo pelkästään "Wait 1" lisääminen silmukkaan tiputtaa sen prosessorin käyttöasteen pois sieltä sadasta prosentista. Se voisi olla ihan järkevä ratkaisu, jos ei halua prosessorin tuulettimen alkavan huutamaan näytönsäästäjän takia.
cbEnchanted, uudelleenkirjoitettu runtime. Uusin versio: 0.4.1 — Nyt myös sorsat GitHubissa!
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com
Efektit
Pientä palikkaposauttelua...
Hiirtä klikkaamalla posauttaa.
Välilyönti = Värillisyys, pois\päälle
Q = Sarjaposauttelu (ilman klikkailua)
W = Drawscreen On\Off
E = Pause
R = Reset
Code: Select all
SCREEN 1000,1000
Type tahti
Field x
Field y
Field size
Field xx //X nopeus
Field yy //Y nopeus
Field vari
Field vari2
Field vari3
EndType
co = 1
Repeat
If KeyHit(16) Then //Jatkuva pommitus päälle\pois
If meno = 1 Then
meno = 0
Else
meno = 1
EndIf
EndIf
If KeyHit(57) Then
If co = 1 Then
co = 0
Else
co = 1
EndIf
EndIf
If meno = 1 Then
For i = 0 To 20
star.tahti = New(tahti)
star\x = MouseX()
star\y = MouseY()
Randomize Timer()
star\size = Rand(1,5)
star\xx = Rand(-5,5)
star\yy = Rand(-5,5)
star\vari = Rand(0,360)
star\vari2 = Rand(0,360)
star\vari3 = Rand(0,360)
Next i
EndIf
If MouseHit(1) Then
For i = 0 To 20
star.tahti = New(tahti)
star\x = MouseX()
star\y = MouseY()
star\size = Rand(1,5)
star\xx = Rand(-5,5)
star\yy = Rand(-5,5)
If star\xx = 0 And star\yy = 0 Then
star\xx = Rand(-5,5)
star\yy = Rand(-5,5)
EndIf
star\vari = Rand(0,360)
star\vari2 = Rand(0,360)
star\vari3 = Rand(0,360)
Next i
EndIf
For star.tahti = Each tahti
If co = 1 Then
Color star\vari,star\vari2,star\vari3
Else
Color cbwhite
EndIf
Box star\x,star\y,star\size,star\size
If stop = 0 Then
star\x = star\x-star\xx
star\y = star\y-star\yy
EndIf
If star\x < 0 Or star\y < 0 Or star\x > 1000 Or star\y > 1000 Then
Delete star.tahti
EndIf
Next star
If KeyHit(17) Then
If of = 1 Then
of = 0
Else
of = 1
EndIf
EndIf
If of = 1 Then
DrawScreen OFF
Else
DrawScreen
EndIf
If KeyHit(18) Then
If stop = 1 Then
stop = 0
Else
stop = 1
EndIf
EndIf
If KeyHit(19) Then
For star.tahti = Each tahti
Delete star.tahti
Next star
EndIf
Forever
Välilyönti = Värillisyys, pois\päälle
Q = Sarjaposauttelu (ilman klikkailua)
W = Drawscreen On\Off
E = Pause
R = Reset
SpaceCraft on kokopitkä peli! Nyt ladattavissa! Tsekkaa!
Re: Efektit
Tämmöne nuotio tuli tuos lauantaina koodattua..
Code: Select all
Type Flame
Field Flame_Life As Float
Field Flame_LifeRedu As Float
Field Flame_X As Float
Field Flame_Y As Float
Field Flame_Size As Float
Field Flame_Angle As Float
Field Flame_AnglePlus As Float
EndType
Const SW = 200 : Const SH = 320
SCREEN SW, SH
Dim palette(3, 100) As Float
Gosub sub_paletti
Repeat
For i = 0 To 50
liekki.FLAME = New(FLAME)
liekki\Flame_Life = 1.0
dist# = Rnd(-1, 1)
liekki\Flame_LifeRedu = Rnd(0.025, 0.10)*0.875+Abs(dist#)/8 * 0.25
liekki\Flame_X = SW/2 + dist# * 30
liekki\Flame_Y = SH
liekki\Flame_Size = Rand(2, 10)
liekki\Flame_Angle = Rand(0, 120)
liekki\Flame_AnglePlus = Rnd(-1, 1)
Next i
For liekki.FLAME = Each FLAME
liekki\Flame_Life = liekki\Flame_Life - liekki\Flame_LifeRedu
liekki\Flame_X = liekki\Flame_X + Cos(liekki\Flame_Angle*(1/liekki\Flame_Life)*2) * 1.5
liekki\Flame_Y = liekki\Flame_Y - 5
liekki\Flame_Angle = liekki\Flame_Angle + liekki\Flame_AnglePlus * 10 * (0.10 / liekki\Flame_LifeRedu) * 0.25
If liekki\Flame_Life =< 0 Then Delete liekki
Next liekki
Gosub sub_render
Forever
sub_render:
Lock SCREEN()
For liekki.FLAME = Each FLAME
Color palette(RED, Int(liekki\Flame_Life*100)), palette(GREEN, Int(liekki\Flame_Life*100)), palette(BLUE, Int(liekki\Flame_Life*100))
TriFill(liekki\Flame_X+Cos(liekki\Flame_Angle)*liekki\Flame_Size , liekki\Flame_Y-Sin(liekki\Flame_Angle)*liekki\Flame_Size, liekki\Flame_X+Cos(liekki\Flame_Angle+120)*5, liekki\Flame_Y-Sin(liekki\Flame_Angle+120)*5, liekki\Flame_X+Cos(liekki\Flame_Angle+240)*liekki\Flame_Size, liekki\Flame_Y-Sin(liekki\Flame_Angle+240)*5)
Next liekki
Unlock SCREEN()
DrawScreen Not MouseDown(2)
Return
sub_paletti:
For i = 0 To 33
palette(RED, i) = (164.0/33.0*Float(i))
palette(GREEN, i) = (32.0/33.0*Float(i))
palette(BLUE, i) = 0
Next i
For i = 0 To 33
palette(RED, 33 + i) = 164 + (32.0/33.0*Float(i))
palette(GREEN, 33 + i) = 32 + (128.0/33.0*Float(i))
palette(BLUE, 33 + i) = (32/33.0*Float(i))
Next i
For i = 0 To 34
palette(RED, 66 + i) = 196.0 + (59.0 / 34.0 * Float(i))
palette(GREEN, 66 + i) = 160.0 + (95.0 / 34.0 * Float(i))
palette(BLUE, 66 + i) = 32.0 + (223.0 / 34.0 * Float(i))
Next i
Return
Function TriFill(x1,y1,x2,y2,x3,y3)
If y2<y1 Then
tmp=y1
y1=y2
y2=tmp
tmp=x1
x1=x2
x2=tmp
EndIf
If y3<y1 Then
tmp=y1
y1=y3
y3=tmp
tmp=x1
x1=x3
x3=tmp
EndIf
If y3<y2 Then
tmp=y2
y2=y3
y3=tmp
tmp=x2
x2=x3
x3=tmp
EndIf
dy1=y2-y1
dx1=x2-x1
dy2=y3-y1
dx2=x3-x1
If dy1 Then
For i = y1 To y2
ax=x1+((i-y1)*dx1)/dy1
bx=x1+((i-y1)*dx2)/dy2
Line ax,i,bx,i
Next i
EndIf
dy1=y3-y2
dx1=x3-x2
If dy1 Then
For i = y2 To y3
ax=x2+((i-y2)*dx1)/dy1
bx=x1+((i-y1)*dx2)/dy2
Line ax,i,bx,i
Next i
EndIf
End Function
Solar Eclipse
We're in a simulation, and God is trying to debug us.
Re: Efektit
Yksinkertanen mutta komia voi jospa CB jaksais tuollasii pyörittää vaikka jonki pelin taustalla pätkimättä... voih.MaGetzUb wrote:Tämmöne nuotio tuli tuos lauantaina koodattua..
cbEnchanted, uudelleenkirjoitettu runtime. Uusin versio: 0.4.1 — Nyt myös sorsat GitHubissa!
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com
-
- Devoted Member
- Posts: 594
- Joined: Tue Sep 30, 2008 4:30 pm
- Location: Ruudun toisella puolella
Re: Efektit
Teinpäs taas pitkästä aikaa jotain efektin tapaista, tämä ei kyllä mitenkään erikoinen ole.
Kyseessä siis 3d-tunneli, jossa piirrän viivoja vektorien välille.
Kommentoimaton koodi:
Q ja A muuttavat zoomausta (testaussyistä jätin zoomin muuttamisen, parhaus saavutetaan kun zoom= jotain 5 ja 10 väliltä)
W ja S muuttavat nopeutta (tosin, ohjelmassa on 2 nopeusmuuttujaa, koska tämä muutettava säätää myös viivojen pituutta, enkä halua liikkeen pysähtyvän)
Kyseessä siis 3d-tunneli, jossa piirrän viivoja vektorien välille.
Kommentoimaton koodi:
Code: Select all
sw=800
sh=600
'SCREEN sw*2,sh*2,0,1
SCREEN sw,sh,0,1
Const DENS=20
Type CIR
Field x As Float
Field y As Float
Field z As Float
Field s As Float
Field m
EndType
Type DOTD
Field x As Float
Field y As Float
Field z As Float
Field r As Float
Field g As Float
Field b As Float
Field rr As Float
Field gg As Float
Field bb As Float
Field cir
Field raide
EndType
siz#=1000
x#=Cos(matka)*512
y#=Sin(matka+90)*512
ro.CIR=New(CIR)
ro\x=x
ro\y=y
ro\z=256
ro\s=siz
ro\m=matka
Gosub circ
c=255
r#=0
g#=0
b#=0
tint#=0
spe#=0.5
spe2#=1
zoom#=1
zoom2=5
dist=270
Repeat
zoom=CurveValue(zoom2,zoom,20)
siz=1200++Cos(matka/3)*1000
x#=Cos(matka)*512
y#=Sin(matka+(45+Cos(matka)*45))*512
ox#=Cos(matka+dist)*(siz/1000*32)
oy#=Sin(matka+(45+Cos(matka+dist)*45)+dist)*(siz/1000*32)
r=1.5+Cos(matka/10)*1.5
g=1+Cos(matka/10+90)
b=0.5+Cos(matka/10+180)*0.5
tint=CurveValue(1,tint,20)
spe=spe+(KeyHit(17)-KeyHit(31))*0.1
spe=Max(0,spe)
zoom2=zoom2+(KeyHit(16)-KeyHit(30))
matka=matka+spe+spe2
For ro.CIR=Each CIR
If ro\m<matka-6 Then
ro1.CIR=New(CIR)
ro1\x=x
ro1\y=y
ro1\z=256
ro1\s=siz
ro1\m=matka
Gosub circ
Delete ro
EndIf
Next ro
Lock
For d.DOTD=Each DOTD
dx#=sw/2+(d\x/(d\z/zoom))
dy#=sh/2+(d\y/(d\z/zoom))
If d\raide=1 Then
dx2#=sw/2+(d\x/((d\z+d\raide*8)/zoom))
dy2#=sh/2+(d\y/((d\z+d\raide*8)/zoom))
Else
dx2#=sw/2+(d\x/((d\z+Max(0.1,spe)*5)/zoom))
dy2#=sh/2+(d\y/((d\z+Max(0.1,spe)*5)/zoom))
EndIf
d\z=d\z-spe-spe2
d\r=Min(1,(Max(0,(5120-d\z*20))/5120)*d\rr)
d\g=Min(1,(Max(0,(5120-d\z*20))/5120)*d\gg)
d\b=Min(1,(Max(0,(5120-d\z*20))/5120)*d\bb)
Color c*d\r*tint,c*d\g*tint,c*d\b*tint
If d\cir Mod 3 =0 Then
Line dx+ox,dy+oy,dx2+ox,dy2+oy
EndIf
'Line dx+ox,dy+oy,dx2+ox,dy2+oy
If d<> First(DOTD) Then
'Line dx,dy,dxx,dyy
EndIf
If d\z<(1+spe*2) Then Delete d
dxx=dx
dyy=dy
Next d
Unlock
l=0
Color 1,1,1
Box 0,sh-100,200,100,1
Color 255*tint,255*tint,255*tint
Box -1,sh-100,201,101,0
Text 5,sh-99+12*l,"spe: "+spe
l+1
Text 5,sh-99+12*l,"zoom: "+zoom2
l+1
Text 5,sh-99+12*l,"Distance: "+matka
l+1
Text 5,sh-99+12*l,"pieces: "+piece
l+1
Text 5,sh-99+12*l,"size: "+siz
l+1
Text 5,sh-99+12*l,"R: "+Int(r*128)
l+1
Text 5,sh-99+12*l,"G: "+Int(g*128)
l+1
Text 5,sh-99+12*l,"B: "+Int(b*128)
DrawScreen
Forever
circ:
For i=-30 To 210 Step DENS
Gosub dott
d\cir=piece+1
Next i
piece+1
i=260
Gosub dott
d\raide=1
i=280
Gosub dott
d\raide=1
i=258
Gosub dott
d\raide=1
i=282
Gosub dott
d\raide=1
Return
dott:
d.DOTD=New(DOTD)
d\x=ro\x-Cos(i)*ro\s-10
d\y=ro\y-Sin(i)*ro\s
d\z=ro\z
d\rr=r
d\gg=g
d\bb=b
Return
W ja S muuttavat nopeutta (tosin, ohjelmassa on 2 nopeusmuuttujaa, koska tämä muutettava säätää myös viivojen pituutta, enkä halua liikkeen pysähtyvän)
Re: Efektit
MaGetzUb kun kyseli äskön ditheröinnistä (noinkohan taipuu?) niin päätin tehdä CB:lle tänne efekteihin yhden version siitä. Käytetty paletti on MaGetzUbin myöskin. Koodia ei ole mitenkään optimoitu vaan se on toteutettu aikalailla yksinkertaisesti tätä hyödyntäen. Optimoinnin puuteesta ja CB:n pikselioperaatioiden hitaudesta johtuen, ei kannata ihmetellä jos 1024x768 kokoisen kuvan muokkaus kestää minuutin. Kannattaa sitten vaihtaa koodin lopussa ladattava kuva toiseen sillä tuo CB:n median map.bmp kuva ei ole kovin hyvä esimerkki. Muutamalla ensimäisellä rivillä olevaa palettia muuttamalla saa erilaisen lopputuloksen...
Code: Select all
Const MAX_COLORS = 63
Dim col(MAX_COLORS) As Integer
col($00) = $7F7F7F : col($10) = $C7C7C7 : col($20) = $FFFFFF : col($30) = $FFFFFF
col($01) = $003DA5 : col($11) = $0077FF : col($21) = $0FD7FF : col($31) = $A5FCFF
col($02) = $0012AF : col($12) = $2054FF : col($22) = $68A2FF : col($32) = $B3ECFF
col($03) = $430095 : col($13) = $8136FA : col($23) = $D47FFF : col($33) = $DAABEB
col($04) = $A1005D : col($14) = $EB2fB4 : col($24) = $FF44F3 : col($34) = $FFA7F9
col($05) = $C70027 : col($15) = $FF294F : col($25) = $FF608B : col($35) = $FFABB3
col($06) = $BA0500 : col($16) = $FF2100 : col($26) = $FF8732 : col($36) = $FFD2AF
col($07) = $8B1600 : col($17) = $D53100 : col($27) = $FF9B12 : col($37) = $FFEFA5
col($08) = $5B2F00 : col($18) = $C36100 : col($28) = $FABB20 : col($38) = $FFF79B
col($09) = $0F4400 : col($19) = $357f00 : col($29) = $9EE30D : col($39) = $D7E894
col($0A) = $054900 : col($1A) = $058E00 : col($2A) = $2AF035 : col($3A) = $A5EDAE
col($0B) = $00472D : col($1B) = $008954 : col($2B) = $0CF0A3 : col($3B) = $A2F2DA
col($0C) = $004065 : col($1C) = $002B39 : col($2C) = $05FBFF : col($3C) = $98FFFC
col($0D) = $000000 : col($1D) = $202020 : col($2D) = $5D5D5D : col($3D) = $DDDDDD
col($0E) = $050505 : col($1E) = $090909 : col($2E) = $0C0C0C : col($3E) = $111111
col($0F) = $000000 : col($1F) = $090909 : col($2F) = $0C0C0C : col($3F) = $111111
Function Halftone(r,g,b)
afterdist = (255*255*3+1)
cr1 = r //((colorin Shl 8) Shr 24)
cg1 = g //((colorin Shl 16) Shr 24)
cb1 = b //((colorin Shl 24) Shr 24)
For i = 0 To MAX_COLORS
cr2 = ((col(i) Shl 8) Shr 24)
cg2 = ((col(i) Shl 16) Shr 24)
cb2 = ((col(i) Shl 24) Shr 24)
distr = (cr1 - cr2)(cr1 - cr2)
distg = (cg1 - cg2)(cg1 - cg2)
distb = (cb1 - cb2)(cb1 - cb2)
dist = distr + distg + distb
If dist < afterdist Then chosencol = i : afterdist = dist
Next i
Return chosencol
EndFunction
Function Dithering(img)
Lock Image(img)
For y = 0 To ImageHeight(img)-1
Lock SCREEN()
For x = 0 To ImageWidth(img)-1
PickImageColor2 img,x,y
oldR = getRGB(RED)
oldG = getRGB(GREEN)
oldB = getRGB(BLUE)
newPixelIndex = Halftone(oldR,oldG,oldB)
newPixel = col(newPixelIndex)
newR = ((newPixel Shl 8) Shr 24)
newG = ((newPixel Shl 16) Shr 24)
newB = ((newPixel Shl 24) Shr 24)
qerR = oldR - newR
qerG = oldG - newG
qerB = oldB - newB
PutPixel2 x,y,newPixel,Image(img)
PutPixel2 x,y,newPixel,SCREEN()
If x < ImageWidth(img)-1 Then
PickImageColor2 img,x+1,y
r = getRGB(RED) + 7.0/16.0 * qerR
g = getRGB(GREEN) + 7.0/16.0 * qerG
b = getRGB(BLUE) + 7.0/16.0 * qerB
r = Max(0,Min(r,255))
g = Max(0,Min(g,255))
b = Max(0,Min(b,255))
PutPixel2 x+1,y,b + (g Shl 8) + (r Shl 16),Image(img)
EndIf
If x > 0 And y < ImageHeight(img)-1 Then
PickImageColor2 img,x-1,y+1
r = getRGB(RED) + 3.0/16.0 * qerR
g = getRGB(GREEN) + 3.0/16.0 * qerG
b = getRGB(BLUE) + 3.0/16.0 * qerB
r = Max(0,Min(r,255))
g = Max(0,Min(g,255))
b = Max(0,Min(b,255))
PutPixel2 x-1,y+1,b + (g Shl 8) + (r Shl 16),Image(img)
EndIf
If y < ImageHeight(img)-1 Then
PickImageColor2 img,x,y+1
r = getRGB(RED) + 5.0/16.0 * qerR
g = getRGB(GREEN) + 5.0/16.0 * qerG
b = getRGB(BLUE) + 5.0/16.0 * qerB
r = Max(0,Min(r,255))
g = Max(0,Min(g,255))
b = Max(0,Min(b,255))
PutPixel2 x,y+1,b + (g Shl 8) + (r Shl 16),Image(img)
EndIf
If (y < ImageHeight(img)-1) And (x < ImageWidth(img)-1) Then
PickImageColor2 img,x+1,y+1
r = getRGB(RED) + 1.0/16.0 * qerR
g = getRGB(GREEN) + 1.0/16.0 * qerG
b = getRGB(BLUE) + 1.0/16.0 * qerB
r = Max(0,Min(r,255))
g = Max(0,Min(g,255))
b = Max(0,Min(b,255))
PutPixel2 x+1,y+1,b + (g Shl 8) + (r Shl 16),Image(img)
EndIf
Next x
Unlock SCREEN()
DrawScreen OFF
Next y
Unlock Image(img)
Return img
EndFunction
SCREEN 1366,768
img = LoadImage("Media\map.bmp")
DrawImage img,0,0
img = Dithering(img)
AddText "Dithered"
Repeat
DrawImage img,0,0
DrawScreen
Until KeyHit(28)
Last edited by Latexi95 on Mon Nov 07, 2011 7:45 pm, edited 2 times in total.
-
- Moderator
- Posts: 1583
- Joined: Mon Aug 27, 2007 11:24 pm
- Location: Otaniemi - Mikkeli -pendelöinti
Re: Efektit
Itse tein joskus jonkun hienon artikkelin pohjalta tällaisen, joka vain muuttaa kuvan värien bittimäärää pienemmäksi. Ei sitten vissiin tullut koskaan julkaistua :v
Code: Select all
kuva$ = "media/map.bmp"
img = LoadImage(kuva)
SCREEN ImageWidth(img), ImageHeight(img)
img = LoadImage(kuva)
DrawImage img, 0, 0
ds# = 3
ds = 256.0/(2^(ds-1)-1)
For x = 1 To ImageWidth (img)-2
Lock SCREEN()
For y = 1 To ImageHeight(img)-2
col% = GetPixel2(x, y)
r# = col Shl 8 Shr 24
g# = col Shl 16 Shr 24
b# = col Shl 24 Shr 24
re# = r: ge# = g: be# = b
r = Int(r/ds)*ds
g = Int(g/ds)*ds
b = Int(b/ds)*ds
re# - r: ge# - g: be# - b
col = GetPixel2(x, Min(ImageHeight(img), y+1))
PutPixel2 x , y+1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*7/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*7/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*7/16.0)))
If x<ImageWidth(img)-1 Then
col = GetPixel2(x+1, Max(y-1, 0))
PutPixel2 x+1, y-1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*3/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*3/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*3/16.0)))
col = GetPixel2(x+1, y)
PutPixel2 x+1, y , Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*5/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*5/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*5/16.0)))
col = GetPixel2(x+1, Min(ImageHeight(img), y+1))
PutPixel2 x+1, y+1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re /16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge /16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be /16.0)))
EndIf
PutPixel2 x, y, Int(Max(0, Min(255, r))) Shl 16 + int(Max(0, Min(255, g))) Shl 8 + Int(Max(0, Min(255, b)))
Next y
Unlock
DrawScreen OFF
Next x
WaitKey
Re: Efektit
Aika vastaavat nuo meidän koodit oli. Samaa algorithmiäkin käytimme. Sinun koodisi on kuitenkin varsin paljon nopeampi. Onkohan GetPixel2 paljonkin PickImageColor2 + getRGB yhdistelmää nopeampi tai sitten ero tulee paletin läpikäymisestä.koodaaja wrote:Itse tein joskus jonkun hienon artikkelin pohjalta tällaisen, joka vain muuttaa kuvan värien bittimäärää pienemmäksi. Ei sitten vissiin tullut koskaan julkaistua :v
Code: Select all
kuva$ = "media/map.bmp" img = LoadImage(kuva) SCREEN ImageWidth(img), ImageHeight(img) img = LoadImage(kuva) DrawImage img, 0, 0 ds# = 3 ds = 256.0/(2^(ds-1)-1) For x = 1 To ImageWidth (img)-2 Lock SCREEN() For y = 1 To ImageHeight(img)-2 col% = GetPixel2(x, y) r# = col Shl 8 Shr 24 g# = col Shl 16 Shr 24 b# = col Shl 24 Shr 24 re# = r: ge# = g: be# = b r = Int(r/ds)*ds g = Int(g/ds)*ds b = Int(b/ds)*ds re# - r: ge# - g: be# - b col = GetPixel2(x, Min(ImageHeight(img), y+1)) PutPixel2 x , y+1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*7/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*7/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*7/16.0))) If x<ImageWidth(img)-1 Then col = GetPixel2(x+1, Max(y-1, 0)) PutPixel2 x+1, y-1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*3/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*3/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*3/16.0))) col = GetPixel2(x+1, y) PutPixel2 x+1, y , Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re*5/16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge*5/16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be*5/16.0))) col = GetPixel2(x+1, Min(ImageHeight(img), y+1)) PutPixel2 x+1, y+1, Int(Min(255, Max(0, ((col Shl 8) Shr 24)+re /16.0))) Shl 16 + Int(Min(255, Max(0, ((col Shl 16) Shr 24)+ge /16.0))) Shl 8 + Int(Min(255, Max(0, ((col Shl 24) Shr 24)+be /16.0))) EndIf PutPixel2 x, y, Int(Max(0, Min(255, r))) Shl 16 + int(Max(0, Min(255, g))) Shl 8 + Int(Max(0, Min(255, b))) Next y Unlock DrawScreen OFF Next x WaitKey
Korjasin yhden virheen tuossa koodissani ja muutin sen näyttämään etenemistään Koodaajan koodin tapaan.
Re: Efektit
En tiedä sopiiko mutta tälläinen teksti "eripuolelle" efekti
Code: Select all
SCREEN 250,175,0,cbsizable
Repeat
x = Rand(0,250)
y = Rand (0,175)
Text x,y,"Troll"
DrawScreen
Until EscapeKey ()
¤ Art
Re: Efektit
Code: Select all
Repeat
For i = 1 To 10
x = Rand(0,500)
y = Rand (0,350)
Circle x,y,10
Next i
DrawScreen
Until EscapeKey ()
¤ Art
Re: Efektit
Tämä on Esimerkit ja tutoriaalit -alue. Ideana on se, että joku saattaa oppia näistä esimerkeistä jotain hyödyllistä. En usko tuosta olevan kauheasti hyötyä kenellekään, tosin ei tuosta varmaan kauhean suurta haittaakaan ole.Art wrote:En tiedä sopiiko mutta tälläinen teksti "eripuolelle" efektiCode: Select all
SCREEN 250,175,0,cbsizable Repeat x = Rand(0,250) y = Rand (0,175) Text x,y,"Troll" DrawScreen Until EscapeKey ()
Tuon muuten olisi voinut tehdä myös näin:
Code: Select all
'jätän turhan screenin pois, koska se ei tee mitään relevanttia hyödyllistä, mutta hidastaa ohjelman käynnistämistä ja pidentää koodia
Repeat
Text Rand(400), Rand(300), "Troll"
DrawScreen
Forever 'koska safeexit on automaattisesti päällä, forever toimii ihan yhtä hyvin kuin Until EscapeKey():kin.
Re: Efektit
Aiwan kyllä mä vielä opin , oon kirjottanu cb 4 päivää ..Tuon muuten olisi voinut tehdä myös näin:Code: Select all
'jätän turhan screenin pois, koska se ei tee mitään relevanttia hyödyllistä, mutta hidastaa ohjelman käynnistämistä ja pidentää koodia Repeat Text Rand(400), Rand(300), "Troll" DrawScreen Forever 'koska safeexit on automaattisesti päällä, forever toimii ihan yhtä hyvin kuin Until EscapeKey():kin.
¤ Art
Re: Efektit
Katso tuon koodin alapuolella oleva koodi oli ns . korjausChaosworm wrote:Tämä on Esimerkit ja tutoriaalit -alue. Ideana on se, että joku saattaa oppia näistä esimerkeistä jotain hyödyllistä. En usko tuosta olevan kauheasti hyötyä kenellekään, tosin ei tuosta varmaan kauhean suurta haittaakaan ole.Art wrote:En tiedä sopiiko mutta tälläinen teksti "eripuolelle" efektiCode: Select all
SCREEN 250,175,0,cbsizable Repeat x = Rand(0,250) y = Rand (0,175) Text x,y,"Troll" DrawScreen Until EscapeKey ()
¤ Art
-
- Advanced Member
- Posts: 308
- Joined: Tue Nov 25, 2008 8:06 pm
- Contact:
Re: Efektit
Vinkki: Kannattaa käyttää sitä muokkaa-nappulaa niin ei tule tulplaposteja.
a.k.a. Gehock
Re: Efektit
juu =)Herra Siili wrote:Vinkki: Kannattaa käyttää sitä muokkaa-nappulaa niin ei tule tulplaposteja.
¤ Art
Re: Efektit
Päätinpä kokeilla koodaamista pitkästä aikaa ja tein tämmöisen pienen savueffektin. Toimintaperiaate on erittäin yksinkertainen ja olen kommentoinut koodissani mitä milläkin rivillä oikein haetaan takaa. Efektin laatua voi muutella helposti koodin alussa olevien vakioiden avulla. Kokeilkaa siis eri arvoja ja kommentoikaa! Olisin oikein mielissäni jos saisin kuulla mielipiteitä varsinkin kun olen koodannut viimeks 1,5 vuotta sitten!
Code: Select all
//////////////////////////////////
////// VAKIOIDEN MÄÄRITYS //////
//////////////////////////////////
Const QUALITY = 5 // Efektin laatu, mitä pienempi sitä parempi
Const SMOOTHNESS = 30 // Partikkeleiden liikkumisen pehmeys x-akselin suunnassa
Const RADIUS = 80 // Partikkeleiden "menosuunnan" maksimietäisyys määrittely hetken pisteestä
Const MAXSPEED = 5.2 // Partikkelin maksiminopeus y-akselin suunnassa
Const MINSPEED = 0.3 // Partikkelin miniminopeus y-akselin suunnassa
Const THICKNESS = 4 // Yksittäisen partikkelin paksuus
Const PERCLICK = 10 // Partikkeleiden luontimäärä per kierros (hiirtä painettaessa)
Const CLICKRADIUS = 3
Const BLUR = 1 // Sumennus PÄÄLLÄ = 1
Const BLURRADIUS = 4 // Sumennuksen vaikutusalue
Const BLURSTRENGTH = 0.2 // Sumennuksen voimakkuus
// ArrayWidth, varattavan taulukon leveys
// ArrayHeight, varattavan taulukon korkeus
// TempX & TempY ovat väliaikaismuuttujia koodin optimointia varten
Dim ArrayWidth As Integer, ArrayHeight As Integer, TempX As Integer, TempY As Integer, TempColor As Float
ArrayWidth = RoundUp(ScreenWidth() / QUALITY)
ArrayHeight = RoundUp(ScreenHeight() / QUALITY)
// Varataan taulukko johon säilötään kaikkien partikkeleiden värien summa
// Tämän taulukon perusteella hoidetaan partikkeleiden piirtäminen!
Dim DrawParticles(ArrayWidth, ArrayHeight) As Float
// Luodaan partikkeleiden tyyppikokoelma
Type PARTICLES
Field x As Float // x-koodinaatti
Field y As Float // y-koordinaatti
Field TargetX As Float // Piste, mitä kohti partikkeli hakeutuu
EndType
Repeat
SetWindow "" + FPS()
// Venytetään väritaulukko, jolloin päästään eroon vanhoista arvoista
ReDim DrawParticles(ScreenWidth() / QUALITY, ScreenHeight() / Quality)
// Partikkeleiden läpikäynti alkaa
For bit.PARTICLES = Each PARTICLES
// Jos partikkelin etäisyys hakeutumispisteestä on
// pienempi kuin 2, niin määritetään uusi haukeutumispiste
If Abs(bit\x - bit\TargetX) < 2 Then bit\TargetX = bit\x + Rand(-RADIUS, RADIUS)
// Määritetään partikkelin x-koordinaatille uusi arvo hakeutumispisteen avulla
bit\x = CurveValue(bit\TargetX, bit\x, SMOOTHNESS)
// Vähennetään y-koordinaatin arvoa [MINSPEED, MAXSPEED] verran
bit\y = bit\y - Rand(MINSPEED,MAXSPEED)
// Lasketaan x- ja y-koordinaattien sijainti taulukossa ja sijoitetaan ne muuttujiin
TempX = Int(bit\x / QUALITY)
TempY = Int(bit\y / QUALITY)
// Jos partikkeli on ruudulla, päivitetään väritaulukko
If (bit\ x > 0) And (bit\x < ScreenWidth()) And (bit\y > 0) Then
DrawParticles(TempX, TempY) = DrawParticles(TempX, TempY) + THICKNESS
// Jos pehmennys on päällä
If BLUR = 1 Then
// Muodostetaan silmukoilla pehmennyksen alue
For a = -BLURRADIUS To BLURRADIUS
For i = -BLURRADIUS To BLURRADIUS
// Tarkistetaan että koordinaatit pysyvät taulukon korkeuden ja leveyden sisällä
// Jos ehto toteutuu, lisätään väritaulukkoon väriä
// Värin määrä on riippuvainen etäisyydestä partikkeliin
If (TempY + a < 0) Or ((TempY + a) > ArrayHeight) Then Exit
If (TempX + i > 0) And ((TempX + i) < ArrayWidth) Then DrawParticles(TempX + i, TempY + a) = DrawParticles(TempX + i, TempY + a) + THICKNESS * BLURSTRENGTH * (1 - Abs(float(i * a)) / (BLURRADIUS ^ 2))
Next i
Next a
EndIf
EndIf
// Jos partikkeli on ajautunut ulos ruudun yläreunasta, poistetaan partikkeli
If (bit\y < 0) Then Delete bit
Next bit
// Partikkeleiden läpikäynti loppuu
// Väritaulukon läpikäynti alkaa
For a = 0 To ArrayHeight
For i = 0 To ArrayWidth
// Asetetaan piirtoväri taulukon perusteella ja piirretään ruudulle
// Rajoitetaan maksimiväri 155, jotta savu pysyy harmaana
If DrawParticles(i, a) > 0 Then
TempColor = Min(155, DrawParticles(i, a))
Color TempColor, TempColor, TempColor
Box i * QUALITY, a * QUALITY, QUALITY, QUALITY
EndIf
Next i
Next a
// Partikkelien luonti
If MouseDown(1) Then
For a = -CLICKRADIUS To CLICKRADIUS
For i = -CLICKRADIUS To CLICKRADIUS
For u = 1 To RoundUp(PERCLICK / (CLICKRADIUS) ^ 2)
bit.PARTICLES = New(PARTICLES)
bit\x = MouseX() + i
bit\y = MouseY() + a
bit\TargetX = bit\x
Next u
Next i
Next a
EndIf
DrawScreen
Forever
EDIT:
Optimoitu hieman paremmaksi.
Last edited by DatsuniG on Sat Jan 07, 2012 5:14 pm, edited 1 time in total.
Hengität nyt manuaalisesti.
- Kokkelkhan
- Newcomer
- Posts: 6
- Joined: Tue Mar 15, 2011 9:25 pm
- Location: Pk-seutu
Re: Efektit
Pari sini & cosini kikkailua:
Koodi on melkoista sotkua, pahoittelut...
Code: Select all
Type FORM
Field fX
Field fY
Field fID
End Type
Type STARS
Field sX
Field sY
EndType
SCREEN 1200,800,0,1
FrameLimit 30
For i=0 To 200
newStar.STARS=New(STARS)
newStar\sX=Rand(-200,ScreenWidth()+200)
newStar\sY=Rand(-200,ScreenHeight()+200)
Next i
boxes=1
Repeat
For i=0 To boxes
t_var#=t_var#+0.005
modZ=Sin(i/4+t_var+rgb3#)
modY=Cos(i/4+t_var+rgb3#)
newForm.FORM=New(FORM)
newForm\fX=ScreenWidth()-ScreenWidth()/6-i+(modZ*200)'+Rand(-1,1)
newForm\fY=ScreenHeight()/2+(modY*200)'+Rand(-1,1)
newForm\fID=1+i
Next i
If boxes<1016 Then
boxes=boxes+1
EndIf
For iForm.FORM=Each FORM
sin_var1#=sin_var1#+0.001
sin_var2#=sin_var2#+0.001
sin_var3#=sin_var3#+0.0005
rgb1#=Abs(Sin(sin_var1)*180)
rgb2#=Abs(Sin(sin_var2)*80)
Color iForm\fID/rgb3#,iForm\fID/rgb3#/2,iForm\fID/4
modX=Sin(iForm\fID/2+sin_var1)*Sin(sin_var1)*Sin(sin_var2)*Abs(Sin(sin_var3)*500-(iForm\fID/rgb3#))
modY=Cos(iForm\fID/2+sin_var2)*Cos(sin_var1)*Cos(sin_var2/2)*(Cos(sin_var3)*350-(iForm\fID/rgb3#))
Box iForm\fX+modX,iForm\fY+modY,Iform\fID/32,iForm\fID/8,1
Next iForm
star_box_size=Rand(1,2)
For iStar.STARS=Each STARS
Color cbwhite
Box iStar\sX+Sin(sin_var1)*20,iStar\sY+Cos(sin_var1)*20,star_box_size,star_box_size,1
Next iStar
fps_var=FPS()
SetWindow ""+fps_var
rgb3#=4+(Abs(Sin(sin_var3))*4)
DrawScreen 1
For iForm.FORM=Each FORM
Delete iForm
Next iForm
Forever
Code: Select all
Type FORM
Field fX
Field fY
Field fID
End Type
Type STARS
Field sX
Field sY
EndType
SCREEN 1200,800,0,1
FrameLimit 30
For i=0 To 200
newStar.STARS=New(STARS)
newStar\sX=Rand(-200,ScreenWidth()+200)
newStar\sY=Rand(-200,ScreenHeight()+200)
Next i
boxes=1
Repeat
For i=0 To boxes
t_var#=t_var#+0.005
modZ=Sin(i/4+t_var+rgb3#)
modY=Cos(i/4+t_var+rgb3#)
newForm.FORM=New(FORM)
newForm\fX=ScreenWidth()-i
newForm\fY=ScreenHeight()/2
newForm\fID=1+i
Next i
If boxes<1016 Then
boxes=boxes+1
EndIf
star_box_size=Rand(1,2)
For iStar.STARS=Each STARS
Color cbwhite
Box iStar\sX+Sin(sin_var1#)*20,iStar\sY+Cos(sin_var1#)*20,star_box_size,star_box_size,1
Next iStar
For iForm.FORM=Each FORM
sin_var1#=sin_var1#+0.001
sin_var2#=sin_var2#+0.001
sin_var3#=sin_var3#+0.0005
rgb1#=Abs(Sin(sin_var1)*180)
rgb2#=Abs(Sin(sin_var2)*80)
modX=Sin(iForm\fID/2+sin_var1)*Sin(sin_var1)*Sin(sin_var2)*Abs(Sin(sin_var3)*500-(iForm\fID/rgb3#))
modY=Cos(iForm\fID/2+sin_var2)*Cos(sin_var1)*Cos(sin_var2/2)*(Cos(sin_var3)*350-(iForm\fID/rgb3#))
If c1>Iform\fID/32 Then
Color 70+rgb1/2,60+rgb2,20+rgb1/2
Else
Color 60+rgb2,20+rgb1/2,70+rgb1
EndIf
Box iForm\fX+modX,iForm\fY+modY,Iform\fID/32,iForm\fID/32,1
If c1>Iform\fID/32 Then
Color 60+rgb2,20+rgb1/2,70+rgb1
Else
Color 70+rgb1/2,60+rgb2,20+rgb1/2
EndIf
Box iForm\fX+modX,(iForm\fY-iForm\fID/32)+modY,Iform\fID/32,iForm\fID/32,1
c1=c1+1
If c1>(Iform\fID/32*2) Then c1=0
Next iForm
fps_var=FPS()
SetWindow ""+fps_var
rgb3#=4+(Abs(Sin(sin_var3))*4)
DrawScreen 1
For iForm.FORM=Each FORM
Delete iForm
Next iForm
Forever
Päräjää...!
- Misthema
- Advanced Member
- Posts: 312
- Joined: Mon Aug 27, 2007 8:32 pm
- Location: Turku, Finland
- Contact:
Re: Efektit
Melkosen näyttävä tuo 3D-mainen mato! Ensimmäinen oli myös näyttävä, mutta en keksi siitä muuta sanottavaa koska sood2 vei ajatukseni...Kokkelkhan wrote:Pari sini & cosini kikkailua:Code: Select all
sood1
Koodi on melkoista sotkua, pahoittelut...Code: Select all
sood2
Re: Efektit
Teinpä huvikseni tällaisen todella simppelin rumahkon maastogeneraattorin
Code: Select all
SCREEN 800, 600, 32, 0
FrameLimit 60
Dim map(250, 250)
For x = 1 To 250
For y = 1 To 250
map(x,y)=50
Next y
Next x
random = 3'Rand(1,3)
For x = 1 To 250
For y = 1 To 250
l=0
u=0
r=0
d=0
lu=0
ur=0
rd=0
dl=0
val=0
If x <> 1 Then l=map(x-1,y)
If y <> 1 Then u=map(x,y-1)
If x <> 250 Then r=map(x+1,y)
If y <> 250 Then d=map(x,y+1)
If x <> 1 And y <> 1 Then lu=map(x-1,y-1)
If y <> 1 And x <> 250 Then ur=map(x+1,y-1)
If x <> 250 And y <> 250 Then rd=map(x+1,y+1)
If y <> 250 And x <> 1 Then dl=map(x-1,y+1)
val = (l + u + r + d + lu + ur + rd + dl) / 8
Select random
Case 1
map(x,y) = val + Rand(-10, 2)
Case 2
map(x,y) = val + Rand(-2, 10)
Case 3
map(x,y) = val + Rand(-10, 10)
EndSelect
If map(x,y) < 0 Then map(x,y)=0
If map(x,y) > 200 Then map(x,y)=200
Next y
Next x
random = 1
For x = 1 To 250
For y = 1 To 250
l=0
u=0
r=0
d=0
lu=0
ur=0
rd=0
dl=0
val=0
If x <> 1 Then l=map(x-1,y)
If y <> 1 Then u=map(x,y-1)
If x <> 250 Then r=map(x+1,y)
If y <> 250 Then d=map(x,y+1)
If x <> 1 And y <> 1 Then lu=map(x-1,y-1)
If y <> 1 And x <> 250 Then ur=map(x+1,y-1)
If x <> 250 And y <> 250 Then rd=map(x+1,y+1)
If y <> 250 And x <> 1 Then dl=map(x-1,y+1)
val = (l + u + r + d + lu + ur + rd + dl) / 8
Select random
Case 1
map(x,y) = val + Rand(-10, 2)
Case 2
map(x,y) = val + Rand(-2, 10)
Case 3
map(x,y) = val + Rand(-10, 10)
EndSelect
If map(x,y) < 0 Then map(x,y)=0
If map(x,y) > 200 Then map(x,y)=200
Next y
Next x
random = 2
For y = 1 To 250
For x = 1 To 250
l=0
u=0
r=0
d=0
lu=0
ur=0
rd=0
dl=0
val=0
If x <> 1 Then l=map(x-1,y)
If y <> 1 Then u=map(x,y-1)
If x <> 250 Then r=map(x+1,y)
If y <> 250 Then d=map(x,y+1)
If x <> 1 And y <> 1 Then lu=map(x-1,y-1)
If y <> 1 And x <> 250 Then ur=map(x+1,y-1)
If x <> 250 And y <> 250 Then rd=map(x+1,y+1)
If y <> 250 And x <> 1 Then dl=map(x-1,y+1)
val = (l + u + r + d + lu + ur + rd + dl) / 8
Select random
Case 1
map(x,y) = val + Rand(-10, 2)
Case 2
map(x,y) = val + Rand(-2, 10)
Case 3
map(x,y) = val + Rand(-10, 10)
EndSelect
If map(x,y) < 0 Then map(x,y)=0
If map(x,y) > 200 Then map(x,y)=200
Next x
Next y
Repeat
For x = 1 To 250
For y = 1 To 250
'Text x*32, y*32, map(x, y)
If map(x,y) < 42 Then Color 0, 0, map(x,y)
If map(x,y) > 42 And map(x,y) < 50 Then Color 0, map(x,y), 0
If map(x,y) > 50 And map(x,y) < 55 Then Color map(x,y), map(x,y), 0
If map(x,y) > 55 Then Color map(x,y), 0, 0
Box x*2, y*2, 2, 2', map(x, y)
Next y
Next x
DrawScreen
Until EscapeKey()
EDIT:
Paransin vähän
Re: Efektit
Character: Ihan näppärän näköistä jälkeä tuolla tulee. Sainkin siitä inspiraatiota väsätä omani mutta sen tuottama jälki ei ole kauhean kehuttavaa.
Ohjelma generoi mitä tahansa nappia painamalla kartan.
Ohjelma generoi mitä tahansa nappia painamalla kartan.
Code: Select all
Const RW = 128 // HUOM! Tämän tulee olla luvun 2 jokin potenssi
Const ROUGHNESS = 12 // Kartan "karkeus"
SCREEN RW, RW
Dim Array(RW, RW) As Float
Repeat
If GetKey() <> 0 Then
tim = Timer()
ReDim Array(RW, RW)
Array(0, 0) = Rand(10, Rand(10, 255))
Array(RW, 0) = Rand(10, Rand(10, 255))
Array(0, RW) = Rand(10, Rand(10, 255))
Array(RW, RW) = Rand(10, Rand(10, 255))
Diamond(0, 0, RW)
For a = 0 To RW
For i = 0 To RW
If Array(i , a) > 130 Then
Color 150 + 50 * Sin(180 + (Min(255, Array(i, a) - 130) / 125) * 90), 120 + 40 * Sin(180 + (Min(255, Array(i, a) - 130) / 125) * 90), 20
ElseIf Array(i, a) > 80 Then
Color 195 + 45 * Sin(180 + (Min(255, Array(i, a) - 80) / 50) * 90), 175 + 50 * Sin(180 + (Min(255, Array(i, a) - 80) / 50) * 90), 135 + 60 * Sin(180 + (Min(255, Array(i, a) - 80) / 50) * 90)
ElseIf Array(i, a) > 65 Then
Color 40 + 20 * Sin(180 + (Min(255, Array(i, a) - 65) / 15) * 90), 125 + 20 * Sin(180 + (Min(255, Array(i, a) - 65) / 15) * 90), 213 + 30 * Sin(180 + (Min(255, Array(i, a) - 65) / 15) * 90)
Else
Color 20 + 10 * Sin((Min(255, Array(i, a)) / 65) * 90), 50 + 25 * Sin((Min(255, Array(i, a)) / 65) * 90), 120 + 50 * Sin((Min(255, Array(i, a)) / 65) * 90)
EndIf
Dot i, a
Next i
Next a
SetWindow "Time elapsed: " + (Timer() - tim) + "ms"
DrawScreen
EndIf
Until EscapeKey()
Function Diamond(x As integer, y As integer, r As integer)
If r < 2 Then Return 0
Array(x + r / 2, y + r / 2) = (Array(x, y) + Array(x + r, y) + Array(x, y + r) + Array(x + r, y + r)) / 4 + Rand(-ROUGHNESS, ROUGHNESS)
Square(x + r / 2, y + r / 2, r / 2)
EndFunction
Function Square(x As integer, y As integer, r As integer)
If r < 1 Then Return 0
If (x - r) >= 0 Then
If ((y - r) >= 0) And ((y + r) <= RW) And Array(x - r, y) = 0 Then
Array(x - r, y) = (Array(x - r, y - r) + Array(x - r, y + r) + Array(x, y)) / 3
EndIf
If ((y - r) >= 0) And ((y + r) > RW) And Array(x - r, y) = 0 Then
Array(x - r, y) = (Array(x - r, y - r) + Array(x, y)) / 2
EndIf
If ((y - r) < 0) And ((y + r) <= RW) And Array(x - r, y) = 0 Then
Array(x - r, y) = (Array(x - r, y + r) + Array(x, y)) / 2
EndIf
EndIf
If (y - r) >= 0 Then
If ((x - r) >= 0) And ((x + r) <= RW) And Array(x, y - r) = 0 Then
Array(x, y - r) = (Array(x - r, y - r) + Array(x + r, y + r) + Array(x, y)) / 3
EndIf
If ((y - r) >= 0) And ((x + r) > RW) And Array(x, y - r) = 0 Then
Array(x, y - r) = (Array(x - r, y - r) + Array(x, y)) / 2
EndIf
If ((y - r) < 0) And ((x + r) <= RW) And Array(x, y - r) = 0
Array(x, y - r) = (Array(x + r, y + r) + Array(x, y)) / 2
EndIf
EndIf
If (x + r) >= 0 Then
If ((y - r) >= 0) And ((y + r) <= RW) And Array(x + r, y) = 0 Then
Array(x + r, y) = (Array(x + r, y - r) + Array(x + r, y + r) + Array(x, y)) / 3
EndIf
If ((y - r) >= 0) And ((y + r) > RW) And Array(x + r, y) = 0 Then
Array(x + r, y) = (Array(x + r, y - r) + Array(x, y)) / 2
EndIf
If ((y - r) < 0) And ((y + r) <= RW) And Array(x + r, y) = 0
Array(x + r, y) = (Array(x + r, y + r) + Array(x, y)) / 2
EndIf
EndIf
If (y + r) >= 0 Then
If ((x - r) >= 0) And ((x + r) <= RW) And Array(x, y + r) = 0 Then
Array(x, y + r) = (Array(x - r, y - r) + Array(x + r, y - r) + Array(x, y)) / 3
EndIf
If ((y - r) >= 0) And ((x + r) > RW) And Array(x, y + r) = 0 Then
Array(x, y + r) = (Array(x - r, y - r) + Array(x, y)) / 2
EndIf
If ((y - r) < 0) And ((x + r) <= RW) And Array(x, y + r) = 0
Array(x, y + r) = (Array(x + r, y + r) + Array(x, y)) / 2
EndIf
EndIf
Diamond(x - r, y - r, r)
Diamond(x, y - r, r)
Diamond(x - r, y, r)
Diamond(x, y, r)
EndFunction
EDIT:
Värejä optimoitu ja ruudun kokoa pienennetty.
Hengität nyt manuaalisesti.