[Aporte] Nuevo sistema de retos: Búsqueda de retos, emparejamiento vía MMR. [BASE]

G

G Toyz

Invitado
Buenas, este sistema consiste en buscar retos en base al MMR del usuario si ambos usuarios que buscan un reto tienen un parentesco en el MMR los manda a reto. A medida de que pasa el tiempo agranda ese "parentesco" para buscar más usuarios hasta que llega a un límite. El ganador gana un poco de MMR. El MMR es un número que especifica la habilidad de un usuario.

Esto es una base, le faltan detalles pero lo principal (Sistema de búsqueda, sistema de emparejamiento, mandarlos a arenas, definir ganador y perdedor, darles MMR, etc) está hecho, más que nada tienen que hacer unas condicionales cuando muere el usuario, más algunas llamadas y paquetes (los paquetes son super fáciles)

Testeé al 100% el sistema de emparejamiento y búsqueda. El sistema de retos (con rounds, etc) no está testeado al 100%, agradezco al que compruebe que ande bien. Igual, dudo que tenga errores.

Reutilicé código del aporte de Santo. http://www.gs-zone.org/temas/retos-1vs1-2-rounds-cr-items-y-oro-6-arenas.95341/

Cualquier duda o problema que presente el sistema, avisar.

Pronto haré el 2vs2, aunque mucho no cambia :D

Módulo:

Código:
Option Explicit

'@@ Autor: G Toyz
'@@ Fecha: 04/10
'@@ Creación: 22:23

Private Const Max_Search       As Byte = 20 '@@ Máximo de usuarios buscando.
Private Const refError         As String = "No cumples los requisitos"
Private Const MAX_ARENAS As Byte = 10

Private Type uRetos
    ID              As Integer
    Rounds          As Byte
    Pos             As WorldPos
    X               As Byte
    Y               As Byte
End Type

Private Type Retos
    Players(1 To 2) As uRetos
    MAP_Arena       As Byte
    Count           As Byte
    Occupied        As Boolean
End Type

Private Type User_Searching
    ID                         As Integer   '@@ ID del usuario.
    Time_Searching             As Integer   '@@ Tiempo buscando.
    MMR_Rank                   As Integer   '@@ Rango de MMR.
End Type

Private Type Searching
    Searching(1 To Max_Search) As User_Searching
    Users_Searching            As Byte      '@@ Usuarios buscando.
End Type
Private Retos_Searching        As Searching
Private Retos(1 To MAX_ARENAS) As Retos
'_

Public Sub Search(ByVal ID As Integer)

    '@@ Lo ponemos en búsqueda de reto.
    '@@ Llamadas: Nuevo paquete.

    If Can_Search(ID) = False Then Exit Sub

    With Retos_Searching
    
        .Users_Searching = .Users_Searching + 1
        .Searching(.Users_Searching).ID = ID
        .Searching(.Users_Searching).MMR_Rank = 100
        .Searching(.Users_Searching).Time_Searching = 0
        UserList(ID).flags.ArraySearching = .Users_Searching
        Call WriteConsoleMsg(ID, "Buscando reto...", FontTypeNames.FONTTYPE_INFOBOLD)
        Call Matching(ID)
    End With

End Sub
Private Sub Matching(ByVal ID As Integer)

    '@@ Tratamos de emparejar.

    Dim LoopC As Long

    With Retos_Searching
    
        For LoopC = 1 To Max_Search
            If Compare_MMR(.Searching(LoopC).ID, ID) = True Then
                If .Searching(LoopC).ID = ID Then Exit Sub
                    Call GO_Arena(.Searching(LoopC).ID, ID)
                    Call Cancel_Search(.Searching(LoopC).ID, False)
                    Call Cancel_Search(ID, False)
                    Call WriteConsoleMsg(ID, "Has encontrado un rival!", FontTypeNames.FONTTYPE_INFOBOLD)
                    Call WriteConsoleMsg(.Searching(LoopC).ID, "Has encontrado un rival!", FontTypeNames.FONTTYPE_INFOBOLD)
                Exit For
            End If
        Next LoopC
    End With

End Sub
Private Function Compare_MMR(ByVal Searcher_Old As Integer, ByVal Searcher_New As Integer) As Boolean

    '@@ Comparamos MMR.

    Compare_MMR = False

        If UserList(Searcher_Old).Stats.MMR > UserList(Searcher_New).Stats.MMR + Retos_Searching.Searching(UserList(Searcher_New).flags.ArraySearching).MMR_Rank Then Exit Function
        If UserList(Searcher_Old).Stats.MMR < UserList(Searcher_New).Stats.MMR - Retos_Searching.Searching(UserList(Searcher_New).flags.ArraySearching).MMR_Rank Then Exit Function

    Compare_MMR = True

