Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

Pseudozufallszahlengenerator

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 20.03.2021, 12:29    Titel: Pseudozufallszahlengenerator Antworten mit Zitat

Die Funktion NextNumber soll ein Pseudozufallszahlengenerator sein.

Es wird eine Liste von Zahlen verwendet, um einfache Folgen zu erstellen:
Für die 1: Null, Eins, Null, Eins usw.
Für die 2: 2 Nullen, 2 Einsen, 2 Nullen, 2 Einsen usw.
Für die 3: 3 Nullen, 3 Einsen, 3 Nullen, 3 Einsen usw.
Für die 5: 5 Nullen, 5 Einsen, 5 Nullen, 5 Einsen usw.
usw.

Diese Folgen werden dann mit Übertrag addiert, um eine pseudozufällige Binärfolge zu erhalten.

Die Liste mit den Zahlen wird im Abschitt ab Zeile 30 (Assign array) gefüllt. Hier können Funktionen und Anzahl der Zahlen gewählt werden.

Die Periodenlänge der Binärfolge ist 2*(Kleinstes gemeinsames Vielfaches der verwendeten Zahlen).

Aus den Binärziffern können Gleitkommazahlen erstellt werden. Dazu werden 4 aufeinanderfolgende Binärziffern zusammengesetzt und als Zahl im Bereich von 0 bis 15 betrachtet. Alle Zahlen, die größer als 9 sind, werden verworfen. Die anderen Zahlen werden als Dezimalziffer in eine Zeichenkette geschrieben. Die Zeichenkette wird am Anfang um '0.' ergänzt und in eine Doublezahl umgewandelt.

Die Abstände aufeinanderfolgender gleicher Gleitkommazahlen wechseln chaotisch.
Der Mittelwert der Abstände ist 10^(Anzahl der Nachkommastellen), hier also etwa 10^16.

Die Funktion wird mit NextNumber aufgerufen. Zur Berechnung werden alle angegebenen Zahlen verwendet und die nächste Ziffer ausgegeben.

NextNumber(,,1) stellt alle Folgen und den Übertrag auf Null zurück.
NextNumber(,,2) stellt alle Folgen und den Übertrag mit Hilfe der FreeBASIC-Funktion Rnd ein.
NextNumber(,,3): Es wird ohne Übertrag addiert.

Zum Prüfen der Gleichverteilung wird das Produkt der Häufigkeiten aller möglichen Folgen zu einer bestimmten Probenlänge gebildet. Dieses Produkt ist Null, wenn auch nur eine Folge nicht vorgekommen ist. Das Produkt wird mit einem Faktor so normiert, dass es Eins ergibt, wenn alle möglichen Folgen dieselbe Häufigkeit haben, die relativen Häufigkeiten also den Wahrscheinlichkeitswerten entsprechen.

Dann wird noch ein Run-Test gemacht. Bei einer [0,1]-Folge ist der Erwartungswert für die Anzahl der Runs (n+1)/2, wobei n die Anzahl der betrachteten Ziffern ist. Jedenfalls sollte dieser Wert etwa 0,5 sein. http://www.ammu.at/archiv/4/4_4.htm

Zum Testen können Ausschnitte aus der Zahlenliste gewählt werden. Bei 'NextNumber(,,2) können dann die Grenzen angegeben werden, damit der Übertrag im richtigen Bereich gewählt wird.
Einstellen mit Rnd: NextNumber(a,b,2)
Nächste Ziffer erzeugen und anzeigen: Print NextNumber(a,b,0)

Der Generator sollte mit NextNumber(,,2) initialisiert werden.

Das Verfahren für das kleinste gemeinsame Vielfache ist https://en.wikipedia.org/wiki/Least_common_multiple#Using_the_table-method entnommen worden. Es hat den Vorteil, dass keine Multiplikation benötigt wird.

Die Testprogramme PractRand und RaBiGeTe sind mit der Funktion NextNumber noch nicht ganz zufrieden, weshalb ein Programm mit etwas komplizierteren Folgen in Arbeit ist.
Code:

Dim Shared As Ulong numbers()

Sub MakePrimeList(Byval primelimit As Long)
   If primelimit < 2 Then primelimit = 2
   Dim As Ulong i, j
   Redim numbers(1 To primelimit)
   numbers(1) = 1 ' Index is not prime
   
   For i = 2 To primelimit
      If numbers(i) = 0 Then ' If index is prime
         For j = 2 * i To primelimit Step i
            numbers(j) = 1 ' j is not prime
         Next j
      End If
   Next i
   
   For i = 2 To primelimit ' If index is prime then copy index to value
      If numbers(i) = 0 Then numbers(i) = i
   Next i 
   
   j = 0
   For i = 2 To primelimit ' Contract primes
      If numbers(i) > 1 Then j += 1 : numbers(j) = numbers(i)
   Next i
   
   Redim Preserve numbers(1 To j) ' Retain primes
End Sub

' Assign array:
Select Case 3
Case 1
   Redim numbers(1 To 50) ' PractRand: 1 To 200
   For i As Ulong = Lbound(numbers) To Ubound(numbers)
      numbers(i) = i
   Next i
Case 2
   Redim numbers(1 To 50)
   For i As Ulong = Lbound(numbers) To Ubound(numbers)
      numbers(i) = 2 * i - 1
   Next i
