Forum strony www.multipasko.pl [Regulamin]


Dodaj wpis w tym temacie
Spis tematów
Login:

Hasło:
Strona: 1 2 ... 554 555
Wyślij wiadomość do admina

Przewiń wpisy ↓

moje ... oprogramowanie

2025-04-29 (17:57)

status kostka1zn
Data rejestracji: 2021-02-25
Ilość postów: 2802

16333
wpis nr 1 563 802
[ CZCIONKA MONOSPACE ]

Ale co z tymi numerami losowań
robić dalej?

Kolega Scenic nie podpowiedział.
2025-04-29 (18:57)

status fair_play
Data rejestracji: 2016-05-12
Ilość postów: 8769

14865
wpis nr 1 563 806
[ CZCIONKA MONOSPACE ]


Podejrzewam, że bardziej niż numery losowań sensu stricto interesują go odstępy między nimi i dlatego je dołożyłem
2025-04-30 (22:01)

status kostka1zn
Data rejestracji: 2021-02-25
Ilość postów: 2802

16333
wpis nr 1 563 927
[ CZCIONKA MONOSPACE ]

Dziękuję.
Pobrałem sobie następny twój plik.

No to chyba teraz kolega Scenic jest w ekstazie.
Ma już wszystko co mu jest potrzebne.
2025-04-30 (22:12)

status MultiTest
Data rejestracji: 2020-08-05
Ilość postów: 6031

16235
wpis nr 1 563 929
[ CZCIONKA MONOSPACE ]

Scenic,
Sprawdziłem bazę Keno z podanego z linku który podałeś.
Jest tam trochę błędów, zdublowane losowania, losowania puste gdzie zamiast liczb występują same zera,
wymienione po kolei:

0354213 19-10-2013 14:35 01 02 04 05 06 10 12 21 23 27 33 35 36 38 39 41 63 66 68 70 00
0354214 19-10-2013 14:40 04 05 07 08 09 12 16 23 24 26 27 29 31 38 39 56 57 66 67 69 00
0354214 19-10-2013 14:40 04 05 07 08 09 12 16 23 24 26 27 29 31 38 39 56 57 66 67 69 00
0354215 19-10-2013 14:45 14 16 18 19 25 26 29 34 41 42 45 46 48 49 51 55 56 61 66 67 00

zmieniono na :
0354213 19-10-2013 14:35 01 02 04 05 06 10 12 21 23 27 33 35 36 38 39 41 63 66 68 70 00
0354214 19-10-2013 14:40 04 05 07 08 09 12 16 23 24 26 27 29 31 38 39 56 57 66 67 69 00
0354215 19-10-2013 14:45 14 16 18 19 25 26 29 34 41 42 45 46 48 49 51 55 56 61 66 67 00
=======================================================================================



0354652 21-10-2013 21:30 07 08 16 17 19 21 26 30 31 36 37 42 46 48 51 52 58 63 64 70 00
0354653 22-10-2013 06:45 01 07 11 15 17 21 25 30 36 37 40 41 42 45 48 54 62 63 64 70354654 22-10-2013 06:50 03 05 07 08 12 23 31 33 34 37 38 39 43 46 47 49 54 57 58 65 00
//błędny zapis linii, nieobsłużony właściwie (za duża liczba i data zamiast liczby) może być nawet przyczyną dużych błędów

zmieniono na:
0354652 21-10-2013 21:30 07 08 16 17 19 21 26 30 31 36 37 42 46 48 51 52 58 63 64 70 00
0354653 22-10-2013 06:45 01 07 11 15 17 21 25 30 36 37 40 41 42 45 48 54 62 63 64 70 00
0354654 22-10-2013 06:50 03 05 07 08 12 23 31 33 34 37 38 39 43 46 47 49 54 57 58 65 00
=======================================================================================


0442986 02-03-2015 10:30 05 06 16 27 30 31 33 35 44 48 52 53 57 58 60 61 65 67 68 69 00
0442986 02-03-2015 10:30 05 06 16 27 30 31 33 35 44 48 52 53 57 58 60 61 65 67 68 69 00
//zdublowane losowania
//brak losowania następnego
0442988 02-03-2015 10:40 02 03 15 17 25 26 27 33 36 38 43 48 51 52 58 61 62 63 67 68 00

zmieniono na :
0442986 02-03-2015 10:30 05 06 16 27 30 31 33 35 44 48 52 53 57 58 60 61 65 67 68 69 00
0442987 02-03-2015 10:35 07 08 11 13 14 18 20 21 22 24 27 28 36 38 41 45 47 59 60 61 00
0442988 02-03-2015 10:40 02 03 15 17 25 26 27 33 36 38 43 48 51 52 58 61 62 63 67 68 00
=======================================================================================

Ilość losowań : 1375846
1375847
440449 16-02-2015 06:45
====== Brak liczb w losowaniu =======

440459 16-02-2015 07:35
====== Brak liczb w losowaniu =======

440470 16-02-2015 08:30
====== Brak liczb w losowaniu =======

440484 16-02-2015 09:40
====== Brak liczb w losowaniu =======

440498 16-02-2015 10:50
====== Brak liczb w losowaniu =======

