Генератор КвазиСлучайных Лабиринтов

[impersonalis]

Решил выложить кусок исходников заброшенной проги.
Вроде даже работает.
При генерации используется Алгоритм Краскала. В промежуточных вычислениях юзается также волновая трассировка.

Const Const_Line_Size_of_Labirint%=10000

Type TSector
	Field left_wall%
	Field up_wall%
	Field x_position%
	Field y_position%
	;=
	Field system_flag1%
End Type

Type TLabirint
	Field MAP.TSector[Const_Line_Size_of_Labirint%]
	Field Labirint_x_size_private%
	Field Labirint_y_size_private%
End Type

Function WALL_CanGo(WALL_ID.TSector,L.TLabirint)
	Local A.TSector
	Local B.TSector
	;=
	A=TLabirint_GET(L,WALL_ID\y_position,WALL_ID\x_position)
	;=
	Local AX=A\x_position
	Local AY=A\y_position
	Local BX=AX
	Local BY=AY
	If WALL_ID\Left_wall=False
		BX=AX-1
	Else
		BY=AY-1
	EndIf
	B=TLabirint_GET(L,BY,BX)
	If B=Null Return False
	Return  IsConnect%(A,B,L)
End Function

Function WALL_CRACK(WALL_ID.TSector,L.TLabirint)
	Local A.TSector

	A=TLabirint_GET(L,WALL_ID\y_position,WALL_ID\x_position)
	
	If WALL_ID\Left_wall=True
		A\left_wall=False
	Else
		A\up_wall=False
	EndIf
End Function

Function CONSTRUCTOR.TLabirint(x_size%,y_size%)
	L.TLabirint=New TLabirint
	L\Labirint_x_size_private%=x_size
	L\Labirint_y_size_private%=y_size
	For Q=1 To L\Labirint_x_size_private
		For W=1 To L\Labirint_y_size_private
			Local Index2d=(W-1)*L\Labirint_x_size_private+(Q-1)
			L\MAP[Index2d]=New TSector
			L\MAP[Index2d]\left_wall=True
			L\MAP[Index2d]\up_wall=True
			L\MAP[index2d]\x_position=Q
			L\MAP[index2d]\y_position=W
		Next
	Next
	Return L
End Function



Function GENERATOR.TLabirint(x_size%,y_size%)
	L.TLabirint=CONSTRUCTOR(x_size,y_size)
	Local Ast.TSector[Const_Line_Size_of_Labirint%*2]
	Local Bst%[Const_Line_Size_of_Labirint%*2]
	Local Iptr=0;10
	For Q=2 To L\Labirint_x_size_private
		For W=1 To L\Labirint_y_size_private
			Ast[Iptr]=New TSector
			Ast[Iptr]\left_wall=True
			Ast[Iptr]\up_wall=False
			Ast[Iptr]\x_position=Q
			Ast[Iptr]\y_position=W
			Iptr=Iptr+1
		Next
	Next
	For Q=1 To L\Labirint_x_size_private
		For W=2 To L\Labirint_y_size_private
			Ast[Iptr]=New TSector
			Ast[Iptr]\left_wall=False
			Ast[Iptr]\up_wall=True
			Ast[Iptr]\x_position=Q
			Ast[Iptr]\y_position=W
			Iptr=Iptr+1
		Next
	Next

	Local WALL_COUNT%=Iptr
	For I=0 To WALL_COUNT-1
		Bst[i]=Rand(-x_size*y_size*4,x_size*y_size*4)
	Next
	;=
	;сортировка вставками
	For I=0 To WALL_COUNT-1;0!
		Local X=Bst[i]
		Local Z.Tsector=Ast[i]
		Local J
		For J=I-1 To 1 Step -1
			If Bst[J]<X Exit
			Bst[J+1]=Bst[J]
			Ast[J+1]=Ast[J]
		Next
		Bst[J+1]=X
		Ast[J+1]=Z
	Next
	;===
	Local LOCATIONS=x_size*y_size
	Local ITER=0
	While LOCATIONS>1
		Local CURRENT_WALL_ID.TSector=Ast[ITER]
		ITER=ITER+1
		If WALL_CanGo(CURRENT_WALL_ID,L)=False
			WALL_CRACK(CURRENT_WALL_ID,L)
			LOCATIONS=LOCATIONS-1
		EndIf
	Wend
	;=
	;=
	Return L
End Function



