The Quantis device produced by ID Qantique makes use of the uncertainty of photons based on a Polarising Beam Splitter (PBS), which reflects vertically polarised photons and transmits horizontally polarised photons as illustrated in the figure:
' Retrieve a Json response from the service URL of the QRN API.
' Retrieved data is returned in parameter ResponseText.
'
' Returns True if success.
'
' Required reference:
' Microsoft XML, v6.0
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Private Function RetrieveDataResponse( _
ByVal ServiceUrl As String, _
ByRef ResponseText As String) _
As Boolean
' ServiceUrl is expected to have URL encoded parameters.
' Adjustable constants.
' Maximum time in seconds to call the service repeatedly
' in case of error.
Const TimeOut As Integer = 1
' Fixed constants.
Const Async As Boolean = False
Const StatusOk As Integer = 200
Const ErrorNone As Long = 0
' Non-caching engine to communicate with the Json service.
Dim XmlHttp As New ServerXMLHTTP60
Dim Result As Boolean
Dim LastTime As Date
On Error Resume Next
If ServiceUrl = "" Then
Err.Raise DtError.dtInvalidProcedureCallOrArgument
Else
' Sometimes a request fails. If so, try a few times more.
Do
XmlHttp.Open "GET", ServiceUrl, Async
XmlHttp.send
If Err.Number = ErrorNone Then
Result = True
Else
If LastTime = #12:00:00 AM# Then
LastTime = Now
End If
Debug.Print LastTime, Now
End If
Loop Until Result = True Or DateDiff("s", LastTime, Now) > TimeOut
On Error GoTo Err_RetrieveDataResponse
' Fetch the Json formatted data - or an error message.
ResponseText = XmlHttp.ResponseText
Select Case XmlHttp.status
Case StatusOk
Result = (InStr(ResponseText, ResultHeader) = 1)
Case Else
Result = False
End Select
End If
RetrieveDataResponse = Result
Exit_RetrieveDataResponse:
Set XmlHttp = Nothing
Exit Function
Err_RetrieveDataResponse:
MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Web Service Error"
Resume Exit_RetrieveDataResponse
End Function
This function is the "connector" for the two main functions that will retrieve either a series of integer numbers or decimal numbers.
' Retrieves an array of random integer values between a
' minimum and a maximum value.
' By default, only one value of 0 or 1 will be returned.
'
' Arguments:
' SizeValue: Count of values retrieved.
' MinimumValue: Minimum value that will be retrieved.
' MaximumValue: Maximum value that will be retrieved.
'
' SizeValue should be larger than zero. If not, an array of
' one element with the value of 0 will be returned.
' MinimumValue should be smaller than MaximumValue and both
' should be positive, or unexpected values will be returned.
'
' Acceptable minimum/maximum values are about +/-10E+16.
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnIntegers( _
Optional SizeValue As Long = 1, _
Optional MinimumValue As Variant = 0, _
Optional MaximumValue As Variant = 1) _
As Variant()
' Path for returning integer values.
Const IntegerPath As String = "randint"
' Json response with one value.
Const NeutralResult As String = "{""result"": [0]}"
' Key names must be lowercase.
Const SizeKey As String = "size"
Const MinimumKey As String = "min"
Const MaximumKey As String = "max"
Dim Values() As Variant
Dim TextValues As Variant
Dim MinValue As Variant
Dim MaxValue As Variant
Dim Index As Long
Dim ServiceUrl As String
Dim Query As String
Dim ResponseText As String
Dim Result As Boolean
If IsNumeric(MinimumValue) And IsNumeric(MaximumValue) Then
If SizeValue > 0 Then
' Round to integer as passing a decimal value will cause the service to fail.
MinValue = Fix(CDec(MinimumValue))
MaxValue = Fix(CDec(MaximumValue))
Query = BuildUrlQuery( _
BuildUrlQueryParameter(SizeKey, SizeValue), _
BuildUrlQueryParameter(MinimumKey, MinValue), _
BuildUrlQueryParameter(MaximumKey, MaxValue))
ServiceUrl = UrlApi & IntegerPath & Query
Result = RetrieveDataResponse(ServiceUrl, ResponseText)
End If
If Result = False Then
Debug.Print ResponseText
ResponseText = NeutralResult
End If
' Example for ResponseText: {"result": [1, 0, 1]}
TextValues = Split(Split(Split(ResponseText, "[")(1), "]")(0), ", ")
ReDim Values(LBound(TextValues) To UBound(TextValues))
' Convert the text values to Decimal.
For Index = LBound(TextValues) To UBound(TextValues)
Values(Index) = CDec(TextValues(Index))
Next
End If
QrnIntegers = Values
End Function
As noted in the in-line comments, the received Json string is very simple, thus no fancy code is required to parse it; a triple Split() and a conversion from text to number is all that is needed.
Dim RandomNumbers As Variant
RandomNumbers = QrnIntegers(30, 10, 20)
' Retrieves one random decimal value that will be equal to or
' larger than 0 (zero) and smaller than 1 (one).
'
' Values will be retrieved from the source in batches to
' relief the burden on the API service and to speed up
' the time to retrieve single values.
'
' The default size of a batch is preset by the constant
' DefaultSize in function QrnDecimalSize.
' The size of the batch (cache) can be preset by calling the function:
'
' QrnDecimalSize NewCacheSize
'
' Argument Id is for use in a query to force a call of QrnDecimal
' for each record to obtain a random order:
'
' Select * From SomeTable
' Order By QrnDecimal([SomeField])
'
' 2019-12-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnDecimal( _
Optional Id As Variant) _
As Variant
Static Values As Variant
Static LastIndex As Long
Dim Value As Variant
If LastIndex = 0 Then
' First run, or all values have been retrieved.
' Get size of the cache.
LastIndex = QrnDecimalSize
' Retrieve a new set of values.
Values = QrnDecimals(LastIndex)
End If
' Get the next value.
' The index of the array is zero-based.
LastIndex = LastIndex - 1
Value = Values(LastIndex)
QrnDecimal = Value
End Function
The function for pulling an integer number is similar, so it is not listed here.
' Sets or retrieves the size of the array cached by QrnDecimal.
' To set the size, the new size must be larger than zero.
'
' Example:
' NewSize = 100
' QrnDecimalSize NewSize
' CurrentSize = QrnDecimalSize
' CurrentSize -> 100
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function QrnDecimalSize( _
Optional Size As Long) _
As Long
Const DefaultSize As Long = 100
Static CurrentSize As Long
If Size <= 0 Then
' Retrieve cache size.
If CurrentSize = 0 Then
' Cache size has not been set. Use default size.
CurrentSize = DefaultSize
End If
Else
' Set cache size.
CurrentSize = Size
End If
QrnDecimalSize = CurrentSize
End Function
Apart from some helper functions not listed here, only one key function now remains - a function to substitute Rnd().
' Returns a true random number as a Double, like Rnd returns a Single.
' The value will be less than 1 but greater than or equal to zero.
'
' Usage: Excactly like Rnd:
'
' TrueRandomValue = RndQrn[(Number)]
'
' Number < 0 -> The same number every time, using Number as the seed.
' Number > 0 -> The next number in the pseudo-random sequence.
' Number = 0 -> The most recently generated number.
' No Number -> The next number in the pseudo-random sequence.
'
' 2019-12-21. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function RndQrn( _
Optional ByVal Number As Single = 1) _
As Double
Static Value As Double
Select Case Number
Case Is > 0 Or (Number = 0 And Value = 0)
' Return the next number in the random sequence.
Value = CDbl(QrnDecimal)
Case Is = 0
' Return the most recently generated number.
Case Is < 0
' Not supported by QRN.
' Retrieve value from RndDbl.
Value = RndDbl(Number)
End Select
' Return a value like:
' 0.171394365283966
RndQrn = Value
End Function
The not listed function RndDbl() returns an artificial Double made from two Single values from Rnd().
Public Function ThrowDice( _
Optional Throws As Integer = 1, _
Optional Dice As Integer = 1) _
As Integer()
' Array dimensions.
Const DieDimension As Long = 1
Const ThrowDimension As Long = 2
' Pip values.
Const MaximumPip As Double = 6
Const MinimumPip As Double = 1
' The average pip equals the median pip.
Const AveragePip As Double = (MinimumPip + MaximumPip) / 2
Const NeutralPip As Double = 0
Dim DiceTrows() As Integer
Dim Die As Integer
Dim Throw As Integer
Dim Size As Long
Dim Total As Double
If Dice <= 0 Or Throws <= 0 Then
' Return one throw of one die with unknown (neutral) result.
Throws = 1
Dice = 1
Size = 0
Else
' Prepare retrieval of values.
Size = Throws * Dice
QrnIntegerSize Size
QrnIntegerMaximum MaximumPip
QrnIntegerMinimum MinimumPip
End If
ReDim DiceTrows(1 To Dice, 1 To Throws)
If Size > 0 Then
' Fill array with results.
For Throw = LBound(DiceTrows, ThrowDimension) To UBound(DiceTrows, ThrowDimension)
For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
DiceTrows(Die, Throw) = QrnInteger
Total = Total + DiceTrows(Die, Throw)
Next
Next
End If
' Print header line.
Debug.Print , ;
For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
Debug.Print "Die" & Str(Die), ;
Next
Debug.Print
' Print results.
For Throw = LBound(DiceTrows, ThrowDimension) To UBound(DiceTrows, ThrowDimension)
Debug.Print "Throw" & Str(Throw);
For Die = LBound(DiceTrows, DieDimension) To UBound(DiceTrows, DieDimension)
Debug.Print , " " & DiceTrows(Die, Throw);
Next
Debug.Print
Next
Debug.Print
' Print total.
If DiceTrows(1, 1) = NeutralPip Then
' No total to print.
Else
Debug.Print "Average pips:", Format(Total / Size, "0.00"), Format((Total / Size - AveragePip) / AveragePip, "Percent") & " off"
Debug.Print
End If
ThrowDice = DiceTrows
End Function
It basically contains two loops, one for the throws and one for the dice of the throw, then prints the result.
throw | Die 1 | die 2 | die 3 | die 4 |
---|---|---|---|---|
Throw 1 | 5 | 4 | 5 | 3 |
Throw 2 | 3 | 4 | 6 | 3 |
Throw 3 | 1 | 5 | 4 | 2 |
Throw 4 | 1 | 4 | 6 | 6 |
Throw 5 | 6 | 2 | 5 | 1 |
Throw 6 | 1 | 5 | 1 | 5 |
SELECT
MSysObjects.Name,
QrnInteger([Flags]) AS RandomId
FROM
MSysObjects
WHERE
(((QrnIntegerMinimum(1))>0) AND ((QrnIntegerMaximum(100))>0));
The trick is here, that QrnMinimum and QrnMaximum both will be
called once only - and
before the query is run - because they are placed in the WHERE clause.
SELECT
MSysObjects.id,
MSysObjects.Name
FROM
MSysObjects
ORDER BY
QrnDecimal([Flags]);
If you open either of these queries, you will notice, that the numbers in the first and the order of objects in the second will change every time you press
Update on the ribbon.
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (6)
Author
Commented:On the long list of things-to-do-when-I-get-th
Commented:
https://qrng.anu.edu.au/
Author
Commented:Commented:
https://www.experts-exchange.com/articles/11114/An-Examination-of-Visual-Basic's-Random-Number-Generation.html
Author
Commented:As for the count of possible numbers, see my function RndDbl which offers a simple way around, adequate in the many cases where "truly" is not needed.
View More