Vorige Pagina About the Author

' Generates Sudoku Comparable Simple Magic Cubes of order 4 for integers 0 thru 3
' Associated and 3D-Compact

' Tested with Office 2007 under Windows 7

Sub SudCube44()

Dim a(64), b(4)

y = MsgBox("Locked", vbCritical, "Routine SudCube44")
End

n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 3: s1 = 6

'   Generate data
    
    Sheets("Klad1").Select
    
    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 - 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

    a(57) =    - a(60) + a(62) + a(63): If a(57) < m1 Or a(57) > m2 Then GoTo 600

For j59 = m1 To m2                                                   'a(59)
    a(59) = j59

    a(58) = s1 - a(59) - a(62) - a(63): If a(58) < m1 Or a(58) > m2 Then GoTo 590

For j56 = m1 To m2                                                   'a(56)
    a(56) = j56

    a(55) =   s1 - a(56) - a(59) - a(60): If a(55) < m1 Or a(55) > m2 Then GoTo 560
    a(52) =   s1 - a(56) - a(60) - a(64): If a(52) < m1 Or a(52) > m2 Then GoTo 560
    a(51) =        a(56) + a(60) - a(63): If a(51) < m1 Or a(51) > m2 Then GoTo 560

For j54 = m1 To m2                                                   'a(54)
    a(54) = j54

    a(53) =      - a(54) + a(59) + a(60): If a(53) < m1 Or a(53) > m2 Then GoTo 540
    a(50) =      - a(54) + a(59) + a(63): If a(50) < m1 Or a(50) > m2 Then GoTo 540
    a(49) =        a(54) - a(59) + a(64): If a(49) < m1 Or a(49) > m2 Then GoTo 540
 
For j48 = m1 To m2                                                   'a(48)
    a(48) = j48

    a(45) =      - a(48) + a(62) + a(63): If a(45) < m1 Or a(45) > m2 Then GoTo 480
    a(36) =      - a(48) + a(56) + a(60): If a(36) < m1 Or a(36) > m2 Then GoTo 480
    a(33) =        a(48) - a(54) + a(59): If a(33) < m1 Or a(33) > m2 Then GoTo 480
    
For j47 = m1 To m2                                                   'a(47)
    a(47) = j47

    a(46) =   s1 - a(47) - a(62) - a(63): If a(46) < m1 Or a(46) > m2 Then GoTo 470
    a(35) =   s1 - a(47) - a(56) - a(60): If a(35) < m1 Or a(35) > m2 Then GoTo 470
    a(34) =        a(47) + a(54) - a(59): If a(34) < m1 Or a(34) > m2 Then GoTo 470
     
For j44 = m1 To m2                                                   'a(44)
    a(44) = j44

    a(43) = 2*s1 - a(44) - a(47) - a(48) - a(59) - a(60) - a(63) - a(64): 
    If a(43) < m1 Or a(43) > m2 Then GoTo 440 
    a(42) =      - a(43) + a(62) + a(63): If a(42) < m1 Or a(42) > m2 Then GoTo 440
    a(41) =   s1 - a(44) - a(62) - a(63): If a(41) < m1 Or a(41) > m2 Then GoTo 440
    a(40) =   s1 - a(44) - a(56) - a(60): If a(40) < m1 Or a(40) > m2 Then GoTo 440
    a(39) =      - a(43) + a(56) + a(60): If a(39) < m1 Or a(39) > m2 Then GoTo 440
    a(38) =      - a(39) - a(54) + a(56) + a(59) + a(60): 
    If a(38) < m1 Or a(38) > m2 Then GoTo 440
    a(37) =        a(44) + a(54) - a(59): If a(37) < m1 Or a(37) > m2 Then GoTo 440

    a(32) = s1/2 - a(33): a(24) = s1/2 - a(41): a(16) = s1/2 - a(49): a(8) = s1/2 - a(57)
    a(31) = s1/2 - a(34): a(23) = s1/2 - a(42): a(15) = s1/2 - a(50): a(7) = s1/2 - a(58)
    a(30) = s1/2 - a(35): a(22) = s1/2 - a(43): a(14) = s1/2 - a(51): a(6) = s1/2 - a(59)
    a(29) = s1/2 - a(36): a(21) = s1/2 - a(44): a(13) = s1/2 - a(52): a(5) = s1/2 - a(60)
    a(28) = s1/2 - a(37): a(20) = s1/2 - a(45): a(12) = s1/2 - a(53): a(4) = s1/2 - a(61)
    a(27) = s1/2 - a(38): a(19) = s1/2 - a(46): a(11) = s1/2 - a(54): a(3) = s1/2 - a(62)
    a(26) = s1/2 - a(39): a(18) = s1/2 - a(47): a(10) = s1/2 - a(55): a(2) = s1/2 - a(63)
    a(25) = s1/2 - a(40): a(17) = s1/2 - a(48): a(9)  = s1/2 - a(56): a(1) = s1/2 - a(64)
    
'       Exclude solutions with identical numbers in rows, colums or pillars
        
        GoSub 800: If fl1 = 0 Then GoTo 440     'rows, colums or pillars
                           
        n9 = n9 + 1: GoSub 740  'Print results (selected numbers)
'       n9 = n9 + 1: GoSub 750  'Print results (planes 1, 2, 3, 4)

440 Next j44
    
470 Next j47
480 Next j48

540 Next j54

560 Next j56
    
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 SudCube44")

End

'   Print results (selected numbers)

740 For i1 = 1 To 64
        Cells(n9, i1).Value = a(i1)
    Next i1
    Cells(n9, 64).Select
    Return

'   Print results (planes 11, 12, 13 and 14)

750 n2 = n2 + 1
    If n2 = 9 Then
        n2 = 1: k1 = k1 + 20: k2 = 1
    Else
        If n9 > 1 Then k2 = k2 + 5
    End If
       
    Cells(k1, k2 + 1).Select
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = CStr(n9)
       
    For i0 = 1 To 4
        i3 = (4 - i0) * 16
        For i1 = 1 To 4
            For i2 = 1 To 4
                i3 = i3 + 1
                Cells(k1 + i1 + (i0 - 1) * 5, k2 + i2).Value = a(i3)
            Next i2
        Next i1
    Next i0
    
    Return

'   Exclude solutions with identical numbers in rows, colums or pillars

800 fl1 = 1

'   Rows
    
    i1 = -3
    For i0 = 1 To 16
        i1 = i1 + 4
        b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3)
        GoSub 860
        If fl1 = 0 Then Return
    Next i0
   
'   Columns
    
    i1 = 0: i2 = 0
    For i0 = 1 To 16
        i1 = i1 + 1
        b(1) = a(i1): b(2) = a(i1 + 4): b(3) = a(i1 + 8): b(4) = a(i1 + 12)
        i2 = i2 + 1: If i2 = 4 Then i2 = 0: i1 = i1 + 12
        GoSub 860
        If fl1 = 0 Then Return
    Next i0
    
'   Pillars
    
    i1 = 0: i2 = 0
    For i0 = 1 To 16
        i1 = i0
        b(1) = a(i1): b(2) = a(i1 + 16): b(3) = a(i1 + 32): b(4) = a(i1 + 48)
        GoSub 860
        If fl1 = 0 Then Return
    Next i0
    
    Return

860 fl1 = 1
    For j1 = 1 To 4
       b2 = b(j1)
       For j2 = (1 + j1) To 4
           If b2 = b(j2) Then fl1 = 0: Return
       Next j2
    Next j1
    Return

End Sub

Vorige Pagina About the Author