Retos por MMR - Mejorado - 1vs1 hasta lo que quieras.

Ir abajo

Retos por MMR - Mejorado - 1vs1 hasta lo que quieras.

Mensaje por Toyz el 30/11/2016, 9:56 pm

Miren este aporte para que entiendan qué es.

APORTE: http://www.servers-argentum.org/t35850-nuevo-sistema-de-retos-13-0

Mejoras a comparación del antiguo aporte:

*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.
*Ahora funciona para cualquier tipo de reto.

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
avatar
Toyz
Administrador
Administrador

¿BANEADO? : No.
Premios :
[1er puesto] Usuario del año 2016
Cantidad de envíos : 5046
Edad : 17
Localización : Global.
Fecha de inscripción : 28/09/2014

Ver perfil de usuario

Volver arriba Ir abajo

Re: Retos por MMR - Mejorado - 1vs1 hasta lo que quieras.

Mensaje por Santiago216 el 1/12/2016, 2:47 am

Buen aporte !

Santiago216
Nivel 2
Nivel 2

¿BANEADO? : No.
Premios : Ninguno.
Cantidad de envíos : 36
Localización : En La Compu
Fecha de inscripción : 13/04/2016

Ver perfil de usuario

Volver arriba Ir abajo

Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.