' Reads Data Base, Check Properties of Transformations (192 ea)
' Centrally Symmetric made of two Latin squares with Latin main diagonals
' Tested with Office 2007 under Windows 7
Sub ReadDb8e(fl8, fl3)
Dim MyDB As Database, MyWorkSpace As Workspace
Dim Td1 As Recordset
Dim a(64), b8(64), b1(64), B2(64), a1(64), b(64), s(100)
' b8() Record BiMagic Essential Different
' a() Corresponding Transformations (192)
' B1, B2 Sudoku Comparable Squares
' a1() Scratch Area Sudoku Check, Print
' b() Scratch Area Sudoku Check
' s() Scratch Area Magic Sum: Pan Diagonals, Pairs, etc
' fl8 Format Flag fl8 = 1 Line Format
' fl8 = 0 Square Format
' fl3 Suduku Flag fl3 = 1 Show Sudoku Squares n8 = 4
' fl3 = 0 Show Squares n8 = 5 (Default)
' n8 Default n8 = 5: 4 Squares per Line
' M/B1/B2 n8 = 4: 3 Squares per Line
If fl8 = 1 Then
Cells(n9 + 1, 65).Select
Else
Cells(k1 + 1, 1).Select
If fl3 = 1 Then n8 = 4 Else n8 = 5
End If
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
f1 = "C:\Users\Jos\Devellopments\Vierkanten\Bimagic\Trump8\Bimagic8.mdb"
f2 = "Bimagic8": f3 = "TrInd8"
k1 = 1: k2 = 1
' Open the database and input table
Set MyWorkSpace = DBEngine.Workspaces(0)
Set MyDB = MyWorkSpace.OpenDatabase(f1)
Set Td1 = MyDB.OpenRecordset(f2, dbOpenTable)
Set Td2 = MyDB.OpenRecordset(f3, dbOpenTable)
Td1.MoveFirst
Do Until Td1.EOF
n10 = n10 + 1
If fl8 = 1 Then
Cells(n9 + 1, 65).Value = n10
Else
Cells(k1 + 1, 1).Value = n10
End If
' Read Record (BiMagic Square)
For j1 = 1 To 64
FldName = "Veld" + CStr(j1)
t1 = Td1.Fields(FldName)
b8(j1) = t1
Next j1
Td2.MoveFirst
Do Until Td2.EOF
' Read Record (Index Transformations)
For j2 = 1 To 64
FldName = "Veld" + CStr(j2)
t1 = Td2.Fields(FldName)
a(j2) = b8(CInt(t1))
Next j2
Td2.MoveNext
' Check Criteria a()
GoSub 150: GoSub 500 ' Associated
If fl1 = 0 Then GoTo 200
' Decomposition and Check Sudoku Comparable Squares B1(), B2()
For i1 = 1 To 64
b1(i1) = (a(i1) - 1) Mod 8
a1(i1) = b1(i1)
Next i1
GoSub 810: If fl1 = 0 Then GoTo 200 ' Check Rows B1
GoSub 820: If fl1 = 0 Then GoTo 200 ' Check Columns B1
GoSub 830: If fl1 = 0 Then GoTo 200 ' Check Diagonals B1
For i1 = 1 To 64
B2(i1) = Int((a(i1) - 1) / 8)
a1(i1) = B2(i1)
Next i1
GoSub 810: If fl1 = 0 Then GoTo 200 ' Check Rows B2
GoSub 820: If fl1 = 0 Then GoTo 200 ' Check Columns B2
GoSub 830: If fl1 = 0 Then GoTo 200 ' Check Diagonals B2
' Meets Criterium: Print Results
For i1 = 1 To 64: a1(i1) = a(i1): Next i1
n9 = n9 + 1
If fl8 = 1 Then
GoSub 645 'Print results (selected numbers)
Else
GoSub 650 'Print results (squares)
If fl3 = 1 Then
For i1 = 1 To 64: a1(i1) = b1(i1): Next i1
n9 = n9 + 1: GoSub 650
For i1 = 1 To 64: a1(i1) = B2(i1): Next i1
n9 = n9 + 1: GoSub 650
End If
End If
200
Loop
100 Td1.MoveNext
Loop
y = MsgBox("Records: " + CStr(n9), vbInformation, "ReadDb8e")
MyDB.Close
End
' Print results (selected numbers)
645 For i1 = 1 To 64
Cells(n9, i1).Value = a1(i1)
Next i1
Cells(n9, 65).Select
Cells(n9, 65).Value = n9
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = n8 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Font.Color = -4165632
Cells(k1, k2 + 2).Value = "R" + CStr(n10)
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a1(i3)
Next i2
Next i1
Return
' Check Associated
150 n4 = 32: s2 = 65
s(1) = a(1) + a(64): s(2) = a(2) + a(63): s(3) = a(3) + a(62): s(4) = a(4) + a(61):
s(5) = a(5) + a(60): s(6) = a(6) + a(59): s(7) = a(7) + a(58): s(8) = a(8) + a(57)
s(9) = a(16) + a(49): s(10) = a(24) + a(41): s(11) = a(32) + a(33): s(12) = a(40) + a(25):
s(13) = a(48) + a(17): s(14) = a(56) + a(9)
s(15) = a(10) + a(55): s(16) = a(11) + a(54): s(17) = a(12) + a(53): s(18) = a(13) + a(52):
s(19) = a(14) + a(51): s(20) = a(15) + a(50)
s(21) = a(23) + a(42): s(22) = a(31) + a(34): s(23) = a(39) + a(26): s(24) = a(47) + a(18)
s(25) = a(19) + a(46): s(26) = a(20) + a(45): s(27) = a(21) + a(44): s(28) = a(22) + a(43):
s(29) = a(30) + a(35): s(30) = a(38) + a(27)
s(31) = a(28) + a(37): s(32) = a(29) + a(36)
Return
' Check Criterium
500 fl1 = 1
For i1 = 1 To n4
If s(i1) <> s2 Then fl1 = 0: Return
Next i1
Return
' Check Sudoku Comparable Squares
' Exclude solutions with identical numbers in rows, columns, diagonals
' Rows
810 fl1 = 1
i1 = -7
For i0 = 1 To 8
i1 = i1 + 8
b(1) = a1(i1): b(2) = a1(i1 + 1): b(3) = a1(i1 + 2): b(4) = a1(i1 + 3)
b(5) = a1(i1 + 4): b(6) = a1(i1 + 5): b(7) = a1(i1 + 6): b(8) = a1(i1 + 7)
GoSub 860: If fl1 = 0 Then Return
Next i0
Return
' Columns
820 fl1 = 1
i1 = 0
For i0 = 1 To 8
i1 = i1 + 1
b(1) = a1(i1): b(2) = a1(i1 + 8): b(3) = a1(i1 + 16): b(4) = a1(i1 + 24)
b(5) = a1(i1 + 32): b(6) = a1(i1 + 40): b(7) = a1(i1 + 48): b(8) = a1(i1 + 56)
GoSub 860: If fl1 = 0 Then Return
Next i0
Return
' Diagonals
830 fl1 = 1
b(1) = a1(1): b(2) = a1(10): b(3) = a1(19): b(4) = a1(28)
b(5) = a1(37): b(6) = a1(46): b(7) = a1(55): b(8) = a1(64)
GoSub 860: If fl1 = 0 Then Return
b(1) = a1(8): b(2) = a1(15): b(3) = a1(22): b(4) = a1(29)
b(5) = a1(36): b(6) = a1(43): b(7) = a1(50): b(8) = a1(57)
GoSub 860: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 8
b20 = b(j1)
For j2 = (1 + j1) To 8
If b20 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
End Sub