Function TLabirint_GET.TSector(L.TLabirint,SNumber,CNumber)
	If SNumber>L\Labirint_y_size_private Or SNumber<1 Return Null
	If CNumber>L\Labirint_x_size_private Or CNumber<1 Return Null
	Local Index2d=(SNumber-1)*L\Labirint_x_size_private+(CNumber-1)
	Return L\MAP[Index2d]
End Function

Function TSector_PosEqual%(A.TSector,B.TSector)
	If A=Null Return False
	If B=Null Return False
	If A\x_position=B\x_position And A\y_position=B\y_position
		Return True
	Else
		Return False
	EndIf
End Function

Function TSector_CanGo%(y1%,x1%,y2%,x2%,L.TLabirint)
	A.TSector=TLabirint_GET(L,y1,x1)
	If A=Null Return False
	B.TSector=TLabirint_GET(L,y2,x2)
	If B=Null Return False
	If x2=x1+1
		Return Not(B\left_wall)
	ElseIf x2=x1-1
		Return Not(A\left_wall)
	ElseIf y2=y1-1
		Return Not(A\up_wall)
	ElseIf y2=y1+1
		Return Not(B\up_wall)
	Else
		Return False
	EndIf
End Function

Function IsConnect%(A.TSector,B.TSector,Labirint.TLabirint)
	For Q=1 To Labirint\Labirint_x_size_private
		For W=1 To Labirint\Labirint_y_size_private
			S.TSector=TLabirint_GET(Labirint,W,Q)
			S\system_flag1=False
		Next
	Next
	A\system_flag1=True
	;====
	Local flag%=1
	While True
		bool=False
		For Q=1 To Labirint\Labirint_x_size_private
			For W=1 To Labirint\Labirint_y_size_private
				S.TSector=TLabirint_GET(Labirint,W,Q)
				If S\system_flag1=flag
					;=
					If TSector_CanGo(W,Q,W,Q+1,Labirint)=True
						C.TSector=TLabirint_GET(Labirint,W,Q+1)
						If C\system_flag1=False
							C\system_flag1=flag+1
							If TSector_PosEqual%(C,B)=True Return True
							bool=True
						EndIf
					EndIf
					;=
					;=
					If TSector_CanGo(W,Q,W,Q-1,Labirint)=True
						C.TSector=TLabirint_GET(Labirint,W,Q-1)
						If C\system_flag1=False
							C\system_flag1=flag+1
							If TSector_PosEqual%(C,B)=True Return True
							bool=True
						EndIf
					EndIf
					;=
					;=
					If TSector_CanGo(W,Q,W-1,Q,Labirint)=True
						C.TSector=TLabirint_GET(Labirint,W-1,Q)
						If C\system_flag1=False
							C\system_flag1=flag+1
							If TSector_PosEqual%(C,B)=True Return True
							bool=True
						EndIf
					EndIf
					;=
					;=
					If TSector_CanGo(W,Q,W+1,Q,Labirint)=True
						C.TSector=TLabirint_GET(Labirint,W+1,Q)
						If C\system_flag1=False
							C\system_flag1=flag+1
							If TSector_PosEqual%(C,B)=True Return True
							bool=True
						EndIf
					EndIf
					;=
				EndIf
			Next
		Next
		If bool=False Exit
		flag=flag+1
	Wend
	Return False
End Function




Function show(k.TLabirint)
	ssx=16
	Rect 0,0,k\Labirint_x_size_private*ssx,k\Labirint_y_size_private*ssx,0
	For Q=1 To k\Labirint_x_size_private
		For W=1 To k\Labirint_y_size_private
			S.TSector=TLabirint_GET(k,W,Q)
			If S\left_wall=True
				Line (Q-1)*ssx,(W-1)*ssx,(Q-1)*ssx,W*ssx
			EndIf
			If S\up_wall=True
				Line (Q-1)*ssx,(W-1)*ssx,Q*ssx,(W-1)*ssx
			EndIf
		Next
	Next
End Function
;========================== demo code
Graphics 800,600,32
SetBuffer BackBuffer()
SetFont LoadFont("arial",20)
SeedRnd(MilliSecs())

Global z.TLabirint=GENERATOR(20,20)

While Not KeyHit(1)
	show(z)
	Flip
Wend
End

[tormoz]

Неплохо...
А случайно генерации бесконечного ландшафта не завалялось ?

[impersonalis]

Была когда-то убогая...
как-нибудь перепишу.