Forum strony www.multipasko.pl [Regulamin]


Dodaj wpis w tym temacie
Spis tematów
Login:

Hasło:
Strona: 1 2 ... 554 555 556 ... 561 562
Wyślij wiadomość do admina
🎱 MultiPairs 2027 – zapisz się na listę beta BETA

Przewiń wpisy ↓

moje ... oprogramowanie

2025-08-03 (09:52)

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

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: 14609

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: 23256

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: 14609

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: 14609

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: 23256

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: 420

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: 23256

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: 420

14639
wpis nr 1 574 690
[ CZCIONKA MONOSPACE ]

Witam.

777ch nie zamilkaj...
2025-09-11 (10:22)

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

1386
wpis nr 1 579 322
[ CZCIONKA MONOSPACE ]

Od czasu do czasu coś napiszę.

Mini lotto ,
gra w której losowane jest aktualnie 5 liczb z 42.
Wszystkich 5-ek z 42 liczb jest 850 668.

A jednak ..... przy zawartych ponad 1,2 mln zakładów
np:

nie pada zadna 5-ka

No i TERAZ.
gdyby ktoś z Was pokusił się o wylosowanie
tych 1,2 mln piątek to zobaczy jak to losowe rozdanie
w rzeczywistości pokrywa cały zbiór [850 668].

Jeśli generator losowo zestawi 1 200 000 zakładów
to przekonacie się że pokrycie całego zbioru [850 668]
będzie wynosiło zawsze cirka 73 %
i zawsze niepokrytych 5-ek będzie
cirka tyle samo.

Przykład 4-losowo wygenerowanych zbiorów 1,2 mln 5z42

-----------------------------------
liczba powtórek csn : 572514
ilość linii sprawdzanych : 1200000
Unique5 : 627486
wszystkich csn : 1200000

Elapsed time 00:00:00:124
Coverage[5] % 73,7639125957483%
Uncovered[5] 223182
-----------------------------------
liczba powtórek csn : 571892
ilość linii sprawdzanych : 1200000
Unique5 : 628108
wszystkich csn : 1200000

Elapsed time 00:00:00:109
Coverage[5] % 73,8370316033987%
Uncovered[5] 222560
-----------------------------------
liczba powtórek csn : 572312
ilość linii sprawdzanych : 1200000
Unique5 : 627688
wszystkich csn : 1200000

Elapsed time 00:00:00:141
Coverage[5] % 73,7876586400335%
Uncovered[5] 222980
-----------------------------------


Czyli niepokrytych
jest --> cirka tyle samo [220 000] piątek,
,a powtórnie wylosowanych
co najmniej 2*
jest również --> cirka tyle samo [570 000] piątek.

Unikatowych zakładów
jest zwykle [627 000]


No...... czy to nie ciekawe

Bo w chaosie rodzi się porządek .


»Porządek w chaosie
https://www.miloszwojciechowski.pl/do-poczytania/inne/porzadek-w-chaosie/




2025-09-11 (12:56)

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

1386
wpis nr 1 579 339
[ CZCIONKA MONOSPACE ]

No i TERAZ.
gdyby ktoś z Was pokusił się o wylosowanie
tych 1,2 mln piątek to zobaczy
--> jak
[? tu dodaję po jak pytajnik]
to losowe rozdanie
w rzeczywistości pokrywa cały zbiór [850 668].

no i zawsze będzie to cirka 73% z [850 668].


ale.............

Marriusz2 riposuje
Tyle ,że one nie są losowane .

I to jest fakt .....
"czynnik ludzki" ...... nie wdając się w szczegóły
zaniży poziom 73% ...

jak bardzo nie mam pojęcia
ale na pewno ...... dość sporo.
Przykłady są znane z historii...... gier

cyt: źródło:
https://www.rmf24.pl/fakty/polska/news-30-lat-temu-osiemdziesiat-osob-trafilo-szostke-w-lotto,nId,7420442


