Page 2 of 34

Re: Efektit

Posted: Wed Sep 17, 2008 4:59 pm
by Valtzu
Syksyn pimeyteen hidas ilotulitus-efekti, klikkaamalla räjähdys :)

Code: Select all

Const SW = 800
Const SH = 600

Const MAX_PARTS_PER_EXPLOSION = 300

SCREEN SW,SH,0,0

Type raketti
    Field x#
    Field y#
    Field sx#
    Field sy#
    Field r#
    Field g#
    Field b#
    Field gs#
    Field m
    Field id As Integer
End Type

Type explosion
    Field count As Short
End Type

Const GRAVITY = 0.02

PositionMouse SW/2,SH/2

Repeat
    PutPixel MouseX(),MouseY(),16777215
    If MouseHit(1) Then MakeExplosion()
    UpdateAll()
    Color 255,255,255
    Text 0,0,FPS()
    DrawScreen
Forever


Function UpdateAll()
    Lock
    For iR.raketti = Each raketti
        
        tmp.explosion = ConvertToType(iR\id)
        
        iR\x = iR\x + iR\sx
        iR\y = iR\y + iR\sy+iR\gs
        
        iR\gs=iR\gs+GRAVITY*(1.0-0.2*(iR\m=0))
        
        iR\sx = iR\sx + (Abs(iR\sx)>=0.4) * -Sgn(iR\sx) * (0.3+0.1*(iR\m=0))
        iR\sx = iR\sx + (Abs(iR\sx)<0.4) * -Sgn(iR\sx) * 0.001
        iR\sy = iR\sy + (Abs(iR\sy)>=0.4) * -Sgn(iR\sy) * (0.3+0.1*(iR\m=0))
        iR\sy = iR\sy + (Abs(iR\sy)<0.4) * -Sgn(iR\sy) * 0.001
        
        If iR\m = 0 Then PutPixel iR\x,iR\y,Int(iR\r Shl 16 +iR\g Shl 8+iR\b)
        
        If tmp\count<MAX_PARTS_PER_EXPLOSION And Rand(10)=0 And (iR\r>150 Or iR\g>150 Or iR\b>150) Then 
            PoE(iR\id,iR\x,iR\y,0,0,Max(0,iR\r-30),Max(0,iR\g-30),Max(0,iR\b-30),0,Rnd(0,0.5))
            tmp\count = tmp\count + 1
        EndIf
        
        iR\r=Max(0,iR\r-1)
        iR\g=Max(0,iR\g-1)
        iR\b=Max(0,iR\b-1)
        
        
        If iR\y > SH Or (iR\r<20 And iR\g<20 And iR\b<20) Then
            Delete iR
            tmp\count = tmp\count - 1
        EndIf
    Next iR
    Unlock
    For iR.raketti = Each raketti
        If iR\m = 1 Then
            Color iR\r,iR\g,iR\b
            Line iR\x,iR\y,iR\x-iR\sx/2,iR\y-iR\sY/2
            Color Max(0,iR\r-70),Max(0,iR\g-70),Max(0,iR\b-70)
            Line iR\x-iR\sx/2,iR\y-iR\sY/2,iR\x-iR\sx,iR\y-iR\sY
        EndIf
    Next iR
    Color cbwhite
    If tmp<>NULL Then Text 0,15,tmp\count
End Function