End Function

Public Sub Cancel_Search(ByVal ID As Integer, Optional ByVal No_Message As Boolean)

    '@@ Cancela la búsqueda de un usuario, también sirve para cuando se desconecta _
        y para cuando entra a un reto.

    '@@ Llamadas: _
        CloseSocket _
        Nuevo paquete

    Dim LoopC As Long

    With Retos_Searching
        For LoopC = UserList(ID).flags.ArraySearching To .Users_Searching - 1
            .Searching(LoopC).ID = .Searching(LoopC + 1).ID
        Next LoopC
            .Searching(.Users_Searching).ID = 0
            UserList(ID).flags.ArraySearching = 0
            .Users_Searching = .Users_Searching - 1
            If No_Message = False Then _
            WriteConsoleMsg ID, "Has cancelado la búsqueda", FontTypeNames.FONTTYPE_INFOBOLD
    End With

End Sub

Private Function Can_Search(ByVal ID As Integer) As Boolean

   '@@ ¿Puede buscar retos?

    Can_Search = False

    With UserList(ID)

        If .flags.ArraySearching > 0 Then
            Call WriteConsoleMsg(ID, refError, FontTypeNames.FONTTYPE_INFOBOLD)
            Exit Function
        End If
    
        If .flags.Muerto Then
            Call WriteConsoleMsg(ID, refError, FontTypeNames.FONTTYPE_INFOBOLD)
            Exit Function
        End If

        If Retos_Searching.Users_Searching = 20 Then
            Call WriteConsoleMsg(ID, "Búsqueda de retos llena", FontTypeNames.FONTTYPE_INFOBOLD)
            Exit Function
        End If
    
        If There_Arena() = 0 Then
            Call WriteConsoleMsg(ID, "En estos momentos no se puede buscar retos, espere unos momentos", FontTypeNames.FONTTYPE_INFOBOLD)
            Exit Function
        End If

    End With

    Can_Search = True

End Function

Private Sub Extend_MMR_Rank(ByVal ID As Integer)

    '@@ Extendemos el rango de su MMR a medida que pasa el tiempo buscando.

    With Retos_Searching
        If .Searching(ID).Time_Searching Mod 10 = 0 Then
            .Searching(ID).MMR_Rank = .Searching(ID).MMR_Rank + 10
            Call Matching(ID)
        End If
    End With

End Sub

Public Sub Extend_MMR_Rank_Time(ByVal ID As Integer)

    '@@ El tiempo que lleva buscando un reto...
    '@@ Llamadas: Timer de 1 segundo.

    With Retos_Searching
        If UserList(ID).flags.ArraySearching > 0 Then
            If There_Arena() = 0 Then Exit Sub
            .Searching(UserList(ID).flags.ArraySearching).Time_Searching = .Searching(UserList(ID).flags.ArraySearching).Time_Searching + 1
            If .Searching(UserList(ID).flags.ArraySearching).MMR_Rank = 200 Then Exit Sub
            Call Extend_MMR_Rank(ID)
        End If
    End With

End Sub

Private Sub Start_Arenas(ByVal N_Arena As Integer, _
                         ByVal MAP_Arena As Byte, _
                         ByVal Player1_X As Byte, _
                         ByVal Player1_Y As Byte, _
                         ByVal Player2_X As Byte, _
                         ByVal Player2_Y As Byte)

    With Retos(N_Arena)
        .MAP_Arena = MAP_Arena
        .Players(1).X = Player1_X
        .Players(1).Y = Player1_Y
        .Players(2).X = Player2_X
        .Players(2).Y = Player2_Y
    End With

End Sub

Public Sub Load_Arenas()

    '@@ Pongan sus mapas y coordenadas.
    '@@ Llamadas: Main.

    Call Start_Arenas(1, 1, 50, 50, 70, 70)
    Call Start_Arenas(2, 1, 50, 50, 70, 70)
    Call Start_Arenas(3, 1, 50, 50, 70, 70)
    Call Start_Arenas(4, 1, 50, 50, 70, 70)
    Call Start_Arenas(5, 1, 50, 50, 70, 70)
    Call Start_Arenas(6, 1, 50, 50, 70, 70)
    Call Start_Arenas(7, 1, 50, 50, 70, 70)
    Call Start_Arenas(8, 1, 50, 50, 70, 70)
    Call Start_Arenas(9, 1, 50, 50, 70, 70)
    Call Start_Arenas(10, 1, 50, 50, 70, 70)

