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 FunctionThis 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 FunctionAs 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 FunctionThe 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 FunctionApart 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 FunctionThe 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 FunctionIt 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