Vorige Pagina About the Author

' Generates Quaternary Squares of order 8 for integers 0 ... 3
' Associated,
' Sudoku Comparable Non Overlapping Subsquares

' Tested with Office 2007 under Windows 7

Sub Quat867z()

Dim a(64), b(4), b1(8)

y = MsgBox("Locked", vbCritical, "Routine Quat867z")
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

For j61 = m1 To m2                                            'a(61)
    a(61) = j61

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 - a(58) - a(59) - a(60) - a(61) - a(62) - a(63) - a(64)
    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) = s1 / 2 - a(54) - a(61) - a(62)
    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) = s1 / 2 - a(50) - a(57) - a(58)
    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 - a(46) - a(47) - a(48) + a(50) - a(52) - a(54) + a(56) + a(58) - a(60) - a(61) - 2 * a(62) - a(63)
    If a(45) < m1 Or a(45) > m2 Then GoTo 460
    a(44) = -s1 + a(48) - a(50) + a(54) + a(59) + a(60) + 2 * a(61) + 2 * a(62) + a(63) + a(64)
    If a(44) < m1 Or a(44) > m2 Then GoTo 460
    a(43) = s1 - a(47) - 2 * a(48) + a(50) - a(54) - 2 * a(61) - 2 * a(62)
    If a(43) < m1 Or a(43) > m2 Then GoTo 460
    a(42) = -s1 + a(46)+2*a(47)+2*a(48)-2*a(50)+a(52)+2*a(54)-a(56)-2*a(58)-a(59)+a(60)+2*a(61)+4*a(62)+a(63)-a(64)
    If a(42) < m1 Or a(42) > m2 Then GoTo 460
    a(41) = s1 - a(46) - a(47) - a(48) + a(50) - a(54) + a(58) - a(60) - a(61) - 2 * a(62) - a(63)
    If a(41) < m1 Or a(41) > m2 Then GoTo 460
    a(40) = s1 - a(47) - 2 * a(48) - a(54) - a(61) - 2 * a(62)
    If a(40) < m1 Or a(40) > m2 Then GoTo 460
    a(39) = -s1 / 2 + a(48) + a(54) + a(61) + 2 * a(62)
    If a(39) < m1 Or a(39) > m2 Then GoTo 460
    
    b(1) = a(39): b(2) = a(40): b(3) = a(47): b(4) = a(48): GoSub 1860: If fl1 = 0 Then GoTo 460
    
    a(38) = s1 - a(46) - a(47) - a(48) + a(50) - a(52) - a(54) + a(58) - a(60) - a(61) - 2 * a(62)
    If a(38) < m1 Or a(38) > m2 Then GoTo 460
    a(37) = -3*s1/2 + a(46)+2*a(47)+2*a(48)-2*a(50)+2*a(52)+2*a(54)-a(56)-2*a(58)+2*a(60)+2*a(61)+4*a(62)+a(63)
    If a(37) < m1 Or a(37) > m2 Then GoTo 460

    b(1) = a(37): b(2) = a(38): b(3) = a(45): b(4) = a(46): GoSub 1860: If fl1 = 0 Then GoTo 460

    a(36) = a(47) - a(54) + a(57)
    If a(36) < m1 Or a(36) > m2 Then GoTo 460
    a(35) = -s1 / 2 + a(48) + a(54) + a(58) + a(61) + a(62)
    If a(35) < m1 Or a(35) > m2 Then GoTo 460
    
    b(1) = a(35): b(2) = a(36): b(3) = a(43): b(4) = a(44): GoSub 1860: If fl1 = 0 Then GoTo 460
    
    a(34) = s1 - a(46) - a(47) - a(48) + a(50) - a(52) - a(54) + a(58) + a(59) - a(60) - a(61) - 2 * a(62) - a(63)
    If a(34) < m1 Or a(34) > m2 Then GoTo 460
    a(33) = -s1 / 2 + a(46) + a(56) + a(60) + a(63) + a(64)
    If a(33) < m1 Or a(33) > m2 Then GoTo 460

    b(1) = a(33): b(2) = a(34): b(3) = a(41): b(4) = a(42): GoSub 1860: If fl1 = 0 Then GoTo 460

    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)


'                  Check Zigzag Requirements
                   GoSub 1800: If fl1 = 0 Then GoTo 460

'                  Ensure that 0, 1, 2, 3 occurs only one time in the Non Overlapping Subsquares
                   GoSub 1830: If fl1 = 0 Then GoTo 460
                           
                   n9 = n9 + 1
                   GoSub 2650      'Print results (squares)
'                  GoSub 2645      'Print results (selected numbers)


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
610 Next j61
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 Quat867z")

End

'    Check Zigzag Requirements

1800  fl1 = 1
    
    'Top/Bottom
    s(1) = a(1) + a(10) + a(3) + a(12) + a(5) + a(14) + a(7) + a(16)
    s(2) = a(9) + a(18) + a(11) + a(20) + a(13) + a(22) + a(15) + a(24)
    s(3) = a(17) + a(26) + a(19) + a(28) + a(21) + a(30) + a(23) + a(32)
    s(4) = a(25) + a(34) + a(27) + a(36) + a(29) + a(38) + a(31) + a(40)
    s(5) = a(33) + a(42) + a(35) + a(44) + a(37) + a(46) + a(39) + a(48)
    s(6) = a(41) + a(50) + a(43) + a(52) + a(45) + a(54) + a(47) + a(56)
    s(7) = a(49) + a(58) + a(51) + a(60) + a(53) + a(62) + a(55) + a(64)
    s(8) = a(57) + a(2) + a(59) + a(4) + a(61) + a(6) + a(63) + a(8)
    
    'Left/Right
    s(9) = a(1) + a(10) + a(17) + a(26) + a(33) + a(42) + a(49) + a(58)
    s(10) = a(2) + a(11) + a(18) + a(27) + a(34) + a(43) + a(50) + a(59)
    s(11) = a(3) + a(12) + a(19) + a(28) + a(35) + a(44) + a(51) + a(60)
    s(12) = a(4) + a(13) + a(20) + a(29) + a(36) + a(45) + a(52) + a(61)
    s(13) = a(5) + a(14) + a(21) + a(30) + a(37) + a(46) + a(53) + a(62)
    s(14) = a(6) + a(15) + a(22) + a(31) + a(38) + a(47) + a(54) + a(63)
    s(15) = a(7) + a(16) + a(23) + a(32) + a(39) + a(48) + a(55) + a(64)
    s(16) = a(8) + a(9) + a(24) + a(25) + a(40) + a(41) + a(56) + a(57)

'   Check Four Way V type Zigzag

    fl1 = 1
    For j20 = 1 To 16
        If s(j20) <> s1 Then fl1 = 0: Exit For
    Next j20

    Return


'    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

Vorige Pagina About the Author