440504 16-02-2015 11:20
====== Brak liczb w losowaniu =======

440508 16-02-2015 11:40
====== Brak liczb w losowaniu =======

440521 16-02-2015 12:45
====== Brak liczb w losowaniu =======

479071 20-09-2015 21:15
====== Brak liczb w losowaniu =======

479080 21-09-2015 07:10
====== Brak liczb w losowaniu =======

479083 21-09-2015 07:25
====== Brak liczb w losowaniu =======

482864 12-10-2015 11:00
====== Brak liczb w losowaniu =======

482874 12-10-2015 11:50
====== Brak liczb w losowaniu =======

483294 14-10-2015 17:10
====== Brak liczb w losowaniu =======

483311 14-10-2015 18:35
====== Brak liczb w losowaniu =======

483312 14-10-2015 18:40
====== Brak liczb w losowaniu =======

483317 14-10-2015 19:05
====== Brak liczb w losowaniu =======

483318 14-10-2015 19:10
====== Brak liczb w losowaniu =======

483339 14-10-2015 20:55
====== Brak liczb w losowaniu =======

483341 14-10-2015 21:05
====== Brak liczb w losowaniu =======

483345 14-10-2015 21:25
====== Brak liczb w losowaniu =======

1049365 23-11-2021 23:54
====== Brak liczb w losowaniu =======

1052491 06-12-2021 08:02
====== Brak liczb w losowaniu =======

1052492 06-12-2021 08:06
====== Brak liczb w losowaniu =======

1052493 06-12-2021 08:10
====== Brak liczb w losowaniu =======

1052494 06-12-2021 08:14
====== Brak liczb w losowaniu =======

1052495 06-12-2021 08:18
====== Brak liczb w losowaniu =======

1052496 06-12-2021 08:22
====== Brak liczb w losowaniu =======

1052497 06-12-2021 08:26
====== Brak liczb w losowaniu =======

1054812 14-12-2021 23:26
====== Brak liczb w losowaniu =======

1054813 14-12-2021 23:30
====== Brak liczb w losowaniu =======

1054814 14-12-2021 23:34
====== Brak liczb w losowaniu =======

1054815 14-12-2021 23:38
====== Brak liczb w losowaniu =======

1054816 14-12-2021 23:42
====== Brak liczb w losowaniu =======

1054817 14-12-2021 23:46
====== Brak liczb w losowaniu =======

1054818 14-12-2021 23:50
====== Brak liczb w losowaniu =======

1054819 14-12-2021 23:54
====== Brak liczb w losowaniu =======

razem 37 losowań bez liczb
======================================

Część z tych losowań zostało uzupełnionych.
Jeżeli chcesz kompletną naprawioną baza do 30.04.2025 włącznie mogę wrzucić do pobrania,
a najlepiej by było żeby te poprawki zostało uwzględnione u źródła, przez właściciela strony.

--- wpis edytowano 2025-04-30 22:14 ---

2025-04-30 (22:44)

status MultiTest
Data rejestracji: 2020-08-05
Ilość postów: 6031

16235
wpis nr 1 563 943
[ CZCIONKA MONOSPACE ]

Scenic,
Jeżeli interesują Ciebie liczby zimne i gorące z Keno podawane na bieżąco przez AI to można spróbować z programikiem Keno_Rotacja_GorąceZimne.
10 liczb na próbę, na podstawie losowań do numeru 1376612 z godz.22:42

34,64,25,9,56,30,63,38,31,53

2025-06-14 (14:49)

status BochiCintra
Data rejestracji: 2019-07-29
Ilość postów: 103

16005
wpis nr 1 568 982
[ CZCIONKA MONOSPACE ]

Cześć, przekonwertowałem program lottodesigner Nicka Koutrasa na Delphi, działa, ale wymaga udoskonalenia, w linku znajduje się plik .exe i kod źródłowy

}}
2025-06-14 (14:50)

status BochiCintra
Data rejestracji: 2019-07-29
Ilość postów: 103

16005
wpis nr 1 568 983
[ CZCIONKA MONOSPACE ]

https://www.mediafire.com/file/dzd6ps1f1vk5d33/lottodesigner_-_1.zip/file
2025-07-04 (19:09)

status vidmo
Data rejestracji: 2004-11-03
Ilość postów: 12066

449
wpis nr 1 571 021
[ CZCIONKA MONOSPACE ]

Witaj Leo. Czy mógłbyś "podrasować" swoim softem ten schemacik?

C(70,28,8,20)=8 - 100%
C(70,28,2x 8,20)=8 - 99,993449%
C(70,28,3x 8,20)=8 - 99,938261%
C(70,28,8x 8,20)=8 - 99,24155%
C(70,28,9,20)=8 - 99,235427%
C(70,28,2x 9,20)=8 - 95,978477%
C(70,28,6x 9,20)=8 - 85,137422%
C(70,28,10,20)=8 - 85,114775%
C(70,28,2x 10,20)=8 - 64,647534%
C(70,28,7x 10,20)=8 - 29,749756%
C(70,28,19,20)=8 - 0,000002%

