2votos

Torneo round-robin balanceado en Haskell

por josejuan hace 3 años

Si no se exige asegurar la solución óptima en tiempo razonable (de lo que desconozco si existe algoritmo) se pueden usar muchos algoritmos (ej. probabilísticos). Usando un simple backtracking y una heurística obvia se obtienen resultados decentes y runtimes aceptables (hasta 100 ~ 200 jugadores en tiempos razonables). En todo caso, es un algoritmo puramente intuitivo y a mi juicio muy muy feo (precisamente por ser intuitivo y no razonado).

Crear emparejamientos para una liga de una forma concreta.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
{-# LANGUAGE LambdaCase #-} 
import System.Environment 
import Control.Arrow 
import Control.Monad 
import Data.List 
import qualified Data.Map as Map 
import Text.Printf 
import Data.List.Split 
 
 
-- todas las formas de distribuir a los jugadores usando heurística 
todasPosibles :: Int -> [[(Int, Int)]] 
todasPosibles n = solve [((a, 0), (b, 0)) | a <- [1 .. n], b <- [a + 1 .. n]]   -- tomamos todas las parejas con espera inicial 0 
  where solve [] = return [] 
        solve xs = do 
          (((a, _), (b, _)), xs') <- holes $ sortBy heuristica xs               -- buscaremos soluciones ordenando por heurística 
          let inc (x, u) = if x == a || x == b then (x, 0) else (x, u + 1) 
          rs <- solve $ map (inc *** inc) xs'                                   -- incrementamos las otras parejas y seguimos 
          return ((a, b):rs) 
 
-- tomamos el par que más tiempo lleve esperando 
heuristica ((_,u0),(_,v0)) ((_,u1),(_,v1)) = 
  case max u1 v1 `compare` max u0 v0 of { EQ -> min u1 v1 `compare` min u0 v0; r  -> r } 
 
 
 
 
 
 
 
 
{- === análisis de la heurística ====================================================================== 
 
  Se definen tres funciones en el ejecutable: 
 
    roundrobintournament solve `n` 
 
      Que resuelve una distribución para un `n` (impar) dado 
 
    roundrobintournament evaluate-from-to `a` `b` 
 
      Que calcula lo buenas que son las primeras soluciones para n = a, a + 1 .. b 
 
    roundrobintournament inspect-groups `n` `size` 
 
      Que para un `n` fijo y agrupando las soluciones de `size` en `size` muestra el mejor, el peor y la media 
      de la calidad de las soluciones, ésto es para poder ver que las mejores soluciones están las primeras (lo 
      que no impide que la mejor esté en la posición `k`). 
 
 
  Por ejemplo: 
 
  $ ./roundrobintournament solve 5 
  [(1,2),(3,4) 
  ,(1,5),(2,3) 
  ,(4,5),(1,3) 
  ,(2,4),(3,5) 
  ,(1,4),(2,5)] 
 
  $ crono ./roundrobintournament solve 100 > /dev/null 
  Mem: 2299140 kbytes. Time: 0:18.03                  # 2G de RAM y 18 segundos. 
 
  $ ./roundrobintournament evaluate-from-to 3 31 
  #3, wait 1 (avg 0.7), 50.0 % (33.3 %) 
  #5, wait 2 (avg 1.8), 66.7 % (60.0 %) 
  #7, wait 4 (avg 3.3), 100.0 % (82.1 %) 
  #9, wait 5 (avg 4.6), 100.0 % (91.1 %) 
  #11, wait 6 (avg 5.7), 100.0 % (95.5 %) 
  #13, wait 8 (avg 7.0), 114.3 % (100.0 %) 
  #15, wait 9 (avg 8.2), 112.5 % (102.5 %) 
  #17, wait 10 (avg 9.2), 111.1 % (102.0 %) 
  #19, wait 12 (avg 10.8), 120.0 % (108.4 %) 
  #21, wait 12 (avg 11.3), 109.1 % (103.0 %) 
  #23, wait 14 (avg 12.7), 116.7 % (105.4 %) 
  #25, wait 15 (avg 13.7), 115.4 % (105.2 %) 
  #27, wait 16 (avg 15.0), 114.3 % (107.1 %) 
  #29, wait 18 (avg 16.3), 120.0 % (109.0 %) 
  #31, wait 20 (avg 17.7), 125.0 % (110.5 %) 
   |        |        |      |        | 
   |        |        |      |        +--- incremento sobre lo ideal de la espera media 
   |        |        |      | 
   |        |        |      +------------ incremento sobre lo ideal de la espera máxima 
   |        |        | 
   |        |        +------------------- espera media de los jugadores 
   |        | 
   |        +---------------------------- espera del que más espera 
   +------------------------------------- nº de jugadores 
 
  $ ./roundrobintournament inspect-groups 13 10000 > lst.txt 
  (ver imagen en comentarios, se puede ver como las soluciones a lo largo de la aplicación 
  de la heurística son peores y ¡aunque no se puede asegurar! en principio la probabilidad [bajo la heurística] 
  de obtener una mejor solución disminuye) 
 
-} 
 
-- las esperas máximas de cada jugador 
esperas :: [(Int, Int)] -> [Int] 
esperas ps = let turnos = Map.elems $ Map.fromListWith (flip (++)) [(p, [t]) | (t, (a, b)) <- zip [1..] ps, p <- [a, b]] 
               in  map (\ts -> maximum $ zipWith (\a b -> a - b - 1) ts (0:ts)) turnos 
 
-- extrae cada uno de los elementos con la lista sin él 
holes :: [a] -> [(a, [a])] 
holes = h [] where { h _ [] = []; h us (v:vs) = (v, us ++ vs): h (us ++ [v]) vs } 
 
main = do 
 
  let f a b = (fromIntegral a / fromIntegral b :: Double) 
 
  getArgs >>= \case 
    ["solve", n] -> print $ head $ todasPosibles $ read n 
    ["evaluate-from-to", a, b] -> forM_ [read a, read a + 2 .. read b] $ \n -> do 
                                      let s = head $ todasPosibles n 
                                          e = esperas s 
                                          m = sum e 
                                          w = maximum e 
                                          i = n `div` 2 + n `mod` 2 
                                      printf "#%i, wait %i (avg %.1f), %.1f %% (%.1f %%)\n" n w (f m n) (f (100 * w) i) (f (100 * m) (n * i)) 
    ["inspect-groups", n, sz] -> do 
                                    let z = read sz 
                                    printf "min\tmax\tavg\n" 
                                    forM_ (chunksOf z (map (maximum . esperas) $ todasPosibles $ read n)) $ \es -> do 
                                       let maxE = maximum es 
                                           sumE = sum     es 
                                           minE = minimum es 
                                       printf "%i\t%i\t%.1f\n" minE maxE (f sumE z) 
1 comentario
0votos

Escrito por josejuan hace 3 años

Usando `inspect-groups` puede verse como las mejores soluciones ¡¿probablemente?! son las primeras encontradas por la heurística.

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.