End Sub

Private Sub GO_Arena(ByVal Player1_ID As Integer, ByVal Player2_ID As Integer)

    '@@ Los llevamos al área de batalla.

    Dim Arena As Byte

    Arena = There_Arena()

    With Retos(Arena)

        .Players(1).ID = Player1_ID
        .Players(2).ID = Player2_ID
    
        .Occupied = True
    
        UserList(.Players(1).ID).flags.Arena = Arena
        UserList(.Players(2).ID).flags.Arena = Arena
    
        UserList(Player1_ID).flags.Reto = 1
        UserList(Player2_ID).flags.Reto = 1
    
        .Players(1).Pos = UserList(.Players(1).ID).Pos
        .Players(2).Pos = UserList(.Players(2).ID).Pos
    
        Call WarpUserChar(.Players(1).ID, .MAP_Arena, .Players(1).X, .Players(1).Y, False)
        Call WarpUserChar(.Players(2).ID, .MAP_Arena, .Players(2).X, .Players(2).Y, False)
    
        Call WritePauseToggle(.Players(1).ID)
        Call WritePauseToggle(.Players(2).ID)

    End With

End Sub

Public Sub Count()

    Dim LoopC As Long

    For LoopC = 1 To MAX_ARENAS
        With Retos(LoopC)
    
            If .Count = 0 Then
                .Count = -1
                If .Players(1).ID > 0 Then
                    Call WriteConsoleMsg(.Players(1).ID, "Reto> YA", FontTypeNames.FONTTYPE_INFOBOLD)
                    Call WritePauseToggle(.Players(1).ID)
                End If
                If .Players(2).ID > 0 Then
                    Call WriteConsoleMsg(.Players(2).ID, "Reto> YA", FontTypeNames.FONTTYPE_INFOBOLD)
                    Call WritePauseToggle(.Players(2).ID)
                End If
            End If
        
            If .Count >= 1 Then
                If .Players(1).ID > 0 Then
                    Call WriteConsoleMsg(.Players(1).ID, "Reto> " & .Count, FontTypeNames.FONTTYPE_INFOBOLD)
                End If
                If .Players(2).ID > 0 Then
                   Call WriteConsoleMsg(.Players(2).ID, "Reto> " & .Count, FontTypeNames.FONTTYPE_INFOBOLD)
                End If
                .Count = .Count - 1
            End If
        
        End With
    Next LoopC

End Sub

Public Sub Death(ByVal ID As Integer)

    Dim Not_Death As Byte

    With Retos(UserList(ID).flags.Arena)
        If UserList(ID).flags.Arena = 0 Then Exit Sub
    
        Call RevivirUsuario(ID)

        With UserList(ID)
            .Stats.MinHp = .Stats.MaxHp
            .Stats.MinMAN = .Stats.MaxMAN
            Call WriteUpdateUserStats(ID)
        End With

        If .Players(1).ID = ID Then Not_Death = 2 Else Not_Death = 1
        .Players(Not_Death).Rounds = .Players(Not_Death).Rounds + 1
    
        If .Players(Not_Death).Rounds = 2 Then
            Call Finish(Not_Death, ID)
        Else
            Call WarpUserChar(.Players(1).ID, .MAP_Arena, .Players(1).X, .Players(1).Y, False)
            Call WarpUserChar(.Players(2).ID, .MAP_Arena, .Players(2).X, .Players(2).Y, False)
            Call WritePauseToggle(.Players(1).ID)
            Call WritePauseToggle(.Players(2).ID)
            .Count = 10
        End If
    End With

End Sub

Public Sub Finish(ByVal ID_Winner As Integer, ByVal ID_Loser As Integer)

    With Retos(UserList(ID_Winner).flags.Arena)

        Call WarpUserChar(.Players(1).ID, .Players(1).Pos.Map, .Players(1).Pos.X, .Players(1).Pos.Y, True)
        Call WarpUserChar(.Players(2).ID, .Players(2).Pos.Map, .Players(2).Pos.X, .Players(2).Pos.Y, True)

        Call WriteConsoleMsg(ID_Winner, "Has ganado el reto, felicidades!", FontTypeNames.FONTTYPE_INFOBOLD)
        Call WriteConsoleMsg(ID_Loser, "Has perdido el reto, siga practicando!", FontTypeNames.FONTTYPE_INFOBOLD)

        With UserList(ID_Winner)
            .Stats.MMR = .Stats.MMR + 50
            .flags.Arena = 0
            .flags.Reto = 0
            .flags.Paralizado = 0
        End With

        With UserList(ID_Loser)
            .Stats.MMR = .Stats.MMR - 50
            .flags.Arena = 0
            .flags.Reto = 0
            .flags.Paralizado = 0
        End With
    
    
        .Occupied = False
    
        .Players(1).ID = 0
        .Players(2).ID = 0
    
        .Players(1).Rounds = 0
        .Players(2).Rounds = 0
    
    End With