01 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 29 33
02 03 04 05 07 08 09 11 12 13 14 15 16 18 20 24 25 26 27 29 30 31 32 33 34 37 41 42
01 04 05 06 07 08 09 10 13 17 18 19 21 22 23 24 25 26 27 28 30 34 35 36 38 39 40 42
01 02 03 06 10 11 12 14 15 16 17 19 20 21 22 23 28 29 31 32 33 35 36 37 38 39 40 41
29 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 61
30 31 32 33 35 36 37 39 40 41 42 43 44 46 48 52 53 54 55 57 58 59 60 61 62 65 69 70
29 32 33 34 35 36 37 38 41 45 46 47 49 50 51 52 53 54 55 56 58 62 63 64 66 67 68 70
29 30 31 34 38 39 40 42 43 44 45 47 48 49 50 51 56 57 59 60 61 63 64 65 66 67 68 69
2025-07-05 (01:56)

status vidmo
Data rejestracji: 2004-11-03
Ilość postów: 12066

449
wpis nr 1 571 058
[ CZCIONKA MONOSPACE ]

Witaj ponownie Leo. Jak już się rozpędzisz, to może i ten ulepszysz...

C(80,28,4x 7,20)=8 - 100%
C(80,28,8,20)=8 - 99,808504%
C(80,28,2x 8,20)=8 - 97,860738%
C(80,28,3x 8,20)=8 - 93,749808%
C(80,28,8x 8,20)=8 - 87,113325%
C(80,28,9,20)=8 - 87,113307%
C(80,28,9,20)=8 - 81,85808%
C(80,28,2x 9,20)=8 - 65,934026%
C(80,28,10,20)=8 - 50,236704%
C(80,28,2x 10,20)=8 - 25,814962%
C(80,28,5x 10,20)=8 - 19,962052%
C(80,28,18,20)=8 - 0,000004%

01 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 29 33
02 03 04 05 07 08 09 11 12 13 14 15 16 18 20 24 25 26 27 29 30 31 32 33 34 37 41 42
01 04 05 06 07 08 09 10 13 17 18 19 21 22 23 24 25 26 27 28 30 34 35 36 38 39 40 42
01 02 03 06 10 11 12 14 15 16 17 19 20 21 22 23 28 29 31 32 33 35 36 37 38 39 40 41
39 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 66 67 71
40 41 42 43 45 46 47 49 50 51 52 53 54 56 58 62 63 64 65 67 68 69 70 71 72 75 79 80
39 42 43 44 45 46 47 48 51 55 56 57 59 60 61 62 63 64 65 66 68 72 73 74 76 77 78 80
39 40 41 44 48 49 50 52 53 54 55 57 58 59 60 61 66 67 69 70 71 73 74 75 76 77 78 79
2025-08-03 (09:52)

status 777ch
Data rejestracji: 2005-11-07
Ilość postów: 22679

1386
wpis nr 1 574 412
[ CZCIONKA MONOSPACE ]

Witka
Czasem zaglądam
i ..zamykam 🫣
2025-08-03 (16:11)

status vidmo
Data rejestracji: 2004-11-03
Ilość postów: 12066

449
wpis nr 1 574 441
[ CZCIONKA MONOSPACE ]

Witaj Leo.
Jakbyś mógł przemienić swoją maszynką te 28 ósemki, bo tylko Ty masz do tego soft.
2025-08-03 (16:33)

status 777ch
Data rejestracji: 2005-11-07
Ilość postów: 22679

1386
wpis nr 1 574 443
[ CZCIONKA MONOSPACE ]

Sorry Vidmo
Nie mielę chwilowo niczego. 🤭

Coś mi się kojarzy
.. mianowicie fakt
że w historii Multi Multi
tylko 6-zestawów wystarczało
do trafienia co najmniej 1x 8/20
jakieś 4x w 25- letniej historii Multi
te 6-zestawów nie uzyskało minimum 8/20
czyli raz na 6-lat 🤭
Ale nie mam tych danych ,
już skasowane..
pamiętam ,że kilka miesięcy temu
to sprawdzałem.

--- wpis edytowano 2025-08-03 16:41 ---

2025-08-03 (17:20)

status vidmo
Data rejestracji: 2004-11-03
Ilość postów: 12066

449
wpis nr 1 574 447
[ CZCIONKA MONOSPACE ]

Witaj
Ok, ale jakby się kiedyś skończyło to " chwilowo " to pamiętaj o mnie...
2025-08-03 (20:43)

status BochiCintra
Data rejestracji: 2019-07-29
Ilość postów: 103

16005
wpis nr 1 574 457
[ CZCIONKA MONOSPACE ]

Cześć, konwertuję kod źródłowy „cover32.c” z nummela na pascal.

program CombinatoricalOptimization;

{$mode objfpc}{$H+}

uses
Math, SysUtils;

const
MAXV = 100;
EXPSIZE = 2000;
MAXKSETCOUNT = High(Integer);
MAXRANDOM = High(Integer);

type
TIntArray = array of Integer;
TFloatArray = array of Double;
TBinCoefArray = array[0..MAXV, 0..MAXV+1] of Integer;

var
{ Global variables }
kset: TIntArray;
neighborLen: Integer;
coverLen: Integer;
coveredLen: Integer;
neighbors: TIntArray;
coverings: TIntArray;
covered: TIntArray;
costs: TIntArray;
costds: TIntArray;
iterCounter: Integer;
endT: Double;

