Vorige Pagina About the Author

' Generates Quaternary Pantriagonal Magic Cubes (Complete) of order 4 for integers 0 thru 3
' Sudoku Comparable (Optional)

' Tested with Office 2007 under Windows 7

Sub SudCube46()

Dim a(64), b(4)

y = MsgBox("Locked", vbCritical, "Routine SudCube46")
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
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): If a(57) < m1 Or a(57) > m2 Then GoTo 580

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

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

For j55 = m1 To m2                                                   'a(55)
    a(55) = j55

    a(51) = s1 - a(55) - a(59) - a(63): If a(51) < m1 Or a(51) > m2 Then GoTo 550

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

    a(53) = s1 - a(54) - a(55) - a(56): If a(53) < m1 Or a(53) > m2 Then GoTo 540
    a(50) = s1 - a(54) - a(58) - a(62): If a(50) < m1 Or a(50) > m2 Then GoTo 540
    a(49) = s1 - a(53) - a(57) - a(61): If a(49) < m1 Or a(49) > m2 Then GoTo 540
 
For j48 = m1 To m2                                                   'a(48)
    a(48) = j48

    a(38) = a(48) - a(54) + a(64): If a(38) < m1 Or a(38) > m2 Then GoTo 480    
    
For j47 = m1 To m2                                                   'a(47)
    a(47) = j47

    a(37) = a(47) - a(53) + a(63): If a(37) < m1 Or a(37) > m2 Then GoTo 470
     
For j46 = m1 To m2                                                   'a(46)
    a(46) = j46
    
    a(45) =   s1 - a(46) - a(47) - a(48): If a(45) < m1 Or a(45) > m2 Then GoTo 460
    a(40) =        a(46) - a(56) + a(62): If a(40) < m1 Or a(40) > m2 Then GoTo 460
    a(39) =        a(45) - a(55) + a(61): If a(39) < m1 Or a(39) > m2 Then GoTo 460

For j44 = m1 To m2                                                   'a(44)
    a(44) = j44

    a(42) = 2*s1 - a(44) - a(46) - a(48) - a(58) - a(60) - a(62) - a(64)
    If a(42) < m1 Or a(42) > m2 Then GoTo 440    
    a(36) =   s1 - a(44) - a(46) - a(48) + a(56) - a(62): 
    If a(36) < m1 Or a(36) > m2 Then GoTo 440
    a(34) = - s1 + a(44) + a(54) + a(58) + a(60) + a(62): 
    If a(34) < m1 Or a(34) > m2 Then GoTo 440

For j43 = m1 To m2                                                   'a(43)
    a(43) = j43

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

430 Next j43
440 Next j44
    
460 Next j46
470 Next j47
480 Next j48

540 Next j54
550 Next j55    
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 SudCube46")

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
   
'    Check Pan Triagonals

