PureBoard

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

Terrainlinie mit Kollision

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

Seite 1 von 2

Terrainlinie mit Kollision

Verfasst: 09.12.2005 22:10
von remi_meier
Ein kleines Interface um ein Terrain automatisch generieren zu lassen (2D).
Dazu noch eine kleine Kollisionsdemo oder wie man es nennen soll...
Einfach mal ausprobieren :wink:

Code: Alles auswählen

;-#################################### START OF INTERFACE ####################################

Interface iTERRAIN
	GenerateTerrain() ; berechnet Terrain
	GetTerrain.l() ; gibt Pointer auf Terrain-Array zurück
	SetTerrain(*Terrain, CountOfPoints.l) ; kopiert ein Terrain-Array in die Klasse
	SetCountOfPoints(Count.l) ; setzt, wieviele Punkte berechnet werden sollen
	GetCountOfPoints.l()
	SetZoomFactor(Factor.f) ; setzt einen Vergrösserungsfaktor
	GetZoomFactor.f()
	SetTransFactor(Factor.f) ; setzt einen Verschiebungsfaktor
	GetTransFactor.f()
	SetRandomSeed(Seed.l) ; setze Startwert für Terrain
	GetRandomSeed.l()
	SetPoint(Index.l, Value.f)
	GetPoint.f(Index.l)
EndInterface

Structure cTERRAIN_VTABLE
	GenerateTerrain.l
	GetTerrain.l
	SetTerrain.l
	SetCountOfPoints.l
	GetCountOfPoints.l
	SetZoomFactor.l
	GetZoomFactor.l
	SetTransFactor.l
	GetTransFactor.l
	SetRandomSeed.l
	GetRandomSeed.l
	SetPoint.l
	GetPoint.l
EndStructure

Structure cTERRAIN
	*VTable.cTERRAIN_VTABLE
	
	; Data
	ZoomFactor.f
	TransFactor.f
	CountOfPoints.l
	pTerrain.l
	RndSeed.l
EndStructure


;- Hilfsprozeduren
Global terrain_mv.f, terrain_d.l, terrain_max.l, terrain_array.l
Global terrain_transl.f, terrain_zoom.f

