Efektit

Oletko tehnyt jotain, mistä muut voisivat hyötyä. Postita vinkit tänne.
User avatar
Cooler
Newcomer
Posts: 6
Joined: Thu Jan 17, 2013 8:49 pm

Re: Efektit

Post by Cooler »

atomimalli wrote:
Cooler wrote:Tuli mieleen tällänen metapalloa muistuttava efekti:

Code: Select all

koodia
Hurjan lähellä metapalloa tuo onkin!
Yhtä riviä vaan tarvii muuttaa.

Code: Select all

lisää koodia
Samalla idealla tehty liikkuva ASCII-"metapallo"

Code: Select all

nl=400
nk=300
merkki$="@"

SCREEN nl,nk

mpX=Rand(nl/TextWidth(merkki$))
mpY=Rand(nk/TextHeight(merkki$))+(nk*0.022)
mpPlusX=Cos(120)
mpPlusY=Sin(120)

Repeat
    
    For x = 0 To nl/TextWidth(merkki$)
        For y = 0 To nk/TextHeight(merkki$)+(nk*0.022)
            Color 0,0,Min(255,(nl+nk)*1.3/Distance(x,y,mpX,mpY))
            If getRGB(BLUE) <> 0 Then Text x*TextWidth(merkki$),y*TextHeight(merkki$)-(y*3),merkki$
        Next y
    Next x
    
    mpX=mpX+mpPlusX
    mpY=mpY+mpPlusY
    
    If mpX<0 Or mpX>nl/TextWidth(merkki$) Then mpPlusX= -mpPlusX
    If mpY<0 Or mpY>nk/TextHeight(merkki$)+(nk*0.022) Then mpPlusY= -mpPlusY
    
    DrawScreen
    
Forever
<Ize> Pitäs tehä allekirjotus..
<Ize> Vois keksiä jonkin nasahtavan sanonnan..
<Ize> Siitä tulis upea legenda ja kaikki vaihtaisivat allekirjoituksensa siihen.
<Ize> Ehkä ei kuitenkaa...
User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema »

Code: Select all

///////////////////////////////////////////
// SlidingLoadingBar() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBarCount As Integer
gSlrBarCount = 20 // Adjust this to fit the wanted width of the sliding loading bar
Dim aSlrBars#(gSlrBarCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBar(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Max(-1, Min(gSlrBarCount+1, (0.95 + Sin(Timer()/10)) * Float(gSlrBarCount/2)))
    
    bw = w / gSlrBarCount
    
    For i = 0 To gSlrBarCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBarCount And gSlrCurPos = i Then
            aSlrBars(i) = 0
        Else
            aSlrBars(i) = aSlrBars(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBars(i)))
        bg = Max(0, Min(255, g - aSlrBars(i)))
        bb = Max(0, Min(255, b - aSlrBars(i)))

        Color br, bg, bb
        
        Box x + i * bw, y, bw, h
        
    Next i
    
    Color r, g, b
    Box x, y, w, h, 0

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBar(0,130,400,40,0.7, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever

Mulla oli tylsää. :<
MrMonday
Advanced Member
Posts: 378
Joined: Fri Oct 10, 2008 2:35 pm

Re: Efektit

Post by MrMonday »

Misthema wrote:

Code: Select all

///////////////////////////////////////////
// SlidingLoadingBar() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBarCount As Integer
gSlrBarCount = 20 // Adjust this to fit the wanted width of the sliding loading bar
Dim aSlrBars#(gSlrBarCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBar(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Max(-1, Min(gSlrBarCount+1, (0.95 + Sin(Timer()/10)) * Float(gSlrBarCount/2)))
    
    bw = w / gSlrBarCount
    
    For i = 0 To gSlrBarCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBarCount And gSlrCurPos = i Then
            aSlrBars(i) = 0
        Else
            aSlrBars(i) = aSlrBars(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBars(i)))
        bg = Max(0, Min(255, g - aSlrBars(i)))
        bb = Max(0, Min(255, b - aSlrBars(i)))

        Color br, bg, bb
        
        Box x + i * bw, y, bw, h
        
    Next i
    
    Color r, g, b
    Box x, y, w, h, 0

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBar(0,130,400,40,0.7, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever

Mulla oli tylsää. :<
Vallan komia, vaikkakin vanhanaikainen, kun nykyään latauksissa suositaan ympyrää. Mutta silti, hieno :)
User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema »

MrMonday wrote:
Misthema wrote:

Code: Select all

///////////////////////////////////////////
// SlidingLoadingBar() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBarCount As Integer
gSlrBarCount = 20 // Adjust this to fit the wanted width of the sliding loading bar
Dim aSlrBars#(gSlrBarCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBar(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Max(-1, Min(gSlrBarCount+1, (0.95 + Sin(Timer()/10)) * Float(gSlrBarCount/2)))
    
    bw = w / gSlrBarCount
    
    For i = 0 To gSlrBarCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBarCount And gSlrCurPos = i Then
            aSlrBars(i) = 0
        Else
            aSlrBars(i) = aSlrBars(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBars(i)))
        bg = Max(0, Min(255, g - aSlrBars(i)))
        bb = Max(0, Min(255, b - aSlrBars(i)))

        Color br, bg, bb
        
        Box x + i * bw, y, bw, h
        
    Next i
    
    Color r, g, b
    Box x, y, w, h, 0

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBar(0,130,400,40,0.7, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever

Mulla oli tylsää. :<
Vallan komia, vaikkakin vanhanaikainen, kun nykyään latauksissa suositaan ympyrää. Mutta silti, hieno :)
Image

Code: Select all

////////////////////////////////////////////
// SlidingLoadingBall() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBallCount As Integer
gSlrBallCount = 20 // Adjust this to fit the wanted amount of the balls
Dim aSlrBall#(gSlrBallCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBalls(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Timer()/100 Mod gSlrBallCount
    
    bw = w*2 / gSlrBallCount
    bh = h*2 / gSlrBallCount
    
    For i = 0 To gSlrBallCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBallCount And gSlrCurPos = i Then
            aSlrBall(i) = 0
        Else
            aSlrBall(i) = aSlrBall(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBall(i)))
        bg = Max(0, Min(255, g - aSlrBall(i)))
        bb = Max(0, Min(255, b - aSlrBall(i)))

        Color br, bg, bb
        
        bx# = x + Cos(360 / gSlrBallCount * i) * w/2
        by# = y - Sin(360 / gSlrBallCount * i) * h/2
        
        Ellipse bx-(bw/2), by-(bh/2), bw, bh
        
    Next i

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBalls(200,150,50,50,2, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever
En jaksanut kaikkia nimiä muuttaa...
MrMonday
Advanced Member
Posts: 378
Joined: Fri Oct 10, 2008 2:35 pm

Re: Efektit

Post by MrMonday »

Misthema wrote:
MrMonday wrote:
Misthema wrote:

Code: Select all

///////////////////////////////////////////
// SlidingLoadingBar() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBarCount As Integer
gSlrBarCount = 20 // Adjust this to fit the wanted width of the sliding loading bar
Dim aSlrBars#(gSlrBarCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBar(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Max(-1, Min(gSlrBarCount+1, (0.95 + Sin(Timer()/10)) * Float(gSlrBarCount/2)))
    
    bw = w / gSlrBarCount
    
    For i = 0 To gSlrBarCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBarCount And gSlrCurPos = i Then
            aSlrBars(i) = 0
        Else
            aSlrBars(i) = aSlrBars(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBars(i)))
        bg = Max(0, Min(255, g - aSlrBars(i)))
        bb = Max(0, Min(255, b - aSlrBars(i)))

        Color br, bg, bb
        
        Box x + i * bw, y, bw, h
        
    Next i
    
    Color r, g, b
    Box x, y, w, h, 0

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBar(0,130,400,40,0.7, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever

Mulla oli tylsää. :<
Vallan komia, vaikkakin vanhanaikainen, kun nykyään latauksissa suositaan ympyrää. Mutta silti, hieno :)
Image

Code: Select all

