' FindPath_Volna.bi

'Declare Sub CopyMemF Lib "kernel32.dll" alias "RtlMoveMemory" (ByVal pDst As long, ByVal pSrc As long, ByVal ByteLen As Long)

Public Const cBlock = 4095 ' 255 ' 255 - непроходимая клетка - константа cBlock
Public Const cFree = 4094  ' 254 ' 254 - проходимая клетка   - константа cFree
Public Const cStart = 4093 ' 253 ' 253 - стaртовая позиция
Public Const cEnd = 0      ' 0   - финишная позиция

Public Enum EDirection
  cSkip = -1
  cdDown = 0
  cdLeftDown = 1
  cdLeft = 2
  cdLeftup = 3
  cdUp = 4
  cdRightUp = 5
  cdRight = 6
  cdRightDown = 7
End Enum
Public Type TRetpath
  X As Long
  Y As Long
  d As EDirection
End Type

Dim Shared arr() As Long
Dim Shared VarD() As TRetpath ' Варианты движения
Dim Shared As Long VarD2 = 0
' xbeg,ybeg,xend,yend - стартовые и конечные координаты
Dim Shared As Long xbeg, ybeg, xend, yend
Dim Shared As Long MapLeft, MapTop, MapRight, MapBottom
Dim Shared As Long gg1 
'Private Sub Init1() ' Ининициализация вариантов движения включая диагональное
'  ReDim VarD(0 To 8) As TRetpath 'Варианты движения
'  With VarD(1): .x = 1: .y = 0: .d = cdRight: End With
'  With VarD(2): .x = 0: .y = 1: .d = cdDown: End With
'  With VarD(3): .x = 0: .y = -1: .d = cdUp: End With
'  With VarD(4): .x = -1: .y = 0: .d = cdLeft: End With
'  With VarD(5): .x = 1: .y = 1: .d = cdRightDown: End With
'  With VarD(6): .x = -1: .y = -1: .d = cdLeftup: End With
'  With VarD(7): .x = 1: .y = -1: .d = cdRightUp: End With
'  With VarD(8): .x = -1: .y = 1: .d = cdLeftDown: End With
'End Sub
Sub Init_Volna_2() ' Ининициализация вариантов движения
  ReDim VarD(0 To 4) As TRetpath 'Варианты движения
  With VarD(1): .X = 1: .Y = 0: .d = cdRight: End With
  With VarD(2): .X = 0: .Y = 1: .d = cdDown: End With
  With VarD(3): .X = 0: .Y = -1: .d = cdUp: End With
  With VarD(4): .X = -1: .Y = 0: .d = cdLeft: End With
  VarD2 = 1
End Sub

Function FindPathVolna(retarr() As TRetpath, ByVal MaxPop As Integer = 50) As Long
  ' Функция поиска пути грузчика к объекту, retarr() - массив который возращает найденый путь
  Dim As Integer X, Y, i, j, k, x1, y1
  Dim As Integer mink, minv, ni, cnt, newx, newy
  Dim As Integer lbx, lby, ubx, uby, radius
  
  radius = 30
  lbx = xend - xbeg: lby = yend - ybeg
  If lbx > MapLeft Then
    ubx = xend + radius: lbx = xbeg - radius
  Else
    ubx = xend - radius: lbx = xbeg + radius
  End If
  If lbx > ubx Then i = lbx: lbx = ubx: ubx = i
  If lby < MapTop Then
    uby = yend + radius: lby = ybeg - radius
  Else
    uby = yend - radius: lby = ybeg + radius
  End If
  If lby > uby Then i = lby: lby = uby: uby = i

  If ubx > MapRight Then ubx = MapRight
  If uby > MapBottom Then uby = MapBottom
  If lbx < MapLeft Then lbx = MapLeft
  If lby < MapTop Then lby = MapLeft

  ' 2.Первая стадия нахождения пути
  For ni = 0 To MaxPop ' счётчик итерaций (повторений)
    For i = lbx To ubx
      For j = lby To uby
        If arr(i, j) = ni Then
          For k = 1 To 4
            newx = i + VarD(k).X: newy = j + VarD(k).Y
            If newx >= MapLeft And newy >= MapTop And newx <= MapRight And newy <= MapBottom Then
              If arr(newx, newy) = cFree Then
                arr(newx, newy) = ni + 1
              Else
                If arr(newx, newy) = cStart Then GoTo FindIt
                ' извините за GoTo, но есть ли у кого-то другие варианты :?:
              End If
            End If
          Next
        End If
      Next
    Next
  Next
  Return 0  '!! Невозможно найти путь :(
