Option Explicit
Public PCou As Long 'Propriété: Position courante du dernier numéro rendu par Suivant
Private Joueur() As Long, PMax As Long
Private Posit() As Long, JMax As Long
Public Sub Init(ByVal Nombre As Long)
Rem. Méthode. Initialise l'objet aux numéros allant de 1 au Nombre spécifié.
' Il vous appartient en principe d'exécuter une instruction Randomize auparavant.
' La méthode ne l'assume pas, afin que vous en gardiez la maitrise. Exemple :
' MaGraine = Date Mod 7 + Time: Rnd -1: Randomize MaGraine
Dim P As Long
ReDim Joueur(1 To Nombre): For P = 1 To Nombre: Joueur(P) = P: Next P
PMax = Nombre: Désordre
End Sub
Public Sub Désordre()
Rem. Méthode. Re-change aléatoirement l'ordre des numéros. Init le fait déjà une 1ère fois.
Dim P As Long, R As Long, J As Long
For P = PMax To 2 Step -1
R = Int(Rnd * P) + 1: J = Joueur(R): Joueur(R) = Joueur(P): Joueur(P) = J
Next P
RectifierPositions
End Sub
Public Function Aléat(Optional ByVal P As Long = 1) As Long
Rem. Méthode. Renvoie un numéro au hasard.
' P: Position dans la liste du numéro souhaité.
' Facultatif: 1 assumé ce qui qui correspond à celui de tête de liste.
' Renvoie 0 si P est supérieur au nombre de numéros portés dans l'objet.
If P > PMax Then Aléat = 0 Else Aléat = Joueur(P)
End Function
Public Sub Supprimer(ByVal J As Long)
Rem. Méthode. S'il y figure encore, supprime de l'objet le numéro J spécifié.
' S'il s'agit du numéro juste rendu précédemment par Suivant,
' la position courante du prochain à rendre sera reprise.
' À sa position, ce numéro sera remplacé par celui figurant en fin de liste.
Dim P As Long
P = Posit(J): If P = 0 Then Exit Sub
Posit(J) = 0
If P < PMax Then J = Joueur(PMax): Joueur(P) = J: Posit(J) = P
Joueur(PMax) = 0: PMax = PMax - 1
If PCou = P Then PCou = P - 1
End Sub
Public Sub Remettre(ByVal J As Long, Optional ByVal P As Long = &H7FFFFFFF)
Rem. Méthode. Replace le numéro J à la position P (Maxi + 1 assumé si non spécifié)
' Si P est supérieur au nombre de numéros portés, il est rectifié à ce nombre + 1.
' Si le numéro J exite déja à une autre position, il est échangé avec celui en P.
' Sinon le numéro figurant préalablement à la position P est chassé en fin de liste.
' Ceci a pour conséquence de remettre l'objet dans le même état que si J figurait
' à la position P quand il a été rendu par Aléat avant d'être supprimé.
Dim Q As Long, A As Long
Q = Posit(J): If P < 1 Then P = 1
If Q = 0 Then PMax = PMax + 1
If P > PMax Then P = PMax
If Q = P Then Exit Sub
If Q = 0 And P < PMax Then Q = PMax
If Q > 0 Then A = Joueur(P): Joueur(Q) = A: Posit(A) = Q
Joueur(P) = J: Posit(J) = P
End Sub
Public Function Existe(ByVal J As Long) As Boolean
Rem. Méthode. Indique si le numéro J spécifié est encore porté dans l'objet.
Existe = Posit(J) > 0
End Function
Public Function Pos(ByVal J As Long) As Long
Rem. Méthode. Renvoie la position dans l'objet à laquelle est porté le numéro J spécifié.
Pos = Posit(J)
End Function
Public Function Count()
Rem. Propriété en lecture seule. Renvoie le nombre de numéros disponibles.
Count = PMax
End Function
Public Function Suivant() As Long
Rem. Méthode. Renvoie un numéro au hasard mais avec la possibilité d'en demander un autre par la
' suite s'il ne convient pas. Renvoie 0 si plus aucun numéro n'est disponible.
' La séquence des numéros successivement rendus est abandonnée par l'emploi de l'une
' des méthodes RàZSuc, ClonéDe, Init ainsi que lors d'une affectation à Table et par
' la méthode Supprimer pour un numéro que cette méthode Suivant a rendu antérieurement
' à son invocation la plus récente. Sans numéro indiqué, Supprimer n'en perd donc pas
' le fil, ni jamais la méthodes Existe, ni la propriété Table utilisée en lecture.
If PCou < PMax Then PCou = PCou + 1: Suivant = Joueur(PCou) Else Suivant = 0
End Function
Public Property Let Table(TJ() As Long)
Rem. Propriété en lecture/écriture. Table des numéros contenus dans l'objet.
' Attention: Sa dimension n'est pas ajustée au nombre de numéros qu'elle porte
' mais au numéro le plus grand qu'elle pourrait porter. Elle se termine donc par
' des 0 à la fin s'ils n'y figurent plus tous.
Joueur = TJ: RectifierPositions
End Property
Public Property Get Table() As Long()
Table = Joueur
End Property
Function PartieClassée(Optional ByVal Nombre As Long) As Long()
Rem. Méthode. Renvoie un tableau de numéros en ordre croissant (genre tirage Loto)
' Nombre: Le nombre maximum de numéros souhaités. Facultatif. Si omis, le
' nombre de numéros figurant encore dans l'objet est assumé.
ExtraireClassés PartieClassée, Nombre
End Function
Public Sub ExtraireClassés(T() As Long, Optional ByVal Nombre As Long)
Rem. Méthode. fabrique un tableau des numéros en ordre croissant (genre tirage Loto).
' Nombre: Le nombre maximum de numéros souhaités. Facultatif. Si omis, ou trop
' grand, le nombre de numéros figurant encore dans l'objet est assumé.
Dim J As Long, P As Long, N As Long
If Nombre <= 0 Then Nombre = PMax
ReDim T(1 To Nombre)
For J = 1 To JMax
P = Posit(J): If P > 0 And P <= Nombre Then N = N + 1: T(N) = J
Next J
End Sub
Rem. N'hésitez pas à utiliser de nombreux tableaux d'objets de type ListeAléat.
' Il en faut au moins déja un par manche: le ListAléat des joueurs restant à apparier
Rem. Procédure à usage interne
Private Sub RectifierPositions()
Dim P As Long, J As Long
JMax = UBound(Joueur)
ReDim Posit(1 To JMax)
PMax = 0
For P = 1 To JMax: J = Joueur(P): If J = 0 Then Exit For
Posit(J) = P: PMax = P: Next P
PCou = 0
End Sub
