Per Salvo50

[sorujoe]

Ciao Salvo,
ti volevo chiedere se è possibile realizzare questo script:
Io immetto un pronostico integrale sino a 45 numeri lo script me li sistema in un cruciverba dove io determino i due lati (non per forza uguali ad esempio 10x10 io posso mettere 12x4 cosi fare 4 righe da 12 combinazioni)
L'unica condizione in automatico è questa che nelle righe ed eventuali colonne e due diagonali lo script sistemi i numeri in modo da prendere il minor numero possibile di cadenze decine e figure uguali; quindi se nell'integrale abbiamo ad esempio 5 numeri in decina dovrà sparpagliarli.
Dopo aver stilato il cruciverba immette sotto i numeri estrapolati dalle varie righe, colonne e 2 diagonali.

In piu devo aver l'opportunità di inserire a mia facoltà una combinazione vincente da 5 a 20 numeri ed lo script quelli che trova nel cruciverba o nello sviluppo sotto riportato me li deve evidenziare.
Un controllo che deve fare lo script è che siano presenti tutti i numeri caso contrario non deve generare il cruciverba.

Si può fare???

 

[sorujoe]

Dimenticavo!
Il tutto NON deve essere random quindi se inputo un medesimo integrale in occasioni diverse lo sviluppo deve essere sempre uguale

 

[salvo50]

Ciao a Tutti.

Non ho la più pallida idea di come fare quello che chiedi, mi ricordo che un quadrato tipo tavola pitagorica l'avevo visto in uno script di Joe.

 

[sorujoe]

