Vorige Pagina About the Author

' Generates Sudoku Comparable Squares of order 9 based on Ternary Squares

' Tested with Office 2007 under Windows 7

Sub CnstrSqrs9b()

    Dim b1(2, 81), a(81), b(9)

    Sheets("Klad1").Select
    
y = MsgBox("Locked", vbCritical, "Routine CnstrSqrs9b")
End
    
    n4 = 3456 			 'Base Case    : 3456
                                 'Solutions962 :   24

    n2 = 0: n9 = 0: k1 = 1: k2 = 1
    s1 = 36
    
    t1 = Timer
    
    For j1 = 2 To n4 + 1
    
    Cells(n9 + 1, 82).Select: Cells(n9 + 1, 82).Value = j1
    
    For j2 = 2 To n4 + 1
    If j2 = j1 Then GoTo 20
        
        j10 = j1: j20 = 1: GoSub 100                 'Read Ternary Square 1
        j10 = j2: j20 = 2: GoSub 100                 'Read Ternary Square 2
        
        For j4 = 1 To 81
            a(j4) = b1(1, j4) + 3 * b1(2, j4)
        Next j4
        
        GoSub 1800: If fl1 = 0 Then GoTo 20          'Check identical numbers
                                                     'in rows, columns, main diagonals and sub squares
                           
        n9 = n9 + 1: GoSub 740                       'Print results (selected numbers)
'       n9 = n9 + 1: GoSub 750                       'Print results (squares)

20  Next j2
    
    Next j1
    
    t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine CnstrSqrs9b")

End
    
'   Read Ternary Squares (Line Format)

100 For i1 = 1 To 81
        b1(j20, i1) = Sheets("Input962").Cells(j10, i1).Value
    Next i1
    Return
    
'   Check identical numbers
'   in rows, columns, main diagonals and sub squares (partly compact only)
    
1800 fl1 = 1
'    Rows
    
     i1 = -8
     For i0 = 1 To 9
         i1 = i1 + 9
         b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3): b(5) = a(i1 + 4)
         b(6) = a(i1 + 5): b(7) = a(i1 + 6): b(8) = a(i1 + 7): b(9) = a(i1 + 8)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0
   
'    Columns
    
     i1 = 0
     For i0 = 1 To 9
         i1 = i1 + 1
         b(1) = a(i1): b(2) = a(i1 + 9): b(3) = a(i1 + 18): b(4) = a(i1 + 27): b(5) = a(i1 + 36)
         b(6) = a(i1 + 45): b(7) = a(i1 + 54): b(8) = a(i1 + 63): b(9) = a(i1 + 72)
         GoSub 1860: If fl1 = 0 Then Return
     Next i0
    
'    Main Diagonals

     b(1) = a(1): b(2) = a(11): b(3) = a(21): b(4) = a(31): b(5) = a(41): b(6) = a(51): b(7) = a(61): b(8) = a(71): b(9) = a(81):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(9): b(2) = a(17): b(3) = a(25): b(4) = a(33): b(5) = a(41): b(6) = a(49): b(7) = a(57): b(8) = a(65): b(9) = a(73):
     GoSub 1860: If fl1 = 0 Then Return

     Return

'    Sub Squares 3 x 3 (Optional)

     b(1) = a(1): b(2) = a(2): b(3) = a(3): b(4) = a(10): b(5) = a(11): b(6) = a(12): b(7) = a(19): b(8) = a(20): b(9) = a(21):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(4): b(2) = a(5): b(3) = a(6): b(4) = a(13): b(5) = a(14): b(6) = a(15): b(7) = a(22): b(8) = a(23): b(9) = a(24):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(7): b(2) = a(8): b(3) = a(9): b(4) = a(16): b(5) = a(17): b(6) = a(18): b(7) = a(25): b(8) = a(26): b(9) = a(27):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(28): b(2) = a(29): b(3) = a(30): b(4) = a(37): b(5) = a(38): b(6) = a(39): b(7) = a(46): b(8) = a(47): b(9) = a(48):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(31): b(2) = a(32): b(3) = a(33): b(4) = a(40): b(5) = a(41): b(6) = a(42): b(7) = a(49): b(8) = a(50): b(9) = a(51):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(34): b(2) = a(35): b(3) = a(36): b(4) = a(43): b(5) = a(44): b(6) = a(45): b(7) = a(52): b(8) = a(53): b(9) = a(54):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(55): b(2) = a(56): b(3) = a(57): b(4) = a(64): b(5) = a(65): b(6) = a(66): b(7) = a(73): b(8) = a(74): b(9) = a(75):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(58): b(2) = a(59): b(3) = a(60): b(4) = a(67): b(5) = a(68): b(6) = a(69): b(7) = a(76): b(8) = a(77): b(9) = a(78):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(61): b(2) = a(62): b(3) = a(63): b(4) = a(70): b(5) = a(71): b(6) = a(72): b(7) = a(79): b(8) = a(80): b(9) = a(81):
     GoSub 1860: If fl1 = 0 Then Return

     Return