Case 3
   MakePrimeList(200) ' PractRand: 400
End Select

Function NextNumber(Byval a As Ulong = 0, Byval b As Ulong = 0, Byval set As Ulong = 0) As Ubyte Static
   
   Dim As Ulong i, sum, carry, count(Lbound(numbers) To Ubound(numbers))
   Dim As Ubyte digit(Lbound(numbers) To Ubound(numbers))
   
   If a > b Then Swap a,b
   If (a = 0) Or (a > Ubound(numbers)) Then a = Lbound(numbers)
   If (b = 0) Or (b > Ubound(numbers)) Then b = Ubound(numbers)
   
   Select Case set
   Case 1 ' Reset arrays
      For i = Lbound(numbers) To Ubound(numbers)
         digit(i) = 0
         count(i) = 0
      Next i
      carry = 0
      Exit Function
   Case 2 ' Set arrays with Rnd
      For i = Lbound(numbers) To Ubound(numbers)
         digit(i) = Int(Rnd * 2)
         count(i) = Int(Rnd * numbers(i))
      Next i
      carry = Int(Rnd * (b - a + 1))
      Exit Function
   End Select
   
   sum = 0
   For i = a To b
      sum += digit(i)
   Next i
   If set <> 3 Then ' Add with/without carry
      sum += carry
      carry = sum \ 2
   End If
   Function = sum Mod 2
   For i = a To b
      count(i) += 1
      If count(i) = numbers(i) Then
         If digit(i) = 0 Then
            digit(i) = 1
         Else
            digit(i) = 0
         End If
         count(i) = 0
      End If
   Next i
End Function

Function NextDouble As Double
   Const stringlength = 18 ' "0." and 16 digits
   Dim As String*stringlength s
   Dim As Ubyte value, bitnumber, stringindex
   s[0] = 48 : s[1] = 46
   stringindex = 2
   Do
      value = 0
      For bitnumber = 0 To 3
         If NextNumber = 1 Then value = Bitset(value,bitnumber)
      Next bitnumber
      If value < 10 Then s[stringindex] = value + 48 : stringindex += 1
   Loop Until stringindex = stringlength
   Return Val(s)
End Function

Function LogarithmOfLeastCommonMultiple As Double
   Redim As Ulong PrimefactorsOfLeastCommonMultiple(0)
   Dim As Ulong i, j, k, factor
   Dim As Double result
   
   Dim As Ulong table(1 To Ubound(numbers))
   For i = 1 To Ubound(numbers)
      table(i) = numbers(i)
   Next i
   
   factor = 2
   Do
      k = 0
      For i = 1 To Ubound(table)
         If (table(i) Mod factor = 0) And (table(i) > 1) Then
            table(i) = table(i) \ factor
            j = 1
         End If
         If table(i) = 1 Then k += 1
      Next i
     
      If j = 1 Then
         Redim Preserve PrimefactorsOfLeastCommonMultiple(1 To 1 + Ubound(PrimefactorsOfLeastCommonMultiple))
         PrimefactorsOfLeastCommonMultiple(Ubound(PrimefactorsOfLeastCommonMultiple)) = factor
         j = 0
      Else
         If factor = 2 Then factor += 1 Else factor += 2
      End If
   Loop Until k = Ubound(table)
   
   For i = 1 To Ubound(PrimefactorsOfLeastCommonMultiple)
      result += Log(PrimefactorsOfLeastCommonMultiple(i))
   Next i
   Function = result
End Function

Sub PeriodLength
   Print "Calculating period length...";
   Dim As Double d = LogarithmOfLeastCommonMultiple
   d += Log(2) ' Period Length is the double of the least common multiple
   d = d / Log(10) ' Convert to decimal logarithm
   Locate ,1 : Print Space(30); : Locate ,1
   Print "Numbers:";Ubound(numbers)
   Print "Period length: ";
   Print Using "#.##*10^&";10^Frac(d);Int(d)
End Sub

'=================================================================

Scope
   Dim As Ulong i, j
   For i = 1 To Ubound(numbers)
      Print numbers(i);" ";
      j += 1 : If j = 8 Then Print : j = 0
      If Len(Inkey) Then Exit For
   Next i
   Print : Print
End Scope

'-------------------------------------

PeriodLength
Print

'-------------------------------------

Scope
   Dim As Ulong i, j, k, m
   k = 50
   For m = 2 To 3
      NextNumber(,,1) ' Reset arrays
      For j = 1 To m
         Print "numbers(" & j & ")";Spc(6);
         For i = 1 To k
            Print NextNumber(j,j);
         Next i
         Print
      Next j
     
      NextNumber(,,1) ' Reset arrays
      Print Spc(16);String(k,"-")
     
      Print "Add with carry";Spc(2);
      For i = 1 To k
         Print NextNumber(1,m);
      Next i
      Print : Print
      Print "Return key to continue..."
      Print
      Getkey
   Next m
End Scope

'-------------------------------------

Randomize
NextNumber(,,2) ' Set arrays with Rnd

'-------------------------------------

Do
   Print NextNumber;
Loop Until Len(Inkey)
Print
Print : Print "Return key to continue..."
Getkey
Print
Do
   Print NextDouble