binCoef: TBinCoefArray;
exps: TFloatArray;
neglibleExp: Double;
coolFact: Double;
initProb: Double;
v, k, t, m, b: Integer;
testCount: Integer;
restrictedNeighbors: Integer;
initialT: Double;
frozen: Integer;
endLimit: Integer;
apprexp: Integer;
Tset: Integer;
L: Integer;
Lset: Integer;
LFact: Double;
localOpt: Integer;
onTheFly: Integer;
coverNumber: Integer;
solX: Integer;
memoryLimit: Integer;
searchB: Integer;
SBFact: Double;
pack: Integer;
check: Integer;
verbose: Integer;
setNumber: Integer;
nextS: Integer;
// stored: array[0..1] of Integer;
currSto: Integer;
nextSto: Integer;
storedPtr: array[0..1] of TIntArray;

function OverflowBinCoef(vVal, kVal: Integer): Boolean;
begin
Result := binCoef[vVal, kVal] = 0;
end;

function MinVal(X, Y: Integer): Integer;
begin
if X < Y then Result := X else Result := Y;
end;

function MaxVal(X, Y: Integer): Integer;
begin
if X > Y then Result := X else Result := Y;
end;

function ApprExpProb(R: Double): Double;
begin
if R > neglibleExp then
Result := 0.0
else
Result := exps[Round(R / neglibleExp * EXPSIZE + 0.5)];
end;

function ExpProb(R: Double): Double;
begin
if apprexp <> 0 then
Result := ApprExpProb(R)
else
Result := Exp(-R);
end;

function Random01: Double;
begin
Result := Random / MAXRANDOM;
end;

function BinCoef1(n, kVal: Integer): Integer;
var
i: Integer;
K: Integer;
nCk: Double;
begin
if kVal > n then
begin
Result := 0;
Exit;
end;
if kVal = n then
begin
Result := 1;
Exit;
end;

N := n;
K := kVal;
nCk := 1.0;

for i := 0 to kVal - 1 do
nCk := nCk * (N - i) / (K - i);

Result := Round(nCk);
end;

function Factorial(nValue: Double): Double;
var
pc: Double;
begin
Result := nValue;
pc := nValue;
while pc > 2 do
begin
Result := Result * (pc - 1);
pc := pc - 1;
end;
end;

procedure CalculateExps;
var
i: Integer;
neglibleProb: Double;
begin
neglibleProb := 1.0 / EXPSIZE;
neglibleExp := -Ln(neglibleProb);

SetLength(exps, EXPSIZE + 1);
for i := 0 to EXPSIZE do
exps[i] := Exp(-i / EXPSIZE * neglibleExp);
end;

procedure BIs(bl: Integer);
begin
b := bl;
if b > 100 then
begin
{ Handle error }
WriteLn('Error: b exceeds maximum');
Exit;
end;

SetLength(kset, b);
SetLength(costs, b + 1);
SetLength(costds, b + 1);
end;

function NewBAfterSuccess(oldB: Integer): Integer;
var
lb: Integer;
begin
lb := Round(SBFact * oldB + 0.5);
if lb = oldB then
lb := lb - 1;
Result := lb;
end;

procedure AllocateMemory;
var
elemCountNeighbors, elemCountCoverings, elemCountCovered: Integer;
i, tmp: Integer;
begin
elemCountNeighbors := 0;
elemCountCoverings := 0;
elemCountCovered := 0;

neighborLen := k * (v - k);

if v > MAXV then
begin
WriteLn('Error: v exceeds maximum');
Exit;
end;

tmp := 0;
coverLen := 0;
for i := 0 to MinVal(k - t, m - t) do
begin
coverLen := coverLen + BinCoef1(k, t + i) * BinCoef1(v - k, m - t - i);
if coverLen < tmp then
begin
WriteLn('Error: coverLen overflow');
Exit;
end;
tmp := coverLen;
end;
coverLen := coverLen + 1;

if onTheFly = 0 then
begin
elemCountNeighbors := neighborLen * BinCoef1(v, k);
elemCountCoverings := coverLen * BinCoef1(v, k);
end
else
elemCountCoverings := coverLen * 2;

elemCountCovered := BinCoef1(v, m);
coveredLen := elemCountCovered;

if (memoryLimit > 0) and
(elemCountNeighbors * 4 + elemCountCoverings * 4 + elemCountCovered * 4 > memoryLimit) then
begin
WriteLn('Error: Memory limit exceeded');
end
else
begin
if elemCountNeighbors > 0 then
SetLength(neighbors, elemCountNeighbors);
SetLength(coverings, elemCountCoverings);
SetLength(covered, elemCountCovered);
end;
end;

procedure MakeComplement(var s, c: TIntArray; vVal: Integer);
var
sPtr, cPtr, i: Integer;
begin
sPtr := 0;
cPtr := 0;

for i := 0 to vVal - 1 do
begin
if (sPtr < Length(s)) and (s[sPtr] = i) then
Inc(sPtr)
else
begin
c[cPtr] := i;
Inc(cPtr);
end;
end;
c[cPtr] := MAXV + 1;
end;

