PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

snake (extrem primitiv...)

https://www.purebasic.fr/german/viewtopic.php?t=3791

Seite 1 von 2

snake (extrem primitiv...)

Verfasst: 25.06.2005 19:47
von benpicco
Der code sollte ja eigentlich ein 20zeiler werden, aber naja, das ist mir jetzt doch nicht ganz so gut gelungen...
Naja, das es nicht ganz so primitiv aussieht, hab ich das ganze wenigstens nicht im fullscreenmode gestartet <)

Code: Alles auswählen

InitSprite()
InitKeyboard()
InitSprite3D()
MessageRequester("Snake by Benpicco","Special thanks to XP/TRISTAR/SECRETLY for the particle engine")
Procedure.f GCos(winkel.f,speed) 
  preturn.f=Cos(winkel*(speed*3.14159265/360)) 
  ProcedureReturn preturn 
EndProcedure
Procedure.f Gsin(winkel.f,speed) 
  preturn.f=Sin(winkel*(speed*3.14159265/360)) 
  ProcedureReturn preturn 
EndProcedure
Procedure generate_ptcl(file$,size,color.f,grosse)
grosse=510+grosse
CreateImage(1,grosse,grosse)
UseImage(1)
StartDrawing(ImageOutput())
For x=255 To 1 Step -1
red=Red(color)-x
green=Green(color)-x
blue=Blue(color)-x
If red<0
red=0
EndIf
If green<0
green=0
EndIf
If blue<0
blue=0
EndIf
For w= 0 To 360
Plot((grosse/2)+(gcos(w,1)*x),(grosse/2)+(gsin(w,1)*x),RGB(red,green,blue))
Plot((grosse/2)+(gcos(w,1)*x),(grosse/2)-(gsin(w,1)*x),RGB(red,green,blue))
Next
Next
ResizeImage(1,size,size)
StopDrawing()
SaveImage(1,file$)
FreeImage(1)
EndProcedure
Procedure install()
generate_ptcl("ptcl_rot.bmp",32,RGB(255,0,0),800)
generate_ptcl("ptcl_blau.bmp",32,RGB(0,0,255),800)
generate_ptcl("ptcl_gelb.bmp",32,RGB($FF,$FF,$00),800)
OpenFile(1,"installed.dat")
WriteByte(1)
CloseFile(1)
EndProcedure
;-partikelengine
;********************************************
;**********PARTIKEL-ENGINE 1.0***************
;********************************************
;********* BY XP/TRISTAR/SECRETLY ***********
;********************************************


;***typefield
Structure ptcl
  x.w               ;startpositionx
  y.w               ;startpositiony
  image.w           ;das image
  speedx.w          ;bewegungx
  speedy.w          ;bewegungy
  lifetime.w        ;lebenszeit
  rotspeed.w        ;rotationsgeschwindigkeit
  winkel.w
  scalex.w          ;scalierung x
  scaley.w          ;scalierung y
  alpha.w           ;start-alphawert
  fade.w            ;alphawert bei animation
  zoomx.w           ;scalewert bei animation
  zoomy.w           ;scalewert y bei anim
EndStructure
NewList ptcl.ptcl()

Structure ptclemitter
  x.w
  y.w
  typ.w
  lifetime.l
  bewegung.l
  sx.l
  sy.l
  wave.l
  part.b
  EndStructure
NewList ptclemitter.ptclemitter()

Procedure create_ptcl(x,y,lifetime,scalex,scaley,alpha,fade,zoomx,zoomy,speedx,speedy,rot,image)
AddElement(ptcl())
  ptcl()\x        = x
  ptcl()\y        = y
  ptcl()\image    = image
  ptcl()\speedx   = speedx
  ptcl()\speedy   = speedy
  ptcl()\lifetime = lifetime
  ptcl()\rotspeed = rot
  ptcl()\winkel   = 0
  ptcl()\scalex   = scalex
  ptcl()\scaley   = scaley
  ptcl()\alpha    = alpha
  ptcl()\fade     = fade
  ptcl()\zoomx    = zoomx
  ptcl()\zoomy    = zoomy
  EndProcedure