Function Sgn(luku#)
    Return (luku>0)-(luku<0)
End Function

Function MakeExplosion()
    n.explosion=New(explosion)
    mx#=MouseX()
    my#=MouseY()
    c=20
    fact#=360.0/c
    For a = 0 To c-1
        r=Rand(220,255)
        g=Rand(0,200)
        b=Rand(200,240)
        PoE(ConvertToInteger(n),mx,my,Cos((a+Rnd(-1,1)) * fact) * 8.0,Sin((a+Rnd(-1,1)) * fact) * 8.0,r,g,b,1)
    Next a
End Function

Function PoE(_id As Integer,x#,y#,sx#,sy#,r,g,b,m,gs#=0)
    tmp.explosion=ConvertToType(_id)
    If tmp\count>MAX_PARTS_PER_EXPLOSION Then Return False
    tmp\count = tmp\count + 1
    n.raketti = New(raketti)
    n\x=x
    n\y=y
    n\sx=sx
    n\sy=sy
    n\r=r
    n\g=g
    n\b=b
    n\m=m
    n\gs=gs
    n\id=_id
    Return ConvertToInteger(n)
End Function

Re: Efektit

Posted: Wed Sep 17, 2008 6:13 pm
by MaGetzUb
Tuo on hieno. Pistäppä vähä eri väreillä. :) Nii ja sit jotenki tuntuu et ku klikkaa kaks kertaa päällekkäi nii ne pikselit tulee justii samoihi paikkoihi.

Re: Efektit

Posted: Wed Sep 17, 2008 8:48 pm
by Valtzu
programmer of DSG wrote:Tuo on hieno. Pistäppä vähä eri väreillä. :) Nii ja sit jotenki tuntuu et ku klikkaa kaks kertaa päällekkäi nii ne pikselit tulee justii samoihi paikkoihi.
Tässäpä optimoitu ja eri väreillä oleva versio. Värit vaihtuvat 1-5 numeronäppäimillä.

Code: Select all

Const SW = 800
Const SH = 600
Const GRAVITY = 0.02

Const MAX_PARTS_PER_EXPLOSION = 300

SCREEN SW,SH,0,0

Type raketti
    Field x#
    Field y#
    Field sx#
    Field sy#
    Field r#
    Field g#
    Field b#
    Field gs#
    Field m
    Field id As Integer
End Type

Type explosion
    Field count As Short
End Type

Dim COLORS(9,5) As Byte,sg(2) As Float


//      key  R    R    G    G    B    B
SetColor(1, 220, 255, 0,   200, 200, 240)
SetColor(2, 225, 255, 50,  150, 0,   50)
SetColor(3, 245, 255, 245, 255, 245, 255)
SetColor(4, 120, 200, 120, 200, 245, 255)
SetColor(5, 120, 180, 220, 255, 120, 180)


Global currentColor As Byte
currentColor = 1


PositionMouse SW/2,SH/2

Repeat
    PutPixel MouseX(),MouseY(),16777215
    If MouseHit(1) Then MakeExplosion()
    UpdateAll()
    Color 255,255,255
    Text 0,0,FPS()
    If Timer()>t Then
        ScreenGamma Int(sg(0)),Int(sg(1)),Int(sg(2))
        t=Timer()+20
        sg(0) = CurveValue(0.0,sg(0),10.0)
        sg(1) = CurveValue(0.0,sg(1),10.0)
        sg(2) = CurveValue(0.0,sg(2),10.0)
    EndIf
    DrawScreen
Forever

Function SetColor(id,r1,r2,g1,g2,b1,b2)
    COLORS(id,0)=r1:COLORS(id,1)=r2
    COLORS(id,2)=g1:COLORS(id,3)=g2
    COLORS(id,4)=b1:COLORS(id,5)=b2
End Function

Function UpdateAll()
    For i=0 To 9
        If KeyHit(2+i) Then currentColor = (i + 1)-(i=9)*10
    Next i
    cc=0
    Lock
    For iR.raketti = Each raketti
        
        tmp.explosion = ConvertToType(iR\id)
        
        If iR\m = 0 And iR\y>=0 Then PutPixel2 iR\x,iR\y,Int(iR\r Shl 16 +iR\g Shl 8+iR\b)
        
        iR\x = iR\x + iR\sx
        iR\y = iR\y + iR\sy+iR\gs
        
        iR\gs=iR\gs+GRAVITY
        m#=(3+(iR\m=0))/10.0
        
        If iR\sx>0 Then
            If iR\sx>0.4 Then iR\sx = iR\sx - m Else iR\sx = iR\sx - 0.001
        ElseIf iR\sx<0 Then
            If iR\sx<-0.4 Then iR\sx = iR\sx + m Else iR\sx = iR\sx + 0.001
        EndIf
        
        If iR\sy>0 Then
            If iR\sy>0.4 Then iR\sy = iR\sy - m Else iR\sy = iR\sy - 0.001
        ElseIf iR\sy<0 Then
            If iR\sy<-0.4 Then iR\sy = iR\sy + m Else iR\sy = iR\sy + 0.001
        EndIf
        
        If tmp\count<MAX_PARTS_PER_EXPLOSION And Rand(10)=0 And (iR\r>150 Or iR\g>150 Or iR\b>150) Then 
            PoE(iR\id,iR\x,iR\y,0,0,Max(0,iR\r-30),Max(0,iR\g-30),Max(0,iR\b-30),0,Rnd(0,0.5))
            tmp\count = tmp\count + 1
        EndIf
        
        iR\r=Max(0,iR\r-1)
        iR\g=Max(0,iR\g-1)
        iR\b=Max(0,iR\b-1)
        
        If iR\y > SH-1 Or (iR\r<20 And iR\g<20 And iR\b<20) Or iR\x<0 Or iR\x>SW-1 Then
            Delete iR
            tmp\count = tmp\count - 1
        EndIf
        cc+1
    Next iR
    Unlock
    For iR.raketti = Each raketti
        If iR\m = 1 Then
            Color iR\r,iR\g,iR\b
            Line iR\x,iR\y,iR\x-iR\sx/2,iR\y-iR\sY/2
            Color Max(0,iR\r-70),Max(0,iR\g-70),Max(0,iR\b-70)
            Line iR\x-iR\sx/2,iR\y-iR\sY/2,iR\x-iR\sx,iR\y-iR\sY
        EndIf
    Next iR
    Color cbwhite
    Text 0,15,cc