procedure GetFirstSubset(var subset: TIntArray; card: Integer);
var
i: Integer;
begin
for i := 0 to card - 1 do
subset[i] := i;
subset[card] := MAXV + 1;
end;

function GetNextSubset(var subset: TIntArray; card, vVal: Integer): Boolean;
var
j, i: Integer;
begin
if subset[0] >= vVal - card then
begin
Result := False;
Exit;
end;

j := 0;
while (j + 1 < card) and (subset[j + 1] <= subset[j] + 1) do
Inc(j);

Inc(subset[j]);
for i := 0 to j - 1 do
subset[i] := i;

Result := True;
end;

procedure UnrankSubset(rank: Integer; var subset: TIntArray; card: Integer);
var
mVal, i, p: Integer;
begin
mVal := rank;
for i := card - 1 downto 0 do
begin
p := i;
while BinCoef1(p + 1, i + 1) <= mVal do
Inc(p);
mVal := mVal - BinCoef1(p, i + 1);
subset[i] := p;
end;
end;

function RankSubset(var subset: TIntArray; card: Integer): Integer;
var
rank, i: Integer;
begin
rank := 0;
for i := 0 to card - 1 do
rank := rank + BinCoef1(subset[i], i + 1);
Result := rank;
end;

procedure CalculateNeighbors;
var
subset, csubset, subsubset, subcsubset, mergeset: TIntArray;
nptr, r, ssptr, scptr, mptr, i: Integer;
begin
SetLength(subset, MAXV + 1);
SetLength(csubset, MAXV + 1);
SetLength(subsubset, MAXV + 1);
SetLength(subcsubset, MAXV + 1);
SetLength(mergeset, MAXV + 1);

nptr := 0;
GetFirstSubset(subset, k);

for r := 0 to BinCoef1(v, k) - 1 do
begin
MakeComplement(subset, csubset, v);
GetFirstSubset(subsubset, k - 1);

repeat
GetFirstSubset(subcsubset, 1);
repeat
ssptr := 0;
scptr := 0;
mptr := 0;
subsubset[k - 1] := k;
subcsubset[1] := v - k;

for i := 0 to k - 1 do
begin
if subset[subsubset[ssptr]] < csubset[subcsubset[scptr]] then
begin
mergeset[mptr] := subset[subsubset[ssptr]];
Inc(ssptr);
end
else
begin
mergeset[mptr] := csubset[subcsubset[scptr]];
Inc(scptr);
end;
Inc(mptr);
end;

subsubset[k - 1] := MAXV + 1;
subcsubset[1] := MAXV + 1;
mergeset[mptr] := MAXV + 1;
neighbors[nptr] := RankSubset(mergeset, k);
Inc(nptr);
until not GetNextSubset(subcsubset, 1, v - k);
until not GetNextSubset(subsubset, k - 1, k);
GetNextSubset(subset, k, v);
end;
end;

procedure CalculateOneCovering(kRank: Integer; var buf: TIntArray);
var
subset, csubset, subsubset, subcsubset, mergeset: TIntArray;
coverptr, ti, ssptr, scptr, mptr, i: Integer;
begin
SetLength(subset, MAXV + 1);
SetLength(csubset, MAXV + 1);
SetLength(subsubset, MAXV + 1);
SetLength(subcsubset, MAXV + 1);
SetLength(mergeset, MAXV + 1);

coverptr := 0;
UnrankSubset(kRank, subset, k);
subset[k] := MAXV + 1;
MakeComplement(subset, csubset, v);

for ti := t to MinVal(k, m) do
begin
GetFirstSubset(subsubset, ti);
repeat
GetFirstSubset(subcsubset, m - ti);
repeat
ssptr := 0;
scptr := 0;
mptr := 0;
subsubset[ti] := k;
subcsubset[m - ti] := v - k;

for i := 0 to m - 1 do
begin
if subset[subsubset[ssptr]] < csubset[subcsubset[scptr]] then
begin
mergeset[mptr] := subset[subsubset[ssptr]];
Inc(ssptr);
end
else
begin
mergeset[mptr] := csubset[subcsubset[scptr]];
Inc(scptr);
end;
Inc(mptr);
end;

subsubset[ti] := MAXV + 1;
subcsubset[m - ti] := MAXV + 1;
mergeset[mptr] := MAXV + 1;
buf[coverptr] := RankSubset(mergeset, m);
Inc(coverptr);
until not GetNextSubset(subcsubset, m - ti, v - k);
until not GetNextSubset(subsubset, ti, k);
end;
buf[coverptr] := BinCoef1(v, m);
end;

procedure CalculateCoverings;
var
r: Integer;
tempBuf: TIntArray;
begin
SetLength(tempBuf, coverLen);
for r := 0 to BinCoef1(v, k) - 1 do
begin
CalculateOneCovering(r, tempBuf);
Move(tempBuf[0], coverings[r * coverLen], coverLen * SizeOf(Integer));
end;
end;

procedure ComputeTables(tl, kl, ml, vl: Integer);
begin
t := tl;
k := kl;
m := ml;
v := vl;
AllocateMemory;
if onTheFly = 0 then
begin
CalculateNeighbors;
CalculateCoverings;
end;
end;