Procedure update_ptcl()
Sprite3DBlendingMode(5,7)
  ResetList(ptcl())
  While NextElement(ptcl())
    killptcl=0      ;löschbit
    If ptcl()\y < -50 Or ptcl()\y > 768     ;ob noch im bild
      killptcl=1
    EndIf
    If ptcl()\x < -50 Or ptcl()\x > 1024     ;andernfalls sowieso löschen
      killptcl=1    
    EndIf
    ptcl()\lifetime-1
    If  ptcl()\lifetime<0                   ;wenn lebenszeit zu ende dann löschen
      killptcl=1
    EndIf
    ptcl()\x+ptcl()\speedx      ;bewegen x
    ptcl()\y+ptcl()\speedy      ;bewegen y
    ptcl()\scalex+ptcl()\zoomx  ;zoomen x
    ptcl()\scaley+ptcl()\zoomy  ;zoomen y
    ptcl()\alpha+ptcl()\fade    ;faden
   ZoomSprite3D   ( ptcl()\image , ptcl()\scalex , ptcl()\scaley )
   DisplaySprite3D( ptcl()\image , ptcl()\x , ptcl()\y ,ptcl()\alpha )
  If killptcl=1     ;löschen
    killptcl=0
    DeleteElement(ptcl())
  EndIf
  Wend
Sprite3DBlendingMode(0,0)
EndProcedure

Procedure free_ptcl()
ResetList(ptcl())
  While NextElement(ptcl())
 DeleteElement(ptcl())
  Wend
EndProcedure

Procedure create_ptclemitter(x,y,life,typ,beweg,part)
AddElement( ptclemitter())
  ptclemitter()\x = x
  ptclemitter()\y = y
  ptclemitter()\typ = typ
  ptclemitter()\lifetime = life
  ptclemitter()\bewegung = beweg
  ptclemitter()\sx=Random(8)-4
  ptclemitter()\sy=Random(8)-4
  ptclemitter()\wave=Random(10) -20 
  ptclemitter()\part=part
EndProcedure


Procedure update_ptclemitter()

ResetList(ptclemitter())
  While NextElement(ptclemitter())


;create_ptcl(x,y,lifetime,scalex,scaley,alpha,fade,zoomx,zoomy,speedx,speedy,rot,image)
Select ptclemitter()\typ
Case 1 ;rauch 1
  create_ptcl(ptclemitter()\x+Random(10),ptclemitter()\y+Random(10),49,20,20,100,-2,1,1,0,0,0,ptclemitter()\part)
  
Case 2 ;rauch2
  create_ptcl(ptclemitter()\x,ptclemitter()\y,49,5,5,100,-2,1,1,0,0,0,ptclemitter()\part)

Case 3 ;rauch2
  create_ptcl(ptclemitter()\x,ptclemitter()\y,49,3,3,100,-2,1,1,0,0,0,ptclemitter()\part)
Case 4
create_ptcl(ptclemitter()\x,ptclemitter()\y,49,30,30,100,-2,-1,-1,Random(4)-2,0,0,ptclemitter()\part)

Case 5
create_ptcl(ptclemitter()\x,ptclemitter()\y,49,30,30,100,-2,-1,-1,Random(4)-2,0,0,ptclemitter()\part)
Case 6
create_ptcl(ptclemitter()\x,ptclemitter()\y,49,30,30,150,-2,-1,-1,Random(4)-2,0,0,ptclemitter()\part)
Case 7
create_ptcl(ptclemitter()\x,ptclemitter()\y,Random(50)+10,40,40,150,-2,-1,-1,Random(4)-2,Random(4)-2,0,ptclemitter()\part)

EndSelect

Select ptclemitter()\bewegung
Case 1

ptclemitter()\wave+1
 ;ptclemitter()\x=x
ptclemitter()\y+ptclemitter()\sy
ptclemitter()\x+ ptclemitter()\sx
EndSelect

ptclemitter()\lifetime-1
If ptclemitter()\lifetime<0
emitterkill=1
EndIf
If ptclemitter()\y<0 Or ptclemitter()\y>600
emitterkill=1
EndIf
If ptclemitter()\x<0 Or ptclemitter()\x>800
emitterkill=1
EndIf
If emitterkill=1
DeleteElement(ptclemitter())
EndIf
Wend
EndProcedure


Procedure free_ptclemitter()
ResetList(ptclemitter())
  While NextElement(ptclemitter())
 DeleteElement(ptclemitter())
  Wend
