| impersonalis |
16.04.2006 14:43 |
Решил выложить кусок исходников заброшенной проги.
Вроде даже работает.
При генерации используется Алгоритм Краскала. В промежуточных вычислениях юзается также волновая трассировка.
Код:
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
|