End Sub

Private Function There_Arena() As Byte

    Dim LoopC As Long

    For LoopC = 1 To MAX_ARENAS
        If Retos(LoopC).Occupied = False Then
            There_Arena = LoopC
            Exit Function
        End If
    Next LoopC
    There_Arena = 0

End Function
 
Última edición por un moderador:

El_santo43

High as fuck
Ex-Staff
Muy linda la idea, bien que hayas empezado a programar sistemas mas complejos y extensos. Felicitaciones.
 

Dhornek

Youtuber
Esto funcionaría como el Lol? que capaz tenes 100 partidas ganadas y si la busqueda tarda mucho te empareja con gente de win rate mas alto?
 

CUICUI

Oráculo Lvl 4
Está buena la idea, recuerdo que habías hablado de esta wea hace bastante si no me equivoco. Me explicas para qué usarías el .Emergency?

Esto funcionaría como el Lol? que capaz tenes 100 partidas ganadas y si la busqueda tarda mucho te empareja con gente de win rate mas alto?
Supongo que no porque por cada segundo, o mejor dicho cada 10 segundos que estás buscando un match, el sistema te está subiendo 10MMR.

Pero qué pasa si:
*Yo=mmr 1000
*Otro=mmr 300
Y ambos estamos en búsqueda de un match?
 

MAB

Destructor Lvl 2
Está buena la idea, recuerdo que habías hablado de esta wea hace bastante si no me equivoco. Me explicas para qué usarías el .Emergency?



Supongo que no porque por cada segundo, o mejor dicho cada 10 segundos que estás buscando un match, el sistema te está subiendo 10MMR.

Pero qué pasa si:
*Yo=mmr 1000
*Otro=mmr 300
Y ambos estamos en búsqueda de un match?
Nada porque sos muy pro para emparejarte con mmr menor.
 
G

G Toyz

Invitado
El Emergency es para que no busquen retos cuando no hay arenas y para dejar extender el rango de mmr hasta que, obviamente, se libere una arena.

Esto funcionaría como el Lol? que capaz tenes 100 partidas ganadas y si la busqueda tarda mucho te empareja con gente de win rate mas alto?
Así es, pero tiene límite.

En el LoL si sos bronce te emparejan al toque, si sos challenger te tarda unos minutos.

Igual lo pueden poner a su gusto, recuerden que esto es una base y di la forma básica (sin cálculos ni nada) de subir el mmr. La idea (como dije antes) es cada cierto tiempo reseteen el mmr y den premios :p
 

MAB

Destructor Lvl 2
Asumo que para balancear el sistema lo que pueden hacer es establecer un límite (como el LoL mismo) donde llegado a un punto el mmr tiene un máximo, cosa de evitar que seas el único boludo buscando partida porque tu mmr subió tanto que nadie te alcanza.
 

Fhkek

Siempre hay una solución.
Hola, perdón por mi ignorancia no supe entender esta parte 'User_Searching', ¿a qué va? Sí vos mandas un reto normalmente se supone que el otro puede aceptar independientemente. ¿No?
 
G

G Toyz

Invitado
Esto no es un sistema para mandar/aceptar retos (aunque tranquilamente se le puede hacer un apartado y es muy fácil).

User_Searching son los datos de los usuarios que están buscando un reto.
 
G

G Toyz

Invitado
Chicos, me tomé el tiempo de rediseñarlo: (Ahora se puede con cualquier tipo de reto!)
EDIT: No viene con el sistema de retos incluido, tienen que utilizar sus sistemas de retos. Es simple, sólo tienen que hacer que se aumente el MMR y que los lleve a la arena.
EDIT2: Tiene algunas mejoras como:

*Se puede cancelar la búsqueda.
*Se puede invitar a compañeros. Los compañeros deben aceptar.
*Se tiene que aceptar cuando se genera un emparejamiento.
*Se puede rechazar el emparejamiento.
*Todos deben aceptar el emparejamiento

