Option Explicit
Sub main()
Const c_int_side_dice = 6 'сколько граней у кубика
Const c_int_dice_number = 100 'кол-во кубиков
Const c_int_number_to_find = 200 'число, вероятность выпадения которого хотим найти
Dim probability
probability = dice_probability(c_int_dice_number, c_int_number_to_find, c_int_side_dice)
MsgBox probability
End Sub
' собственно поиск вероятности определённого значения
Function dice_probability(int_dice_number, int_number_to_find, c_int_side_dice)
If int_number_to_find >= int_dice_number And int_number_to_find <= c_int_side_dice * int_dice_number Then
ReDim list_values(int_dice_number * (c_int_side_dice - 1))
Dim i, j
i = 0
For j = int_dice_number To c_int_side_dice * int_dice_number
list_values(i) = j
i = i + 1
Next
Dim list_interm_probability()
interm_probabilities c_int_side_dice, int_dice_number, list_interm_probability
For i = 0 To int_dice_number * (c_int_side_dice - 1)
If list_values(i) = int_number_to_find Then
Exit For
End If
Next
dice_probability = list_interm_probability(i) / (c_int_side_dice ^ int_dice_number)
Else
'задаваемое число выходит за рамки реально возможного диапазона значений
dice_probability = 0.0
End If
End Function
'возвращает список/массив: сколько раз встречается значение
Sub interm_probabilities(int_side_dice, int_pow, list_out)
'На примере int_side_dice = 6, int_pow = 5
'{
' 1: [1, 1, 1, 1, 1, 1],
' 2: [1, 2, 3, 4, 5, 6, 5, 4, 3, 2, 1],
' 4: [1, 4, 10, 20, 35, 56, 80, 104, 125, 140, 146, 140, 125, 104, 80, 56, 35, 20, 10, 4, 1]
' 5: [1, 5, 15, 35, 70, 126, 205, 305, 420, 540, 651, 735, 780, 780, 735, 651, 540, 420, 305, 205, 126, 70, 35, 15, 5, 1]
'}
Dim j
Dim list_interm_probability()
ReDim list_interm_probability(int_side_dice - 1)
For j = 0 To int_side_dice - 1
list_interm_probability(j) = 1
Next
Dim dict_interm_probability
Set dict_interm_probability = CreateObject("Scripting.Dictionary")
dict_interm_probability.Add 1, list_interm_probability
If int_pow = 0 Then
MsgBox "Не поддерживается"
Quit
ElseIf int_pow <> 1 Then
Dim list_to_do()
map_todo list_to_do, int_pow
For j = 0 To UBound(list_to_do, 2)
'MsgBox list_to_do(0, j) & vbTab & list_to_do(1, j) & vbTab & list_to_do(2, j)
multiply_cins_orig _
dict_interm_probability.Item(list_to_do(0, j)), _
dict_interm_probability.Item(list_to_do(1, j)), _
list_out
dict_interm_probability.Add list_to_do(2, j), list_out
' ArrOut_1 list_out
Next
End If
End Sub
'Как добраться до интересующего значения, используя x2/+nx для степеней
Sub map_todo(list_solution, int_wanted)
'На примере int_wanted = 5
'Степени "числа":
'1
'1 * 2 = 2 -> Array(1, 1, 2)
'2 * 2 = 4 -> Array(2, 2, 4)
'4 + 1 = 5 -> Array(4, 1, 5)
Dim int_current_id
Dim int_sum
Dim b_ascending
Dim i
int_current_id = 1
int_sum = 1
b_ascending = True
i = -1
Do
If b_ascending And 2 * int_current_id <= int_wanted Then
i = i + 1
ReDim Preserve list_solution(2, i)
list_solution(0, i) = int_current_id
list_solution(1, i) = int_current_id
list_solution(2, i) = 2 * int_current_id
int_current_id = 2 * int_current_id
int_sum = int_current_id
ElseIf b_ascending And 2 * int_current_id > int_wanted Then
b_ascending = False
int_sum = int_current_id
int_current_id = CInt(int_current_id / 2) 'чтобы возвращал именно integer
ElseIf Not b_ascending And int_sum + int_current_id <= int_wanted Then
i = i + 1
ReDim Preserve list_solution(2, i)
list_solution(0, i) = int_sum
list_solution(1, i) = int_current_id
list_solution(2, i) = int_sum + int_current_id
int_sum = int_sum + int_current_id
int_current_id = CInt(int_current_id / 2) 'чтобы возвращал именно integer
ElseIf Not b_ascending And int_sum + int_current_id > int_wanted Then
int_current_id = CInt(int_current_id / 2) 'чтобы возвращал именно integer
End If
Loop Until (int_sum = int_wanted)
End Sub
' "умножение" в столбик двух массивов/списков
Sub multiply_cins_orig(list_in_1, list_in_2, list_in)
Dim int_len_1
Dim int_len_2
int_len_1 = Ubound(list_in_1, 1)
int_len_2 = Ubound(list_in_2, 1)
Dim list_for_sum()
ReDim list_for_sum(int_len_2, int_len_1 + int_len_2)
Dim i, j, k, n
For i = 0 To int_len_2
j = 0
For n = 0 To int_len_2
If i = n Then
For k = 0 To int_len_1
list_for_sum(i, j) = list_in_1(k) * list_in_2(n)
j = j + 1
Next
Else
list_for_sum(i, j) = 0
j = j + 1
End If
Next
Next
'[list_in_1 X elem_2[0], 0, 0, 0, 0, 0]
'[0, list_in_1 X elem_2[1], 0, 0, 0, 0]
'[0, 0, list_in_1 X elem_2[2], 0, 0, 0]
'[0, 0, 0, list_in_1 X elem_2[3], 0, 0]
'[0, 0, 0, 0, list_in_1 X elem_2[4], 0]
'[0, 0, 0, 0, 0, list_in_1 X elem_2[5]]
'ArrOut_2 list_for_sum
Erase list_in
ReDim list_in(int_len_1 + int_len_2)
Dim sum_out
For j = 0 To int_len_1 + int_len_2
sum_out = 0
For i = 0 To int_len_2
sum_out = sum_out + list_for_sum(i, j)
Next
list_in(j) = sum_out
Next
' [1, 3, 6, 10, 15, 21, 25, 27, 27, 25, 21, 15, 10, 6, 3, 1]
'ArrOut_1 list_in
End Sub
'==================================================
'<Additional_MsgBox_For_Arrays>
Sub ArrOut_1(arr_in)
Dim str_out
Dim i
For i = 0 To UBound(arr_in)
If i = 0 Then
str_out = arr_in(i)
Else
str_out = str_out & " " & arr_in(i)
End If
Next
MsgBox str_out
End Sub
Sub ArrOut_2(arr_in)
Dim str_out
Dim i, j
For i = 0 To UBound(arr_in, 1)
For j = 0 To UBound(arr_in, 2)
If i = 0 And j = 0 Then
str_out = arr_in(i, j)
ElseIf j = 0 Then
str_out = str_out & vbNewLine & arr_in(i, j)
Else
str_out = str_out & " " & arr_in(i, j)
End If
Next
Next
MsgBox str_out
End Sub
'</Additional_MsgBox_For_Arrays>
'==================================================
main