////////////////////////////////////////////
// SlidingLoadingBall() by misthema @ 2013//
Global gSlrCurPos
Global gSlrBallCount As Integer
gSlrBallCount = 20 // Adjust this to fit the wanted amount of the balls
Dim aSlrBall#(gSlrBallCount)

// x, y       = Where to draw
// w, h       = What size (width, height)
// fadeForce# = How much the colors are faded each loop
// r, g, b    = Wanted colors
Function SlidingLoadingBalls(x, y, w, h, fadeForce# = 0.5, r=0, g=0, b=255)

    gSlrCurPos = Timer()/100 Mod gSlrBallCount
    
    bw = w*2 / gSlrBallCount
    bh = h*2 / gSlrBallCount
    
    For i = 0 To gSlrBallCount - 1
        
        If gSlrCurPos >= 0 And gSlrCurPos <= gSlrBallCount And gSlrCurPos = i Then
            aSlrBall(i) = 0
        Else
            aSlrBall(i) = aSlrBall(i) + fadeForce
        EndIf
        
        br = Max(0, Min(255, r - aSlrBall(i)))
        bg = Max(0, Min(255, g - aSlrBall(i)))
        bb = Max(0, Min(255, b - aSlrBall(i)))

        Color br, bg, bb
        
        bx# = x + Cos(360 / gSlrBallCount * i) * w/2
        by# = y - Sin(360 / gSlrBallCount * i) * h/2
        
        Ellipse bx-(bw/2), by-(bh/2), bw, bh
        
    Next i

EndFunction

// ESIMERKKIOHJELMA
SetFont LoadFont("Arial Black", 18,1)

Repeat
    
    SlidingLoadingBalls(200,150,50,50,2, 64,128,255)
    
    Color cbBlack
    CenterText 202,152,"Loading...",2
    Color cbWhite
    CenterText 200,150,"Loading...",2
    
    DrawScreen
Forever
En jaksanut kaikkia nimiä muuttaa...
No mutta, nyt se on sekä hävyttömän komia, ettäpä vielä nykyaikainen :) Tällaista voisi jo ihan oikeasti käyttää jossain projektissa :)
User avatar
MetalRain
Active Member
Posts: 188
Joined: Sun Mar 21, 2010 11:17 am
Location: Espoo

Re: Efektit

Post by MetalRain »

Katselin irkissä Viltzun komeaa partikkeliefektiä ja mietin että mihis se cb pystyy. Hiirellä voi vähän muuttaa perspektiiviä.

Code: Select all

Dim ScreenImages(255) As integer 

Global ScreenEmptyImage, ScreenImageCount, ScreenImageLimit, ImageScreenInitialized

Global gScaledImage
gScaledImage = MakeImage(1, 1)

CONST BYTE_SIZE = 4

//offset of data in memoryblocks
Const MEMBLOCK_OFFSET_ScreenImageLayers = 0
Const MEMBLOCK_OFFSET_ScreenTextureWidth = 4
Const MEMBLOCK_OFFSET_ScreenTextureHeight = 8
Const MEMBLOCK_OFFSET_ScreenWidth = 12
Const MEMBLOCK_OFFSET_ScreenHeight = 16
Const MEMBLOCK_OFFSET_ScreenLayerAmount = 20
Const MEMBLOCK_OFFSET_ScreenBufferType = 24
Const MEMBLOCK_OFFSET_ScreenBuffer = 25
Const MEMBLOCK_OFFSET_ScreenRenderScaleFactor = 29
Const MEMBLOCK_SIZE_Screen = 33

CONST MEMBLOCK_OFFSET_LayerBaseImage = 0
CONST MEMBLOCK_OFFSET_LayerScaledImage = 4
CONST MEMBLOCK_OFFSET_LayerNewImageCount = 8
CONST MEMBLOCK_OFFSET_LayerNewImageList = 12
CONST MEMBLOCK_OFFSET_LayerNewImageListSize = 16
Const MEMBLOCK_SIZE_Layer = 20

Const MEMBLOCK_OFFSET_ImageIndex = 0
Const MEMBLOCK_OFFSET_ImageX = 4
Const MEMBLOCK_OFFSET_ImageY = 8
Const MEMBLOCK_SIZE_Image = 12

Const LIST_INCREASE_SIZE = 20

CONST BUFFERTYPE_MEMBLOCK = 1
CONST BUFFERTYPE_STREAMFILE = 2


Function InitializeImageScreenLibrary(limit=255)
    ScreenEmptyImage = MakeImage(10,10)
	ScreenImageLimit = limit
    ReDim ScreenImages(limit) As integer 
    ScreenImageCount = 0
    ImageScreenInitialized=1
End Function 

Function MakeImageScreen(width=16, height=16, imageW=32, imageH=32, layerAmount=10)
   
    mem = MakeMEMBlock(MEMBLOCK_SIZE_Screen)
    
    width = Max(width, 1)
    height = Max(height, 1)
    
    PokeInt mem,MEMBLOCK_OFFSET_ScreenTextureWidth, imageW
    PokeInt mem,MEMBLOCK_OFFSET_ScreenTextureHeight, imageH

    PokeInt mem,MEMBLOCK_OFFSET_ScreenWidth, width 
    PokeInt mem,MEMBLOCK_OFFSET_ScreenHeight, height
	
    PokeInt mem,MEMBLOCK_OFFSET_ScreenLayerAmount, layerAmount
	
	PokeFloat mem, MEMBLOCK_OFFSET_ScreenRenderScaleFactor, 1.0
	
	//use buffer only if it's small enough
	if (width * height * layerAmount < 100000) Then 
		PokeByte mem,MEMBLOCK_OFFSET_ScreenBufferType, BUFFERTYPE_MEMBLOCK
	else 
		PokeByte mem,MEMBLOCK_OFFSET_ScreenBufferType, BUFFERTYPE_STREAMFILE
	endif 
	
	ClearImageScreen(mem)
    
    Return mem
End Function 

//Deletes Image Screen
Function DeleteImageScreen(mem)
    
	if (mem and MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen) Then 
	
		layerObjects = Peekint(mem,MEMBLOCK_OFFSET_ScreenImageLayers)
		
		layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
		
		// delete previous layer images and memblocks if present
		
		if (layerObjects) then 
			
			for iterator=0 to MemBlocksize(layerObjects)-1 step BYTE_SIZE
			
				layer = PeekInt(layerObjects, iterator)
				
				if (layer) Then 
				
					layerImage = PeekInt(layer,MEMBLOCK_OFFSET_LayerBaseImage)
					
					if (layerImage) then DeleteImage layerImage
					
					changeList = peekint(layer,MEMBLOCK_OFFSET_LayerNewImageList)
					
					if (changeList) then 
						
						DeleteMEMBlock changeList
						
					endif 
					
					DeleteMEMBlock layer

				Endif 

			next iterator
			
			DeleteMEMBlock layerObjects
			
		EndIf 
		
		bufferType = PeekByte(mem,MEMBLOCK_OFFSET_ScreenBufferType)
		
		if (bufferType = BUFFERTYPE_MEMBLOCK) then 
			screenBuffer = PeekInt(mem,MEMBLOCK_OFFSET_ScreenBuffer)
			// remove screen buffer
			if (screenBuffer) then DeleteMEMBlock screenBuffer
			
		endif 
		
		DeleteMEMBlock mem

    EndIf 
End Function 

//Clears all ImageScreen layerObjects
Function ClearImageScreen(mem)

	If mem Then 
		If MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen Then 
		
			width = PeekInt(mem,MEMBLOCK_OFFSET_ScreenWidth)
			height = PeekInt(mem,MEMBLOCK_OFFSET_ScreenHeight)
			layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
			bufferType = PeekByte(mem,MEMBLOCK_OFFSET_ScreenBufferType)
			
			if (bufferType = BUFFERTYPE_MEMBLOCK) then 
				screenBuffer = PeekInt(mem,MEMBLOCK_OFFSET_ScreenBuffer)
				// remove screen buffer
				if (screenBuffer) then DeleteMEMBlock screenBuffer
				// init screen buffer
				PokeInt mem,MEMBLOCK_OFFSET_ScreenBuffer, MakeMEMBlock(width * height * layerAmount * BYTE_SIZE)
			endif 

			// init new memblocks and images for layerObjects
			ImageScreenInitLayers(mem) 
			
		endif 

	endif 