Procedure terrain_Split(low.l, high.l)
	Protected m.l
	
	m = (high + low) / 2
	terrain_d = high - low
	If terrain_d <= 1
		ProcedureReturn 0
	EndIf
	
	terrain_mv = (PeekF(terrain_array + high * #SizeOf_Float) + PeekF(terrain_array + low * #SizeOf_Float)) / 2.0
	
	PokeF(terrain_array + m * #SizeOf_Float, terrain_mv - (Random(10000) / 10000.0 - terrain_transl) * terrain_zoom * terrain_d / Sqr(terrain_max))
	
	terrain_Split(m, high)
	terrain_Split(low, m)
EndProcedure

;- Methoden
Procedure terrain_GenerateTerrain(*this.cTERRAIN) ; berechnet Terrain
	Protected *mem
	
	*mem = ReAllocateMemory(*this\pTerrain, *this\CountOfPoints)
	If *mem
		*this\pTerrain = *mem
	Else
		ProcedureReturn #False
	EndIf
	
	; Globale Variablen setzen
	terrain_mv = 0
	terrain_d = 0
	terrain_max = *this\CountOfPoints - 1
	terrain_array = *this\pTerrain
	terrain_transl = *this\TransFactor
	terrain_zoom = *this\ZoomFactor
	
	RandomSeed(*this\RndSeed)
	; Aufruf:
	terrain_Split(0, *this\CountOfPoints - 1)
EndProcedure

Procedure.l terrain_GetTerrain(*this.cTERRAIN) ; gibt Pointer auf Terrain-Array zurück
	ProcedureReturn *this\pTerrain
EndProcedure

Procedure terrain_SetTerrain(*this.cTERRAIN, *Terrain, CountOfPoints.l) ; kopiert ein Terrain-Array in die Klasse
	Protected *mem
	
	*mem = ReAllocateMemory(*this\pTerrain, CountOfPoints * #SizeOf_Float)
	If *mem
		*this\pTerrain = *mem
	Else
		ProcedureReturn #False
	EndIf
	
	CopyMemory(*Terrain, *this\pTerrain, CountOfPoints * #SizeOf_Float)
EndProcedure

Procedure terrain_SetCountOfPoints(*this.cTERRAIN, Count.l) ; setzt, wieviele Punkte berechnet werden sollen
	*this\CountOfPoints = Count
EndProcedure

Procedure.l terrain_GetCountOfPoints(*this.cTERRAIN)
	ProcedureReturn *this\CountOfPoints
EndProcedure

Procedure terrain_SetZoomFactor(*this.cTERRAIN, Factor.f) ; setzt einen Vergrösserungsfaktor
	*this\ZoomFactor = Factor
EndProcedure

Procedure.f terrain_GetZoomFactor(*this.cTERRAIN)
	ProcedureReturn *this\ZoomFactor
EndProcedure

Procedure terrain_SetTransFactor(*this.cTERRAIN, Factor.f) ; setzt einen Verschiebungsfaktor
	*this\TransFactor = Factor
EndProcedure

Procedure.f terrain_GetTransFactor(*this.cTERRAIN)
	ProcedureReturn *this\TransFactor
EndProcedure

Procedure terrain_SetRandomSeed(*this.cTERRAIN, Seed.l)
	*this\RndSeed = Seed
EndProcedure

Procedure.l terrain_GetRandomSeed(*this.cTERRAIN)
	ProcedureReturn *this\RndSeed
EndProcedure

Procedure terrain_SetPoint(*this.cTERRAIN, Index.l, Value.f)
	PokeF(*this\pTerrain + Index * #SizeOf_Float, Value)
EndProcedure

Procedure.f terrain_GetPoint(*this.cTERRAIN, Index.l)
	ProcedureReturn PeekF(*this\pTerrain + Index * #SizeOf_Float)
EndProcedure


Procedure.l new_terrain()
	Protected *temp.cTERRAIN
	
	*temp = AllocateMemory(SizeOf(cTERRAIN))
	If *temp
		*temp\ZoomFactor = 200
		*temp\TransFactor = 0.5
		
		*temp\VTable = AllocateMemory(SizeOf(cTERRAIN_VTABLE))
		If *temp\VTable
			*temp\VTable\GenerateTerrain	= @terrain_GenerateTerrain()
			*temp\VTable\GetTerrain				= @terrain_GetTerrain()
			*temp\VTable\SetTerrain				= @terrain_SetTerrain()
			*temp\VTable\SetCountOfPoints	= @terrain_SetCountOfPoints()
			*temp\VTable\GetCountOfPoints	= @terrain_GetCountOfPoints()
			*temp\VTable\SetZoomFactor		= @terrain_SetZoomFactor()
			*temp\VTable\GetZoomFactor		= @terrain_GetZoomFactor()
			*temp\VTable\SetTransFactor		= @terrain_SetTransFactor()
			*temp\VTable\GetTransFactor		= @terrain_GetTransFactor()
			*temp\VTable\SetRandomSeed		= @terrain_SetRandomSeed()
			*temp\VTable\GetRandomSeed		= @terrain_GetRandomSeed()
			*temp\VTable\SetPoint					= @terrain_SetPoint()
			*temp\VTable\GetPoint					= @terrain_GetPoint()
		Else
			FreeMemory(*temp)
			*temp = 0
		EndIf
	EndIf
	
	ProcedureReturn *temp
EndProcedure

Procedure delete_terrain(*terrain.cTERRAIN)
	If *terrain
		If *terrain\pTerrain
			FreeMemory(*terrain\pTerrain)
		EndIf
		If *terrain\VTable
			FreeMemory(*terrain\VTable)
		EndIf
		FreeMemory(*terrain)
	EndIf
EndProcedure

;-#################################### END OF INTERFACE ####################################




;- nicht mehr Interface -> Programm

Structure XY
  x.f
  y.f
EndStructure

Procedure.f LineLineCol(*P.XY, *r.XY, *A.XY, *B.XY, *OUT.XY)
  Protected t.f, s.f
  Protected AB.XY
  
  s = *A\x * *r\y - *A\y * *r\x
  t = (s - *P\x * *r\y + *P\y * *r\x) / (s - *B\x * *r\y + *B\y * *r\x)
  
  AB\x = *B\x - *A\x
  AB\y = *B\y - *A\y
  
  If t >= -0.0001 And t <= 1.0001
  	*OUT\x = *A\x + t * AB\x
	  *OUT\y = *A\y + t * AB\y
  	
  	ProcedureReturn Pow(*OUT\x - *P\x, 2) + Pow(*OUT\y - *P\y, 2)
  EndIf
  
  ProcedureReturn 99999999.0
EndProcedure

Procedure.l LineCollideArray(terrain.iTERRAIN, *Start.XY, *Dir.XY, *Out.XY)
	Protected i.l, shortestDis.f, t.f
	Protected A.XY, B.XY, Out2.XY, max.l
	
	max = terrain\GetCountOfPoints()
	
	shortestDis = 99999999.0
	For i = 1 To max - 1
		A\y = 1.0 + terrain\GetPoint(i - 1) + 250.0
		A\x = 1.0 * (i - 1) / max * 500
		B\y = 1.0 + terrain\GetPoint(i) + 250.0
		B\x = 1.0 * i / max * 500
		
		t = LineLineCol(*Start, *Dir, @A, @B, @Out2)
		If t < shortestDis
		  shortestDis = t
  		*Out\x = Out2\x
		  *Out\y = Out2\y
		EndIf
	Next
EndProcedure


terr.iTERRAIN = new_terrain()
terr\SetCountOfPoints(100)
terr\SetZoomFactor(50)
;terr\SetRandomSeed(30)
terr\GenerateTerrain()



CreateImage(0, 500, 500)

OpenWindow(0, 200, 200, 500, 500, #PB_Window_SystemMenu|#PB_Window_ScreenCentered, "Drawing")
CreateGadgetList(WindowID())
	ImageGadget(1, 0, 0, 500, 500, UseImage(0))





SetGadgetState(1, UseImage(0))
Repeat
  UseImage(0)
	hdc = StartDrawing(ImageOutput())
	  Box(0,0, 500,500, 0)
  	
	  px.l = terr\GetCountOfPoints()
		For z = 1 To px - 1
			LineXY(1.0 * (z - 1) / px * 500, terr\GetPoint(z - 1) + 250, 1.0 * z / px * 500, terr\GetPoint(z) + 250, $FF)
		Next
		
		P.XY
		P\x = 250
		P\y = 0
		Dir.XY
		Dir\x = WindowMouseX() - 250
		Dir\y = WindowMouseY()
		Out.XY
		LineCollideArray(terr, @P, @Dir, @Out)
		Circle(Out\x, Out\y, 10, $FF00)
		Line(P\x, P\y, Dir\x, Dir\y, $FF0000)
	StopDrawing()
	SetGadgetState(1, UseImage(0))
	
	
	Delay(10)
Until WindowEvent() = #PB_Event_CloseWindow
greetz
Remi

Verfasst: 10.12.2005 11:11
von DarkDragon
8) Mach doch eine neue Liero variante daraus.

Verfasst: 10.12.2005 12:55
von MVXA
Hehe, Genial. Ich sehe schon die Worms Clone kommen :lol:.

Verfasst: 10.12.2005 16:56
von Nik
Here the debugegr says that OUT hasn't got a structure. :cry:

Verfasst: 10.12.2005 17:01
von AndyX
Bei mir dasselbe :(

Verfasst: 10.12.2005 17:10
von remi_meier
? Out hat die Struktur XY :freak:

Verfasst: 10.12.2005 17:20
von DarkDragon
Nik hat geschrieben:Here the debugegr says that OUT hasn't got a structure. :cry:
In PB 3.93 funktionieren Interfaces nicht korrekt.

Verfasst: 10.12.2005 17:56
von remi_meier
Tja dann :wink:

Hier noch mit Lemmingen (benötigt Interface von oben):

Code: Alles auswählen

Structure XY
  x.f
  y.f
EndStructure


Procedure.l GetPointAndVector(terrain.iTERRAIN, x.f, *P.XY, *VEC.XY)
	Protected max.l, index.l
	Protected A.XY, B.XY, AB.XY, len.f
	
	max = terrain\GetCountOfPoints()
	
	index = Int(x / 500.0 * max)
	If index >= max - 1
		ProcedureReturn
	EndIf
	
	A\x = 1.0 * index / max * 500
	A\y = 1.0 * terrain\GetPoint(index) + 250.0
	B\x = 1.0 * (index + 1) / max * 500
	B\y = 1.0 * terrain\GetPoint(index + 1) + 250.0
	AB\x = B\x - A\x
	AB\y = B\y - A\y
	
	
	*P\x = x
	*P\y = A\y + (x - A\x) * AB\y / AB\x
	
	len = Sqr(AB\x * AB\x + AB\y * AB\y)
	*VEC\x = AB\y / len * 10
	*VEC\y = -AB\x / len * 10
	
EndProcedure


terr.iTERRAIN = new_terrain()
terr\SetCountOfPoints(300)
terr\SetZoomFactor(30)
terr\SetRandomSeed(30)
terr\GenerateTerrain()



CreateImage(0, 500, 500)

OpenWindow(0, 200, 200, 500, 500, #PB_Window_SystemMenu|#PB_Window_ScreenCentered, "Drawing")
CreateGadgetList(WindowID())
	ImageGadget(1, 0, 0, 500, 500, UseImage(0))





SetGadgetState(1, UseImage(0))

#LEMMINGS = 20
Dim lemminge.f(#LEMMINGS)
For x = 0 To #LEMMINGS
	lemminge(x) = x * 10
Next

Repeat
  UseImage(0)
	hdc = StartDrawing(ImageOutput())
	  Box(0,0, 500,500, 0)
  	
	  px.l = terr\GetCountOfPoints()
		For z = 1 To px - 1
			LineXY(1.0 * (z - 1) / px * 500, terr\GetPoint(z - 1) + 250, 1.0 * z / px * 500, terr\GetPoint(z) + 250, $FF)
		Next
		
		For x = 0 To #LEMMINGS
			lemminge(x) + 0.5
			If lemminge(x) > 500
				lemminge(x) = 0
			EndIf
			P.XY
			Dir.XY
			GetPointAndVector(terr, lemminge(x), @P, @Dir)
			Circle(P\x, P\y, 1, $FF00)
			Line(P\x, P\y, Dir\x, Dir\y, $FF0000)
		Next
	StopDrawing()
	SetGadgetState(1, UseImage(0))
	
	
	Delay(20)
Until WindowEvent() = #PB_Event_CloseWindow

greetz
Remi

EDIT: Fehler ausgebessert!

Verfasst: 10.12.2005 18:25
von MVXA
ich finds geil :lol:

Verfasst: 10.12.2005 20:20
von Nik
Ich benutze pb 3.94 aber wayne des mit den Lemmingen geht ist wirklich beeindruckend... :allright:
Alle Zeiten sind UTC+02:00
Seite 1 von 2

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de