procedure CalculateCosts;
var
i: Integer;
begin
if pack <> 0 then
begin
for i := 0 to b do
begin
if i < coverNumber then
costs[i] := 0
else
costs[i] := i - coverNumber;
end;
end
else
begin
for i := 0 to b do
begin
if i < coverNumber then
costs[i] := coverNumber - i
else
costs[i] := 0;
end;
end;

for i := 0 to b - 1 do
costds[i] := costs[i] - costs[i + 1];
end;

function InitSolution: Integer;
var
initCost, i, j: Integer;
coveringsPtr: Integer;
begin
initCost := 0;

{ Initialize covered array }
for i := 0 to coveredLen - 1 do
covered[i] := 0;

for i := 0 to b - 1 do
begin
kset[i] := Random(BinCoef1(v, m));
if onTheFly <> 0 then
begin
SetLength(storedPtr[0], coverLen);
CalculateOneCovering(kset[i], storedPtr[0]);
coveringsPtr := 0;
end
else
coveringsPtr := kset[i] * coverLen;

for j := 0 to coverLen - 2 do
begin
if onTheFly <> 0 then
Inc(covered[storedPtr[0][j]])
else
Inc(covered[coverings[coveringsPtr + j]]);
end;
end;

for i := 0 to coveredLen - 1 do
initCost := initCost + costs[covered[i]];

Result := initCost;
end;

function RandomNeighbor(curr: Integer): Integer;
var
subset, csubset: TIntArray;
i, temp: Integer;
begin
SetLength(subset, MAXV + 1);
SetLength(csubset, MAXV + 1);

UnrankSubset(curr, subset, k);
MakeComplement(subset, csubset, v);
subset[Random(k)] := csubset[Random(v - k)];

{ Sort subset }
for i := 0 to k - 2 do
begin
if subset[i] > subset[i + 1] then
begin
temp := subset[i];
subset[i] := subset[i + 1];
subset[i + 1] := temp;
end;
end;

Result := RankSubset(subset, k);
end;

function ComputeNeighbor: Integer;
var
costDelta, currS: Integer;
currPtr, nextPtr: TIntArray;
i: Integer;
begin
costDelta := 0;

if restrictedNeighbors <> 0 then
begin
if setNumber + 1 = b then
setNumber := 0
else
setNumber := setNumber + 1;
end
else
setNumber := Random(b);

currS := kset[setNumber];

if onTheFly <> 0 then
nextS := RandomNeighbor(currS)
else
nextS := neighbors[currS * neighborLen + Random(neighborLen)];

if onTheFly <> 0 then
begin
{ Handle on-the-fly calculation }
SetLength(currPtr, coverLen);
SetLength(nextPtr, coverLen);
CalculateOneCovering(currS, currPtr);
CalculateOneCovering(nextS, nextPtr);
currSto := 0;
nextSto := 1;
end
else
begin
SetLength(currPtr, coverLen);
SetLength(nextPtr, coverLen);
Move(coverings[currS * coverLen], currPtr[0], coverLen * SizeOf(Integer));
Move(coverings[nextS * coverLen], nextPtr[0], coverLen * SizeOf(Integer));
end;

i := 0;
while i < (coverLen - 1) * 2 do
begin
if currPtr[0] = nextPtr[0] then
begin
{ Remove first elements }
Move(currPtr[1], currPtr[0], (Length(currPtr) - 1) * SizeOf(Integer));
Move(nextPtr[1], nextPtr[0], (Length(nextPtr) - 1) * SizeOf(Integer));
Inc(i);
end
else if currPtr[0] < nextPtr[0] then
begin
costDelta := costDelta + costds[covered[currPtr[0]] - 1];
Move(currPtr[1], currPtr[0], (Length(currPtr) - 1) * SizeOf(Integer));
end
else
begin
costDelta := costDelta - costds[covered[nextPtr[0]]];
Move(nextPtr[1], nextPtr[0], (Length(nextPtr) - 1) * SizeOf(Integer));
end;
Inc(i);
end;

Result := costDelta;
end;

procedure AcceptNeighbor;
var
currS, i: Integer;
coveringsPtr: Integer;
begin
currS := kset[setNumber];

if onTheFly <> 0 then
coveringsPtr := currSto * coverLen
else
coveringsPtr := currS * coverLen;

for i := 0 to coverLen - 2 do
begin
if onTheFly <> 0 then
Dec(covered[storedPtr[currSto][i]])
else
Dec(covered[coverings[coveringsPtr + i]]);
end;

if onTheFly <> 0 then
coveringsPtr := nextSto * coverLen
else
coveringsPtr := nextS * coverLen;

for i := 0 to coverLen - 2 do
begin
if onTheFly <> 0 then
Inc(covered[storedPtr[nextSto][i]])
else
Inc(covered[coverings[coveringsPtr + i]]);
end;

kset[setNumber] := nextS;
end;

function LocalOptimization(frozenVal, endLimitVal: Integer): Integer;
var
currCost, costDelta, notChanged: Integer;
begin
CalculateCosts;
currCost := InitSolution;
notChanged := 0;

