Efektit

Oletko tehnyt jotain, mistä muut voisivat hyötyä. Postita vinkit tänne.
User avatar
valscion
Moderator
Moderator
Posts: 1599
Joined: Thu Dec 06, 2007 7:46 pm
Location: Espoo
Contact:

Re: Efektit

Post by valscion »

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
User avatar
Execute
Active Member
Posts: 110
Joined: Fri Feb 11, 2011 6:41 pm

Efektit

Post by Execute »

Pientä palikkaposauttelua... :)

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 
Hiirtä klikkaamalla posauttaa.
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!
MaGetzUb
Guru
Posts: 1715
Joined: Sun Sep 09, 2007 12:35 pm
Location: Alavus

Re: Efektit

Post by MaGetzUb »

Tämmöne nuotio tuli tuos lauantaina koodattua.. :D

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
Meneillä olevat Projektit:
We're in a simulation, and God is trying to debug us.
User avatar
valscion
Moderator
Moderator
Posts: 1599
Joined: Thu Dec 06, 2007 7:46 pm
Location: Espoo
Contact:

Re: Efektit

Post by valscion »

MaGetzUb wrote:Tämmöne nuotio tuli tuos lauantaina koodattua.. :D
Yksinkertanen mutta komia :) voi jospa CB jaksais tuollasii pyörittää vaikka jonki pelin taustalla pätkimättä... voih.
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
Wingman
Devoted Member
Posts: 594
Joined: Tue Sep 30, 2008 4:30 pm
Location: Ruudun toisella puolella

Re: Efektit

Post by Wingman »

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:

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 
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)
- - - -
Latexi95
Guru
Posts: 1166
Joined: Sat Sep 20, 2008 5:10 pm
Location: Lempäälä

Re: Efektit

Post by Latexi95 »

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.
koodaaja
Moderator
Moderator
Posts: 1583
Joined: Mon Aug 27, 2007 11:24 pm
Location: Otaniemi - Mikkeli -pendelöinti

Re: Efektit

Post by koodaaja »

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
Latexi95
Guru
Posts: 1166
Joined: Sat Sep 20, 2008 5:10 pm
Location: Lempäälä

Re: Efektit

Post by Latexi95 »

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
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ä.

Korjasin yhden virheen tuossa koodissani ja muutin sen näyttämään etenemistään Koodaajan koodin tapaan.
Art
Member
Posts: 53
Joined: Wed Dec 07, 2011 5:37 pm

Re: Efektit

Post by Art »

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
Art
Member
Posts: 53
Joined: Wed Dec 07, 2011 5:37 pm

Re: Efektit

Post by Art »

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
Awaclus
Forum Veteran
Posts: 2939
Joined: Tue Aug 28, 2007 2:50 pm

Re: Efektit

Post by Awaclus »

Art wrote: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 ()
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.

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
Member
Posts: 53
Joined: Wed Dec 07, 2011 5:37 pm

Re: Efektit

Post by Art »

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.
Aiwan :) kyllä mä vielä opin , oon kirjottanu cb 4 päivää ..
¤ Art
Art
Member
Posts: 53
Joined: Wed Dec 07, 2011 5:37 pm

Re: Efektit

Post by Art »

Chaosworm wrote:
Art wrote: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 ()
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.
Katso tuon koodin alapuolella oleva koodi oli ns . korjaus :)
¤ Art
Herra Siili
Advanced Member
Posts: 308
Joined: Tue Nov 25, 2008 8:06 pm
Contact:

Re: Efektit

Post by Herra Siili »

Vinkki: Kannattaa käyttää sitä muokkaa-nappulaa niin ei tule tulplaposteja.
a.k.a. Gehock
Art
Member
Posts: 53
Joined: Wed Dec 07, 2011 5:37 pm

Re: Efektit

Post by Art »

Herra Siili wrote:Vinkki: Kannattaa käyttää sitä muokkaa-nappulaa niin ei tule tulplaposteja.
juu =)
¤ Art
DatsuniG
Advanced Member
Posts: 367
Joined: Fri Aug 15, 2008 9:57 pm

Re: Efektit

Post by DatsuniG »

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.
User avatar
Kokkelkhan
Newcomer
Posts: 6
Joined: Tue Mar 15, 2011 9:25 pm
Location: Pk-seutu

Re: Efektit

Post by Kokkelkhan »

Pari sini & cosini kikkailua:

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 
Koodi on melkoista sotkua, pahoittelut...
Päräjää...!
User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema »

Kokkelkhan wrote:Pari sini & cosini kikkailua:

Code: Select all

sood1

Code: Select all

sood2
Koodi on melkoista sotkua, pahoittelut...
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... :D
Character
Active Member
Posts: 113
Joined: Thu Nov 27, 2008 2:16 pm

Re: Efektit

Post by Character »

Teinpä huvikseni tällaisen todella simppelin rumahkon maastogeneraattorin :mrgreen:

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

DatsuniG
Advanced Member
Posts: 367
Joined: Fri Aug 15, 2008 9:57 pm

Re: Efektit

Post by DatsuniG »

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. :D

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.
Post Reply