Brendan,
 I beg your pardon, I can't concentrate myself on all
these "uniformity" questions now.
 I've slightly modified VB example. If someone want to
run it, he could paste the code into Excel sheet
VB module. (Open VBA editor, click Sheet1). It will
work on activating the sheet (just open another sheet
and then return to this one). Folks I really need
your feedback(I like hotter :-)
 About correlation between "uniformity" and initial
registers' values: qualitative assessment is obvious:
The more initial values - the more randomness (less
uniformity) since relative difference between registers
will be smaller. When uniformity or randomness are
" good enough " -I don't know, it depends upon applications.
Maybe experimental way is better then trying to formalize
the problem. As for me, I can't even recall now all these
abstract math words to do it.
 As James Newton wrote: "In fact, I've been spending
a lot of time thinking about why this (PBK) project
bothers me so much and others have not....". I'm thinking
about it too. I can't make myself not to post one more
message on this topic. I've some ideas, constructive, I
hope.

 Mike.

---------------------------------------------------------



'   RE: [PIC] Random sequence
'   How to get randomly-biased dice number (08-19-2002).
'
'   1. Associate six registers with six dice numbers.
'   2. Init them with lngReg1InitValue...lngReg6InitValues
'        respectively.
'   3. On each loop subtract 5 from the register which
'      number was hit.
'      And add 1 to other registers.
'      If values < 1 or > lngRegMaxValue were reached -
'       discard this cast (shadow this row in the Excel sheet).
'   4. Get Sum of the registers.
'   5. Get random value from 1 to the Sum.
'   6. Summarize register values until this sum reached
'      previous "The Sum". Last register's number involved
'      with this summarizing is the "randomly-biased dice
'      number".
'   7. Go to "3."

Option Explicit

Private Const lngRegMaxValue  As Long = 1000
Private Const lngReg1InitValue  As Long = 15
Private Const lngReg2InitValue  As Long = 15
Private Const lngReg3InitValue  As Long = 15
Private Const lngReg4InitValue  As Long = 15
Private Const lngReg5InitValue  As Long = 15
Private Const lngReg6InitValue  As Long = 15

Private Const lngNumberOfSteps  As Long = 1000

Private lngLastNonDiscardedRow As Long

Private Sub Worksheet_Activate()
   Dim i As Long

    Cells.Select
    Selection.Delete Shift:=xlUp       'Clear Worksheet
    Range("A1").Select

    SetInitialValues

    For i = 4 To lngNumberOfSteps
      RefreshRegs i
      Cells(i, 7) = GetRegSum(i)
      Cells(i, 8) = GetRndOfSum(i)
      Cells(i, 9) = GetDiceNumber(i)
      RefreshHits i
      DiscardRowIfBeyondTheBounds (i)
    Next i
End Sub

Private Sub SetInitialValues()

  lngLastNonDiscardedRow = 3

  Cells(1, 1) = "Biased Dice"

  ' Registers associated with the Dice numbers 1...6
  Cells(2, 1) = "Reg1"
  Cells(2, 2) = "Reg2"
  Cells(2, 3) = "Reg3"
  Cells(2, 4) = "Reg4"
  Cells(2, 5) = "Reg5"
  Cells(2, 6) = "Reg6"

  ' Sum of the previous six cells
  Cells(2, 7) = "RegSum"

  ' Random value from 1 to previous cell value
  Cells(2, 8) = "RndOfSum"

  ' Dice number that was hitted
  Cells(2, 9) = "Dice"

  ' Numbers of hitts of the Dice numbers 1...6
  Cells(2, 10) = "HitsD1"
  Cells(2, 11) = "HitsD2"
  Cells(2, 12) = "HitsD3"
  Cells(2, 13) = "HitsD4"
  Cells(2, 14) = "HitsD5"
  Cells(2, 15) = "HitsD6"

  ' Place init values
  Cells(3, 1) = lngReg1InitValue
  Cells(3, 2) = lngReg2InitValue
  Cells(3, 3) = lngReg3InitValue
  Cells(3, 4) = lngReg4InitValue
  Cells(3, 5) = lngReg5InitValue
  Cells(3, 6) = lngReg6InitValue

  Cells(3, 7) = GetRegSum(3)
  Cells(3, 8) = GetRndOfSum(3)
  Cells(3, 9) = GetDiceNumber(3)

  RefreshHits 3
End Sub

Private Function GetRegSum( _
   lngRow As Long) As Long
   Dim i As Long
   For i = 1 To 6
      GetRegSum = GetRegSum + Cells(lngRow, i)
   Next i
End Function

Private Function GetRndOfSum( _
   lngRow As Long) As Long
   GetRndOfSum = Int(Rnd * Cells(lngRow, 7)) + 1
End Function

Private Function GetDiceNumber( _
   lngRow As Long) As Long
   Dim i As Long, lngTmpSum As Long

   For i = 1 To 6
      lngTmpSum = lngTmpSum + Cells(lngRow, i)
      If lngTmpSum >= Cells(lngRow, 8) Then
         GetDiceNumber = i
         Exit Function
      End If
   Next i
End Function

Private Sub RefreshRegs(lngRow As Long)
   Dim i As Long

   For i = 1 To 6
      If i = Cells(lngRow - 1, 9) Then
         Cells(lngRow, i) = Cells(lngLastNonDiscardedRow, i) - 5
      Else
         Cells(lngRow, i) = Cells(lngLastNonDiscardedRow, i) + 1
      End If
   Next i
End Sub

Private Sub DiscardRowIfBeyondTheBounds( _
   lngRow As Long)
   Dim i As Long

   For i = 1 To 6
      If Cells(lngRow, i) < 1 Or Cells(lngRow, i) > lngRegMaxValue Then
         Rows(lngRow).Interior.ColorIndex = 15
         Cells(lngRow, i).Font.ColorIndex = 2
         Cells(lngRow, i).Interior.ColorIndex = 3
         Cells(lngRow, 16) = "Discarded"
         Exit Sub
      End If
   Next i
   lngLastNonDiscardedRow = lngRow
End Sub

Private Sub RefreshHits(lngRow As Long)
   Dim i As Long

   For i = 1 To 6
      Cells(lngRow, 9 + i) = Val(Cells(lngLastNonDiscardedRow, 9 + i))
   Next i

   Cells(lngRow, 9 + Val(Cells(lngRow - 1, 9))) = _
      Cells(lngRow, 9 + Val(Cells(lngRow - 1, 9))) + 1
End Sub



'
'
'

--
http://www.piclist.com hint: To leave the PICList
mailto:piclist-unsubscribe-request@mitvma.mit.edu