FindIt:
  ReDim retarr(1 To MaxPop)
  cnt = 0: X = xbeg: Y = ybeg
  ' 2.Вторая стадия - Построения маршрута пути
  Do
    Dim maxk As Integer
    minv = MaxPop + 1
    For k = 4 To 1 Step -1
      newx = X + VarD(k).X: newy = Y + VarD(k).Y
      If newx >= MapLeft And newy >= MapTop And newx <= MapRight And newy <= MapBottom Then
        If arr(newx, newy) <= minv Then
          minv = arr(newx, newy): x1 = newx: y1 = newy: maxk = k
        End If
      End If
    Next
    cnt += 1: X = x1: Y = y1
    If cnt > MaxPop Then Return 0
    With retarr(cnt): .d = VarD(maxk).d: .X = X: .Y = Y: End With
    ' Путь найден!
    If arr(X, Y) = cEnd Then ReDim Preserve retarr(1 To cnt): Return 1
  Loop
End Function

' Просчёт пути для грузчика из Сокобана
Sub NewInit()
	Init_Volna_2()
	MapLeft = 1: MapTop = 1: MapRight = xMax: MapBottom = yMax
	ReDim arr(MapLeft To MapRight, MapTop To MapBottom)	
End Sub

Function FPVErr2(v() As Byte, x1 As Long, y1 As Long, x2 As Long, y2 As Long, pBeg As Byte = 0) As Long
	' pBeg = 1 - учитывать ямы, pBeg = 2 - не учитывать ямы 
	Dim As Long x, y, i, k
	Dim As Byte p1, p2
	Dim R() As TRetpath
	If x1 = x2 And y1 = y2 Then Return 0
	If VarD2 = 0 Then NewInit()
	 
  For y = MapTop To MapBottom
    For x = MapLeft To MapRight
    	If x1 = x And y1 = y Then
    	Else
    		p1 = Map1(x, y).Obj
	    	If p1 = 1 Or p1 = 99 Or p1 = 98 Then 
	    		arr(x, y) = cBlock    ' непроходимая клетка (стена)
	    		'gg1 += 1 : Locate 1, 1: ? Str(gg1)
	    	Else
	    		p2 = Map1(x, y - 1).Obj
	    		If p1 = 0 And (p2 = 1 Or p2 = 99 Or p2 = 98) Then
	    			arr(x, y) = cFree   ' проходимая клетка
	    		Else
	    			If p1 = 2 Then
	    				arr(x, y) = cFree   ' проходимая клетка
	    			Else
	    				arr(x, y) = cBlock  ' непроходимая клетка
	    			EndIf
	    		EndIf
	    	End If
    	End If
    Next X
  Next Y
  arr(X1, Y1) = cStart: xbeg = X1: ybeg = Y1 ' Начальная позиция
	arr(X2, Y2) = cEnd: xend = X2: yend = Y2   ' финишная позиция

  k = FindPathVolna(R())
  'Locate 1, 1: ? Str(k) : Sleep 1000
  If k = 1 Then
  	'MsgBox "Количество ходов до ящика: " & CStr(UBound(r()))
  	ReDim v(UBound(R))
    For i = 1 To UBound(R)
      ' cdDown = 0  cdLeft = 2  cdUp = 4  cdRight = 6
      Select Case R(i).d
      	Case 0: v(i) = 1 ' vbKeyDown
      	Case 2: v(i) = 2 ' vbKeyLeft
      	Case 6: v(i) = 3 ' vbKeyRight
      	Case 4: v(i) = 4 ' vbKeyUp
      End Select
    Next 
  End If
  Return k
End Function