Loop Until Len(Inkey)
Print : Print "Return key to continue..."
Getkey

'-------------------------------------

Scope
   Dim As Ulong i, j, k, x, y
   i = 8 : j = 8
   Dim As Ulong a(i)
   Screenres(2^(i+1),2^(j+1))
   Do
      x = 0
      y = 0
      For k = 0 To i
         a(k) = NextNumber
         x = x Or (a(k) Shl k)
      Next
      For k = 0 To j
         a(k) = NextNumber
         y = y Or (a(k) Shl k)
      Next
      If Point(x,y) Then Preset(x,y) Else Pset(x,y)
   Loop Until Len(Inkey)
   Cls
   Do
      x = 0
      y = 0
      For k = 0 To i
         a(k) = NextNumber
         x = x Or (a(k) Shl k)
      Next
      For k = 0 To j
         a(k) = NextNumber
         y = y Or (a(k) Shl k)
      Next
      Pset(x,y)
   Loop Until Len(Inkey)
   Screen 0,,,&h80000000 ' Close graphics window
End Scope

'-------------------------------------

Print : Print "Now with NextDouble, Return key to continue..."
Getkey

'-------------------------------------

Scope
   Dim As Ulong i, j, x, y 
   i = 600
   j = 600
   Screenres(i,j)
   Do
      x = i*NextDouble
      y = j*NextDouble
      If Point(x,y) Then Preset(x,y) Else Pset(x,y)
   Loop Until Len(Inkey)
   Cls
   Do
      x = i*NextDouble
      y = j*NextDouble
      Pset(x,y)
   Loop Until Len(Inkey)
   Screen 0,,,&h80000000 ' Close graphics window
End Scope

'-------------------------------------

Print : Print "Normalized product of the frequencies, ESC to end, Return key to continue..."
Getkey
Print

'-------------------------------------

Scope ' Normalized product of the frequencies
   Dim As Ulong i, j, k
   Dim As Double sum, product, b()
   Dim As Ulong value, digits, bitnumber
   j = 0
   digits = 1
   Do
      Do ' Wait until Return key down
         Sleep 10,1
      Loop Until Multikey(28)
     
      Do ' Wait until Return key up
         Sleep 10,1
      Loop Until Multikey(28) = 0
     
      sum = 0
      k = 2^digits
      Redim b(k-1)
      Do
         value = 0
         For bitnumber = 0 To digits-1
            If NextNumber = 1 Then value = Bitset(value,bitnumber)
         Next bitnumber
         b(value) += 1
         sum += 1
         product = 1
         For i = 0 To Ubound(b)
            product = product*k*b(i)/sum
         Next i
         
         j += 1 : If j > 32768 Then Print "Sample length: "; digits, product : j = 0 ' If j > 0
         
         If Multikey(1) Then Exit Do, Do ' Exit with ESC key
         
      Loop Until Multikey(28) ' Loop until Return key down
     
      If digits < 8*Len(value) Then digits += 1
   Loop
End Scope

'-------------------------------------

Print : Print "Run test, Return key to continue..."

While Len(Inkey) : Wend ' Empty keyboard buffer

Getkey
Print

'-------------------------------------

Scope ' Run test
   Dim As Ulong i, j, k, x
   Dim As Ulong a(1)
   x = 0
   j = nextnumber
   a(j) += 1
   k = 1
   Do
      i = nextnumber
      a(i) += 1
      If i <> j Then k += 1 : j = i
      x += 1 : If x > 1024 Then Print k/(a(0)+a(1)) : x = 0 ' If x > 0
   Loop Until Len(Inkey)
End Scope

'-------------------------------------

Print : Print "Any key to end."
Getkey
End
'


Zuletzt bearbeitet von hhr am 11.04.2021, 09:38, insgesamt einmal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 29.03.2021, 19:11    Titel: Antworten mit Zitat

Nullen und Einsen sollen in jeder Hinsicht gleichberechtigt sein.

Ausgehend von

Code:
  123...
a 01010101010101010101010101010101010101010101010101...
b 01010101010101010101010101010101010101010101010101...
c 01010101010101010101010101010101010101010101010101...
...


wurden im ersten Programm Folgen dieser Art erstellt:

a1,a2,a3,...
a1,b1,a2,b2,a3,b3,...
a1,b1,c1,a2,b2,c2,a3,b3,c3,...
...

Code:
  123...
a 01010101010101010101010101010101010101010101010101...
b 00110011001100110011001100110011001100110011001100...
c 00011100011100011100011100011100011100011100011100...
...


Hieraus werden in diesem Programm Folgen nach demselben Muster abgeleitet:

a1,a2,a3,...
a1,b1,a2,b2,a3,b3,...
a1,b1,c1,a2,b2,c2,a3,b3,c3,...
...

Code:
  123...
a 01010101010101010101010101010101010101010101010101...
b 00100111001001110010011100100111001001110010011100...
c 00010001011100110101011000010101111100010001011100...
...


Mit dem Array numbers wird ausgewählt, welche Folgen verwendet werden. Diese Folgen werden mit oder ohne Übertrag addiert.

Die Periodenlängen sind komplizierter zu berechnen als beim ersten Programm, sind aber auch sehr viel größer: 2*kgV(i*kgV(n(i)))