while notChanged < frozenVal do
begin
costDelta := ComputeNeighbor;
Inc(iterCounter);

if costDelta < 0 then
begin
AcceptNeighbor;
notChanged := 0;
currCost := currCost + costDelta;
if currCost <= endLimitVal then
begin
Result := currCost;
Exit;
end;
end
else
Inc(notChanged);
end;

Result := currCost;
end;

function ApproxInitT: Double;
var
T: Double;
m2, i, costDelta: Integer;
begin
T := 0.0;
m2 := 0;

for i := 0 to 29 do
begin
costDelta := ComputeNeighbor;
if costDelta > 0 then
begin
Inc(m2);
T := T - costDelta;
end;
end;

if m2 <> 0 then
Result := T / m2 / Ln(initProb)
else
Result := 1.0;
end;

function SimulatedAnnealing(coolFactVal, initProbVal: Double; iterLength, frozenVal, endLimitVal: Integer): Integer;
var
currCost, bestSeen, notChanged: Integer;
T: Double;
m1, m2, m3, m0, i, costDelta: Integer;
r, D: Double;
begin
CalculateCosts;
currCost := InitSolution;
bestSeen := currCost;

if Tset <> 0 then
T := initialT
else
T := ApproxInitT;

notChanged := 0;
while notChanged < frozenVal do
begin
m1 := 0; m2 := 0; m3 := 0; m0 := 0;

for i := 0 to iterLength - 1 do
begin
costDelta := ComputeNeighbor;
Inc(iterCounter);

if costDelta <= 0 then
begin
Inc(m3);
AcceptNeighbor;
currCost := currCost + costDelta;

if currCost <= endLimitVal then
begin
endT := T;
Result := currCost;
Exit;
end;

if costDelta < 0 then
begin
notChanged := 0;
if currCost < bestSeen then
bestSeen := currCost;
end
else
Inc(m0);
end
else
begin
r := Random01;
D := costDelta / T;
if r < ExpProb(D) then
begin
AcceptNeighbor;
Inc(m1);
currCost := currCost + costDelta;
end
else
Inc(m2);
end;
end;

if currCost <= bestSeen then
Inc(notChanged);

T := T * coolFactVal;
end;

endT := T;
Result := currCost;
end;

procedure SortSolution;
var
i, j, temp: Integer;
begin
{ Simple bubble sort }
for i := 0 to b - 2 do
for j := 0 to b - 2 - i do
if kset[j] > kset[j + 1] then
begin
temp := kset[j];
kset[j] := kset[j + 1];
kset[j + 1] := temp;
end;
end;

procedure PrintSubset(r, card: Integer);
var
subset: TIntArray;
i: Integer;
begin
SetLength(subset, MAXV + 1);
UnrankSubset(r, subset, card);

if solX <> 0 then
begin
{ Handle solX logic }
end;

for i := 0 to card - 1 do
Write(Format('%2d ', [subset[i] + 1]));
WriteLn;
end;

procedure PrintSolution;
var
j: Integer;
begin
for j := 0 to b - 1 do
PrintSubset(kset[j], k);
end;

function CommonElements(mRank, kRank: Integer): Integer;
var
mSet, kSet: TIntArray;
mPtr, kPtr, matchCount, i: Integer;
begin
SetLength(mSet, MAXV + 1);
SetLength(kSet, MAXV + 1);

UnrankSubset(mRank, mSet, m);
UnrankSubset(kRank, kSet, k);
mSet[m] := MAXV;
kSet[k] := MAXV;

mPtr := 0;
kPtr := 0;
matchCount := 0;

for i := 0 to k + m - 1 do
begin
if mSet[mPtr] = kSet[kPtr] then
begin
Inc(matchCount);
Inc(mPtr);
Inc(kPtr);
end
else if mSet[mPtr] > kSet[kPtr] then
Inc(kPtr)
else
Inc(mPtr);
end;

Result := matchCount;
end;

function CheckSolution: Integer;
var
totalCost, mRank, found, i: Integer;
begin
totalCost := 0;

for mRank := 0 to BinCoef1(v, m) - 1 do
begin
found := 0;
for i := 0 to b - 1 do
begin
if CommonElements(mRank, kset[i]) >= t then
Inc(found);
end;
totalCost := totalCost + costs[found];

if (verbose >= 2) and (costs[found] <> 0) then
PrintSubset(mRank, m);
end;

Result := totalCost;
end;

function NewSplitB(bVal, hi, lo, found: Integer): Boolean;
begin
if hi - lo <= 1 then
begin
Result := False;
Exit;
end;

BIs(lo + (hi - lo + 1) div 2);
Result := True;
end;

function SearchBContinues(found: Integer; var hiB, loB: Integer): Boolean;
begin
if searchB = 0 then
begin
Result := False;
Exit;
end;

if loB = -1 then
begin
if found <> 0 then
begin
hiB := b;
BIs(NewBAfterSuccess(b));
Result := True;
end
else
begin
loB := b;
Result := NewSplitB(b, hiB, loB, found);
end;
end
else
begin
if found <> 0 then
hiB := b
else
loB := b;
Result := NewSplitB(b, hiB, loB, found);
end;
end;