Código:
Option Explicit

'@@ Autor: G Toyz
'@@ Fecha: 04/10
'@@ Creación: 22:23
'@@ Modificación: 28/10 - 10:21 PM _
    Agrego para que se puedan buscar otros tipos de retos.

Private Const Gold                        As Long = 100000 '@@ Cantidad de oro que sale cada reto.
Private Const Max_Search                  As Byte = 30 '@@ Máximo de equipos buscando.
Private Const refError                    As String = "No cumples los requisitos"
Private Const Count_Retos                 As Byte = 3  '@@ Cantidad de retos que haya _
                                                        en el servidor, 1vs1, 2vs2, 3vs3 = 3
Private Type Team_Searching
    Users()                               As Integer  '@@ Usuarios en el equipo.
    Time_Searching                        As Integer  '@@ Tiempo que llevan buscando.
    MMR_Rank                              As Integer  '@@ Rango de MMR para emparejar.
    MMR                                   As Integer  '@@ MMR del equipo (promedio).
    Accepting                             As Boolean  '@@ ¿Están aceptando un emparejamiento?
    Accepts                               As Byte     '@@ ¿Cuántos aceptaron ese emparejamiento?
    Team_ID_Accept                        As Byte     '@@ ¿Contra quién los emparejó?
End Type

Private Type Searching
    Searching(1 To Max_Search)            As Team_Searching '@@ Equipos buscando.
    Teams_Searching                       As Byte           '@@ Cantidad de equipos buscando.
End Type

Private Retos_Searching(1 To Count_Retos) As Searching '@@ ¿Qué tipo de retos quiere buscar?
'_

Public Sub Load()

    '@@ Redimensiono los arrays de Usuarios.

    Dim LoopC As Long
    Dim loopX As Long

    For LoopC = 1 To Count_Retos
        For loopX = 1 To Max_Search
            ReDim Retos_Searching(LoopC).Searching(loopX).Users(1 To LoopC)
        Next loopX
    Next LoopC

End Sub

Public Sub Send_Search(ByRef ID() As Integer, ByVal n_Reto As Byte)

    If Can_Search(ID(), True) = False Then Exit Sub

    Dim LoopC As Long
    Dim loopX As Long
    Dim Names As String

    UserList(ID(1)).Search_Retos.Send = True
    UserList(ID(1)).Search_Retos.Type_Reto = n_Reto
    UserList(ID(1)).Search_Retos.Amount_Accept = 1
    UserList(ID(1)).Search_Retos.Accept = True
    ReDim UserList(ID(1)).Search_Retos.Send_IDS(1 To n_Reto)

    For LoopC = 1 To n_Reto
        UserList(ID(1)).Search_Retos.Send_IDS(LoopC) = ID(LoopC)
        If Names = "" Then
            Names = UserList(ID(LoopC)).name
        Else
            Names = Names & ", " & UserList(ID(LoopC)).name
        End If
    Next LoopC

    If n_Reto = 1 Then
        Call Search(ID(), n_Reto)
        Exit Sub
    End If

    For loopX = 1 To n_Reto
        Call WriteConsoleMsg(ID(loopX), "El usuario " & UserList(ID(1)).name & " los ha invitado a participar en las clasificatorias del reto " & n_Reto & " vs " & n_Reto & " con los usuarios [" & Names & "]. Ponga /ACEPTAR " & UserList(ID(1)).name & " para aceptar la invitación.", FontTypeNames.FONTTYPE_INFOBOLD)
    Next loopX

End Sub

Public Sub Accept_Search(ByVal ID As Integer, ByVal ID_Send As Integer)

    Dim LoopC As Long
    Dim NoYes As Boolean

    If ID_Send = 0 Then Exit Sub

    NoYes = False
    For LoopC = 1 To UserList(ID_Send).Search_Retos.Type_Reto
        If UserList(ID_Send).Search_Retos.Send_IDS(LoopC) = ID Then _
            NoYes = True
    Next LoopC

    If NoYes = False Then _
        Call WriteConsoleMsg(ID, "El usuario " & UserList(ID_Send).name & " no te ha invitado a ninguna clasificatoria.", FontTypeNames.FONTTYPE_INFOBOLD)

    If UserList(ID).Search_Retos.Accept = True Then _
        Call WriteConsoleMsg(ID, "Ya has aceptado una invitación.", FontTypeNames.FONTTYPE_INFOBOLD)

    UserList(ID).Search_Retos.Accept = True
    UserList(ID_Send).Search_Retos.Amount_Accept = UserList(ID_Send).Search_Retos.Amount_Accept + 1

    If UserList(ID_Send).Search_Retos.Amount_Accept = UserList(ID_Send).Search_Retos.Type_Reto Then _
        Call Search(UserList(ID_Send).Search_Retos.Send_IDS(), UserList(ID_Send).Search_Retos.Type_Reto)