Code:
Beispiel:
i       1       2       3       4       5       6       7
n(i)    2       3       5       7       11      13      17
kgV     2       6       30      210     2310    30030   510510
*i      2       12      90      840     11550   180180  3573570
kgV     2       12      180     2520    138600  1801800 214414200
*2      4       24      360     5040    277200  3603600 428828400

Code:
Dim Shared As Ulong numbers()

Sub MakePrimeList(Byval primelimit As Long)
   If primelimit < 2 Then primelimit = 2
   Dim As Ulong i, j
   Redim numbers(1 To primelimit)
   numbers(1) = 1 ' Index is not prime
   
   For i = 2 To primelimit
      If numbers(i) = 0 Then ' If index is prime
         For j = 2 * i To primelimit Step i
            numbers(j) = 1 ' j is not prime
         Next j
      End If
   Next i
   
   For i = 2 To primelimit ' If index is prime then copy index to value
      If numbers(i) = 0 Then numbers(i) = i
   Next i
   
   j = 0
   For i = 2 To primelimit ' Contract primes
      If numbers(i) > 1 Then j += 1 : numbers(j) = numbers(i)
   Next i
   
   Redim Preserve numbers(1 To j) ' Retain primes
End Sub

' Assign array:
Select Case 3
Case 1
   Redim numbers(1 To 50)
   For i As Ulong = 1 To Ubound(numbers)
      numbers(i) = i
   Next i
Case 2
   Redim numbers(1 To 100)
   For i As Ulong = 1 To Ubound(numbers)
      numbers(i) = 2 * i - 1
   Next i
Case 3
   MakePrimeList(200)
End Select

Dim As Ulong maxvalue
For i As Ulong = 1 To Ubound(numbers)
   If maxvalue < numbers(i) Then maxvalue = numbers(i)
Next i

Dim Shared As Ubyte sequences(1 To Ubound(numbers), 1 To 2 * maxvalue + 1)

For row As Ulong = 1 To Ubound(numbers)
   For col As Ulong = 1 To numbers(row)
      sequences(row,col) = 0
   Next col
   For col As Ulong = numbers(row) + 1 To 2 * numbers(row)
      sequences(row,col) = 1
   Next col
   sequences(row,2 * numbers(row) + 1) = 2
Next row

Function NextNumber(Byval a As Ulong = 1, Byval b As Ulong = Ubound(numbers), Byval set As Ulong = 0) As Ubyte Static
   
   Dim As Ulong sum, carry, i, j
   Redim As Ulong col(1 To Ubound(numbers),1 To Ubound(numbers))
   Redim As Ulong row(1 To Ubound(numbers))
   
   Select Case set
   Case 1 ' Reset arrays
      Redim col(1 To Ubound(numbers),1 To Ubound(numbers))
      Redim row(1 To Ubound(numbers))
      carry = 0
      Exit Function
   Case 2 ' Set arrays with Rnd
      For i = 1 To Ubound(numbers)
         row(i) = Int(Rnd * (i + 1))
         For j = 1 To i
            col(j,i) = Int(Rnd * 2 * numbers(j))
         Next j
      Next i
      carry = Int(Rnd * (b - a + 1))
      Exit Function
   End Select
   
   sum = 0
   For i = a To b
      row(i) += 1 : If row(i) > i Then row(i) = 1
      col(row(i),i) += 1 : If sequences(row(i),col(row(i),i)) = 2 Then col(row(i),i) = 1
      sum += sequences(row(i),col(row(i),i))
   Next i
   If set <> 3 Then ' Add with/without carry
      sum += carry
      carry = sum \ 2
   End If
   Function = sum Mod 2
End Function

Function NextDouble As Double
   Const stringlength = 18 ' "0." and 16 digits
   Dim As String*stringlength s
   Dim As Ubyte value, bitnumber, stringindex
   s[0] = 48 : s[1] = 46
   stringindex = 2
   Do
      value = 0
      For bitnumber = 0 To 3
         If NextNumber = 1 Then value = Bitset(value,bitnumber)
      Next bitnumber
      If value < 10 Then s[stringindex] = value + 48 : stringindex += 1
   Loop Until stringindex = stringlength
   Return Val(s)
End Function

'=================================================================

Scope
   Dim As Ulong i, j
   For i = 1 To Ubound(numbers)
      Print numbers(i);" ";
      j += 1 : If j = 8 Then Print : j = 0
      If Len(Inkey) Then Exit For
   Next i
   Print : Print
End Scope

'-------------------------------------

Print "Numbers:";Ubound(numbers)
Print

'-------------------------------------

For i As Ulong = 1 To Iif(Ubound(sequences,1) < 3,Ubound(sequences,1),3)
   For j As Ulong = 1 To Iif(Ubound(sequences,2) < 15,Ubound(sequences,2),15)
      Print sequences(i,j);
      If Len(Inkey) Then Exit For, For
   Next j
   Print
Next i
Print

'-------------------------------------