uno simile ma lontano da cio che mi serve è questo peraltro random
Option Explicit
Dim aNumUsati
Dim aColonne
Dim aNumScelti
Sub Main
Dim nLato
Dim r,c,k
Dim n
Dim s
Dim nTentativi
Dim bTrovato
Dim nScelti
Dim bUnaPresenzaSola
Const nMinLato = 2
Const nMaxLato = 12
Const nTentativiMax = 1000
bUnaPresenzaSola = False
nLato = Int(InputBox("Inserire la quantita di numeri per il lato del cruciverba","Lato Cruciverba",6))
If nLato < nMinLato Or nLato > nMaxLato Then
MsgBox "Il lato dve essere compreso tra " & nMinLato & " e " & nMaxLato
Exit Sub
End If
ReDim aNumScelti(0)
nScelti = ScegliNumeri(aNumScelti)
If nScelti >= nLato * nLato Then
bUnaPresenzaSola = True
End If
Call DoEventsEx
If nScelti <= nLato Then
MsgBox "Selezionare piu numeri",vbInformation
Exit Sub
End If
aNumUsati = ArrayNumeriToBool(aNumScelti)
ReDim aDiagonali(nLato,nLato)
Call CalcolaDiagonali(aDiagonali,nLato)
Do While bTrovato = False
ReDim aNumeri(nLato,nLato)
For r = 1 To nLato
For c = 1 To nLato
n = ScegliNumero(r,c,aNumeri,nLato,aDiagonali,bUnaPresenzaSola)
If n = 0 Then Exit For
aNumeri(r,c) = n
Next
If n = 0 Then Exit For
Next
If colonneDuplicate(aNumeri,nLato,aDiagonali) = False Then
bTrovato = True
Else
nTentativi = nTentativi + 1
If nTentativi > nTentativiMax Then Exit Do
End If
If ScriptInterrotto Then Exit Do
Call Messaggio("Cruciverba Generati " & nTentativi)
DoEventsEx
Loop
For r = 1 To nLato
ReDim aV(nLato)
For c = 1 To nLato
aV(c) = Format2(Int(aNumeri(r,c)))
Next
If r = 1 Then
Call InitTabella(aV,,,6)
Else
Call AddRigaTabella(aV,,,6)
End If
Next
If nTentativi > nTentativiMax Or colonneDuplicate(aNumeri,nLato,aDiagonali) Then
Call Scrivi("ATTENZIONE CRUCIVERBA NON VALIDO",True,,,vbRed)
End If
Call Scrivi("Cruciverba " & nLato & "x" & nLato,True)
Call Scrivi
Call Scrivi("Si vince con le righe , le colonne e le diagonali")
Call CreaTabella
Call Scrivi
Call Scrivi("Colonne in gioco",True)
For k = 1 To UBound(aColonne)
Call Scrivi(FormatSpace(k,5,True) & ") " & aColonne(k))
Next
Call Scrivi
Call Scrivi("Numeri usati",True)
Call Scrivi(SpezzaStringaNumeri(GetNumRealmenteUsati(aNumeri,nLato)),,True)
Call Scrivi
Call ScriviTabellaFreq(aNumeri,nLato)
End Sub
Sub CalcolaDiagonali(aDiagonali,nLato)
Dim r,c
For r = 1 To nLato
c = c + 1
aDiagonali(r,c) = True
Next
c = nLato + 1
For r = 1 To nLato
c = c - 1
If aDiagonali(r,c) Then
aDiagonali(r,c) = 1
Else
aDiagonali(r,c) = True
End If
Next
End Sub
Function ScegliNumero(Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
Dim n
Dim nPassaggi
Do
n = aNumScelti(NumeroCasuale(1,UBound(aNumScelti)))
nPassaggi = nPassaggi + 1
If nPassaggi > 1000 Then
n = 0
Exit Do
End If
If ScriptInterrotto Then
n = 0
Exit Do
End If
Call DoEventsEx
Loop While NumeroNonValido(n,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
ScegliNumero = n
End Function
Function NumeroNonValido(Numero,Riga,Colonna,aNumeri,nLato,aDiagonali,bUnaVoltaSola)
Dim k,r,c
If Numero = 0 Then
NumeroNonValido = True
Exit Function
End If
If bUnaVoltaSola Then
For r = 1 To nLato
For c = 1 To nLato
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
Next
End If
If aNumUsati(Numero) = False Then
NumeroNonValido = True
Exit Function
End If
For k = 1 To nLato
If aNumeri(Riga,k) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
For k = 1 To nLato
If aNumeri(k,Colonna) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
If aDiagonali(Riga,Colonna) Then
'If Riga = Colonna Or ((Riga = nLato/2)And (Colonna = nLato/2)) Then
If Riga = Colonna Then
c = Colonna + 1
For r = Riga To 1 Step - 1
c = c - 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
c = Colonna - 1
For r = Riga + 1 To nLato
c = c + 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
End If
If Riga <> Colonna Or aDiagonali(Riga,Colonna) = 1 Then
c = Colonna - 1
For r = Riga To 1 Step - 1
c = c + 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
c = Colonna + 1
For r = Riga + 1 To nLato
c = c - 1
If aNumeri(r,c) = Numero Then
NumeroNonValido = True
Exit Function
End If
Next
End If
End If
End Function
Function colonneDuplicate(aNumeri,nLato,aDiagonali)
Dim nColonneTot
Dim r,c,i
Dim k,kk
nColonneTot = nLato * 2 + 2
ReDim aColonne(nColonneTot)
For r = 1 To nLato
ReDim aN(nLato)
For c = 1 To nLato
aN(c) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
Next
For c = 1 To nLato
ReDim aN(nLato)
For r = 1 To nLato
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
Next
ReDim aN(nLato)
c = 0
For r = 1 To nLato
c = c + 1
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
ReDim aN(nLato)
c = nLato + 1
For r = 1 To nLato
c = c - 1
aN(r) = aNumeri(r,c)
Next
i = i + 1
Call OrdinaMatrice(aN,1,1)
aColonne(i) = StringaNumeri(aN,,True)
For k = 1 To nColonneTot - 1
For kk = k + 1 To nColonneTot
If aColonne(k) = aColonne(kk) Then
colonneDuplicate = True
Exit Function
End If
Next
Next
For k = 1 To nColonneTot
If Len(aColonne(k)) < nLato *2 +(nLato - 1) Then
colonneDuplicate = True
Exit Function
End If
Next
End Function
Function SpezzaStringaNumeri(sStringa)
Dim k
Dim s,i
ReDim aV(0)
Call SplitByChar(sStringa,".",aV)
s = ""
For k = 0 To UBound(aV)
i = i + 1
s = s & aV(k) & "."
If i Mod 20 = 0 Then
s = s & vbCrLf
End If
Next
SpezzaStringaNumeri = Left(s,Len(s) - 1)
End Function
Function GetNumRealmenteUsati(aNumeri,nLato)
Dim r,c,k
Dim s
ReDim aB(90)
For r = 1 To nLato
For c = 1 To nLato
aB(aNumeri(r,c)) = True
Next
Next
For k = 1 To 90
If aB(k) Then
s = s & Format2(k) & "."
End If
Next
If s <> "" Then
s = Left(s,Len(s) - 1)
End If
GetNumRealmenteUsati = s
End Function
Sub ScriviTabellaFreq(aNumeri,nLato)
Dim r,c,k
Dim s
Dim nNumeriPoss
nNumeriPoss = nLato * nLato
ReDim aN(90,2)
For r = 1 To 90
aN(r,1) = r
Next
For r = 1 To nLato
For c = 1 To nLato
aN(aNumeri(r,c),2) = aN(aNumeri(r,c),2) + 1
Next
Next
Call OrdinaMatrice(aN,- 1,2)
ReDim aT(3)
aT(1) = "Numero"
aT(2) = "Presenze"
aT(3) = " % "
Call InitTabella(aT)
For k = 1 To 90
If aN(k,2) > 0 Then
ReDim aV(3)
aV(1) = aN(k,1)
aV(2) = aN(k,2)
aV(3) = Round((aN(k,2)*100)/nNumeriPoss,3) & " %"
Call AddRigaTabella(aV)
End If
Next
Call Scrivi("Presenze numeri in gioco nel cruciverba")
Call CreaTabella
End Sub

 

[salvo50]

Gli script che faccio io sono lontani anni luce da questo.

 

[sorujoe]

Ahahahahah per me sei comunque un GRANDE