End Function

Function MakeExplosion()
    n.explosion=New(explosion)
    mx#=MouseX()
    my#=MouseY()
    c=20
    fact#=360.0/c
    a_plus# = Rnd(0,359)
    f2#=Rnd(7.5,8.0)
    For a = 0 To c-1
        r=Rand(COLORS(currentColor,0),COLORS(currentColor,1))
        g=Rand(COLORS(currentColor,2),COLORS(currentColor,3))
        b=Rand(COLORS(currentColor,4),COLORS(currentColor,5))
        f#=f2+Rnd(0.0,0.5)
        PoE(ConvertToInteger(n),mx,my,Cos((a+a_plus+Rnd(-1,1)) * fact) * f,Sin((a+a_plus+Rnd(-1,1)) * fact) * f,r,g,b,1)
    Next a
    sg(0)=r/4
    sg(1)=g/4
    sg(2)=b/4
    ScreenGamma Int(sg(0)),Int(sg(1)),Int(sg(2))
End Function

Function PoE(_id As Integer,x#,y#,sx#,sy#,r,g,b,m,gs#=0)
    tmp.explosion=ConvertToType(_id)
    If tmp\count>MAX_PARTS_PER_EXPLOSION Then Return False
    tmp\count = tmp\count + 1
    n.raketti = New(raketti)
    n\x=x
    n\y=y
    n\sx=sx
    n\sy=sy
    n\r=r
    n\g=g
    n\b=b
    n\m=m
    n\gs=gs
    n\id=_id
    Return ConvertToInteger(n)
End Function

Re: Efektit

Posted: Thu Sep 18, 2008 6:50 pm
by Ruuttu
Tuon screengamman käyttö hidastaa efektiä melkoisesti. Eikö esim. taustavärin muuttaminen ajaisi melkein saman asian (ilman hidastumista) ? Muuten erittäin nätti efekti. :D

Re: Efektit

Posted: Thu Sep 18, 2008 6:53 pm
by Valtzu
Ruuttu wrote:Tuon screengamman käyttö hidastaa efektiä melkoisesti. Eikö esim. taustavärin muuttaminen ajaisi melkein saman asian (ilman hidastumista) ? Muuten erittäin nätti efekti. :D
Tämä on ilmeisesti konekohtaista, koska itse en ainakaan havainnut hidastumisia.

Re: Efektit

Posted: Thu Sep 18, 2008 7:25 pm
by MAVmaggot
Itselläni toimi ainakin ihan suht-hyvällä fps:llä :o Ihan luonnollistahan se on, että miljuunasta dotista näytöllä fps vähän tippuu. Ja erittäin hieno ja tyylikäs efekti ;) tack.

Re: Efektit

Posted: Thu Sep 25, 2008 5:27 pm
by Someday coder
Tässä tylsyyksissäni väsäsin tälläisen efektin, jossa eriväriset kirjaimet putoavat ja haihtuvat
kommentointi niukkaa ja voi olla melko purkkaa..