Scope
   Dim As String s
   Dim As Ulong i, j, k, m
   k = 50
   For m = 2 To 3
      NextNumber(,,1) ' Reset arrays
      For j = 1 To m
         s = "numbers(" & j & ")"
         Print s;Spc(16 - Len(s));
         For i = 1 To k
            Print NextNumber(j,j);
         Next i
         Print
      Next j
     
      NextNumber(,,1) ' Reset arrays
      Print Spc(16);String(k,"-")
     
      Print "Add with carry";Spc(2);
      For i = 1 To k
         Print NextNumber(1,m);
      Next i
      Print : Print
      Print "Return key to continue..."
      Print
      Getkey
   Next m
End Scope

'-------------------------------------

Randomize
NextNumber(,,2) ' Set arrays with Rnd

'-------------------------------------

Do
   Print NextNumber;
Loop Until Len(Inkey)
Print
Print : Print "Return key to continue..."
Getkey
Print
Do
   Print NextDouble
Loop Until Len(Inkey)
Print : Print "Return key to continue..."
Getkey

'-------------------------------------

#Define SCREEN_EXIT &h80000000

'-------------------------------------

Scope
   Dim As Ulong i, j, k, x, y
   i = 8 : j = 8
   Dim As Ulong a(i)
   Screenres(2^(i+1),2^(j+1))
   Do
      x = 0
      y = 0
      For k = 0 To i
         a(k) = NextNumber
         x = x Or (a(k) Shl k)
      Next
      For k = 0 To j
         a(k) = NextNumber
         y = y Or (a(k) Shl k)
      Next
      If Point(x,y) Then Preset(x,y) Else Pset(x,y)
   Loop Until Len(Inkey)
   Cls
   Do
      x = 0
      y = 0
      For k = 0 To i
         a(k) = NextNumber
         x = x Or (a(k) Shl k)
      Next
      For k = 0 To j
         a(k) = NextNumber
         y = y Or (a(k) Shl k)
      Next
      Pset(x,y)
   Loop Until Len(Inkey)
   Screen 0,,,SCREEN_EXIT ' Close graphics window
End Scope

'-------------------------------------

Print : Print "Now with NextDouble, Return key to continue..."
Getkey

'-------------------------------------

Scope
   Dim As Ulong i, j, x, y
   i = 600
   j = 600
   Screenres(i,j)
   Do
      x = i*NextDouble
      y = j*NextDouble
      If Point(x,y) Then Preset(x,y) Else Pset(x,y)
   Loop Until Len(Inkey)
   Cls
   Do
      x = i*NextDouble
      y = j*NextDouble
      Pset(x,y)
   Loop Until Len(Inkey)
   Screen 0,,,SCREEN_EXIT ' Close graphics window
End Scope

'-------------------------------------

Print : Print "Normalized product of the frequencies, ESC to end, Return key to continue..."
Getkey
Print

'-------------------------------------

Scope ' Normalized product of the frequencies
   Dim As Ulong i, j, k
   Dim As Double sum, product, b()
   Dim As Ulong value, digits, bitnumber
   j = 0
   digits = 1
   Do
      Do ' Wait until Return key down
         Sleep 10,1
      Loop Until Multikey(28)
     
      Do ' Wait until Return key up
         Sleep 10,1
      Loop Until Multikey(28) = 0
     
      sum = 0
      k = 2^digits
      Redim b(k-1)
      Do
         value = 0
         For bitnumber = 0 To digits-1
            If NextNumber = 1 Then value = Bitset(value,bitnumber)
         Next bitnumber
         b(value) += 1
         sum += 1
         product = 1
         For i = 0 To Ubound(b)
            product = product*k*b(i)/sum
         Next i
         
         j += 1 : If j > 32768 Then Print "Sample length: "; digits, product : j = 0 ' If j > 0
         
         If Multikey(1) Then Exit Do, Do ' Exit with ESC key
         
      Loop Until Multikey(28) ' Loop until Return key down
     
      If digits < 8*Len(value) Then digits += 1
   Loop
End Scope

'-------------------------------------

Print : Print "Run test, Return key to continue..."

While Len(Inkey) : Wend ' Empty keyboard buffer

Getkey
Print

'-------------------------------------

Scope ' Run test
   Dim As Ulong i, j, k, x
   Dim As Ulong a(1)
   x = 0
   j = nextnumber
   a(j) += 1
   k = 1
   Do
      i = nextnumber
      a(i) += 1
      If i <> j Then k += 1 : j = i
      x += 1 : If x > 1024 Then Print k/(a(0)+a(1)) : x = 0 ' If x > 0
   Loop Until Len(Inkey)
End Scope

'-------------------------------------

Print : Print "Any key to end."
Getkey
End
'
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 21.04.2021, 20:20    Titel: Antworten mit Zitat

Das oben verwendete Verfahren lässt sich fortsetzen, indem eine Beziehung zwischen Indizes aufgestellt wird.
Code:
Sub previous(Byval row_in As Ulong, Byval col_in As Ulongint, Byref row_out As Ulong, Byref col_out As Ulongint)
   row_out = ((col_in - 1) Mod row_in) + 1
   col_out = ((col_in - 1) \ row_in) + 1
End Sub

Function repeat(Byval row_in As Ulong, Byval col_in As Ulongint, Byval iterations As Ulong) As Ubyte
   Dim As Ulong row_out, k
   Dim As Ulongint col_out
   For k = 1 To iterations
      previous(row_in,col_in,row_out,col_out)
      row_in = row_out
      col_in = col_out
   Next k
   Function = col_in Mod 2