End Sub

Public Sub Send_Matching(ByVal Team1 As Byte, ByVal Team2 As Byte, ByVal n_Reto As Byte)

    '@@ Hacer un paquete (Write_Send_Matching) que obligue aceptar el reto al usuario.

    Dim LoopC As Long

    With Retos_Searching(n_Reto)
        For LoopC = 1 To n_Reto
            Call WriteSend_Accept_Matching(.Searching(Team1).Users(LoopC))
            Call WriteSend_Accept_Matching(.Searching(Team2).Users(LoopC))
            Userlist(.Searching(Team1).Users(LoopC)).Search_Retos.Accepting = True
            Userlist(.Searching(Team2).Users(LoopC)).Search_Retos.Accepting = True
        Next LoopC
        .Searching(Team1).Accepting = True
        .Searching(Team2).Accepting = True
        .Searching(Team1).Accepts = 0
        .Searching(Team2).Accepts = 0
    End With

End Sub

Public Sub Accept_Matching(ByVal ID As Integer)

    If UserList(ID).Search_Retos.Type_Reto = 0 Then Exit Sub

    With Retos_Searching(UserList(ID).Search_Retos.Type_Reto)
        If .Searching(UserList(ID).Search_Retos.Team).Accepting = True Then
            .Searching(UserList(ID).Search_Retos.Team).Accepts = .Searching(UserList(ID).Search_Retos.Team).Accepts + 1
            If .Searching(UserList(ID).Search_Retos.Team).Accepts = UserList(ID).Search_Retos.Type_Reto And .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Accepts = UserList(ID).Search_Retos.Type_Reto Then
                Call Test_Retos(UserList(ID).Search_Retos.Team, .Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept, UserList(ID).Search_Retos.Type_Reto)
            End If
        End If
    End With

End Sub

Private Sub Test_Retos(ByVal Team1 As Byte, ByVal Team2 As Byte, ByVal n_Retos As Byte)

    Dim LoopC As Long
    Dim loopX As Long

    With Retos_Searching(n_Retos)
        For LoopC = 1 To n_Retos
            Userlist((.Searching(Team1).Users(LoopC)).Search_Retos.Accepting = False
            Userlist((.Searching(Team2).Users(LoopC)).Search_Retos.Accepting = False
            Call WarpUserChar(.Searching(Team1).Users(LoopC), 1, 60, 50 + LoopC, False)
            Call WarpUserChar(.Searching(Team2).Users(LoopC), 1, 60, 55 + LoopC, False)
        Next LoopC
        Call Cancel_Search(.Searching(Team1).Users(1), True)
        Call Cancel_Search(.Searching(Team2).Users(1), True)
    End With

End Sub

Public Sub Refuse_Matching(ByVal ID As Integer)

    On Error GoTo Error_SearchRetos

    If UserList(ID).Search_Retos.Type_Reto = 0 Then Exit Sub

    Dim LoopC As Long

    With Retos_Searching(UserList(ID).Search_Retos.Type_Reto)
        If .Searching(UserList(ID).Search_Retos.Team).Accepting = True Then
            .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Accepting = False
            .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Accepts = 0
            .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Team_ID_Accept = 0
            .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Time_Searching = 0
            .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).MMR_Rank = 100 'Inicial.
            For LoopC = 1 To UserList(ID).Search_Retos.Type_Reto
                WriteConsoleMsg .Searching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept).Users(LoopC), "¡El otro equipo rechazó el encuentro! Has vuelto a la cola.", FontTypeNames.FONTTYPE_INFOBOLD
            Next LoopC
            Call Matching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept, UserList(ID).Search_Retos.Type_Reto)
            Call Cancel_Search(ID)
        End If
    End With

    Exit Sub

Error_SearchRetos:
    Call LogError("Error en Refuse_Matching (Cola de retos). Número " & Err.Number & " Descripción: " & Err.description)

End Sub