EndProcedure
;-ende Partikelengine

If ReadFile(1,"installed.dat")
If ReadByte()=1
Else
install()
EndIf
Else
install()
EndIf
#screenX=640
#screenY=480
Dim raster.f(#screenX,#screenY)
Global futterX.w
Global futterY.w
Global score.w
Global speed.b
Global laenge.f
Global headX.w
Global headY.w
Procedure drawing(text$,X,Y,color)
StartDrawing(ScreenOutput())
DrawingMode(1):Locate(x,y)
FrontColor(Red(color),Green(color),Blue(color))
DrawText(text$)
StopDrawing()
EndProcedure
Procedure.s GetAppDir() 
  FullPath.s = Space(360) 
  DLL = OpenLibrary(#PB_Any, "Kernel32") 
  CallFunction(DLL, "GetModuleFileNameA", CallFunction(DLL, "GetModuleHandleA", 0), @FullPath, 360) 
  CloseLibrary(DLL) 
  FullPath = GetPathPart(FullPath) 
  If Right(FullPath, 1) <> "\" : FullPath + "\" : EndIf 
  ProcedureReturn FullPath 
EndProcedure 
laenge=3
speed=10
retry1:
futterX=((Random(((#screenX-20)/speed)))*speed)+10
futterY=((Random(((#screenY-20)/speed)))*speed)+10
If raster(futterX,futterY)<>0
Goto retry1
EndIf
level$=OpenFileRequester("Level laden", getappdir()+"level\*.slv", "*slv", 0)
If level$=""
headX=10
headY=10
speedX=speed
speedY=0
Goto start
EndIf
OpenFile(1,level$)
For y=0 To #screenY Step 10
For x=0 To #screenX Step 10
raster(x,y)=ValF(ReadString())
If raster(x,y)=3
headX=x
headY=y
EndIf
If raster(x,y)=1
dirX=x
dirY=y
EndIf
Next
Next
If dirY>headY
speedY=speed
ElseIf dirY<headY 
speedY=-speed
ElseIf dirX<headX 
speedX=-speed
ElseIf dirX>headX 
speedX=speed
EndIf
raster(dirX,dirY)=0
CloseFile(1)
start:
OpenWindow(0, 0, 0, #ScreenX,#ScreenY, #PB_Window_ScreenCentered, "Snake")
OpenWindowedScreen(WindowID(0),0,0,#screenX,#screenY,1,0,0)
Sprite3DQuality(1)
LoadSprite(1,"ptcl_blau.bmp",#pb_sprite_texture)
LoadSprite(2,"ptcl_rot.bmp",#pb_sprite_texture)
LoadSprite(3,"ptcl_gelb.bmp",#pb_sprite_texture)
For x=1 To 3
CreateSprite3D(x,x)
Next
SetFrameRate(20)
Repeat
If sini<360:sini+1:Else:sini=0:EndIf 
ClearScreen(10,10,10)
StartDrawing(ScreenOutput())
Box(futterX,futterY,10,10,RGB(255,0,0))
For y=0 To #screenY Step 10
For x=0 To #screenX Step 10
If raster(x,y)>0
Box(x,y,10,10,RGB(255*(raster(x,y)/laenge),255*(raster(x,y)/laenge),255*(raster(x,y)/laenge)))
If raster(x,y)=laenge
Box(x,y,10,10,RGB(0,0,255))
EndIf
raster(x,y)-1
EndIf
If raster(x,y)=-1
Box(x,y,10,10,RGB(255,255,0))
Start3D()
create_ptclemitter(x,y,1,4,0,3)
Stop3D()
EndIf
Next
Next
headX+speedX
headY+speedY
If headX>#screenX-10
headX=10
EndIf
If headX<10
headX=#screenX-10
EndIf
If headY>#screenY-10
headY=10
EndIf
If headY<10
headY=#screenY-10
EndIf
If raster(headX,headY)<>0
Goto die
EndIf
raster(headX,headY)=laenge
StopDrawing()
drawing(Str(score),1,1,RGB(255,255,255))
;-3d
Start3D()
create_ptcl((headX+(speedX/2))+(gsin(sini,2)*10),(headY+(speedY/2))+(gcos(sini,2)*10),25,25,10,120,10,-1,-1,-speedX,-speedy,20,1)
create_ptclemitter(headX-10,headY-10,laenge,1,0,1)
create_ptclemitter(futterX-10,futterY-10,5,7,0,2)
update_ptclemitter()
update_ptcl()
Stop3D()
FlipBuffers()
WindowEvent()
ExamineKeyboard()
If KeyboardPushed(#pb_key_up) And speedY<>speed
speedY=-speed
speedX=0
ElseIf KeyboardPushed(#pb_key_down) And speedY<>-speed
speedY=speed
speedX=0
ElseIf KeyboardPushed(#pb_key_left) And speedX<>speed
speedY=0
speedX=-speed
ElseIf KeyboardPushed(#pb_key_right) And speedX<>-speed
speedY=0
speedX=speed
EndIf
If headX=futterX And headY=futterY
score+1
laenge+1
retry:
futterX=((Random(((#screenX-20)/speed)))*speed)+10
futterY=((Random(((#screenY-20)/speed)))*speed)+10
If raster(futterX,futterY)<>0
Goto retry
EndIf
EndIf
Until KeyboardPushed(#pb_key_escape)
End
die:
StopDrawing()
drawing("GameOver!",100,100,RGB(100,100,100))
OpenFile(1,GetFilePart(level$)+"-highscore.dat")
highscore.w=ReadWord()
CloseFile(1)
drawing("Highscore:"+Str(highscore),50,150,RGB(255,255,0))
FlipBuffers()
Delay(1000)
If score>highscore
drawing("New Highscore!",200,200,RGB(0,255,0))
OpenFile(1,GetFilePart(level$)+"-highscore.dat")
WriteWord(score)
CloseFile(1)
FlipBuffers()
Delay(1000)
EndIf
End
(das ganze war ursprünglich für meinen Taschenrechner geplant, naja, da ist es aber nicht gerade flüssig gelaufen :lol: )
edit: Code wieder leserlich gemacht :wink:
edit2: jetzt meldet sich das Programm auch wieder zurück <)
edit3:Nachrüstung levelfähigkeit
edit4: Ich hab jetzt auch mal ie Partikelengine eingebaut.

Verfasst: 25.06.2005 19:53
von DarkDragon
WindowEvent() fehlt, aber sonst in ordnung, außer des codes, der ist überhaupt nicht in ordnung.

Verfasst: 25.06.2005 20:01
von AndyX
Das Spiel ist echt nett umgesetzt :allright: Die Grafik ist extrem simpel, aber passt wirklich total :allright:

Naja, was den Code angeht, finde ich ziemlich verwirrend :D

Aber wenn du sagst, es soll nen 20-Zeiler sein, dann is das ja nich von so großer Bedeutung :D

Verfasst: 25.06.2005 20:10
von benpicco
DarkDragon hat geschrieben:WindowEvent() fehlt,
Äh, warum?
Die endlosschleife ist doch beabsichtigt und kann durch esc abgebrochen werden (oder man beißt sich in den schwanz ^^)

Verfasst: 25.06.2005 20:15
von DarkDragon
benpicco hat geschrieben:
DarkDragon hat geschrieben:WindowEvent() fehlt,
Äh, warum?
Die endlosschleife ist doch beabsichtigt und kann durch esc abgebrochen werden (oder man beißt sich in den schwanz ^^)
Wohl noch nie gesehen, wie die Sanduhr auf dem Fenster liegt, weil das Fenster nicht auf WindowsNachrichten reagiert?

Verfasst: 25.06.2005 20:21
von benpicco
Ah!
Das erklärt so einiges...
(auch warum das programm vom Taskmanager aus rückmeldungslos eingestuft wurde...)

Verfasst: 25.06.2005 20:33
von AndyX
Hm das ist ja was das ich meiner "Was ich noch tun muss, bevor ich sterbe"-Liste hinzufügen muss :D

* eigene Snake und Breakout-Clones schreiben :mrgreen:

Verfasst: 26.06.2005 18:33
von benpicco
Hier ist noch ein kleiner Leveleditor dazu, den hab ich zwar für was anderes geplant, aber für snake musste ich ihn nur etwas umschreiben (ok, ich hab ihn erst wegen snake gebaut, ich hab mich irgendwie bisher vor den Leleln in meinem momentanen Projekt SpaceConflict (es gibt schon v.0.0.7 ^^) etwas gesträubt hab... Aber da gibt´s wenigstens ne ordentliche grafik (dank der Partikelengine von XP, die müsste irgendwo im codearchiv sein.))

Ok, lange rede, kurzer

Code: Alles auswählen

InitSprite()
InitMouse()
InitKeyboard()
#screenX=640
#screenY=480
Dim raster.b(#screenX,#screenY)
OpenScreen(#screenX,#screenY,32,"editor")
MouseLocate(100,100)
wahl=-1
Procedure.s GetAppDir() 
  FullPath.s = Space(360) 
  DLL = OpenLibrary(#PB_Any, "Kernel32") 
  CallFunction(DLL, "GetModuleFileNameA", CallFunction(DLL, "GetModuleHandleA", 0), @FullPath, 360) 
  CloseLibrary(DLL) 
  FullPath = GetPathPart(FullPath) 
  If Right(FullPath, 1) <> "\" : FullPath + "\" : EndIf 
  ProcedureReturn FullPath 
EndProcedure 
Repeat
color=0
;raster(800,600)=1
ClearScreen(10,10,10)
StartDrawing(ScreenOutput())
For y=0 To #screenY Step 10
For x=0 To #screenX Step 10
If color=0
color=1
Else
color=0
EndIf
Select raster(x,y)
Case 0
Box(x,y,10,10,RGB(255*color,255*color,255*color))
Case 1
Box(x,y,10,10,RGB(255,0,0))
Case -1
Box(x,y,10,10,RGB(255,255,0))
Case 2
Box(x,y,10,10,RGB(100,100,100))
Case 3
Box(x,y,10,10,RGB(0,0,255))
EndSelect
If MouseButton(1)=1 And MouseX()>x And MouseX()<x+10 And MouseY()>y And MouseY()<y+10
raster(x,y)=wahl
EndIf
Next
Next
For x=1 To 1
Line(MouseX(),MouseY(),10-x,10-x,RGB(0,255,0))
Line(MouseX(),MouseY(),-10+x,10-x,RGB(0,255,0))
Line(MouseX(),MouseY(),10-x,-10+x,RGB(0,255,0))
Line(MouseX(),MouseY(),-10+x,-10+x,RGB(0,255,0))
DrawingMode(4)
Circle(MouseX(),MouseY(),10,RGB(0,255,0))
Next
StopDrawing()
FlipBuffers()
ExamineKeyboard()
ExamineMouse()
If KeyboardPushed(#pb_key_1)
wahl=1
ElseIf KeyboardPushed(#pb_key_2)
wahl=-1
ElseIf KeyboardPushed(#pb_key_0)
wahl=0
ElseIf KeyboardPushed(#pb_key_3)
wahl=3
ElseIf KeyboardPushed(#pb_key_4)
wahl=2
EndIf
Until KeyboardPushed(#pb_key_escape)
CloseScreen()
save$=SaveFileRequester("Level speichern", getappdir()+"level\level.slv", "*slv", 0)
If save$<>""
OpenFile(1,save$)
For y=0 To #screenY Step 10
For x=0 To #screenX Step 10
WriteStringN(Str(raster(x,y)))
Next
Next
CloseFile(1)
EndIf
End
Kleine anleitung:
2: gelbe wände
1: rot (kein futter, sondern Richtung, in die die schlange amfangs kriecht)
3: blau schlange (nur 1 Punkt!)
0: löschen

alle anderen tasten sind, sollten sie auch belegt sein, ohne Bedeutung!

Verfasst: 26.06.2005 18:49
von Norbie
Was hast du für einen Taschenrechner, dass da Snake zumindest ruckelnd läuft? Ich kenne (und habe) nur den cfx-9850 Plus, da läuft aber auch nichts mit Grafik flüssig :mrgreen:

Verfasst: 26.06.2005 19:03
von benpicco
denselben hab ich auch, ich habe ja nicht gesagt, das es geruckelt hat, ich konnte vilemehr dem Bild beim aufbauen zusehen :freak:
ich hab auch nicht den grafikbildschirm benutzt, sondern den 7*21 Zeilen bilsdschirm. Aber da er da im edeffekt for 1->x to 7*21 rechnen musste, kann man sich vorstellen, wie das lief...
Alle Zeiten sind UTC+02:00
Seite 1 von 2

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de