End Function

Function nextnumber(Byval numbers As Ulong, Byval iterations As Ulong) As Ubyte Static
   Dim As Ulong row, sum, carry
   Dim As Ulongint column
   sum = 0
   column += 1
   For row = 1 To numbers
      sum += repeat(row,column,iterations)
   Next row
   sum += carry
   carry = sum \ 2
   Function = sum Mod 2
End Function

'=================================================================

Dim As Ulong row, iterations = 0
Dim As Ulongint col

Do
   For row = 1 To 20
      For col = 1 To 70
         Print repeat(row,col,iterations);
      Next col
      Print
   Next row
   Print "iterations = ";iterations
   Print : Print "Any key to continue..."
   iterations += 1
   Sleep
   Cls
Loop Until iterations = 5

While Len(Inkey) : Wend ' Empty keyboard buffer

'-------------------------------------

col = 0
iterations = 3
Do
   col += 1
   For row = 1 To 20
      Print repeat(row,col,iterations);
   Next row
   Print
   Sleep 100,1
Loop Until Len(Inkey)

While Len(Inkey) : Wend ' Empty keyboard buffer

'-------------------------------------

Do
   Print nextnumber(20,3);
Loop Until Len(Inkey)

'-------------------------------------

Dim As Ulong i, j, k, x, y
i = 8 : j = 8
Dim As Ulong a(i)
Screenres(2^(i+1),2^(j+1))
Do
   x = 0
   y = 0
   For k = 0 To i
      a(k) = nextnumber(20,3)
      x = x Or (a(k) Shl k)
   Next
   For k = 0 To j
      a(k) = nextnumber(20,3)
      y = y Or (a(k) Shl k)
   Next
   If Point(x,y) Then Preset(x,y) Else Pset(x,y)
Loop Until Len(Inkey)
Cls
Do
   x = 0
   y = 0
   For k = 0 To i
      a(k) = nextnumber(20,3)
      x = x Or (a(k) Shl k)
   Next
   For k = 0 To j
      a(k) = nextnumber(20,3)
      y = y Or (a(k) Shl k)
   Next
   Pset(x,y)
Loop Until Len(Inkey)

End
'
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 19.05.2021, 17:41    Titel: Antworten mit Zitat

Code:
Dim Shared As Ulong numbers(1 To ...) = {3,1,4,1,5,9,2,5,3,5,9,2,3}

Sub previous(Byval row_in As Ulong, Byval col_in As Ulongint, Byref row_out As Ulong, Byref col_out As Ulongint)
   row_out = col_in Mod (row_in + 1)
   col_out = col_in \ (row_in + 1)
End Sub

Function repeat(Byval row_in As Ulong, Byval col_in As Ulongint, Byval iterations As Ulong) As Ubyte
   Dim As Ulong row_out, i
   Dim As Ulongint col_out
   For i = 1 To iterations
      previous(row_in,col_in,row_out,col_out)
      row_in = row_out
      col_in = col_out
   Next i
   Function = (col_in \ numbers(row_in + 1)) Mod 2
End Function

Redim Shared As Ulongint column(1 To Ubound(numbers))
Dim Shared As Ulong carry

Sub init(Byval set As Ulong = 0)
   Select Case set
   Case 1 ' Reset
      Redim column(1 To Ubound(numbers))
      carry = 0
   Case 2 ' Set with Rnd
      For i As Ulong = 1 To Ubound(numbers)
         column(i) = (Rnd ^ 8) * Cast(Ulongint,-1) ' nothing but an example
      Next i
      carry = Int(Rnd * (Ubound(numbers)))
   End Select
End Sub

Function nextnumber(Byval iterations As Ulong) As Ubyte
   Dim As Ulong row, sum
   sum = 0
   For row = 0 To Ubound(numbers) - 1
      sum += repeat(row,column(row + 1),iterations)
      column(row + 1) += 1
   Next row
   sum += carry
   carry = sum \ 2
   Function = sum Mod 2
End Function

'=================================================================

Dim As Ulong row, iterations' = 0
Dim As Ulongint col

Do
   Print "iterations = ";iterations
   For row = 0 To Ubound(numbers) - 1
      For col = 0 To 70
         Print repeat(row,col,iterations);
      Next col
      Print
   Next row
   init(1)
   Print String(70,"-")
   For col = 0 To 70
      Print nextnumber(iterations);
   Next col
   Print
   Print : Print "Any key to continue..."
   iterations += 1
   Getkey
   'Cls
Loop Until iterations = 5

'-------------------------------------

col = 0
iterations = 0
Do
   For row = 0 To Ubound(numbers) - 1
      Print repeat(row,col,iterations);
   Next row
   col += 1
   Print
   Sleep 100,1
Loop Until Len(Inkey)

While Len(Inkey) : Wend ' Empty keyboard buffer

'-------------------------------------

Dim As Ulong i, j, k, x, y
i = 8 : j = 8
Dim As Ulong a(i)
Screenres(2^(i+1),2^(j+1))
iterations = 4
Do
   x = 0
   y = 0
   For k = 0 To i
      a(k) = nextnumber(iterations)
      x = x Or (a(k) Shl k)
   Next
   For k = 0 To j
      a(k) = nextnumber(iterations)
      y = y Or (a(k) Shl k)
   Next
   If Point(x,y) Then Preset(x,y) Else Pset(x,y)