end function 

//(Re)creates ImageScreen layerObjects
Function ImageScreenInitLayers(mem) 

    If ImageScreenInitialized=0 Then MakeError "You must call ImageScreenInitialize() before calling other ImageScreen functions!"

	if (mem and MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen) Then 
	
		previousLayers = Peekint(mem,MEMBLOCK_OFFSET_ScreenImageLayers)
		
		layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
		
		// delete previous layer images and memblocks if present
		
		if (previousLayers) then 
			
			for iterator=0 to MemBlocksize(previousLayers)-1 step BYTE_SIZE
			
				layer = PeekInt(previousLayers, iterator)
				
				if (layer) Then 
				
					layerImage = PeekInt(layer,MEMBLOCK_OFFSET_LayerBaseImage)
					
					if (layerImage) then DeleteImage layerImage
					
					changeList = peekint(layer,MEMBLOCK_OFFSET_LayerNewImageList)
					
					if (changeList) then 
						
						DeleteMEMBlock changeList
						
					endif 
					
					DeleteMEMBlock layer

				Endif 

			next iterator
			
			DeleteMEMBlock previousLayers
			
		EndIf 

		width = PeekInt(mem,MEMBLOCK_OFFSET_ScreenWidth)
		height = PeekInt(mem,MEMBLOCK_OFFSET_ScreenHeight)
		
		//create new layerObjects 
	
		layerObjects = MakeMemblock(BYTE_SIZE * layerAmount)
		
		textureWidth = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureWidth)
		textureHeight = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureHeight)
		
		for iterator=0 to layerAmount-1
		
			layer = MakeMemBlock(MEMBLOCK_SIZE_Layer)
			
			PokeInt layer, MEMBLOCK_OFFSET_LayerBaseImage, MakeImage(width * textureWidth, height * textureHeight)
			PokeInt layer, MEMBLOCK_OFFSET_LayerScaledImage, MakeImage(1,1) 
			PokeInt layer, MEMBLOCK_OFFSET_LayerNewImageCount, 0
			
			changeListSize = LIST_INCREASE_SIZE * MEMBLOCK_SIZE_Image
			
			PokeInt layer, MEMBLOCK_OFFSET_LayerNewImageListSize, changeListSize
			
			PokeInt layer, MEMBLOCK_OFFSET_LayerNewImageList, MakeMEMBlock(changeListSize)

			PokeInt layerObjects, iterator * BYTE_SIZE, layer
			
		next iterator
		
		PokeInt mem, MEMBLOCK_OFFSET_ScreenImageLayers, layerObjects 
	
	Endif 
	
End function 

//Sets value to ImageScreen
Function ImageScreenPut(mem, x, y, imageIndex=0, layer=0, fillLayer=0, fillAllLayers=0)

    If (mem And layer > -1 and imageIndex >= 0 and imageIndex < ScreenImageCount) Then 
        If MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen Then 
		
            width = PeekInt(mem,MEMBLOCK_OFFSET_ScreenWidth)
            height = PeekInt(mem,MEMBLOCK_OFFSET_ScreenHeight)
            layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
			layerObjects = PeekInt(mem,MEMBLOCK_OFFSET_ScreenImageLayers)
			bufferType = PeekByte(mem,MEMBLOCK_OFFSET_ScreenBufferType)
			
			if (bufferType = BUFFERTYPE_MEMBLOCK) then screenBuffer = PeekInt(mem,MEMBLOCK_OFFSET_ScreenBuffer)
			
			//put value to only one cell
            If (fillLayer=0 and layerObjects <> 0 ) Then 
			
				//check that coordinates are inside of screen and layer exists 
                If ( x => 0)( x < width )( y => 0)( y < height )( layer < layerAmount) Then 
				
					//start at last layer if clearing all layerObjects 
					if (fillAllLayers=1) Then layerIndex = layerAmount-1 Else layerIndex = layer
					
					// loop through all layerObjects 
					while (layerIndex >= 0)
					
						// if buffer is used check old value 
						if (bufferType = BUFFERTYPE_MEMBLOCK) then 
							// get old value
							oldValue = PeekInt (screenBuffer,(x + y * width + layerIndex * width * height) * BYTE_SIZE)
							writeValue = (oldValue <> imageIndex )
						else 
							writeValue = true
						endif 

	
						if (writeValue) then 
						
							//set buffer value to imageIndex
							if (bufferType = BUFFERTYPE_MEMBLOCK) then PokeInt screenBuffer,(x + y * width + layerIndex * width * height) * BYTE_SIZE, imageIndex
							
							layerObject = Peekint(layerObjects, layerIndex * BYTE_SIZE) 
							
							if (layerObject <> 0) Then 
							
								layerChangeList = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageList)
								
								if (layerChangeList <> 0) Then 
								
									layerChangedAmount = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageCount)
									
									changeListSize = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize)
									
									//changelist is too small, increase size
									if ( changeListSize < (layerChangedAmount+1) * MEMBLOCK_SIZE_Image) then 
									
										newSize = (layerChangedAmount + LIST_INCREASE_SIZE) * MEMBLOCK_SIZE_Image
										ResizeMEMBlock layerChangeList, newSize
										
										//resize can alter pointer so save
										pokeint layerObject, MEMBLOCK_OFFSET_LayerNewImageList, layerChangeList
										
										
										//store new size 
										PokeInt layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize, newSize
									
									
									endif 
									
									// Add value to changelist 
									PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageIndex, imageIndex
									PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageX, x
									PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageY, y
									
									//increase changelist counter 
									PokeInt layerObject, MEMBLOCK_OFFSET_LayerNewImageCount, layerChangedAmount + 1
									
								endif 
								
							Endif 
							
						EndIf 
						
						//break out if not going to clear all layerObjects
						if (fillAllLayers=0) Then exit
					
					wend 
                    
                EndIf 
				
			// fill this layer 
            ElseIf fillLayer=1 And fillAllLayers=0 Then 
			
				// layer exists 
                If (layer < layerAmount) Then 
				
					layerObject = Peekint(layerObjects, layer * BYTE_SIZE) 
						
					layerChangeList = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageList)
					layerChangedAmount = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageCount)
					changeListSize = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize)
					
					//loop through layer 
                    For x=0 To width - 1
                        For y=0 To height - 1
						
							// if buffer is used check old value 
							if (bufferType = BUFFERTYPE_MEMBLOCK) then 
								// get old value
								oldValue = PeekInt (screenBuffer,(x + y * width + layer * width * height) * BYTE_SIZE)
								writeValue = (oldValue <> imageIndex )
							else 
								writeValue = true
							endif 

							if (writeValue) then 
							
								//set buffer value to imageIndex
								if (bufferType = BUFFERTYPE_MEMBLOCK) then PokeInt screenBuffer,(x + y * width + layer * width * height) * BYTE_SIZE, imageIndex
								
								//changelist is too small, increase size
								if ( changeListSize < (layerChangedAmount+1) * MEMBLOCK_SIZE_Image) then 
									newSize = (layerChangedAmount + LIST_INCREASE_SIZE) * MEMBLOCK_SIZE_Image
									ResizeMEMBlock layerChangeList, newSize
									
									//resize can alter pointer so save
									pokeint layerObject, MEMBLOCK_OFFSET_LayerNewImageList, layerChangeList
									
									//store new size 
									PokeInt layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize, newSize
									
								endif 
								
								// Add value to changelist 
								PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageIndex, imageIndex
								PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageX, x
								PokeInt layerChangeList, layerChangedAmount * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageY, y
								
								//increase changelist counter 
								PokeInt layerObject, MEMBLOCK_OFFSET_LayerNewImageCount, layerChangedAmount + 1

                            EndIf 
							
                        Next y
                    Next x
					
                EndIf 
				
			// clear all -- this is expensive call, avoid if possible
            ElseIf fillLayer=1 And fillAllLayers=1 Then 
			
				 ClearImageScreen(mem)
				
            EndIf 
			
        EndIf 
    EndIf 
