' Generates Quaternary Squares of order 8 for integers 0 ... 3
' Pan Magic, Complete,
' Sudoku Comparable Non Overlapping Subsquares
' Tested with Office 2007 under Windows 7
Sub Quat869()
Dim a(64), b(4), b1(8)
y = MsgBox("Locked", vbCritical, "Routine Quat869")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 3: s1 = 12
t1 = Timer
For j64 = m1 To m2 'a(64)
a(64) = j64
For j63 = m1 To m2 'a(63)
a(63) = j63
For j62 = m1 To m2 'a(62)
a(62) = j62
a(61) = s1 / 2 - a(62) - a(63) - a(64)
If a(61) < m1 Or a(61) > m2 Then GoTo 620
For j60 = m1 To m2 'a(60)
a(60) = j60
For j59 = m1 To m2 'a(59)
a(59) = j59
For j58 = m1 To m2 'a(58)
a(58) = j58
a(57) = s1 / 2 - a(58) - a(59) - a(60)
If a(57) < m1 Or a(57) > m2 Then GoTo 580
For j56 = m1 To m2 'a(56)
a(56) = j56
a(55) = s1 / 2 - a(56) - a(63) - a(64)
If a(55) < m1 Or a(55) > m2 Then GoTo 560
b(1) = a(55): b(2) = a(56): b(3) = a(63): b(4) = a(64): GoSub 1860: If fl1 = 0 Then GoTo 560
For j54 = m1 To m2 'a(54)
a(54) = j54
a(53) = -a(54) + a(63) + a(64)
If a(53) < m1 Or a(53) > m2 Then GoTo 540
b(1) = a(53): b(2) = a(54): b(3) = a(61): b(4) = a(62): GoSub 1860: If fl1 = 0 Then GoTo 540
For j52 = m1 To m2 'a(52)
a(52) = j52
a(51) = s1 / 2 - a(52) - a(59) - a(60)
If a(51) < m1 Or a(51) > m2 Then GoTo 520
b(1) = a(51): b(2) = a(52): b(3) = a(59): b(4) = a(60): GoSub 1860: If fl1 = 0 Then GoTo 520
For j50 = m1 To m2 'a(50)
a(50) = j50
a(49) = -a(50) + a(59) + a(60)
If a(49) < m1 Or a(49) > m2 Then GoTo 500
b(1) = a(49): b(2) = a(50): b(3) = a(57): b(4) = a(58): GoSub 1860: If fl1 = 0 Then GoTo 500
For j48 = m1 To m2 'a(48)
a(48) = j48
For j47 = m1 To m2 'a(47)
a(47) = j47
For j46 = m1 To m2 'a(46)
a(46) = j46
a(45) = s1 / 2 - a(46) - a(47) - a(48)
If a(45) < m1 Or a(45) > m2 Then GoTo 460
For j44 = m1 To m2 'a(44)
a(44) = j44
For j43 = m1 To m2 'a(43)
a(43) = j43
For j42 = m1 To m2 'a(42)
a(42) = j42
a(41) = s1 / 2 - a(42) - a(43) - a(44)
If a(41) < m1 Or a(41) > m2 Then GoTo 420
a(40) = s1 / 2 - a(48) - a(56) - a(64)
If a(40) < m1 Or a(40) > m2 Then GoTo 420
a(39) = -a(47) + a(56) + a(64)
If a(39) < m1 Or a(39) > m2 Then GoTo 420
b(1) = a(39): b(2) = a(40): b(3) = a(47): b(4) = a(48): GoSub 1860: If fl1 = 0 Then GoTo 420
a(38) = s1 / 2 - a(46) - a(54) - a(62)
If a(38) < m1 Or a(38) > m2 Then GoTo 420
a(37) = -s1 / 2 + a(46) + a(47) + a(48) + a(54) + a(62)
If a(37) < m1 Or a(37) > m2 Then GoTo 420
b(1) = a(37): b(2) = a(38): b(3) = a(45): b(4) = a(46): GoSub 1860: If fl1 = 0 Then GoTo 420
a(36) = s1 / 2 - a(44) - a(52) - a(60)
If a(36) < m1 Or a(36) > m2 Then GoTo 420
a(35) = -a(43) + a(52) + a(60)
If a(35) < m1 Or a(35) > m2 Then GoTo 420
b(1) = a(35): b(2) = a(36): b(3) = a(43): b(4) = a(44): GoSub 1860: If fl1 = 0 Then GoTo 420
a(34) = s1 / 2 - a(42) - a(50) - a(58)
If a(34) < m1 Or a(34) > m2 Then GoTo 420
a(33) = -s1 / 2 + a(42) + a(43) + a(44) + a(50) + a(58)
If a(33) < m1 Or a(33) > m2 Then GoTo 420
b(1) = a(33): b(2) = a(34): b(3) = a(41): b(4) = a(42): GoSub 1860: If fl1 = 0 Then GoTo 420
a(32) = s1 / 4 - a(33): a(31) = s1 / 4 - a(34): a(30) = s1 / 4 - a(35): a(29) = s1 / 4 - a(36)
a(28) = s1 / 4 - a(37): a(27) = s1 / 4 - a(38): a(26) = s1 / 4 - a(39): a(25) = s1 / 4 - a(40)
a(24) = s1 / 4 - a(41): a(23) = s1 / 4 - a(42): a(22) = s1 / 4 - a(43): a(21) = s1 / 4 - a(44)
a(20) = s1 / 4 - a(45): a(19) = s1 / 4 - a(46): a(18) = s1 / 4 - a(47): a(17) = s1 / 4 - a(48)
a(16) = s1 / 4 - a(49): a(15) = s1 / 4 - a(50): a(14) = s1 / 4 - a(51): a(13) = s1 / 4 - a(52)
a(12) = s1 / 4 - a(53): a(11) = s1 / 4 - a(54): a(10) = s1 / 4 - a(55): a(9) = s1 / 4 - a(56)
a(8) = s1 / 4 - a(57): a(7) = s1 / 4 - a(58): a(6) = s1 / 4 - a(59): a(5) = s1 / 4 - a(60)
a(4) = s1 / 4 - a(61): a(3) = s1 / 4 - a(62): a(2) = s1 / 4 - a(63): a(1) = s1 / 4 - a(64)
' Ensure that 0, 1, 2, 3 occurs only one time in Non Overlapping Subsquares
GoSub 1830: If fl1 = 0 Then GoTo 420
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
420 Next j42
430 Next j43
440 Next j44
460 Next j46
470 Next j47
480 Next j48
500 Next j50
520 Next j52
540 Next j54
560 Next j56
580 Next j58
590 Next j59
600 Next j60
620 Next j62
630 Next j63
640 Next j64
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine Quat869")
End
' Ensure that 0, 1, 2, 3 occurs only one time in Non Overlapping Subsquares
1830 fl1 = 1: Erase b
b(1) = a(1): b(2) = a(2): b(3) = a(9): b(4) = a(10): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(3): b(2) = a(4): b(3) = a(11): b(4) = a(12): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(5): b(2) = a(6): b(3) = a(13): b(4) = a(14): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(7): b(2) = a(8): b(3) = a(15): b(4) = a(16): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(17): b(2) = a(18): b(3) = a(25): b(4) = a(26): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(19): b(2) = a(20): b(3) = a(27): b(4) = a(28): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(21): b(2) = a(22): b(3) = a(29): b(4) = a(30): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(23): b(2) = a(24): b(3) = a(31): b(4) = a(32): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(33): b(2) = a(34): b(3) = a(41): b(4) = a(42): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(35): b(2) = a(36): b(3) = a(43): b(4) = a(44): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(37): b(2) = a(38): b(3) = a(45): b(4) = a(46): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(39): b(2) = a(40): b(3) = a(47): b(4) = a(48): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(49): b(2) = a(50): b(3) = a(57): b(4) = a(58): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(51): b(2) = a(52): b(3) = a(59): b(4) = a(60): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(53): b(2) = a(54): b(3) = a(61): b(4) = a(62): GoSub 1860: If fl1 = 0 Then Return
b(1) = a(55): b(2) = a(56): b(3) = a(63): b(4) = a(64): GoSub 1860: If fl1 = 0 Then Return
Return
' Check identical numbers
1860 fl1 = 1
For j10 = 1 To 4
b20 = b(j10)
For j20 = (1 + j10) To 4
If b20 = b(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
' Print results (selected numbers)
2645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 64).Select
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 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 = CStr(n9)
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