Loop Until Len(Inkey)
Cls
Do
   x = 0
   y = 0
   For k = 0 To i
      a(k) = nextnumber(iterations)
      x = x Or (a(k) Shl k)
   Next
   For k = 0 To j
      a(k) = nextnumber(iterations)
      y = y Or (a(k) Shl k)
   Next
   Pset(x,y)
Loop Until Len(Inkey)

End
'


Zuletzt bearbeitet von hhr am 21.06.2021, 09:13, insgesamt 2-mal bearbeitet
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 19.05.2021, 17:45    Titel: Antworten mit Zitat

Zum Testen sind PractRand und RaBiGeTe verwendet worden.
Der Aufruf nextnumber muss bei den letzten beiden Programmen um Parameter ergänzt werden: z.B. nextnumber(21,3) oder nextnumber(4).

PractRand (IDE, Eingabeaufforderung):
Code:
'Randomize
'nextnumber(,,2)
'init(2)

'Chdir "Path to RNG_test.exe"
Open Pipe "RNG_test stdin8" For Binary Access Write As #1
   Do
      Dim As Ubyte z' = 0
      For i As Ubyte = 0 To 7
         If nextnumber = 1 Then z = Bitset(z,i)
      Next i
      Put #1,,z
   Loop ' Endless loop, cancel with ^C
'Close #1
'


PractRand (Eingabeaufforderung):
Programmname | RNG_test stdin8
Z.B.: a.exe | RNG_test stdin8
Code:
'Randomize
'nextnumber(,,2)
'init(2)

Dim As Ubyte z
Do
   z = 0
   For i As Ulong = 0 To 7
      If nextnumber = 1 Then z = Bitset(z,i)
   Next i
   Print Chr(z);
Loop
'

RaBiGeTe:
Code:
'Randomize
'nextnumber(,,2)
'init(2)

Kill "a.txt"
Sleep 1000

Dim As Ubyte z

Open "a.txt" For Output As #1
   For j As Ulong = 1 To 10485760
      z = 0
      For i As Ulong = 0 To 7
         If nextnumber = 1 Then z = Bitset(z,i)
      Next i
      Print #1, Chr(z); ' Put #1,,z
   Next j
Close #1

End
'
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 28.08.2021, 12:21    Titel: Antworten mit Zitat

In meinem Rechner zeigt PractRand bei folgendem Programm meistens 'no anomalies' und nur selten 'unusual':
Code:
Function popcount(Byref n As Ulong) As Ulong
   Dim As Ulong i,sum
   For i=0 To 31
      sum += (-Bit(n,i))
   Next i
   Return sum
End Function

Function nextnumber As Ulong Static
   Dim As Ulong sum
   Dim As Ulong ts
   Asm
      rdtsc ' Read time-stamp counter into EDX:EAX
      mov [ts],eax
   End Asm
   sum += ts
   Function = popcount(sum) Mod 2
End Function

'=================================================

Dim As Ulong i,j,k,x,y
i = 8 : j = 8
Screenres(1 Shl (i+1),1 Shl (j+1))
Do
   x = 0
   y = 0
   For k = 0 To i
      If nextnumber = 1 Then x = Bitset(x,k)
   Next
   For k = 0 To j
      If nextnumber = 1 Then y = Bitset(y,k)
   Next
   If Point(x,y) Then Preset(x,y) Else Pset(x,y)
Loop Until Len(Inkey)
Cls
Do
   x = 0
   y = 0
   For k = 0 To i
      If nextnumber = 1 Then x = Bitset(x,k)
   Next
   For k = 0 To j
      If nextnumber = 1 Then y = Bitset(y,k)
   Next
   Pset(x,y)
Loop Until Len(Inkey)
Screen 0,,,&h80000000 ' Close graphics window

'-------------------------------------------------

'Chdir "Path to PractRand's RNG_test.exe"
Open Pipe "RNG_test stdin64 -tlmin 1KB -tlmaxonly" For Binary Access Write As #1
Dim As Ulongint z
Do
   z = 0
   For i As Ubyte = 0 To 63
      If nextnumber = 1 Then z = Bitset(z,i)
   Next i
   Put #1,,z
Loop ' Endless loop, cancel with ^C
'Close #1
'End
'

Die Funktion popcount ist sehr langsam, funktioniert dafür aber bei gas und gcc.

Der Pfad zu PractRand's RNG_test.exe muss noch eingetragen werden, verwendet wurde PractRand_0.94.

xoroshiro128.bas:
https://www.freebasic.net/forum/viewtopic.php?f=3&t=28687&start=75#p283547

popcount (Die Beispiele funktionieren mit -gen gcc):
https://www.freebasic.net/forum/viewtopic.php?f=3&t=29549

Timer anstelle von rdtsc:
Code:
Function nextnumber As Ulong Static
   Dim As Ulong sum
   sum += Int((2^32)*Frac(Timer))
   Function = popcount(sum) Mod 2
End Function

parity(x) = popcount(x) Mod 2:
Code:
Function parity(Byref n As Ulong) As Ubyte
   Dim As Ubyte i,p
   For i=0 To 31
      p Xor= (-Bit(n,i))
   Next i
   Return p
