Das deutsche QBasic- und FreeBASIC-Forum :: Thema anzeigen

Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!

FAQ

Suchen

Mitgliederliste

Benutzergruppen

Registrieren

Profil

Einloggen, um private Nachrichten zu lesen

Zur Begleitseite des Forums / Chat / Impressum

Aktueller Forenpartner:

Chaoten-Plasma

Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.

Vorheriges Thema anzeigen :: Nächstes Thema anzeigen

Autor

Nachricht

Eternal_pain

Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

Verfasst am: 18.08.2007, 13:58 Titel: Chaoten-Plasma

Bei einem Langeweile-Versuch ohne wirklich zu wissen was ich da mache ein "Mini"-Plasma zu coden, entstand ein CPU-Fressendes aber dennoch interessantes... 'Irgendwas?' vor lachen auf dem Boden rollen

Code:

Const W=640 'Breite
Const H=480 'Hoehe
Screen 18,32 'Bilderschirm Initialisieren (640x480 32bpp)

'Mini-Plasma-Versuch'

'Grundfarben'
#Define Rot &hFF0000
#Define Gruen &h00FF00
#Define Blau &h0000FF
#Define Pink &hFF00FF
#Define Gelb &hFFFF00
#Define HBlau &h00FFFF

Function CreateRaster (Byval XSize as UByte, Byval YSize as UByte) as UByte Ptr
If XSize=0 or YSize=0 Then Return 0

Dim RasterPTR as UByte Ptr
RasterPTR=Allocate((XSize*YSize)+2)

RasterPTR[0]=XSize
RasterPTR[1]=YSize

For y as Integer=1 to YSize
For x as Integer=1 to XSize
RasterPTR[(x*y)+1]=Int(Rnd*6)
Next x
Next y

Return RasterPTR
End Function

Sub EraseRaster (Byref RasterPTR as UByte Ptr)
If RasterPTR Then
DeAllocate (RasterPTR)
End If
End Sub

Sub MoveRaster (Byref RasterPTR as UByte Ptr)
Dim XMD as byte=Int(rnd*3)-1

If XMD Then
For ym as integer=1 to RasterPTR[1]

Select Case XMD
Case -1
RasterPTR[(RasterPTR[0]*ym)+1]=RasterPTR[(1*ym)+1]

For xm as integer=1 to RasterPTR[0]-1
RasterPTR[(xm*ym)+1]=RasterPTR[(xm*ym)+2]
Next xm

Case 1
RasterPTR[(RasterPTR[0]*ym)+1]=RasterPTR[(1*ym)+1]
For xm as integer=RasterPTR[0]-1 to 1 Step -1
RasterPTR[(xm*ym)+1]=RasterPTR[(xm*ym)+2]
Next xm
End Select
Next ym

End If

End Sub

Sub ShowPlasma (Byref RasterPTR as UByte Ptr)
If RasterPTR=0 Then Exit Sub

Dim as Double Rad = ((ATN(1) * 4) / 180)

Dim Grundfarben(5) as Integer={Rot,Gruen,Blau,Pink,Gelb,HBlau}
Dim OnScreen as UInteger Ptr=ScreenPtr

Dim ScrRFarbeol as UInteger
Dim ScrPFarbeol as Any Ptr=@ScrRFarbeol
Dim ScrFarbeol as UByte Ptr=ScrPFarbeol

Dim ScrRFarbeor as UInteger
Dim ScrPFarbeor as Any Ptr=@ScrRFarbeor
Dim ScrFarbeor as UByte Ptr=ScrPFarbeor

Dim ScrRFarbeur as UInteger
Dim ScrPFarbeur as Any Ptr=@ScrRFarbeur
Dim ScrFarbeur as UByte Ptr=ScrPFarbeur

Dim ScrRFarbeul as UInteger
Dim ScrPFarbeul as Any Ptr=@ScrRFarbeul
Dim ScrFarbeul as UByte Ptr=ScrPFarbeul

Dim RstRFarbe as UInteger
Dim RstPFarbe as Any Ptr=@RstRFarbe
Dim RstFarbe as UByte Ptr=RstPFarbe

Dim NewFarbeR as UByte
Dim NewFarbeG as UByte
Dim NewFarbeB as UByte
Dim NewFarbe as Integer

Dim SizeX as UByte=RasterPTR[0]
Dim SizeY as UByte=RasterPTR[1]

If OnScreen[0]=&hFF000000 or OnScreen[0]=&h00 Then
ScreenLock

For y as Integer=1 To SizeY
For x as Integer=1 To SizeX
Line (((x-1)*10),((y-1)*10))-((x*10),(y*10)),Grundfarben(RasterPTR[(x*y)+1]),bf
Next x
Next y

ScreenUnLock
End If

Dim LeftBlock as Integer
Dim RightBlock as Integer
Dim UpBlock as Integer
Dim DownBlock as Integer

