Boolean: ReLoad
https://boolean.forumenko.com/

Генератор КвазиСлучайных Лабиринтов
https://boolean.forumenko.com/topic13.html
Страница 1 из 1

Автор:  impersonalis [ 11-02, 00:07 ]
Заголовок сообщения:  Генератор КвазиСлучайных Лабиринтов

Код:
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

Страница 1 из 1 Часовой пояс: UTC + 3 часа
Powered by phpBB® Forum Software © phpBB Group
http://www.phpbb.com/