Code: Select all

//luodaan taulukot
Dim x(250) As Float
Dim y(250) As Float
Dim k(250) As String
Dim p(250) As Float
Dim v(250)
Dim r(250) As Float
Dim g(250) As Float
Dim b(250) As Float


//alku settingsit
  For i=1 To 250 

   k(i)=Chr(Rand(1,26)+64)
   p(i)=Rnd(0.1,0.25)
   y(i)=339
   r(i)=Rand(1,255)
   g(i)=Rand(1,255)
   b(i)=Rand(1,255)
   
  Next i
  nm=1
  
  ShowMouse OFF

Repeat

SetWindow "fps: "+FPS()+", letters: "+m+""

Color 255,255,255

//väri säädöt
 For i=1 To nm
 

  y(i)=y(i)+p(i)*10
  
   r(i)=r(i)-2
   g(i)=g(i)-2
   b(i)=b(i)-2
   
   If r(i) <= 0 Then r(i) = 0
   If g(i) <= 0 Then g(i) = 0
   If b(i) <= 0 Then b(i) = 0
   
   If r(i) <= 20 And g(i) <= 20 And b(i) <= 20 Then 
     r(i)=0
     g(i)=0
     b(i)=0
     y(i)=400
     m=m-1
   EndIf 
   

  //piirretään ja lasketaan monta kirjainta 
   
  If y(i) < 300 Then
    Color r(i),g(i),b(i)
    Text x(i),y(i),""+k(i)+""
    mm=mm+1
  EndIf 
  
  
 Next i

 m=mm
 mm=0



     
        If nm >= 249 Then nm=249
        
     // tehdään kolme kirjainta:   
      For c=1 To 3  
      
       For i=1 To nm  
       If y(i) > 300 Then
        nm=nm+1
         r(i)=Rand(1,255)
         g(i)=Rand(1,255)
         b(i)=Rand(1,255)
        x(i)=Rand(1,400)
        y(i)=-10
        Goto A
       EndIf
       Next i
        A:
     
     Next c

 DrawScreen  
Forever



Re: Efektit

Posted: Fri Sep 26, 2008 5:07 pm
by Ris
Tein huvikseni tälläisen järjettömän efektin + rand testin.

Code: Select all

//Järjetön efekti ja samalla rand testi.
//Tehnyt Ris. Erittäin yksinkertainen koodi, eikö?

Const RuutuX = 400
Const RuutuY = 400

Const Dots1X = 1
Const Dots2X = 1
Const Dot1Y = 400
Const Dot2Y = 400
Const DotMäärä = 1000
Const Box1X = 1
Const Box2X = 1
Const Box1Y = 400
Const Box2Y = 400
Const Xkoko = 5
Const Ykoko = 5
Const Boxkiinteä = 1

SCREEN RuutuX,RuutuY
FrameLimit 60

sys=LoadFont("Lucida Console",11)
SetFont sys

Repeat 

    o+1 'Joka loopin alussa nostetaan muuttujan o arvoa yhdellä.
         
    If o=30 Then  'Jos muuttuja m on 30, niin  
        ClearText 'poistetaan tekstit,
        Cls       'tyhjennetään ruutu ja 
        o=0       'nollataan muuttuja o 
    EndIf
    
    Randomize Timer() 'Alustetaan siemenluku ajan mukaan.
    
    'Näillä 3 funktiolla sitten arvotaan dotit, boxit,linet, määrät ja niitten värit.
    'Dotin määrä on tietenkin asetettu vakioon.
    
    DrawDotsRand(Dots1X,Dot1Y,Dots2X,Dot2Y,Rand(0,255),Rand(0,255),Rand(0,255),DotMäärä)

    DrawBoxsRand(Box1X,Box1Y,Box2X,Box2Y,Xkoko,Ykoko,Boxkiinteä,Rand(0,255),Rand(0,255),Rand(0,255),Rand(5,15))

    DrawLinesRand(Rand(10,30),Rand(0,255),Rand(0,255),Rand(0,255),Rand(10,RuutuY),Rand(Timer(),RuutuY),Rand(-60,RuutuY),Rand(-100,RuutuY))
    
    Color Rand(0,255),Rand(0,255),Rand(0,255) 'Tätä coloria ei tässä välttämättä tarvitse

    Locate Rand(1,RuutuY),Rand(1,RuutuY) 'Arvotaan tekstien paikka.
    
    AddText Rand(0,1)+" T "+ Rand(FPS(),100)
    AddText Rand(0,2)+" e "+ Rand(FPS(),100)
    AddText Rand(0,3)+" s "+ Rand(FPS(),100)
    AddText Rand(0,4)+" t "+ Rand(FPS(),100)  
    AddText Rand(0,5)+" i "+ Rand(FPS(),100)    
    
    DrawScreen OFF 