Dim PRadc as Double
Dim PRads as Double
Dim XPos as Integer
Dim YPos as Integer

Dim ScrRFarbeXPol as Integer
Dim ScrRFarbeYPol as Integer
Dim ScrRFarbeXPor as Integer
Dim ScrRFarbeYPor as Integer
Dim ScrRFarbeXPul as Integer
Dim ScrRFarbeYPul as Integer
Dim ScrRFarbeXPur as Integer
Dim ScrRFarbeYPur as Integer

Dim NSFarbe as Integer

ScreenLock
For y as Integer=1 To SizeY
For x as Integer=1 To SizeX
XPos=x*10 : YPos=y*10

'' Nebenstehenden Block Festlegen ''
LeftBlock = x
RightBlock = x+1
If RightBlock>RasterPTR[0] Then RightBlock=1

UpBlock = y
DownBlock = y+1
If DownBlock>RasterPTR[1] Then DownBlock=1
'' ------------------------------ ''

For l as integer=0 to 6 'Radius

For ll as integer=0 to 359 Step (360/((l+1)*8))
PRadc=(Cos(ll*Rad)*(l))
PRads=(Sin(ll*Rad)*(l))

ScrRFarbeXPol=PRadc + (XPos-1)
ScrRFarbeYPol=PRads + (YPos-1)

If ScrRFarbeXPol<0 Then ScrRFarbeXPol+=(RasterPTR[0]*10)
If ScrRFarbeXPol>((RasterPTR[0]*10)-1) Then ScrRFarbeXPol-=(RasterPTR[0]*10)

If ScrRFarbeYPol<0 Then ScrRFarbeYPol+=(RasterPTR[1]*10)
If ScrRFarbeYPol>((RasterPTR[1]*10)-1) Then ScrRFarbeYPol-=(RasterPTR[1]*10)

ScrRFarbeXPor=PRadc + XPos
ScrRFarbeYPor=PRads + (YPos-1)

If ScrRFarbeXPor<0 Then ScrRFarbeXPor+=(RasterPTR[0]*10)
If ScrRFarbeXPor>((RasterPTR[0]*10)-1) Then ScrRFarbeXPor-=(RasterPTR[0]*10)

If ScrRFarbeYPor<0 Then ScrRFarbeYPor+=(RasterPTR[1]*10)
If ScrRFarbeYPor>((RasterPTR[1]*10)-1) Then ScrRFarbeYPor-=(RasterPTR[1]*10)

ScrRFarbeXPul=PRadc + (XPos-1)
ScrRFarbeYPul=PRads + YPos

If ScrRFarbeXPul<0 Then ScrRFarbeXPul+=(RasterPTR[0]*10)
If ScrRFarbeXPul>((RasterPTR[0]*10)-1) Then ScrRFarbeXPul-=(RasterPTR[0]*10)

If ScrRFarbeYPul<0 Then ScrRFarbeYPul+=(RasterPTR[1]*10)
If ScrRFarbeYPul>((RasterPTR[1]*10)-1) Then ScrRFarbeYPul-=(RasterPTR[1]*10)

ScrRFarbeXPur=PRadc + XPos
ScrRFarbeYPur=PRads + YPos

If ScrRFarbeXPur<0 Then ScrRFarbeXPur+=(RasterPTR[0]*10)
If ScrRFarbeXPur>((RasterPTR[0]*10)-1) Then ScrRFarbeXPur-=(RasterPTR[0]*10)

If ScrRFarbeYPur<0 Then ScrRFarbeYPur+=(RasterPTR[1]*10)
If ScrRFarbeYPur>((RasterPTR[1]*10)-1) Then ScrRFarbeYPur-=(RasterPTR[1]*10)

ScrRFarbeol=OnScreen[ScrRFarbeXPol+(ScrRFarbeYPol*W)]
ScrRFarbeul=OnScreen[ScrRFarbeXPul+(ScrRFarbeYPul*W)]
ScrRFarbeor=OnScreen[ScrRFarbeXPor+(ScrRFarbeYPor*W)]
ScrRFarbeur=OnScreen[ScrRFarbeXPur+(ScrRFarbeYPur*W)]

''OL
RstRFarbe=Grundfarben(RasterPTR[(LeftBlock*UpBlock)+1])
NewFarbeR=(ScrFarbeol[2]/5)+ _
(ScrFarbeor[2]/5)+ _
(ScrFarbeul[2]/5)+ _
(ScrFarbeur[2]/5)+ _
(RstFarbe[2]/5)

NewFarbeG=(ScrFarbeol[1]/5)+ _
(ScrFarbeor[1]/5)+ _
(ScrFarbeul[1]/5)+ _
(ScrFarbeur[1]/5)+ _
(RstFarbe[1]/5)