Private Sub Search(ByRef ID() As Integer, ByVal n_Reto As Byte)

    '@@ Lo ponemos en búsqueda de reto.

  '  If Can_Search(ID()) = False Then Exit Sub

    Dim LoopC As Long

    With Retos_Searching(n_Reto)
        .Teams_Searching = .Teams_Searching + 1
        For LoopC = 1 To n_Reto
            .Searching(.Teams_Searching).Users(LoopC) = ID(LoopC)
            UserList(ID(LoopC)).Search_Retos.Type_Reto = n_Reto
            UserList(ID(LoopC)).Search_Retos.Team = .Teams_Searching
            WriteConsoleMsg (ID(LoopC)), "Buscando reto...", FontTypeNames.FONTTYPE_INFOBOLD
        Next LoopC
        .Searching(.Teams_Searching).MMR_Rank = 100
        .Searching(.Teams_Searching).Time_Searching = 0
        .Searching(.Teams_Searching).MMR = MMR_Amount(ID())
        Call Matching(.Teams_Searching, n_Reto)
    End With

End Sub

Private Sub Matching(ByVal ID_Team As Byte, ByVal n_Reto As Byte)

    '@@ Tratamos de emparejar.

    Dim Team_LoopC As Long

    With Retos_Searching(n_Reto)
        For Team_LoopC = 1 To .Teams_Searching
            If Compare_MMR(ID_Team, Team_LoopC, n_Reto) = True Then
                If ID_Team = Team_LoopC Then Exit Sub
                If .Searching(Team_LoopC).Accepting = True Then Exit Sub
                .Searching(ID_Team).Team_ID_Accept = Team_LoopC
                .Searching(Team_LoopC).Team_ID_Accept = ID_Team
                Call Send_Matching(ID_Team, Team_LoopC, n_Reto)
                Exit For
            End If
        Next Team_LoopC
    End With

End Sub

Private Function Compare_MMR(ByVal Team_1 As Byte, ByVal Team_2 As Byte, ByVal n_Reto As Byte) As Boolean

    '@@ Comparamos MMR.

    Compare_MMR = False

    With Retos_Searching(n_Reto)

        If .Searching(Team_1).MMR > .Searching(Team_2).MMR + .Searching(Team_1).MMR_Rank Then _
            Exit Function
    
        If .Searching(Team_1).MMR < .Searching(Team_2).MMR - .Searching(Team_1).MMR_Rank Then _
            Exit Function

    End With

    Compare_MMR = True

End Function

Private Function MMR_Amount(ByRef Players() As Integer) As Integer

    MMR_Amount = 0

    Dim LoopC As Long
    Dim MMR As Integer

    For LoopC = 1 To UBound(Players())
        MMR = MMR + UserList(Players(LoopC)).Search_Retos.MMR
    Next LoopC
    
    MMR_Amount = (MMR / UBound(Players()))
    
End Function

Public Sub Cancel_Search(ByVal ID As Integer, Optional ByVal No_Message As Boolean)

    '@@ Cancela la búsqueda de un usuario, también sirve para cuando se desconecta _
        y para cuando entra a un reto.

    '@@ Llamadas: _
        CloseSocket _
        Nuevo paquete

    On Error GoTo Error_SearchRetos

    Dim LoopC As Long
    Dim loopX As Long

    With Retos_Searching(UserList(ID).Search_Retos.Type_Reto)
        .Searching(UserList(ID).Search_Retos.Team).MMR = 0
        .Searching(UserList(ID).Search_Retos.Team).MMR_Rank = 0
        .Searching(UserList(ID).Search_Retos.Team).Time_Searching = 0
      '  If .Searching(UserList(ID).Search_Retos.Team).Accepting Then _
             Call Matching(.Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept, UserList(ID).Search_Retos.Type_Reto)
        .Searching(UserList(ID).Search_Retos.Team).Accepting = False
        .Searching(UserList(ID).Search_Retos.Team).Accepts = 0
        .Searching(UserList(ID).Search_Retos.Team).Team_ID_Accept = 0
        For LoopC = 1 To UserList(ID).Search_Retos.Type_Reto
            If No_Message = False Then _
                WriteConsoleMsg .Searching(UserList(ID).Search_Retos.Team).Users(LoopC), "¡Se canceló la búsqueda por: " & UserList(ID).name & ".", FontTypeNames.FONTTYPE_INFOBOLD
            With UserList(.Searching(UserList(ID).Search_Retos.Team).Users(LoopC)).Search_Retos
                Retos_Searching(UserList(ID).Search_Retos.Type_Reto).Searching(UserList(ID).Search_Retos.Team).Users(LoopC) = 0
                If .Send = True Then
                    For loopX = 1 To UserList(ID).Search_Retos.Type_Reto
                        .Send_IDS(loopX) = 0
                    Next loopX
                    .Send = False
                End If
                .Team = 0
                .Type_Reto = 0
            End With
        Next LoopC
        .Teams_Searching = .Teams_Searching - 1
    End With

    Exit Sub