End Function 

//Applies ImageScreen Changes 
Function ImageScreenUpdate(mem)

    If mem Then 
        If MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen Then 
		
			width = PeekInt(mem,MEMBLOCK_OFFSET_ScreenWidth)
			height = PeekInt(mem,MEMBLOCK_OFFSET_ScreenHeight)
			
			textureWidth = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureWidth)
			textureHeight = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureHeight)
			
			layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
			layerObjects = PeekInt(mem, MEMBLOCK_OFFSET_ScreenImageLayers)
			
			scaleFactor# = PeekFloat(mem, MEMBLOCK_OFFSET_ScreenRenderScaleFactor)
			
			if ( layerObjects ) Then 
			
				for layerIndex = 0 to layerAmount-1
				
					layerObject = Peekint(layerObjects, layerIndex * BYTE_SIZE) 
					
					if (layerObject ) Then 
					
						layerImage = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerBaseImage)
						
						if layerImage then 
						
							layerChangeList = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageList)
							layerChangedAmount = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageCount)
							changeListSize = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize)
							
							if (layerChangedAmount > 0 and layerChangeList <> 0) Then

								//apply changes to layer 
								for changeIterator = 0 to layerChangedAmount - 1

									value	=	PeekInt(layerChangeList, changeIterator * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageIndex)
									x		=	PeekInt(layerChangeList, changeIterator * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageX)
									y		=	PeekInt(layerChangeList, changeIterator * MEMBLOCK_SIZE_Image + MEMBLOCK_OFFSET_ImageY)
									
									If value >= 0 and value < ScreenImageCount Then 
										CopyBox 0,0,textureWidth,textureHeight,x*textureWidth,y*textureHeight,Image(ScreenImages(value)),Image(layerImage)
									Else
										Drawtoimage layerImage
											color 0,0,0
											box x*textureWidth,y*textureHeight,textureWidth,textureHeight
										drawtoscreen 
									EndIf 

								next changeIterator
								
								if (scaleFactor# <> 1.0) then 
								
									fLayerIndex# = -scaleFactor#^float( layerIndex)
									
									scaledImage = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerScaledImage)
									scaledImage = ScaleImage(layerImage, scaledImage, float(textureWidth*width)*fLayerIndex#, float(height*textureHeight)*fLayerIndex#)
									pokeint layerObject, MEMBLOCK_OFFSET_LayerScaledImage, scaledImage
									
								endif 
								
								suggestedSize = (layerChangedAmount * 2 ) * MEMBLOCK_SIZE_Image
								
								if (changeListSize > suggestedSize) then
								
									resizememblock layerChangeList, suggestedSize
									pokeint layerObject, MEMBLOCK_OFFSET_LayerNewImageList, layerChangeList
									pokeint layerObject, MEMBLOCK_OFFSET_LayerNewImageListSize, suggestedSize

								endif 

								//reset changed amount to zero 
								PokeInt layerObject, MEMBLOCK_OFFSET_LayerNewImageCount, 0
							
							Endif 
						
						EndIf
						
					EndIf 
					
				next layerIndex
				
			Endif 
             
        EndIf 
    EndIf 

End Function 

Function ImageScreenDraw(mem,imageScreenX#=0.0,imageScreenY#=0.0,layerOffsetX#=0.0, layerOffsetY#=0.0)

    If mem Then 
        If MEMBlockSize(mem) = MEMBLOCK_SIZE_Screen Then 
			
			layerAmount = PeekInt(mem,MEMBLOCK_OFFSET_ScreenLayerAmount)
			layerObjects = PeekInt(mem, MEMBLOCK_OFFSET_ScreenImageLayers)
			scaleFactor# = PeekFloat(mem,MEMBLOCK_OFFSET_ScreenRenderScaleFactor)
			
			width = PeekInt(mem,MEMBLOCK_OFFSET_ScreenWidth)
			height = PeekInt(mem,MEMBLOCK_OFFSET_ScreenHeight)
			
			textureWidth = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureWidth)
			textureHeight = PeekInt(mem,MEMBLOCK_OFFSET_ScreenTextureHeight)

			for layerIndex = 0 to layerAmount-1
			
				layerObject = Peekint(layerObjects, layerIndex * BYTE_SIZE)
				layerImage = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerBaseImage)
				scaledImage = PeekInt(layerObject, MEMBLOCK_OFFSET_LayerScaledImage)

				if (scaleFactor# <> 1.0 ) then 
				
					fLayerIndex# = scaleFactor#^float(layerIndex)
				
					w# = float(textureWidth*width)
					widthDiff# = w#/2.0 - w#*fLayerIndex#/2.0
					
					h# = float(textureHeight*height)
					heightDiff# = h#/2.0 - h#*fLayerIndex#/2.0
				
					DrawImage scaledImage, imageScreenX+layerOffsetX#*float(layerIndex)+widthDiff#, imageScreenY+layerOffsetY#*float(layerIndex)+heightDiff#
				else 
				
					fLayerIndex# = float(layerIndex)
				
					DrawImage layerImage, imageScreenX+layerOffsetX#*fLayerIndex#, imageScreenY+layerOffsetY#*fLayerIndex#
				endif 
				
			next layerIndex

             
        EndIf 
    EndIf 

End Function 

//Adds image to Screen images and returns index of image
Function AddScreenImage(img) 

    If (img) Then 
        If (ScreenImageCount >= ScreenImageLimit) Then 
			ClearArray OFF
			ScreenImageLimit = ScreenImageLimit + LIST_INCREASE_SIZE 
			ReDim ScreenImages(ScreenImageLimit) As integer 
		EndIf
		
        ScreenImages(ScreenImageCount) = img
        ScreenImageCount = ScreenImageCount + 1
    Else 
        MakeError "Image is not valid to add into ImageScreen"
    
    EndIf 
	
	imgIndex = ScreenImageCount - 1
    
    Return imgIndex

End Function 

Function DeleteScreenImages()
    If ImageScreenInitialized=0 Then MakeError "You must call ImageScreenInitialize() before calling other ImageScreen functions!"

    For iterator = 0 To ScreenImageLimit
		If ScreenImages(ScreenImageLimit) Then DeleteImage ScreenImages(iterator)
    Next iterator

End Function


Function ScaleImage(_image, _scaled, _width, _height)
   //By: Marcoder
   //Modification: Little optimization handling with ImageWidth() And ImageHeight().
   
   If _width <= 0 Or _height <= 0 Then Return _scaled
   
   DeleteImage _scaled
   _scaled = MakeImage(_width, _height)
   
   _image_width = ImageWidth(_image)
   _image_height= ImageHeight(_image)
   
   // Tehdään temppikuva johon skaalataan ensin vain leveys
   lTempImage = MakeImage(_width, ImageHeight(_image))
   DrawToImage lTempImage
   For x = 0 To _width - 1
      sx# = Float(_image_width) / Float(_width) * Float(x)
      DrawImageBox _image, x, 0, sx, 0, 1, _image_height, OFF,OFF
   Next x
   lTempImage_width = ImageWidth(lTempImage)
   DrawToScreen
   
   // Skaalataan myös pystysuunnassa
   DrawToImage _scaled
   For y = 0 To _height - 1
      sy# = Float(_image_height) / Float(_height) * Float(y)
      DrawImageBox lTempImage, 0, y, 0, sy, lTempImage_width, 1, OFF,OFF
   Next y
   DrawToScreen
   DeleteImage lTempImage
   
   Return _scaled
End Function


SAFEEXIT OFF 

Const LAYERS = 50
SCREEN 1024,768

Const TILE_W = 1
Const TILE_H = 1

Const MARGINX = 200
Const MARGINY = 150

SW = (ScreenWidth() - MARGINX) / TILE_W - 2
SH = (ScreenHeight() - MARGINY) / TILE_H - 2

//alustetaan kuvakirjasto
InitializeImageScreenLibrary()

//luodaan kuvaruutu
map = MakeImageScreen(SW,SH,TILE_W,TILE_H,LAYERS)

img = MakeImage(TILE_W,TILE_H)
DrawToImage img
Color 0,0,0
Box 0,0,TILE_W,TILE_H
DrawToScreen 
//viedään kuva kuvataulukkoon
AddScreenImage(img)

//luodaan kuvat etukäteen
For i=1 To 300
    f# = Float(i Mod 100)
    img = MakeImage(TILE_W,TILE_H)
    DrawToImage img
    If (i / 100 < 1) Then 
        Color  0,0 ,f#*(2.25+Rnd(0.2,0.3))
    ElseIf (i / 100 < 2) Then 
        Color 0, f#*(2.25+Rnd(0.2,0.3)), 0 
    Else 
        Color f#*(2.25+Rnd(0.2,0.3)), 0, 0
    EndIf 
        
    Box 0,0,TILE_W,TILE_H
    DrawToScreen 
    //viedään kuva kuvataulukkoon
    AddScreenImage(img)
Next i 

updateGoingOn = True 

Type ball
    Field x#
    Field y#
    Field z#
    Field sx#
    Field sy#
    Field sz#
    Field col
End Type

Type point
    Field x
    Field y
    Field z
    Field die
End Type

b.ball = New(ball)
b\x = Rnd(SW)
b\y = Rnd(SH)
b\z = Rnd(LAYERS)
b\sx = Rnd(3.0,10.0)
b\sy = Rnd(3.0,10.0)
b\sz = Rnd(1.0,3.0)
b\col = 0

b.ball = New(ball)
b\x = Rnd(SW)
b\y = Rnd(SH)
b\z = Rnd(LAYERS)
b\sx = Rnd(3.0,10.0)
b\sy = Rnd(3.0,10.0)
b\sz = Rnd(1.0,3.0)
b\col = 1


b.ball = New(ball)
b\x = Rnd(SW)
b\y = Rnd(SH)
b\z = Rnd(LAYERS)
b\sx = Rnd(3.0,10.0)
b\sy = Rnd(3.0,10.0)
b\sz = Rnd(1.0,3.0)
b\col = 2

Repeat

    If KeyHit(cbkeyreturn) Then updateGoingOn = Not updateGoingOn
    
    If (updateGoingOn) Then 
    
        For b.ball = Each ball

            For i=0 To 150
            
                size# = 75.0
                
                p.point = New(point)
                
                ang# = Rand(360.0)
                d# = Rnd(0.0,size#)
                
                p\x = Int(b\x + Cos(ang#)*d#)
                p\y = Int(b\y - Sin(ang#)*d#)
                
                p\z = Min(LAYERS,Max(0, Int(b\z + Rand(-2,2))))
                
                p\die = Timer() + Rand(60.0 * size# / Max(2.0,Float(Abs(b\x-p\x)))) + Rand(60.0 * size# / Max(2.0,Float(Abs(b\y-p\y)))) 
                
                col = b\col * 100 + Rand(50+p\z) 
                
                ImageScreenPut(map, p\x, p\y, col, p\z )
            Next i
            
            b\x = b\x + b\sx
            b\y = b\y + b\sy
            b\z =  LAYERS /2 + Cos(Timer()/10.0 + b\col * 120 )* Float(LAYERS /2)           

            If (b\x > SW) Then 
                b\x = SW
                b\sx = - Abs(b\sx)
            EndIf 
            
            If (b\x < 0) Then 
                b\x = 0.0
                b\sx = Abs(b\sx)
            EndIf 
            
            If (b\y > SH) Then 
                b\y = SH
                b\sy = - Abs(b\sy)
            EndIf 
            
            If (b\y < 0) Then 
                b\y = 0.0
                b\sy = Abs(b\sy)
            EndIf 
            
            If (b\z > LAYERS) Then 
                b\z = LAYERS
                b\sz = - Abs(b\sz)
            EndIf 
            
            If (b\z < 0) Then 
                b\z = 0
                b\sz = Abs(b\sz)
            EndIf 
            
        Next b
        
        t = Timer()
        
        For p.point = Each point
            If (t > p\die) Then 
                ImageScreenPut(map, p\x, p\y, 0, p\z )
                Delete p 
            EndIf 
        Next p
       
        ImageScreenUpdate(map)
    
    EndIf 

    mx# = Cos(Timer()/30.0)*(SW/200.0) + MouseWX() * 0.02
    my# = -Sin(Timer()/30.0)*(SH/200.0) - MouseWY() * 0.015
    
    ImageScreenDraw(map,MARGINX/2,MARGINY/2,mx#,my#)
    
    SetWindow ""+FPS()
    
    DrawScreen
    
Until EscapeKey()

//tyhjennetään muisti turhasta tauhkasta
DeleteImageScreen(map)
DeleteScreenImages()

End
NightmareOfCoders
Newcomer
Posts: 2
Joined: Sat Mar 02, 2013 11:15 am

Re: Efektit

Post by NightmareOfCoders »

Pari viikkoa kun olen Coolbasicia täyttänyt, niin teinpä tällaisen efektin, joka piirtää sinisen sävyisen spiraalin. Turhia komentoja löytyy, koska vertailin lukittuun puskuriin tehtyjä pikselikomentoja raakoihin piirtokomentoihin. Suorituskyvyn ero oli suuri. Toivoisin myös, että kertoisitte, onko koodinpätkäni huono vai hyvä aloittelijan tekeleeksi :)

Code: Select all

SCREEN 800,600

//Kulma, etäisyys ja ajastin
angle=60
Dist#=0.0
aika=Timer()

Repeat
    //Kulma ja etäisyys nousevat kokoajan
    angle=angle+1
    dist=dist+0.01
    Lock //Lukitaan puskuri nopeita pikselikomentoja varten.
    //Spiraali
    PutPixel  400 + Cos(angle)*dist,300 + Sin(angle)*dist,Rand(160000)
    Unlock //Vapautetaan puskuri.
//Lisää tähän alle komento Drawscreen OFF, jos haluat seurata spiraalin kasvua(Tämä hidastaa prosessia)

Until dist>500 //Kun spiraali on täyttänyt näytön, poistutaan silmukasta ja katsotaan tulos

DrawScreen

SetWindow(Str(Timer()-aika))

WaitKey 
Sly_Jack0
Devoted Member
Posts: 612
Joined: Mon Dec 10, 2007 8:25 am

Re: Efektit

Post by Sly_Jack0 »

Ihan hieno on! Lisää nopeutta saa lukitsemalla puskurin jo ennen silmukkaa ja vapauttamalla sen jälkee.
User avatar
axu
Devoted Member
Posts: 854
Joined: Tue Sep 18, 2007 6:50 pm

Re: Efektit

Post by axu »

NightmareOfCoders wrote:Pari viikkoa kun olen Coolbasicia täyttänyt, niin teinpä tällaisen efektin, joka piirtää sinisen sävyisen spiraalin. Turhia komentoja löytyy, koska vertailin lukittuun puskuriin tehtyjä pikselikomentoja raakoihin piirtokomentoihin. Suorituskyvyn ero oli suuri. Toivoisin myös, että kertoisitte, onko koodinpätkäni huono vai hyvä aloittelijan tekeleeksi :)
Ihan hienohan tuo on! Suorituskykyä voit vielä huomattavasti parantaa, kun lukitset puskurin heti alkuunsa ja vapautat sen koko kuvan piirryttyä. Omalla koneellani tällä tavoin efektin pyöri jopa 30 fps.
EDIT:

Näin sitä koodilla värkkäillessä Sly_Jack vei viestini sisällön harkittuja alkusanoja myöten :O

Jos tämä viesti on kirjoitettu alle 5 min. sitten, päivitä sivu. Se on saattanut jo muuttua :roll:
Image
NightmareOfCoders
Newcomer
Posts: 2
Joined: Sat Mar 02, 2013 11:15 am

Re: Efektit

Post by NightmareOfCoders »

Kiitoksia positiivisesta palautteesta ja neuvoista! :) Joo, kyllä nopeutu tuolla kikalla, itselläni suoritusaika tippui 300>30ms, miltein kymmenkertainen nopeutuminen. Ja Axu: Katsoitko siis FPS:ää vai suoritusaikaa? Sillä FPS ei anna oikeata käsitystä suorituskyvystä, kun on tällainen operaatio kyseessä. Vaan suorituskyvyn mittaa se, miten pitkään kyseinen operaatio on vienyt.
User avatar
axu
Devoted Member
Posts: 854
Joined: Tue Sep 18, 2007 6:50 pm

Re: Efektit

Post by axu »

NightmareOfCoders wrote:Kiitoksia positiivisesta palautteesta ja neuvoista! :) Joo, kyllä nopeutu tuolla kikalla, itselläni suoritusaika tippui 300>30ms, miltein kymmenkertainen nopeutuminen. Ja Axu: Katsoitko siis FPS:ää vai suoritusaikaa? Sillä FPS ei anna oikeata käsitystä suorituskyvystä, kun on tällainen operaatio kyseessä. Vaan suorituskyvyn mittaa se, miten pitkään kyseinen operaatio on vienyt.
Katsoin suoritusaikaa efektin pyöriessä loopissa, josta laskin fps:n.
EDIT:

Siis FPS:n laskin korostaakseni sitä, että efektiä voi pyörittää jopa interaktiivisella nopeudella.

Last edited by axu on Thu Mar 21, 2013 9:00 pm, edited 1 time in total.
Jos tämä viesti on kirjoitettu alle 5 min. sitten, päivitä sivu. Se on saattanut jo muuttua :roll:
Image
koodaaja
Moderator
Moderator
Posts: 1583
Joined: Mon Aug 27, 2007 11:24 pm
Location: Otaniemi - Mikkeli -pendelöinti

Re: Efektit

Post by koodaaja »

Mikäli mittaa koko loopin aikaa, FPS ja suoritusaika ovat vain toistensa käänteislukuja. Yleisesti ottaen parempi on kuitenkin mitata aikaa, koska siten voi mitata vain jonkin kriittisen osan suoritusaikaa ja vertailla niitä eri toteutustapojen välillä - lisäksi se skaalaa lineaarisesti, eli kaksi kertaa saman efektin tekeminen vie kaksi keraa enemmän aikaa, FPS ei toimi yhtä miellyttävästi.
Kumiankka
Member
Posts: 65
Joined: Wed May 18, 2011 5:17 pm
Location: Artjärvi

Re: Efektit

Post by Kumiankka »

Tulipa tossa hetken mielijohteesta tehtyä jonkunlainen Cellular Automata, mutta en jaksanut loppujenlopuksi miettiä kunnon sääntöjä joten siitä tuli vaan jännä efekti :lol:
Pidemmittä puheitta, koodi ilman minkäänlaista optimointia, siivoamista tai kommentteja:

Code: Select all

SCREEN 640, 640

Const CELL_WIDTH = 16
Const CELL_HEIGHT = 16

Const SIZE = 0
Const SIZE_ADD = 1

// nNeightbors <= RULE_GROW_MAX -> Neightbor cells grow
Const RULE_GROW_MAX = 3
// nNeightbors >= RULE_SHRINK_MIN -> Self shrinks
Const RULE_SHRINK_MIN = 5

Const CELL_SIZE_MAX = 9
CELL_COLOR_MODIFIER# = 255.0 / (CELL_SIZE_MAX + 1)

Const CELLS_SIZE = 39
Dim cells(CELLS_SIZE, CELLS_SIZE, 1)
For x = 0 To CELLS_SIZE
	For y = 0 To CELLS_SIZE
		cells(x, y, SIZE) = Rand(0, CELL_SIZE_MAX)
	Next y
Next x

Repeat

	For x = 0 To CELLS_SIZE
		For y = 0 To CELLS_SIZE
			nNeightbors = 0
			
			// -1, -1
			If x > 0 And y > 0 Then
				If cells(x - 1, y - 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			//  0, -1
			If y > 0 Then
				If cells(x, y - 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			//  1, -1
			If x < CELLS_SIZE And y > 0 Then 
				If cells(x + 1, y - 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			// -1, 0
			If x > 0 Then 
				If cells(x - 1, y, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			//  1, 0
			If x < CELLS_SIZE Then 
				If cells(x + 1, y, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			// -1, 1
			If x > 0 And y < CELLS_SIZE Then 
				If cells(x - 1, y + 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			//  0, 1
			If y < CELLS_SIZE Then 
				If cells(x, y + 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
			//  1, 1
			If x < CELLS_SIZE And y < CELLS_SIZE Then
				If cells(x + 1, y + 1, SIZE) >= 5 Then nNeightbors = nNeightbors + 1
			EndIf
		
		
			If nNeightbors <= RULE_GROW_MAX Then
				cells(x, y, SIZE_ADD) = cells(x, y, SIZE_ADD) - (8 - nNeightbors)
				
				// -1, -1
				If x > 0 And y > 0 Then 
					If cells(x - 1, y - 1, SIZE) <= 5 Then cells(x - 1, y - 1, SIZE_ADD) = cells(x - 1, y - 1, SIZE_ADD) + 1
				EndIf
				//  0, -1
				If y > 0 Then 
					If cells(x, y - 1, SIZE) <= 5 Then cells(x, y - 1, SIZE_ADD) = cells(x, y - 1, SIZE_ADD) + 1
				EndIf
				//  1, -1
				If x < CELLS_SIZE And y > 0 Then 
					If cells(x + 1, y - 1, SIZE) <= 5 Then cells(x + 1, y - 1, SIZE_ADD) = cells(x + 1, y - 1, SIZE_ADD) + 1
				EndIf
				// -1, 0
				If x > 0 Then
					If cells(x - 1, y, SIZE) <= 5 Then cells(x - 1, y, SIZE_ADD) = cells(x - 1, y, SIZE_ADD) + 1
				EndIf
				//  1, 0
				If x < CELLS_SIZE Then 
					If cells(x + 1, y, SIZE) <= 5 Then cells(x + 1, y, SIZE_ADD) = cells(x + 1, y, SIZE_ADD) + 1
				EndIf
				// -1, 1
				If x > 0 And y < CELLS_SIZE Then
					If cells(x - 1, y + 1, SIZE) <= 5 Then cells(x - 1, y + 1, SIZE_ADD) = cells(x - 1, y + 1, SIZE_ADD) + 1
				EndIf
				//  0, 1
				If y < CELLS_SIZE Then 
					If cells(x, y + 1, SIZE) <= 5 Then cells(x, y + 1, SIZE_ADD) = cells(x, y + 1, SIZE_ADD) + 1
				EndIf
				//  1, 1
				If x < CELLS_SIZE And y < CELLS_SIZE Then 
					If cells(x + 1, y + 1, SIZE) <= 5 Then cells(x + 1, y + 1, SIZE_ADD) = cells(x + 1, y + 1, SIZE_ADD) + 1
				EndIf
			ElseIf nNeightbors >= RULE_SHRINK_MIN Then
				cells(x, y, SIZE_ADD) = cells(x, y, SIZE_ADD) - 1
			EndIf
		Next y
	Next x
	
	For x = 0 To CELLS_SIZE
		For y = 0 To CELLS_SIZE
			cells(x, y, SIZE) = Max(Min(cells(x, y, SIZE) + cells(x, y, SIZE_ADD), CELL_SIZE_MAX), 0)
			
			Color cells(x, y, SIZE) * CELL_COLOR_MODIFIER, 255 - cells(x, y, SIZE) * CELL_COLOR_MODIFIER, 0
		
			Box x * CELL_WIDTH, y * CELL_HEIGHT, CELL_WIDTH, CELL_HEIGHT, True
			
			//CenterText x * CELL_WIDTH + (CELL_WIDTH / 2.0), y * CELL_HEIGHT + (CELL_HEIGHT / 2.0), "" + cells(x, y, SIZE), 2
		Next y
	Next x

	DrawScreen

	//WaitKey	
	SetWindow "FPS" + FPS()
	
Forever 
User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema »

NightmareOfCoders wrote:Pari viikkoa kun olen Coolbasicia täyttänyt, niin teinpä tällaisen efektin, joka piirtää sinisen sävyisen spiraalin. Turhia komentoja löytyy, koska vertailin lukittuun puskuriin tehtyjä pikselikomentoja raakoihin piirtokomentoihin. Suorituskyvyn ero oli suuri. Toivoisin myös, että kertoisitte, onko koodinpätkäni huono vai hyvä aloittelijan tekeleeksi :)

Code: Select all

SCREEN 800,600

//Kulma, etäisyys ja ajastin
angle=60
Dist#=0.0
aika=Timer()

Repeat
    //Kulma ja etäisyys nousevat kokoajan
    angle=angle+1
    dist=dist+0.01
    Lock //Lukitaan puskuri nopeita pikselikomentoja varten.
    //Spiraali
    PutPixel  400 + Cos(angle)*dist,300 + Sin(angle)*dist,Rand(160000)
    Unlock //Vapautetaan puskuri.
//Lisää tähän alle komento Drawscreen OFF, jos haluat seurata spiraalin kasvua(Tämä hidastaa prosessia)

Until dist>500 //Kun spiraali on täyttänyt näytön, poistutaan silmukasta ja katsotaan tulos

DrawScreen

SetWindow(Str(Timer()-aika))

WaitKey 

Minulla oli tylsää ja tekeleesi inspiroimana sitten...

Code: Select all

SCREEN 800,600

//Kulma, etäisyys ja ajastin
angle# = 60
dist# = 0.0
elo# = 0.0

SetFont LoadFont("Tahoma", 24, True, False, False)

// Laita tämä päälle jos musta tausta ei sovi
// ClsColor 16,24,128

While Not KeyDown(cbKeyEscape)

    elo = elo - 5.0
       
    aika=Timer()

    UpdateLoading(elo, 700, 500)
    
    SetWindow(Str(Timer()-aika))
    
    DrawScreen
    
    

Wend

Function RGB(r,g,b)
    Return 255 Shl 24 + r Shl 16 + g Shl 8 + b
End Function

Function UpdateLoading(elo, x1, y1)
    
    // Jollet taas halua käyttää ClsColor:ia, käytä 2 seuraavaa riviä
    
    //Color 16,24,128
    //Circle x1 - 100, y1 - 100, 200, True
    

    Lock
    Repeat
        angle#=angle+1
        dist#=dist+0.01
        c = angle * dist

        x# = x1 + Cos(angle + elo) * dist
        y# = y1 + Sin(angle + elo) * dist
        
        If x >= 0 And x < ScreenWidth() And y >= 0 And y < ScreenHeight() Then PutPixel2 x, y, RGB(0,0,c), SCREEN()
    
    Until dist>100.0
    Unlock

    
    Color 10,10,10
    CenterText x1+2,y1+2,"Loading",2
    Color 255,255,255
    CenterText x1,y1,"Loading",2
End Function
Jani
Devoted Member
Posts: 741
Joined: Fri Oct 31, 2008 4:53 pm

Re: Efektit

Post by Jani »

Mistheman lataushärpäke on kyllä aivan mahtava! Tuota jaksaa katsellakkin, toisin kuin tylsää palkkia.
Dead men tell no tales. Also, Python rocks!
Codegolf: 99 bottles of beer (oneliner) - Water map partition
User avatar
CCE
Artist
Artist
Posts: 650
Joined: Mon Aug 27, 2007 9:53 pm

Re: Efektit

Post by CCE »

Kas tässäpä pätkä joka analysoi kuvan värit ja piirtää ne kolmiulotteiseen avaruuskuutioon.

Code: Select all

SCREEN 800, 480
clsColor 32,32,32
clearArray OFF
imagepath$ = "media/guy.bmp"
img = loadImage(imagepath)
colorblock = find_unique_colors(img)

setWindow "done "

unique_colors = peekInt(colorblock, 0)
addText "analyzed " + imagepath
addText "unique colors: " + unique_colors

repeat
	draw_color_cube(350, 320, colorblock)
	drawScreen
forever


function draw_color_cube(cx, cy, cblock)
	colors = peekInt(cblock, 0)

	w = 200
	ratio# = 0.25
	ang# = 25.0 + timer()*0.04
	color 64,64,64
	
	line cx , cy, cx + w*cos(ang), cy + w*sin(ang) * 0.5
	line cx , cy , cx + w*cos(ang+90), cy + w*sin(ang+90) * 0.5
	line cx , cy , cx, cy - w 
	//line cx, cy, cx - w*ratio, cy + w*ratio
	boxsize = 3
	
	for i = 1 to colors-1
		pix = peekInt(cblock, i*4)
		color 0,0, pix
		
		x = (getRGB(RED) / 255.0) * w
		y = (getRGB(GREEN) / 255.0) * w
		z = (getRGB(BLUE) / 255.0) * w
		
		sx# = x*cos(ang) + z * cos(ang + 90) 
		sy# = x*sin(ang) + z * sin(ang + 90) 
		sy# = sy * 0.5 - y
		
		
		box cx + sx, cy + sy, boxsize, boxsize, 1
	next i
endFunction

function find_unique_colors(img)
	colors = 0
	size = 512
	temp = makeMEMBlock(size*4)
	
	pixels = imageWidth(img) * imageHeight(img)
	
	lock(image(img))
	
	for y=0 to imageHeight(img)-1
	for x=0 to imageWidth(img)-1
		pix = getPixel2(x, y, image(img))
		found = false
		
		for i = 0 to colors-1
			//setWindow "" + pix + ""
			//setWindow "" + peekInt(temp, i) + ""
			if peekInt(temp, i*4) = pix then
				found = true
				
				exit
			endif
			
		next i
		
		if not found then 
			if colors >= size then
				size = size*size
				resizeMEMBlock temp, size*4
			endif
			
			pokeInt temp, colors*4, pix
			colors = colors+1
		endif
		
	next x
		setWindow "y: " + y + " : colors " + colors 
	next y
	
	
	
	unlock(image(img))
	
	colorblock = makeMEMBlock(colors*4+4)
	memCopy temp, 0, colorblock, 4, colors*4
	pokeInt colorblock, 0, colors
	deleteMEMBlock temp
	
	return colorblock
endFunction
Edit: Pieni offset-virhe korjattu.
User avatar
MetalRain
Active Member
Posts: 188
Joined: Sun Mar 21, 2010 11:17 am
Location: Espoo

Re: Efektit

Post by MetalRain »

CCE wrote:Kas tässäpä pätkä joka analysoi kuvan värit ja piirtää ne kolmiulotteiseen avaruuskuutioon.
Ilmeisesti nuo suorat linjat on enimmäkseen kuvassa käytettyjä liukuvärejä. Tulipa niistä mieleen että miltäköhän kuva näyttäisi jos sen pakkaisi siten että koittaisi pakata kuvan väridatan mahdollisimman pieneen määrään tuollaisia"värisuoria" ja käsittelisi värejä pisteinä kyseisillä suorilla.

media/map.bmp näyttää muuten aika jännältä analysoituna.
naputtelija
Devoted Member
Posts: 718
Joined: Wed Nov 03, 2010 7:56 pm
Location: Joku piste pohjoisessa.

Re: Efektit

Post by naputtelija »

Mandelbrotin sarja erittäin tehokkaasti optimoituna.

Code: Select all

SCREEN 800,600
minRe# = -2.0
maxRe# = 1.0
minIm# = -1.2
maxIm# = minIm+(maxRe-minRe)*ScreenHeight()/ScreenWidth()
re_factor# = (maxRe-minRe)/(ScreenWidth()-1)
im_factor# = (maxIm-minIm)/(ScreenHeight()-1)
maxIterations = 30
div2# = Float(maxIterations/2)
min1# = Float(maxIterations-1)
ti=Timer()
Lock
For y=0 To ScreenHeight()
    c_im# = maxIm - y*im_factor
    For x=0 To ScreenWidth()
        c_re# = minRe + x*re_factor
        
        Z_re# = c_re
        Z_im# = c_im
        For n=0 To maxIterations
            Z_re2# = Z_re*Z_re
            Z_im2# = Z_im*Z_im
            If Z_re2 + Z_im2 >4 Then Exit
            Z_im = 2*Z_re*Z_im + c_im
            Z_re = Z_re2 - Z_im2 + c_re
        Next n
        If n<div2 Then
            col#=n/div2
            PutPixel2 x,y,Int(col*255) Shl 16 + 0 Shl 8
        ElseIf n>=div2 And n<maxIterations
            col#=(n-div2)/(min1-div2)
            PutPixel2 x,y,Int(col*255) + 255 Shl 16 + Int(col*255) Shl 8
        EndIf
    Next x
Next y
Unlock
comp# = (Timer()-ti)/1000.0
Color cbWhite
Text 0,0,"complete in "+comp+" secs"
DrawScreen
WaitKey
<Ize> Pitäs tehä allekirjotus..
<Ize> Vois keksiä jonkin nasahtavan sanonnan..
<Ize> Siitä tulis upea legenda ja kaikki vaihtaisivat allekirjoituksensa siihen.
<Ize> Ehkä ei kuitenkaa...
User avatar
MetalRain
Active Member
Posts: 188
Joined: Sun Mar 21, 2010 11:17 am
Location: Espoo

Re: Efektit

Post by MetalRain »

naputtelija wrote:Mandelbrotin sarja erittäin tehokkaasti optimoituna.

Code: Select all

SCREEN 800,600
minRe# = -2.0
maxRe# = 1.0
minIm# = -1.2
maxIm# = minIm+(maxRe-minRe)*ScreenHeight()/ScreenWidth()
re_factor# = (maxRe-minRe)/(ScreenWidth()-1)
im_factor# = (maxIm-minIm)/(ScreenHeight()-1)
maxIterations = 30
div2# = Float(maxIterations/2)
min1# = Float(maxIterations-1)
ti=Timer()
Lock
For y=0 To ScreenHeight()
    c_im# = maxIm - y*im_factor
    For x=0 To ScreenWidth()
        c_re# = minRe + x*re_factor
        
        Z_re# = c_re
        Z_im# = c_im
        For n=0 To maxIterations
            Z_re2# = Z_re*Z_re
            Z_im2# = Z_im*Z_im
            If Z_re2 + Z_im2 >4 Then Exit
            Z_im = 2*Z_re*Z_im + c_im
            Z_re = Z_re2 - Z_im2 + c_re
        Next n
        If n<div2 Then
            col#=n/div2
            PutPixel2 x,y,Int(col*255) Shl 16 + 0 Shl 8
        ElseIf n>=div2 And n<maxIterations
            col#=(n-div2)/(min1-div2)
            PutPixel2 x,y,Int(col*255) + 255 Shl 16 + Int(col*255) Shl 8
        EndIf
    Next x
Next y
Unlock
comp# = (Timer()-ti)/1000.0
Color cbWhite
Text 0,0,"complete in "+comp+" secs"
DrawScreen
WaitKey
Kun optimoinnista kerran on puhe niin pitihän tuota saada vielä nopeammaksi. Lopputulos ei ole aivan sama, mutta omalla koneellani noin neljä kertaa nopeampi.

Code: Select all

// käytetään vakioita 
Const SW = 800
Const SH = 600
Const maxIterations = 30
Const shl24 = 16711680 // = 255 shl 16
SH2 = SH/2

SCREEN SW, SH


//arvot säädetty niin että keskikohta osuu kivasti peilaussaumaan
//ja muoto ei näytä venyneeltä
pos# = 1.6
maxRe# = (float(SW) / float(SH))
minIm# = -pos#
maxIm# = pos# 
minRe# = minIm / maxRe# - maxIm# - maxRe#

re_factor# = (maxRe-minRe) / (Float(SW) - 1.0)
im_factor# = (maxIm-minIm) / (Float(SH) - 1.0)

ti=Timer()

//esilaskentaa varten taulut
Dim c_re_arr(sw,2) As Float 
Dim iCol_arr(maxIterations)

//esilasketaan arvot
For x=0 To sw
  c_re_arr(x,0) = minRe + x * re_factor  
  //otetaan neliöt talteen
  c_re_arr(x,1) = c_re_arr(x,0) * c_re_arr(x,0)
Next x

//esilasketaan iteraatioiden väriarvot
div2# = Float(maxIterations/2.0)
div3# = Float(maxIterations-1.0) - div2

For i=0 To maxIterations
    If i < div2 Then
        iCol_arr(i) = (i / div2) * shl24
    ElseIf i >= div2 And i < maxIterations
        tCol = (i-div2) / div3# * 255
        iCol_arr(i) = tCol + shl24 + tCol Shl 8
    EndIf
Next i

//piirretään efektistä vain puolikas kuvaan
img = MakeImage(SW,SH2)
Lock Image(img)
For y=0 To sh2-1

    c_im# = maxIm - y * im_factor
    
    // esilasketaan ensimmäiset neliöt
    // jotta iteraatiot n=0 on halpoja
    c_im2# = c_im * c_im
    
    For x=0 To SW-1
    
        c_re# = c_re_arr(x,0)
        
        Z_re# = c_re
        Z_im# = c_im
        
        Z_re2# = c_re_arr(x,1)
        Z_im2# = c_im2#
       
        For n=0 To maxIterations
            If Z_re2 + Z_im2 > 4 Then Exit
            Z_im = 2 * Z_re * Z_im + c_im
            Z_re = Z_re2 - Z_im2 + c_re
            Z_re2# = Z_re * Z_re
            Z_im2# = Z_im * Z_im
        Next n
        
        PutPixel2 x,y, iCol_arr(n), Image(img)
    Next x
Next y
Unlock Image(img)

//piirretään yläpuoli
DrawImageBox img,0,0,0,0,SW,SH2
//peilataan
ResizeImage img,SW,-SH2
//piiretään alapuoli
DrawImageBox img,0,SH2,0,0,SW,SH2

comp# = (Timer()-ti)/1000.0
Color cbWhite
Text 0,0,"complete in "+comp+" secs"
DrawScreen
WaitKey
koodaaja
Moderator
Moderator
Posts: 1583
Joined: Mon Aug 27, 2007 11:24 pm
Location: Otaniemi - Mikkeli -pendelöinti

Re: Efektit

Post by koodaaja »

Isketääs tämä tännekin. Shadebobeja yhden ZX -demon innoittamana, renderöintinopeuksia eri pallomäärille saa ilmoitella.

Code: Select all

SCREEN 640, 480
Dim imgs(9)

Repeat
    If im = 0 And ang = 0 Then
        ball = MakeImage(50, 50)
        DrawToImage ball
        For i = 0 To 49
            If i<10 then imgs(i) = MakeImage(640, 480)
            For j = 0 To 49
                If Distance(i,j,25,25)<23 Then
                    c# = Max(.0, .1+.45*((i-25)/24.0-(j-25)/24.0+Sqrt(1-(i-25)*(i-25)/576.0-(j-25)*(j-25)/756.0)))
                    Color 20+c*80, 40+c*80, 100+c*100
                Else
                    Color 255, 0, 255
                EndIf
                Dot i, j
            Next j
        Next i
        DrawToScreen
        MaskImage ball, 255, 0, 255
        
        Color 255, 255, 255
        im = 0
    EndIf
    im = (im + 1) Mod 10
    DrawToImage imgs(im)
    For i = 0 To balls + 1
        DrawImage ball, 320+120.0*Cos(.20*(ang+im))-80*Sin(.60*(ang+im))-25, 240+120*Sin(.17*(ang+im))+80*Cos(.57*(ang+im))-25
    Next i
    If im = 9 Then
        ang = ang + 9
        count + 1
    EndIf
    DrawToScreen
    DrawImage imgs(im), 0, 0
    Text 5,5, "CB knows no boundaries (FPS():"+Str(FPS())+")"
    Text 400, 460, Str(count)+" bobs by msqrt/Peisik"
    DrawScreen
Forever
Post Reply