End Function

Function nextnumber As Ubyte Static
   Dim As Ulong sum
   sum += Int((2^32)*Frac(Timer))
   Function = parity(sum)
End Function
Code:
Function nextnumber As Ubyte Static
   Dim As Ulong sum,ts,ts_previous
   Do
      ts = Int((2^32)*Frac(Timer))
   Loop While ts = ts_previous
   ts_previous = ts
   sum += ts
   Function = parity(sum)
End Function

Es gibt effiziente Verfahren für popcount und parity, zum Beispiel in
http://graphics.stanford.edu/~seander/bithacks.html
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 17.11.2021, 20:07    Titel: Antworten mit Zitat

Wenn man auf Timer verzichtet, erhält man reproduzierbare Folgen.
Die Zahl in der Funktion nextnumber ist willkürlich gewählt, außerdem kann die Funktion auch anders gestaltet werden.
Das Durcheinander der Zahlen entsteht durch die Überträge beim Addieren.
Dass man in der Grafik keine Struktur erkennen kann, ist notwendig, genügt aber nicht. Man muss trotzdem testen.
Code:
Function parity64(Byval n As Ulongint) As Ubyte
   n = n Xor (n Shr 32)
   n = n Xor (n Shr 16)
   n = n Xor (n Shr 8)
   n = n Xor (n Shr 4)
   n = n Xor (n Shr 2)
   n = n Xor (n Shr 1)
   Return n And 1
End Function

Dim Shared As Ulongint sum,sum1

Function nextnumber As Ubyte
   sum1 += 2738830433
   sum += sum1
   Function = parity64(sum)
End Function

'=================================================

Const SCR_WIDTH = 500
Const SCR_HEIGHT = 300

Const SCR_SIZE = SCR_WIDTH * SCR_HEIGHT
Screenres(SCR_WIDTH,SCR_HEIGHT)
Dim buffer As Byte Ptr = Screenptr
Dim index As Ulong

Do
   Screenlock
   For index = 0 To SCR_SIZE - 1
      buffer[index] = 15 * nextnumber
   Next index
   Screenunlock
   Screensync
Loop Until Len(Inkey)

Screen 0,,,&h80000000 ' Close graphics window

'-------------------------------------------------

Die Anfangswerte sind willkürlich gewählt:
Code:
Dim Shared As Ulongint sum,sum1,sum2
sum = 24 : sum1 = 37 : sum2 = 14
Function nextnumber As Ubyte
   sum2 += sum
   sum1 += sum2
   sum += sum1
   Function = parity64(sum)
End Function
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
hhr



Anmeldungsdatum: 15.07.2020
Beiträge: 47

BeitragVerfasst am: 30.11.2021, 11:10    Titel: Antworten mit Zitat

Mit Langzahlarithmetik kann das Überlaufen der Variablen vermieden werden.
Weil die Zahlen mit der Zeit größer werden, wird die Ausgabe langsamer.
Code:
Sub bigadd(a() As Ulong,b() As Ulong) ' a() += b()
   Dim As Ulongint aa,bb,cc
   Dim As Ulong carry,i
   
   If Ubound(b) > Ubound(a) Then Redim Preserve a(Ubound(b))
   
   For i=0 To Ubound(b)
      aa=a(i)
      bb=b(i)
      cc=aa+bb+carry
      a(i)=cc
      carry=cc Shr 32
   Next i
   
   'i=Ubound(b)+1
   
   Do While (carry > 0) And (i <= Ubound(a))
      aa=a(i)
      cc=aa+carry
      a(i)=cc
      carry=cc Shr 32
      i+=1
   Loop
   
   If carry > 0 Then
      Redim Preserve a(Ubound(a)+1)
      a(Ubound(a))=carry
   End If
End Sub

Function parity32(Byval n As Ulong) As Ubyte
   n = n Xor (n Shr 16)
   n = n Xor (n Shr 8)
   n = n Xor (n Shr 4)
   n = n Xor (n Shr 2)
   n = n Xor (n Shr 1)
   Return n And 1
End Function

Function bigparity(a() As Ulong) As Ubyte
   Dim As Ulong p,i
   For i=0 To Ubound(a)
      p Xor= a(i)
   Next i
   Return parity32(p)
End Function

Redim Shared As Ulong sum(0),sum1(0),sum2(0)
sum(0) = 24 : sum1(0) = 37 : sum2(0) = 14

Function nextnumber As Ubyte
   bigadd(sum2(),sum())
   bigadd(sum1(),sum2())
   bigadd(sum(),sum1())
   Function = bigparity(sum())
End Function

'=================================================

Do
   Print nextnumber;
Loop Until Len(Inkey)

'-------------------------------------------------

Code:
Redim Shared As Ulong sum(0),ts1(0)

Function nextnumber As Ubyte
   Dim As Ulong ts
   Asm
      'cpuid ' Complete every preceding instruction
      rdtsc ' Read time-stamp counter into EDX:EAX
      mov [ts],eax
   End Asm
   ts1(0) = ts
   bigadd(sum(),ts1())
   Function = bigparity(sum())
End Function
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Projektvorstellungen Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.

 Impressum :: Datenschutz