Error_SearchRetos:
    Call LogError("Error en Cancel_Search (Cola de retos). Número de error: " & Err.Number & " Descripción: " & Err.description)

End Sub

Private Function Can_Search(ByRef ID() As Integer, Optional ByVal Sender As Boolean) As Boolean

    Dim LoopC As Long

    Can_Search = False

    For LoopC = 1 To UBound(ID())
        With UserList(ID(LoopC))
    
            If .flags.Muerto Then
                Call WriteConsoleMsg(ID(1), "El usuario " & .name & " está muerto.", FontTypeNames.FONTTYPE_INFOBOLD)
                If Sender = False Then _
                    Call WriteConsoleMsg(ID(LoopC), "¡Estás muerto!", FontTypeNames.FONTTYPE_INFOBOLD)
                Exit Function
            End If
        
            If .Search_Retos.Team > 0 Then
                Call WriteConsoleMsg(ID(1), "El usuario " & .name & " ya está en reto.", FontTypeNames.FONTTYPE_INFOBOLD)
                If Sender = False Then _
                    Call WriteConsoleMsg(ID(LoopC), "¡No puedes aceptar un reto estando en uno!", FontTypeNames.FONTTYPE_INFOBOLD)
                Exit Function
            End If
  
        End With
    Next LoopC

    Can_Search = True

End Function
Public Sub Count()

    '@@ El tiempo que lleva buscando un reto...
    '@@ Llamadas: Timer de 1 segundo.
    '@@ Aviso: Saqué el paquete que se enviaba cada un segundo que mandaba al cliente _
               la cantidad de segundos que iba buscando, hacer en el cliente un timer _
               de un segundo y si se manda la búsqueda (o sea, si inicia) empezar a contar.

    Dim LoopC As Long
    Dim loopX As Long

    For LoopC = 1 To 3
        With Retos_Searching(LoopC)
            For loopX = 1 To Max_Search
                .Searching(loopX).Time_Searching = .Searching(loopX).Time_Searching + 1
                .Searching(loopX).MMR_Rank = .Searching(loopX).MMR_Rank + 1
                If .Searching(loopX).MMR_Rank = 200 Then Exit Sub
            Next loopX
        End With
    Next LoopC
End Sub
Código:
Public Type UserSearchReto
    Team As Byte ' Su equipo. (Array)
    Send_IDS() As Integer ' IDs de los que invitó.
    Send As Boolean ' ¿Mandó solicitud a otros usuarios para buscar retos?
    MMR As Integer  ' Cantidad de MMR.
    Type_Reto As Byte ' En qué reto está.
    Time_Accept As Integer ' Cantidad de tiempo que tienen para aceptar.
    Accept As Boolean   ' ¿Aceptó alguna invitación?
    Amount_Accept As Byte ' ¿Cuántos usuarios aceptaron la invitación?
    Accepting As Boolean ' ¿Está aceptando un emparejamiento?
End Type
 
Última edición por un moderador:

Dhornek

Youtuber
y con el mismo mmr se podría hacer un sistema de ranking o ligas (si, re vicio del lol el pibe) no?
 
G

G Toyz

Invitado
Justito tengo un sv (no es mio) pero tiene un sistema de duelos interesante, voy a testearlo con esto y a ver si se le puede sacar jugo
Cualquier ayuda que necesites al implementarlo, no dudes en venir a preguntarlo.

Testeado y funcional! (Acá una pequeña demostración)

 

CUICUI

Oráculo Lvl 4
Por qué todo por consola? Hacé un form chico y ancho que diga: Emparejamiento encontrado - aceptar - rechazar y listo jaja.
no te voy a mentir, no leí el código, no sé si pusiste que tenga unos 10 seg para aceptar :p
 
G

G Toyz

Invitado
Por qué todo por consola? Hacé un form chico y ancho que diga: Emparejamiento encontrado - aceptar - rechazar y listo jaja.
no te voy a mentir, no leí el código, no sé si pusiste que tenga unos 10 seg para aceptar :p
Jaja, así está en el video xD. Nop, no puse ese contador jajaja, es fácil igual, es hacer lo mismo que el efectoparalisis
 
Arriba