procedure FreeTables;
begin
if onTheFly = 0 then
SetLength(neighbors, 0);
SetLength(coverings, 0);
SetLength(covered, 0);
if Length(kset) > 0 then
SetLength(kset, 0);
end;

procedure InitializeGlobals;
begin
{ Initialize global variables }
neighborLen := 0;
coverLen := 0;
coveredLen := 0;
iterCounter := 0;
endT := 0.0;

{ Initialize parameters }
coolFact := 0.99;
initProb := 0.5;
v := 12;
k := 6;
t := 5;
m := 5;
b := 10;
testCount := 1;
restrictedNeighbors := 0;
initialT := 1.0;
frozen := 10;
endLimit := 0;
apprexp := 0;
Tset := 0;
L := 24;
Lset := 0;
LFact := 1.0;
localOpt := 0;
onTheFly := 0;
coverNumber := 1;
solX := 0;
memoryLimit := 0;
searchB := 0;
SBFact := 0.95;
pack := 0;
check := 0;
verbose := 2;
setNumber := 0;
nextS := 0;
// stored[0] := 0;
// stored[1] := 0;
currSto := 0;
nextSto := 0;
end;

{ Main program }
var
costSum, finalCost, bestCost: Integer;
hiB, loB: Integer;
count1: Integer;

begin
Randomize;
InitializeGlobals;

// retVal := 0;
costSum := 0;
finalCost := 0;
bestCost := -1;
hiB := -1;
loB := -1;

if verbose <> 0 then
begin
{ Handle verbose output }
WriteLn('Starting optimization...');
end;

{ Initialize binomial coefficients }
// for retVal := 0 to MAXV do
// for costSum := 0 to MAXV + 1 do
// binCoef[retVal, costSum] := BinCoef1(retVal, costSum);

CalculateExps;

if Lset = 0 then
L := Round(LFact * k * (v - k) * b + 0.5);

if searchB <> 0 then
BIs(NewBAfterSuccess(hiB))
else
BIs(b);

ComputeTables(t, k, m, v);

repeat
for count1 := 0 to testCount - 1 do
begin
iterCounter := 0;
if localOpt <> 0 then
finalCost := LocalOptimization(L, endLimit)
else
finalCost := SimulatedAnnealing(coolFact, initProb, L, frozen, endLimit);

// if finalCost <= endLimit then
// count1 := testCount;

if (bestCost = -1) or (finalCost < bestCost) then
bestCost := finalCost;

costSum := costSum + finalCost;

// if verbose <> 0 and (finalCost <= endLimit) then
begin
WriteLn('Solution found with cost: ', finalCost);
PrintSolution;
end;

if (check <> 0) and (CheckSolution <> finalCost) then
begin
WriteLn('Error: Check failed');
end;
end;
until not SearchBContinues(Ord(finalCost <= endLimit), hiB, loB);

WriteLn('Best cost found: ', bestCost);
WriteLn('Total iterations: ', iterCounter);

FreeTables;
end.
2025-08-03 (23:02)

status vidmo
Data rejestracji: 2004-11-03
Ilość postów: 12066

449
wpis nr 1 574 493
[ CZCIONKA MONOSPACE ]

Witaj ponownie Leo.
Może uda Ci się osiągnąć 100% w tej pozycji:
C(70,28,8x 8,20)=8 - 99,24155%
Powidoki od videmka.
2025-08-04 (14:04)

status 777ch
Data rejestracji: 2005-11-07
Ilość postów: 22679

1386
wpis nr 1 574 545
[ CZCIONKA MONOSPACE ]

BochiCintra

Cześć,
nikt się "tym" tu nie interesuje,
..raczej nikt.

Ja również nie mam na to ochoty .

Ale .....dziekuję Ci
za wpis ,
i
za kawał kodu .
2025-08-04 (23:58)

status BochiCintra
Data rejestracji: 2019-07-29
Ilość postów: 103

16005
wpis nr 1 574 610
[ CZCIONKA MONOSPACE ]

ok
2025-08-05 (17:45)

status heme24
Data rejestracji: 2015-12-08
Ilość postów: 329

14639
wpis nr 1 574 685
[ CZCIONKA MONOSPACE ]

Witam.

777ch kurcze już tyle lat piszesz tu na forum, jesteś chyba rekordzistą, tyle osób które kiedyś tu pisało
już znikły, pisz dalej bo masz ciekawy punkt widzenia na tematy lotto.

Pozdrawiam
2025-08-05 (18:03)

status 777ch
Data rejestracji: 2005-11-07
Ilość postów: 22679

1386
wpis nr 1 574 688
[ CZCIONKA MONOSPACE ]

heme24

Lepiej nic nie pisać,
niż ..pisać głupoty.

Kwestia druga ..
to po co i do kogo
skierowany jest wpis.

No i ..
wobec tego .. zamilkłem. 🤐
2025-08-05 (18:30)

status heme24
Data rejestracji: 2015-12-08
Ilość postów: 329

14639
wpis nr 1 574 690
[ CZCIONKA MONOSPACE ]

Witam.

777ch nie zamilkaj...
| Dodaj wpis w tym temacie | Spis tematów | Wyniki lottoStrona: 1 2 ... 554 555
Wyślij wiadomość do admina