Positive integers from 1 to 8 inclusively are randomly placed on the faces of a regular octahedron with each face being assigned a different number. For the purposes of the puzzle, 8 and 1 are considered as consecutive numbers.
Determine the probability that no two consecutive numbers are placed on faces that share an edge.
Any octahedron with randomly placed digits 1  8 can be oriented so the 1 is on top, and we can consider the three faces adjacent to that one starting with the highest numbered and proceding left to right (counterclockwise seen from the top). Also, mirror images are not counted, as the probability is the same for those, by requiring the number to the right of the highest, immediately below the top face, to be higher than the one to the left. There are 840 equally likely number placements (7!/3!), 10 of which satisfy the criterion looked for in the probability. Those 10 are shown here:
1
5 4 3
7 6 8
2
1
5 4 3
8 6 7
2
1
6 4 3
2 7 8
5
1
6 5 3
2 7 8
4
1
7 4 3
2 6 5
8
1
7 5 4
3 8 2
6
1
7 6 4
3 8 2
5
1
7 6 5
4 2 3
8
1
7 6 5
4 3 2
8
1
7 6 3
4 8 5
2
10 840 0.01190476190
The probability thus is 10/840 = 1/84 ~= 0.01190476190.
DefDbl AZ
Dim crlf$, adj$(7), good, o$
Function mform$(x, t$)
a$ = Format$(x, t$)
If Len(a$) < Len(t$) Then a$ = Space$(Len(t$)  Len(a$)) & a$
mform$ = a$
End Function
Private Sub Form_Load()
Text1.Text = ""
crlf$ = Chr(13) + Chr(10)
Form1.Visible = True
DoEvents
' 1
' 2 4 6
' 3 5 7
' 8
adj$(1) = "246"
adj$(2) = "37"
adj$(3) = "48"
adj$(4) = "5"
adj$(5) = "68"
adj$(6) = "7"
adj$(7) = "8"
remain$ = "2345678": h$ = remain$
Do
o$ = "1" + remain$
If Mid(o$, 2, 1) > Mid(o$, 4, 1) And Mid(o$, 2, 1) > Mid(o$, 6, 1) Then
If Mid(o$, 4, 1) > Mid(o$, 6, 1) Then
good = 1
For i = 1 To 7
checkFace i
Next
If good Then
goodct = goodct + 1
Text1.Text = Text1.Text & Mid(o$, 1, 1) & crlf
Text1.Text = Text1.Text & Mid(o$, 2, 1) & " " & Mid(o$, 4, 1) & " " & Mid(o$, 6, 1) & crlf
Text1.Text = Text1.Text & " " & Mid(o$, 3, 1) & " " & Mid(o$, 5, 1) & " " & Mid(o$, 7, 1) & crlf
Text1.Text = Text1.Text & Mid(o$, 8, 1) & crlf & crlf
End If
ct = ct + 1
End If
End If
permute remain$
Loop Until remain$ = h$
Text1.Text = Text1.Text & goodct & Str(ct) & mform(goodct / ct, " 0.00000000000") & crlf
End Sub
Sub checkFace(wh)
For i = 1 To Len(adj$(wh))
wh2 = Val(Mid(adj$(wh), i, 1))
v1 = Val(Mid(o$, wh, 1))
v2 = Val(Mid(o$, wh2, 1))
diff = Abs(v2  v1)
If diff = 1 Or diff = 7 Then good = 0: Exit For
Next
End Sub

Posted by Charlie
on 20141201 16:23:18 