Forever 

Function DrawDotsRand(x,y,xx,yy,r,g,b,määrä) 
    For i = 0 To määrä 
        Color r,g,b
        Dot Rand(x,y),Rand(xx,yy)
    Next i   
End Function 

Function DrawBoxsRand(x,y,xx,yy,kokoX,kokoY,kiinteä,r,g,b,määrä)
    For i = 0 To määrä 
        Color r,g,b
        Box Rand(x,y),Rand(xx,yy),kokoX,kokoY,kiinteä
    Next i   
End Function 

Function DrawLinesRand(määrä,r,g,b,x1,y2,x4,y4)
    For i = 0 To määrä 
        Color r,g,b
        Line x1,y2,x4,y4
    Next i   
End Function 

Re: Efektit

Posted: Tue Sep 30, 2008 6:02 pm
by MaGetzUb
Tein tällaisen "Über hianon" Cos ja SIn kikkailun.. :)

Code: Select all

Repeat 

For angle = 0 To 360
Dot 200+Cos(xdist+angle)*50+Cos(angle)*Cos(xdist)*50,150-Sin(ydist+angle)*50-Sin(angle)*Sin(ydist)*50

Next angle


For i = 0 To 90 Step 2
Line 200+Cos(xdist+i)*-50+Cos(xdist+i)*Cos(xdist+i)*-50,150-Sin(ydist+i)*-50-Sin(ydist+i)*Sin(ydist+i)*-50,200+Cos(xdist+i)*50+Cos(xdist+i)*Cos(xdist+i)*50,150-Sin(ydist+i)*50-Sin(ydist+i)*Sin(ydist+i)*50
Next i

xdist = WrapAngle(xdist+1)
ydist = WrapAngle(ydist-1)



If Timer() > h + 500 Then 
d = 1 
h = Timer()

Else 
d=0
EndIf 
DrawScreen d
Forever 

Re: Efektit

Posted: Thu Oct 02, 2008 9:28 pm
by JATothrim
Vaviskaa, te kurjat. Koodasin kuvan venytysfunktion mikä ei ole ihan siitä tavallisesta päästä. Systeemi toimii _lähes_ reaali aikaisesti pienillä/kuvilla venytyksillä, mutta alkaa sitten hidastua kuvakoon suuretessa. Funktio aikas lyhyt, joten kommentteja ei ole. Niin ja, tämä "venyttää" eikä "skaalaa" ;)

Code: Select all