900  fl1 = 1
                
     b(1) = a(49): b(2) = a(38): b(3) = a(27): b(4) = a(16): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(53): b(2) = a(42): b(3) = a(31): b(4) = a(4): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(57): b(2) = a(46): b(3) = a(19): b(4) = a(8): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(61): b(2) = a(34): b(3) = a(23): b(4) = a(12): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(50): b(2) = a(39): b(3) = a(28): b(4) = a(13): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(54): b(2) = a(43): b(3) = a(32): b(4) = a(1): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(58): b(2) = a(47): b(3) = a(20): b(4) = a(5): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(62): b(2) = a(35): b(3) = a(24): b(4) = a(9): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(51): b(2) = a(40): b(3) = a(25): b(4) = a(14): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(55): b(2) = a(44): b(3) = a(29): b(4) = a(2): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(59): b(2) = a(48): b(3) = a(17): b(4) = a(6): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(63): b(2) = a(36): b(3) = a(21): b(4) = a(10): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(52): b(2) = a(37): b(3) = a(26): b(4) = a(15): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(56): b(2) = a(41): b(3) = a(30): b(4) = a(3): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(60): b(2) = a(45): b(3) = a(18): b(4) = a(7): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(64): b(2) = a(33): b(3) = a(22): b(4) = a(11): GoSub 860: If fl1 = 0 Then Return
                    
     b(1) = a(52): b(2) = a(39): b(3) = a(26): b(4) = a(13): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(56): b(2) = a(43): b(3) = a(30): b(4) = a(1): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(60): b(2) = a(47): b(3) = a(18): b(4) = a(5): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(64): b(2) = a(35): b(3) = a(22): b(4) = a(9): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(49): b(2) = a(40): b(3) = a(27): b(4) = a(14): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(53): b(2) = a(44): b(3) = a(31): b(4) = a(2): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(57): b(2) = a(48): b(3) = a(19): b(4) = a(6): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(61): b(2) = a(36): b(3) = a(23): b(4) = a(10): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(50): b(2) = a(37): b(3) = a(28): b(4) = a(15): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(54): b(2) = a(41): b(3) = a(32): b(4) = a(3): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(58): b(2) = a(45): b(3) = a(20): b(4) = a(7): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(62): b(2) = a(33): b(3) = a(24): b(4) = a(11): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(51): b(2) = a(38): b(3) = a(25): b(4) = a(16): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(55): b(2) = a(42): b(3) = a(29): b(4) = a(4): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(59): b(2) = a(46): b(3) = a(17): b(4) = a(8): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(63): b(2) = a(34): b(3) = a(21): b(4) = a(12): GoSub 860: If fl1 = 0 Then Return
                    
     b(1) = a(61): b(2) = a(42): b(3) = a(23): b(4) = a(4): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(49): b(2) = a(46): b(3) = a(27): b(4) = a(8): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(53): b(2) = a(34): b(3) = a(31): b(4) = a(12): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(57): b(2) = a(38): b(3) = a(19): b(4) = a(16): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(62): b(2) = a(43): b(3) = a(24): b(4) = a(1): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(50): b(2) = a(47): b(3) = a(28): b(4) = a(5): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(54): b(2) = a(35): b(3) = a(32): b(4) = a(9): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(58): b(2) = a(39): b(3) = a(20): b(4) = a(13): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(63): b(2) = a(44): b(3) = a(21): b(4) = a(2): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(51): b(2) = a(48): b(3) = a(25): b(4) = a(6): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(55): b(2) = a(36): b(3) = a(29): b(4) = a(10): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(59): b(2) = a(40): b(3) = a(17): b(4) = a(14): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(64): b(2) = a(41): b(3) = a(22): b(4) = a(3): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(52): b(2) = a(45): b(3) = a(26): b(4) = a(7): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(56): b(2) = a(33): b(3) = a(30): b(4) = a(11): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(60): b(2) = a(37): b(3) = a(18): b(4) = a(15): GoSub 860: If fl1 = 0 Then Return
                    
     b(1) = a(64): b(2) = a(43): b(3) = a(22): b(4) = a(1): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(52): b(2) = a(47): b(3) = a(26): b(4) = a(5): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(56): b(2) = a(35): b(3) = a(30): b(4) = a(9): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(60): b(2) = a(39): b(3) = a(18): b(4) = a(13): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(61): b(2) = a(44): b(3) = a(23): b(4) = a(2): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(49): b(2) = a(48): b(3) = a(27): b(4) = a(6): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(53): b(2) = a(36): b(3) = a(31): b(4) = a(10): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(57): b(2) = a(40): b(3) = a(19): b(4) = a(14): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(62): b(2) = a(41): b(3) = a(24): b(4) = a(3): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(50): b(2) = a(45): b(3) = a(28): b(4) = a(7): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(54): b(2) = a(33): b(3) = a(32): b(4) = a(11): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(58): b(2) = a(37): b(3) = a(20): b(4) = a(15): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(63): b(2) = a(42): b(3) = a(21): b(4) = a(4): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(51): b(2) = a(46): b(3) = a(25): b(4) = a(8): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(55): b(2) = a(34): b(3) = a(29): b(4) = a(12): GoSub 860: If fl1 = 0 Then Return
     b(1) = a(59): b(2) = a(38): b(3) = a(17): b(4) = a(16): GoSub 860: If fl1 = 0 Then Return
          
Return

End Sub


Vorige Pagina About the Author