'    Sub Squares Partly Compact (Optional)
    
'    Sub Squares 3 x 3 (left to right)

     For i1 = 1 To 3        'Check 27 Squares
        i22 = (i1 - 1) * 27
        For i2 = 1 To 9
            i11 = i2:
            i12 = (i11 + 1) Mod 9: If i12 = 0 Then i12 = 9
            i13 = (i12 + 1) Mod 9: If i13 = 0 Then i13 = 9
            
            b(1) = a(i22 + i11):      b(2) = a(i22 + i12):      b(3) = a(i22 + i13)
            b(4) = a(i22 + i11 + 9):  b(5) = a(i22 + i12 + 9):  b(6) = a(i22 + i13 + 9)
            b(7) = a(i22 + i11 + 18): b(8) = a(i22 + i12 + 18): b(9) = a(i22 + i13 + 18)
            GoSub 1860: If fl1 = 0 Then Return
        Next i2
     Next i1

'    Sub Squares 3 x 3 (top to bottom) 
   
     For i1 = 1 To 5       'Check 12 Squares
        If i1 <> 3 Then
            i22 = 9 + (i1 - 1) * 9
            For i2 = 1 To 9 Step 3
                i11 = i2:
                i12 = (i11 + 1) Mod 9: If i12 = 0 Then i12 = 9
                i13 = (i12 + 1) Mod 9: If i13 = 0 Then i13 = 9
                
                b(1) = a(i22 + i11):      b(2) = a(i22 + i12):      b(3) = a(i22 + i13)
                b(4) = a(i22 + i11 + 9):  b(5) = a(i22 + i12 + 9):  b(6) = a(i22 + i13 + 9)
                b(7) = a(i22 + i11 + 18): b(8) = a(i22 + i12 + 18): b(9) = a(i22 + i13 + 18)
                GoSub 1860: If fl1 = 0 Then Return
            Next i2
         End If
     Next i1
     
'    Check 6 Squares
     
     b(1) = a(64): b(2) = a(65): b(3) = a(66): b(4) = a(73): b(5) = a(74): b(6) = a(75): b(7) = a(1): b(8) = a(2): b(9) = a(3):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(67): b(2) = a(68): b(3) = a(69): b(4) = a(76): b(5) = a(77): b(6) = a(78): b(7) = a(4): b(8) = a(5): b(9) = a(6):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(70): b(2) = a(71): b(3) = a(72): b(4) = a(79): b(5) = a(80): b(6) = a(81): b(7) = a(7): b(8) = a(8): b(9) = a(9):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(73): b(2) = a(74): b(3) = a(75): b(4) = a(1): b(5) = a(2): b(6) = a(3): b(7) = a(10): b(8) = a(11): b(9) = a(12):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(76): b(2) = a(77): b(3) = a(78): b(4) = a(4): b(5) = a(5): b(6) = a(6): b(7) = a(13): b(8) = a(14): b(9) = a(15):
     GoSub 1860: If fl1 = 0 Then Return
     b(1) = a(79): b(2) = a(80): b(3) = a(81): b(4) = a(7): b(5) = a(8): b(6) = a(9): b(7) = a(16): b(8) = a(17): b(9) = a(18):
     GoSub 1860: If fl1 = 0 Then Return
     
     Return
    
'    Check identical numbers
    
1860 fl1 = 1
     For j10 = 1 To 9
        b2 = b(j10)
        For j20 = (1 + j10) To 9
            If b2 = b(j20) Then fl1 = 0: Return
        Next j20
     Next j10
     Return
    
'   Print results (selected numbers)

740 Cells(n9, 81).Select
    For i1 = 1 To 81
        Cells(n9, i1).Value = a(i1)
    Next i1
    Cells(n9, 82).Value = j1
    Cells(n9, 83).Value = j2
    Return

'   Print results (squares)

750 n2 = n2 + 1
    If n2 = 5 Then
       n2 = 1: k1 = k1 + 10: k2 = 1
    Else
       If n9 > 1 Then k2 = k2 + 10
    End If
     
    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
   
    i3 = 0
    For i1 = 1 To 9
       For i2 = 1 To 9
           i3 = i3 + 1
           Cells(k1 + i1, k2 + i2).Value = a(i3)
       Next i2
    Next i1
    
    Return
    
End Sub

Vorige Pagina About the Author