Global gScaled_Image
Const SCALE_BLOCK_SIZE = 1
Function ScaleImage(img%, botom_w#, right_s#)

	imgW% = ImageWidth(img)
	imgH% = ImageHeight(img)
	
	new_width% = max(imgW, botom_w)
	new_height% = max(imgH, right_s)
	
	If gScaled_Image = 0
		gScaled_Image = MakeImage(new_width, new_height)
	Else
		DeleteImage gScaled_Image
		gScaled_Image = MakeImage(new_width, new_height)
	EndIf
	
	
	DrawToImage gScaled_Image
	
	For y% = 0 To new_height Step SCALE_BLOCK_SIZE
		width = imgW + (y / Float(new_height)) * (botom_w - imgW)
		
		For x% = 0 To new_width Step SCALE_BLOCK_SIZE
			draw_x# = (x / Float(width)) * Float(imgW)
			
			height = imgH + (x / Float(new_width)) * (right_s - imgH)
			draw_y# = (y / Float(height)) * Float(imgH)
			
			DrawImageBox img, x, y, draw_x, draw_y, SCALE_BLOCK_SIZE, SCALE_BLOCK_SIZE
		Next x%
	Next y%
	
	
	DrawToScreen
	
	Return gScaled_Image
EndFunction

img = LoadImage("media\soldier.bmp")

Repeat
	DrawImage ScaleImage(img, MouseX(), MouseY()), 0, 0
	Text 300,0,FPS()
	DrawScreen
Forever
(Kokeilkaa miten tämän saisi viritettyä nopeammaksi, olisiko esim. copybox nopeampi?)

Re: Efektit

Posted: Fri Oct 03, 2008 8:36 pm
by MaGetzUb
Tuo oli hieno, tomiva ja kätevä. Mitenköhän pitkälle tämän vanhan cb:n kuvan käsittely funktiot menevät. Minä sain tehtyä sen ruman kuvan kääntely funktion ja sinä sait tämän hianon kuvan venyttely funktion.. :D :?:

Re: Efektit

Posted: Sat Oct 04, 2008 1:58 am
by tuhoojabotti
Tein tämänlaisen jännän tutkan. Se toimii tilekartoilla ja objekteilla. Tuskin on ainoa, mutta paras varmasti on, no ei vaiskaan. parannella saa ja käyttääkkin.

Code: Select all

FrameLimit 50

tilemap = LoadMap("Media\cdm2.til","Media\tileset.bmp")
PlayObject tilemap,0,0,1
ObjectPickable tilemap,1
guy = LoadObject ("Media\guy.bmp",72)
guy2 = LoadObject ("Media\guy.bmp",72)
ObjectPickable guy2,2
MoveObject guy2,0,200
SetupCollision guy, tilemap, 1, 4, 2

//VARIABLES NEEDED
Const ACCURACY=1 //radar accuracy
Global ang#,fade,speed
ang=0.0 //angle of the pointer
fade=100 //fading speed of the result
speed=7 //speed of the pointer


Repeat
    
    'Ukon ohjaus
    If LeftKey() Then TurnObject guy,5
    If RightKey() Then TurnObject guy,-5
    If UpKey() Then MoveObject guy,2
    If DownKey() Then MoveObject guy,-2


    CloneCameraPosition guy
    DrawGame 
    Color cbwhite 
    Text 0,0,FPS()
    
    Radar(50,50,100,guy,tilemap,300)
    
    DrawScreen
Forever

//x = radar drawing position (center)
//y = --||--
//r = radius of the radar circle
//obj = object we get the radar from
//map = tilemap used
//range# = range of the radarbeam
Function Radar(x,y,r,obj,map,range#)
    //draw base
    Color 0,40,0
    Circle x-r/2,y-r/2,r,1
    Color 0,80,0
    Circle x-r/2,y-r/2,r,0
    oldangle=ObjectAngle(obj) //save the old angle of the guy
    For i=ang-fade To ang Step ACCURACY //loop trought a loop
        RotateObject obj,i
        ObjectPick obj
        Dist#=Distance(PickedX(),PickedY(),ObjectX(obj),ObjectY(obj))
        If Dist<range Then // if the picked object is in the range of the beam
            rdist#=dist/range //make the distance good for the scale of the radar
            If pickedobject()=map Then
                Color 0,150+Max(i-ang,-110),0
            Else //this ain't no wall, shoot it!
                Color 200+Max(i-ang,-160),0,0 
            EndIf
            Dot x+Cos(i)*r/2*rDist,y-Sin(i)*r/2*rDist
        EndIf 
    Next i
    RotateObject obj,oldangle //restore the old angle of the object
    //update and draw teh pointer
    ang+speed
    Color 0,80,0
    Line x,y,x+Cos(ang)*r/2,y-Sin(ang)*r/2
EndFunction

Re: Efektit

Posted: Sat Oct 04, 2008 11:06 am
by MaGetzUb
Juman gekko! Tuo oli hieno.. Varmana tulee jollekki käyttöä.. Ehkäpä jopa minulle.. Riippuu vähän.. :D

Re: Efektit

Posted: Sun Oct 05, 2008 6:47 pm
by SuojelusPerkele
tuhoojabotti wrote:Tein tämänlaisen jännän tutkan. Se toimii tilekartoilla ja objekteilla. Tuskin on ainoa, mutta paras varmasti on, no ei vaiskaan. parannella saa ja käyttääkkin.

Code: Select all

...helvetin hieno koodinpätkä...
Perskules että onnii hieno!

Image

Re: Efektit

Posted: Sun Oct 05, 2008 7:10 pm
by MaGetzUb
Se olisi hieno, jos se piirtäisi vihun siihen radariin pelkkänä pallona, eikä vaa ääriviivana..

Re: Efektit

Posted: Mon Oct 06, 2008 11:24 pm
by axu
Tässäpä parin illan koodaustyö: betaMetapallot! Sisältää reaaliaikaisen efektin, joka on sen verran hidas, että lisäsin myös animaation!
Jos haluat tietää lisää, esim. miten tämä on tehty kehoitan käymään Ohjelmointiputkassa

Code: Select all

////    MetaPallot by aXu   \\\\

Const SW = 100      'Pieni reso on cb-efekteissä hyvä
Const SH = 70
SCREEN SW*2,SH*2
SCREEN SW,SH,0,2
SetWindow "Metapallot",3
Dim p#(SW,SH,2)

SAFEEXIT OFF

Global MODE
//ASETUKSET\\
MODE =0            '0 = Reaaliaikainen, >0 = Nauhoitetaan näin pitkä animaatio(MODE*10), <0 Toista viimeisin animaatio

Const TailLen = .1  '"Hännän" pituus, 0 = ei häntää, 1 = maailmanloppu

Const BallCount = 2 'Pallojen määrä

Const FRAMETIME = 3 'Animaation Framerate, isompi tökkivämpi, pienempi sulavampi(kait) 


W=SW*MODE*10
If W>10000 Then W=10000

If MODE > 0 Then Anim=MakeImage(W,SH*(MODE/10)+SH)  'Tehdään kuva johon animaatio piirretään(rivitetty tarpeen mukaan)
If MODE < 0 Then MODE = -MODE : Goto Animation      'Skipataan suoraan animaatioon


Type MetaBall
    Field X#
    Field Y#
    Field VelX#
    Field VelY#
    Field Col
    Field Radius
End Type

For i=0 To BallCount-1              'Luodaan Metapallot
    Ball.MetaBall = New(MetaBall)
    Ball\X=Rand(SW)
    Ball\Y=Rand(SH)
    Ball\VelX=Rnd(.8,3)*(Rand(1)*2-1)
    Ball\VelY=Rnd(.8,3)*(Rand(1)*2-1)
    Ball\Radius=Rand(10,40)         'Pallon koko
    Ball\Col=Rand(2)                'Arvotaan pallon väri(0=RED,1=GREEN,2=BLUE)
Next i

Repeat
    For x = 0 To SW         'Näillä tarkastetaan ruudun kaikki pisteet
        For y = 0 To SH     'kommenteissa viittaan näihin koordinaatteihin P:llä
            i=0
            For Ball.MetaBall = Each MetaBall
                If i = 0 Then
                    For c=0 To 2
                        p(x,y,c)=(p(x,y,c))*TailLen 'Tummennetaan pikseliä P
                    Next c
                End If
                
                D=Distance(x,y,Ball\X,Ball\Y)
                
                If D<Ball\Radius*1.4 Then       'Tarkastetaan onko P lähempänä kuin Pallon säde/neliöjuuri kahden likiarvolla
                    c=Ball\Col                  'Mitä värikomponenttia "värjätään"
                    p(x,y,c) = p(x,y,c) + Ball\Radius / ( (Ball\X - x) * (Ball\X - x) + (Ball\Y - y) * (Ball\Y - y) + .00001 )  'Tässä on KAIKEN A ja O
                EndIf
                
                
                If i = BallCount-1 Then         'piirretään vasta viimeisten laskutoimitusten jälkeen
                    For c=0 To 2
                        If p(x,y,c) > 1 Then p(x,y,c) = 1   'Ei ylitetä yhtä(testaa kommentoida, niin näet miksi)
                        g#=g#+p(x,y,c)
                    Next c
                    g#=g#/3                     'Värikomponenttejen keskiarvo
                    If g# > 0.08 Or MODE Then   'Nopeuden vuoksi liian tummia pikseleitä ei piirretä
                        Color p(x,y,0) * 255 , p(x,y,1) * 255, p(x,y,2) * 255
                        If MODE Then
                            DrawToImage Anim    'Muokataan animaatiota
                            Dot x+SW*((Frame) Mod 100), y+SH*(Frame/100)
                            DrawToScreen
                        End If
                        Dot x, y                'Piirretään piste P
                    End If
                End If
                
                
                i+1             'Seuraava pallo.
            Next Ball
        Next y
    Next x
    
    For Ball.MetaBall = Each MetaBall
        Ball\X=Ball\X+Ball\VelX/FRAMETIME   'Liikutetaan kaikkia palloja
        Ball\Y=Ball\Y+Ball\VelY/FRAMETIME   'ja katsotaan myös törmäyksiä varten
        If Ball\X<0 Or Ball\X>SW Then Ball\VelX=-Ball\VelX
        If Ball\Y<0 Or Ball\Y>SH Then Ball\VelY=-Ball\VelY
    Next Ball
    
    If MODE Then
        Color 255,255,255
        Text 1,1,Frame+"/"+MODE*10
        If Frame>MODE*10 Then Exit
    End If
    
    DrawScreen
    Frame=Frame+1   'Vaihdetaan animaatioframe
Until EscapeKey()

If MODE Then
    SaveImage Anim,"MetaBalls Animation.bmp"
    DeleteImage Anim
    Animation:
    Anim=LoadAnimImage("MetaBalls Animation.bmp",SW,SH,0,MODE*10)
    FrameLimit 60/FRAMETIME
    Frame=0
    Repeat
        DrawImage Anim,0,0,Frame    'näytetään koko illan elokuva :D
        Frame=Frame+1
        DrawScreen
    Until Frame+1>MODE*10
EndIf

Re: Efektit

Posted: Tue Oct 07, 2008 12:29 pm
by Jonhu
tässä hypnotisoija xD Lataus vähän kestää. Ei mikään huippuhieno, mutta yksinketainen spiraali.. Tällä voi myös kilpailla koneen tehoja xD

Code: Select all

SCREEN 800,600
Dim images(360)

Text 0,0,"Laskee kuvien paikkoja... ottaa noin 5 sekunttia 1 ghz koneella"
Text 0,12,"Pienennä kuvan kokoa, jos kestää liian kauan.."
Text 0,24,"Jos haluat voit pistää smooth2d päälle(ottaa vähän lisää aikaa)"


pyorytys=MakeImage(300,300) ' Pienennä tai suurenna kuvan kokoa!
DrawToImage pyorytys
    For s=1 To 5000
        a+1
        kuvio(1+a,1+a,a/40,ImageWidth(pyorytys)/2,ImageHeight(pyorytys)/2)
    Next s
DrawToScreen

start_time=Timer()

'Smooth2D ON
For i=0 To 36
    images(i*10)=CloneImage(pyorytys)
    RotateImage images(i*10), i*10
Next i

aaa=Timer()-start_time
paikkax=ScreenWidth()/2-ImageWidth(pyorytys)/2
paikkay=ScreenHeight()/2

Repeat
    DrawImage images(angle),paikkax,paikkay
    angle=WrapAngle(angle+10)
    If angle>360 Then angle=0
    
    Color cbwhite
    Text 100,500,"FPS: "+FPS()
    Text 100,520,"Aikaa kului: "+aaa+"ms"
    DrawScreen
Until EscapeKey()

Function kuvio(x1#,y1#,koko,alkux,alkuy)
    x1# = Sin(x1#)*koko
    y1# = -Cos(y1#)*koko
    Dot x1#+alkux,y1#+alkuy
EndFunction


Re: Efektit

Posted: Tue Oct 07, 2008 3:54 pm
by temu92
2816ms ilman smooth2d ja 8741ms sen kanssa! 3GHz prossu :P

Re: Efektit

Posted: Tue Oct 07, 2008 5:32 pm
by Sly_Jack0
3608ms ilman Smooth2D:tä ja 9319ms Smmoth2D päällä.

Re: Efektit

Posted: Fri Oct 17, 2008 2:00 pm
by Someday coder
2840 ms ilman smooth2d:tä ja 8715 sen kanssa ;) prossu on 2.6ghz dual core AMD