cyt:
..."Typowanie szczęśliwych liczb
Ludzie najczęściej grają na "chybił trafił" - przyznała Aida Bella. Rzeczniczka Totalizatora dodała, że wraca tradycja prowadzenia zeszytów z ulubionymi liczbami.

W dawnych czasach były popularne zeszyty, w których gracze zapisywali swoje liczby i historię gier.

Nasi klienci opowiadają, że odszukali zeszyt swojego dziadka i kontynuują tradycję. Podobne zapiski prowadziły raczej osoby starsze - opowiadała Bella. ....."



cyt:źródło:
https://www.fakt.pl/wydarzenia/polska/az-80-szostek-w-lotto-jednego-dnia-czarny-dzien-polskich-milionerow/ts7xyre

."I zdarza się cud! Wygrywasz szóstkę w totka. Tak samo, jak 80 innych osób. Tak właśnie zdarzyło się 30 marca 1994 roku. Ze względu na datę wiele osób myślało, że ma do czynienia z żartem na Prima Aprilis. A jednak była to prawda. Zwycięskie liczby to 11, 16, 23, 30, 35, 41.

Skąd wszyscy je znali? Pochodziły z obrazka umieszczonego na ówcześnie stosowanym blankiecie do typowania....."



Tak więc ........ "CZYNNIK LUDZKI" ... spowoduje
że 1,2 mln zakładów nie osiągnie ......
przewidywanych generatorem
poziomów % rozkładów losowych,

--> słuszna uwaga.

2025-09-11 (16:17)

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

1386
wpis nr 1 579 359
[ CZCIONKA MONOSPACE ]

Z pośród nadanych 1,2 mln zakładów
generator wskaże zawsze cirka 627 000 unikatów


Gdyby każdy gracz z pośród połowy grających zakładów
wybrał opcję
1) co najmniej 3-5 liczb z grupy 15 [typy]
2) co najmniej 2-5 liczb z grupy 27 [pozostałe]
to w grze mieliby zaledwie 159705 kombinacji
bo aż [708513] taki rozkład wykluczy

ale w drugiej połowie z 1,2 mln zakładów
znajdzie się co najmniej 300 000~350 000 unikatów
wiec w sumie można szacować na jakieś cirka 500 000
pokrytych z puli całego zbioru.

co da cirka 58% pokrycia zbioru
a moim zdaniem może być to +-5%
co zmieni ...... czyli obniży o ok. 10%
wskazania generatora losowego [cirka73%]
w kwestii pokrycia przy 1,2 mln nadanych zakładów.

no ......i tak zapewne jest w ..realu.

Ale co mnie obchodzi czynnik ludzki
który .......nie wpływa na mój generator.
Bo ten nie ma dostępu do wyników losowań .

Trzeba pamiętać ,że wskazanie 73 % pokrycia w 1,2 mln losowych
zawiera cirka +- 500 000 powtórzonych.......

No .... to było by na tyle na jakiś czas.

--- wpis edytowano 2025-09-11 16:20 ---

2025-09-13 (12:46)

status Lottonauta
Data rejestracji: 2012-09-03
Ilość postów: 3849

13559
wpis nr 1 579 560
[ CZCIONKA MONOSPACE ]

Samouczek hazardzisty. Część 1: Permutacje i kombinacje
https://eksperymentmyslowy.pl/2024/11/28/samouczek-hazardzisty-czesc-1-permutacje-i-kombinacje/

i ciekawsza część 2:
https://eksperymentmyslowy.pl/2024/12/03/samouczek-hazardzisty-czesc-2-anomalie-i-paradoksy/


Kiedyś się nad tym zastanawiałem i mam parę pomysłów, ale czasu brak.

Pozdrawiam

--- wpis edytowano 2025-09-13 13:00 ---

2025-09-13 (13:47)

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

1386
wpis nr 1 579 563
[ CZCIONKA MONOSPACE ]

hej
no tak......

