275 lines
7.4 KiB
Text
275 lines
7.4 KiB
Text
Const nRows As Integer = 8
|
|
Const nCols As Integer = 8
|
|
Const target As Integer = 12
|
|
Const blank As Integer = 12
|
|
|
|
Dim Shared symbols As String
|
|
symbols = "XYPFTVNLUZWI-"
|
|
Dim Shared grid(nRows - 1, nCols - 1) As Integer
|
|
Dim Shared As Integer pens(63, 7)
|
|
Dim seeds(11) As Integer = {291, 292, 293, 295, 297, 329, 330, 332, 333, 335, 378, 586}
|
|
|
|
Function Puzzle(a As String, b As String) As String
|
|
Dim res As String = ""
|
|
If Len(a) > Len(b) Then b &= Space(Len(a) - Len(b))
|
|
If Len(a) < Len(b) Then a &= Space(Len(b) - Len(a))
|
|
For i As Integer = 0 To Len(a) - 2
|
|
Dim As String cad = " 12"&chr(192)&"4"&chr(217)&chr(196)&chr(193)&"8"&chr(179)&chr(218)&chr(195)&chr(191)&chr(180)&chr(194)&chr(197)
|
|
res &= Mid(cad, (Iif(Mid(a, i + 1, 1) = Mid(a, i + 2, 1), 0, 1) + _
|
|
Iif(Mid(b, i + 2, 1) = Mid(a, i + 2, 1), 0, 2) + _
|
|
Iif(Mid(a, i + 1, 1) = Mid(b, i + 1, 1), 0, 4) + _
|
|
Iif(Mid(b, i + 1, 1) = Mid(b, i + 2, 1), 0, 8)) + 1, 1)
|
|
Next
|
|
Return res
|
|
End Function
|
|
|
|
Function Cornered(s As String) As String
|
|
Dim As String lines(100), res, linea, last
|
|
Dim As Integer lineCount, start, posic, i
|
|
|
|
lineCount = 0
|
|
start = 1
|
|
posic = Instr(start, s, Chr(10))
|
|
While posic > 0
|
|
lines(lineCount) = Mid(s, start, posic - start)
|
|
lineCount += 1
|
|
start = posic + 1
|
|
posic = Instr(start, s, Chr(10))
|
|
Wend
|
|
lines(lineCount) = Mid(s, start)
|
|
lineCount += 1
|
|
|
|
res = ""
|
|
linea = Space(Len(lines(0)) + 1)
|
|
For i = 0 To lineCount - 1
|
|
last = linea
|
|
linea = " " & lines(i)
|
|
res &= Puzzle(last, linea) & Chr(10)
|
|
Next
|
|
Return res & Puzzle(linea, Space(Len(lines(lineCount - 1)) + 1))
|
|
End Function
|
|
|
|
Function TPO(ori() As Integer, Byval row As Integer, Byval col As Integer, Byval sIdx As Integer) As Boolean
|
|
Dim As Integer i, x, y
|
|
For i = 0 To Ubound(ori) Step 2
|
|
x = col + ori(i + 1)
|
|
y = row + ori(i)
|
|
If x < 0 Or x >= nCols Or y < 0 Or y >= nRows Or grid(y, x) <> -1 Then Return False
|
|
Next
|
|
grid(row, col) = sIdx
|
|
For i = 0 To Ubound(ori) Step 2
|
|
grid(row + ori(i), col + ori(i + 1)) = sIdx
|
|
Next
|
|
Return True
|
|
End Function
|
|
|
|
Sub ShuffleShapes(count As Integer)
|
|
Dim As Integer i, j, r, k
|
|
For i = 0 To count
|
|
For j = 0 To Ubound(pens, 1)
|
|
Do
|
|
r = Int(Rnd * (Ubound(pens, 1) + 1))
|
|
Loop Until r <> j
|
|
For k = 0 To Ubound(pens, 2)
|
|
'Dim tmp As Integer = pens(r, k)
|
|
Swap pens(r, k), pens(j, k)
|
|
'pens(j, k) = tmp
|
|
Next
|
|
Dim ch As String = Mid(symbols, r + 1, 1)
|
|
Mid(symbols, r + 1, 1) = Mid(symbols, j + 1, 1)
|
|
Mid(symbols, j + 1, 1) = ch
|
|
Next
|
|
Next
|
|
End Sub
|
|
|
|
Function DW(s As String) As String
|
|
Dim result As String = ""
|
|
For i As Integer = 1 To Len(s)
|
|
Dim ch As String = Mid(s, i, 1)
|
|
result &= ch & Iif(ch = Chr(10), "", ch)
|
|
Next
|
|
Return result
|
|
End Function
|
|
|
|
Sub PrintResult()
|
|
Dim res As String = ""
|
|
For r As Integer = 0 To nRows - 1
|
|
For c As Integer = 0 To nCols - 1
|
|
res &= Iif(grid(r, c) < 0, ".", Mid(symbols, grid(r, c) + 1, 1))
|
|
Next
|
|
res &= " " & Chr(10)
|
|
Next
|
|
Print Cornered(DW(res))
|
|
End Sub
|
|
|
|
Sub RmvO(ori() As Integer, Byval row As Integer, Byval col As Integer)
|
|
grid(row, col) = -1
|
|
For i As Integer = 0 To Ubound(ori) Step 2
|
|
grid(row + ori(i), col + ori(i + 1)) = -1
|
|
Next
|
|
End Sub
|
|
|
|
Sub Expand(i As Integer, result() As Integer)
|
|
result(0) = 0
|
|
For j As Integer = 0 To 3
|
|
result(4 - j) = i And 15
|
|
i Shr= 4
|
|
Next
|
|
End Sub
|
|
|
|
Sub Sort(arr() As Integer)
|
|
Dim As Integer n, i, j
|
|
n = Ubound(arr)
|
|
For i = 0 To n - 1
|
|
For j = 0 To n - i - 1
|
|
If arr(j) > arr(j + 1) Then Swap arr(j), arr(j + 1)
|
|
Next
|
|
Next
|
|
End Sub
|
|
|
|
Sub ToP(p() As Integer, res() As Integer)
|
|
Dim As Integer tmp(4), i, item, adj
|
|
|
|
tmp(0) = 0
|
|
For i = 1 To 4
|
|
item = p(i)
|
|
Select Case (item And 3)
|
|
Case 0
|
|
tmp(i) = tmp(item \ 4) + 1
|
|
Case 1
|
|
tmp(i) = tmp(item \ 4) + 8
|
|
Case 2
|
|
tmp(i) = tmp(item \ 4) - 1
|
|
Case 3
|
|
tmp(i) = tmp(item \ 4) - 8
|
|
End Select
|
|
Next
|
|
Sort(tmp())
|
|
For i = 4 To 1 Step -1
|
|
tmp(i) -= tmp(0)
|
|
Next
|
|
For i = 1 To 4
|
|
item = tmp(i)
|
|
adj = Iif((item And 7) > 4, 8, 0)
|
|
res(2 * (i - 1)) = (adj + item) \ 8
|
|
res(2 * (i - 1) + 1) = (item And 7) - adj
|
|
Next
|
|
End Sub
|
|
|
|
Sub Rot(p() As Integer)
|
|
For i As Integer = 0 To Ubound(p)
|
|
p(i) = (p(i) And -4) Or ((p(i) + 1) And 3)
|
|
Next
|
|
End Sub
|
|
|
|
Sub Mir(p() As Integer)
|
|
For i As Integer = 0 To Ubound(p)
|
|
p(i) = (p(i) And -4) Or (((p(i) Xor 1) + 1) And 3)
|
|
Next
|
|
End Sub
|
|
|
|
Sub Unpack(sv() As Integer)
|
|
Dim As Integer idx, item, i, j, k, l
|
|
Dim As Boolean exists, same
|
|
|
|
idx = 0
|
|
For i = 0 To Ubound(sv)
|
|
item = sv(i)
|
|
Dim exi(3) As Integer
|
|
Expand(item, exi())
|
|
Dim fx(7) As Integer
|
|
ToP(exi(), fx())
|
|
For j = 0 To 7
|
|
pens(idx, j) = fx(j)
|
|
Next
|
|
idx += 1
|
|
For j = 1 To 7
|
|
If j = 4 Then
|
|
Mir(exi())
|
|
Else
|
|
Rot(exi())
|
|
End If
|
|
ToP(exi(), fx())
|
|
exists = False
|
|
For k = 0 To idx - 1
|
|
same = True
|
|
For l = 0 To 7
|
|
If pens(k, l) <> fx(l) Then
|
|
same = False
|
|
Exit For
|
|
End If
|
|
Next
|
|
If same Then
|
|
exists = True
|
|
Exit For
|
|
End If
|
|
Next
|
|
If Not exists Then
|
|
For l = 0 To 7
|
|
pens(idx, l) = fx(l)
|
|
Next
|
|
idx += 1
|
|
End If
|
|
Next
|
|
Next
|
|
End Sub
|
|
|
|
Function TheSame(a() As Integer, b() As Integer) As Boolean
|
|
For i As Integer = 0 To Ubound(a)
|
|
If a(i) <> b(i) Then Return False
|
|
Next
|
|
Return True
|
|
End Function
|
|
|
|
Function Solve(Byval posic As Integer, Byval numPlaced As Integer) As Boolean
|
|
Dim placed(target - 1) As Boolean
|
|
If numPlaced = target Then Return True
|
|
|
|
Dim As Integer row, col, i, j, k, orientation(7)
|
|
row = posic \ nCols
|
|
col = posic Mod nCols
|
|
If grid(row, col) <> -1 Then Return Solve(posic + 1, numPlaced)
|
|
|
|
For i = 0 To Ubound(pens, 1)
|
|
If Not placed(i) Then
|
|
For j = 0 To Ubound(pens, 2)
|
|
For k = 0 To 7
|
|
orientation(k) = pens(i, k)
|
|
Next
|
|
If Not TPO(orientation(), row, col, i) Then Continue For
|
|
placed(i) = True
|
|
If Solve(posic + 1, numPlaced + 1) Then Return True
|
|
RmvO(orientation(), row, col)
|
|
placed(i) = False
|
|
Next
|
|
End If
|
|
Next
|
|
Return False
|
|
End Function
|
|
|
|
'--- Main program ---
|
|
Unpack(seeds())
|
|
Randomize Timer
|
|
ShuffleShapes(2)
|
|
Dim As Integer r, c
|
|
For r = 0 To nRows - 1
|
|
For c = 0 To nCols - 1
|
|
grid(r, c) = -1
|
|
Next
|
|
Next
|
|
Dim As Integer rRow, rCol
|
|
For r = 0 To 3
|
|
Do
|
|
rRow = Int(Rnd * nRows)
|
|
rCol = Int(Rnd * nCols)
|
|
Loop While grid(rRow, rCol) = blank
|
|
grid(rRow, rCol) = blank
|
|
Next
|
|
If Solve(0, 0) Then
|
|
PrintResult()
|
|
Else
|
|
Print "no solution for this configuration:"
|
|
PrintResult()
|
|
End If
|
|
|
|
Sleep
|