NewFarbeB=(ScrFarbeol[0]/5)+ _
(ScrFarbeor[0]/5)+ _
(ScrFarbeul[0]/5)+ _
(ScrFarbeur[0]/5)+ _
(RstFarbe[0]/5)
'OnScreen[ScrRFarbeXPol+(ScrRFarbeYPol*W)]=RGB(NewFarbeR,NewFarbeG,NewFarbeB)
PSet(ScrRFarbeXPol,ScrRFarbeYPol),RGB(NewFarbeR,NewFarbeG,NewFarbeB)

''OR
RstRFarbe=Grundfarben(RasterPTR[(RightBlock*UpBlock)+1])
NewFarbeR=(ScrFarbeol[2]/5)+ _
(ScrFarbeor[2]/5)+ _
(ScrFarbeul[2]/5)+ _
(ScrFarbeur[2]/5)+ _
(RstFarbe[2]/5)

NewFarbeG=(ScrFarbeol[1]/5)+ _
(ScrFarbeor[1]/5)+ _
(ScrFarbeul[1]/5)+ _
(ScrFarbeur[1]/5)+ _
(RstFarbe[1]/5)

NewFarbeB=(ScrFarbeol[0]/5)+ _
(ScrFarbeor[0]/5)+ _
(ScrFarbeul[0]/5)+ _
(ScrFarbeur[0]/5)+ _
(RstFarbe[0]/5)
'OnScreen[ScrRFarbeXPor+(ScrRFarbeYPor*W)]=RGB(NewFarbeR,NewFarbeG,NewFarbeB)
PSet(ScrRFarbeXPor,ScrRFarbeYPor),RGB(NewFarbeR,NewFarbeG,NewFarbeB)

''UL
RstRFarbe=Grundfarben(RasterPTR[(LeftBlock*DownBlock)+1])
NewFarbeR=(ScrFarbeol[2]/5)+ _
(ScrFarbeor[2]/5)+ _
(ScrFarbeul[2]/5)+ _
(ScrFarbeur[2]/5)+ _
(RstFarbe[2]/5)

NewFarbeG=(ScrFarbeol[1]/5)+ _
(ScrFarbeor[1]/5)+ _
(ScrFarbeul[1]/5)+ _
(ScrFarbeur[1]/5)+ _
(RstFarbe[1]/5)

NewFarbeB=(ScrFarbeol[0]/5)+ _
(ScrFarbeor[0]/5)+ _
(ScrFarbeul[0]/5)+ _
(ScrFarbeur[0]/5)+ _
(RstFarbe[0]/5)
'OnScreen[ScrRFarbeXPul+(ScrRFarbeYPul*W)]=RGB(NewFarbeR,NewFarbeG,NewFarbeB)
PSet(ScrRFarbeXPul,ScrRFarbeYPul),RGB(NewFarbeR,NewFarbeG,NewFarbeB)

''UR
RstRFarbe=Grundfarben(RasterPTR[(RightBlock*DownBlock)+1])
NewFarbeR=(ScrFarbeol[2]/5)+ _
(ScrFarbeor[2]/5)+ _
(ScrFarbeul[2]/5)+ _
(ScrFarbeur[2]/5)+ _
(RstFarbe[2]/5)

NewFarbeG=(ScrFarbeol[1]/5)+ _
(ScrFarbeor[1]/5)+ _
(ScrFarbeul[1]/5)+ _
(ScrFarbeur[1]/5)+ _
(RstFarbe[1]/5)

NewFarbeB=(ScrFarbeol[0]/5)+ _
(ScrFarbeor[0]/5)+ _
(ScrFarbeul[0]/5)+ _
(ScrFarbeur[0]/5)+ _
(RstFarbe[0]/5)
'OnScreen[ScrRFarbeXPur+(ScrRFarbeYPur*W)]=RGB(NewFarbeR,NewFarbeG,NewFarbeB)
PSet(ScrRFarbeXPur,ScrRFarbeYPur),RGB(NewFarbeR,NewFarbeG,NewFarbeB)
If Multikey(&h01) Then Exit Sub
Next ll
Next l
Next x
Next y
ScreenUnlock

End Sub

Dim RasterTest as Ubyte Ptr
RasterTest=CreateRaster (64,48)

Do
ShowPlasma (RasterTest)
'MoveRaster (RasterTest)
sleep(5)
Loop until multikey(&h01)

EraseRaster (RasterTest)

_________________

Nach oben

Jojo
alter Rang

Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte

Verfasst am: 18.08.2007, 14:01 Titel:

lol, das bild sieht immer gleich aus, und das bei 100% systemauslastung _________________ » Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.

Nach oben

Eternal_pain

Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

Verfasst am: 18.08.2007, 14:03 Titel:

Das ist das weniger komische daran, eigentlich sollte es auch ohne die (fehlerhafte) ausgeklinkte Bewegnung, eigentlich bewegung ins Spiel kommen... _________________

Nach oben

Beiträge der letzten Zeit anzeigen:

	Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.	Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

Impressum :: Datenschutz