mam tu na myśli fakty opisane z części drugiej ..

cyt:
" Ponieważ gry typu Lotto oparte na losowaniu 6 liczb zpośród 49 są popularne w wielu krajach poza Polską (m.in. w Niemczech, Hiszpanii, Bułgarii, Grecji czy Kanadzie), można się spodziewać, że na przestrzeni wielu lat już gdzieś musiało dojść do powtórki. I rzeczywiście takie przypadki odnotowano parokrotnie. Najbardziej spektakularnym przykładem powtórzonej szóstki była kombinacja 4–15–23–24–35–43, którą wylosowano dwukrotnie w bułgarskim Toto2 (6/49) – najpierw 6 września 2009 r. (niedziela), a następnie w kolejnym losowaniu, 10 września (czwartek). Przeprowadzone dochodzenie nie wykazało żadnych nieprawidłowości w działaniu maszyny losującej.4 Pikanterii dodaje temu przypadkowi następujący fakt: w pierwszym losowaniu nikt nie wygrał głównej nagrody; w drugim musiało się nią podzielić 18 zwycięzców. I to już na pewno nie był „cud statystyczny”, tylko konsekwencja faktu, że zawsze pewnej liczbie ludzi przyjdzie do głowy, by obstawić szczęśliwą szóstkę z poprzedniego."
2025-09-13 (14:06)

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

1386
wpis nr 1 579 568
[ CZCIONKA MONOSPACE ]

w polskim lotto 6z69
na razie 3-sekwencje ... z powtórką 3x 5z6
2025-09-13 (15:15)

status jac11
Data rejestracji: 2011-06-23
Ilość postów: 9118

13094
wpis nr 1 579 572
[ CZCIONKA MONOSPACE ]

A ile razy wymieniona 6 padła w nasze multi ?
2025-09-13 (16:15)

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

1386
wpis nr 1 579 578
[ CZCIONKA MONOSPACE ]

jac11

Wybraną 6-liczb można sobie u Pasko sprawdzić
https://www.multipasko.pl/analizer/multi-lotek/

a wszystkie to jak niżej:

Multilotek 20z80 /dla 16287-losowań
Ilości wystąpień 6-skreśleń

Frq6. wyst. 0x zbiór = 36816399 -kombinacji
Frq6. wyst. 1x zbiór = 77243509 -kombinacji
Frq6. wyst. 2x zbiór = 81090667 -kombinacji
Frq6. wyst. 3x zbiór = 56787502 -kombinacji
Frq6. wyst. 4x zbiór = 29839636 -kombinacji
Frq6. wyst. 5x zbiór = 12547045 -kombinacji
Frq6. wyst. 6x zbiór = 4403811 -kombinacji
Frq6. wyst. 7x zbiór = 1321441 -kombinacji
Frq6. wyst. 8x zbiór = 347589 -kombinacji
Frq6. wyst. 9x zbiór = 81353 -kombinacji
Frq6. wyst. 10x zbiór = 17336 -kombinacji
Frq6. wyst. 11x zbiór = 3264 -kombinacji
Frq6. wyst. 12x zbiór = 550 -kombinacji
Frq6. wyst. 13x zbiór = 81 -kombinacji
Frq6. wyst. 14x zbiór = 13 -kombinacji
Frq6. wyst. 15x zbiór = 3 -kombinacji

05 20 34 39 42 71
09 12 20 25 44 72
15 19 36 39 68 79

Frq6. wyst. 16x zbiór = 1 -kombinacji
07 34 48 61 66 68

Suma kombinacji : 300500200
2025-09-13 (16:17)

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

1386
wpis nr 1 579 579
[ CZCIONKA MONOSPACE ]


| Dodaj wpis w tym temacie | Spis tematów | Wyniki lottoStrona: 1 2 ... 554 555 556 ... 561 562
Wyślij wiadomość do admina
🎱 MultiPairs 2027 – zapisz się na listę beta BETA