1votos

Minimal Superpermutations en Haskell

por josejuan hace 6 años

Puede resolverse fácilmente con LPI, pena que el rendimiento sea penoso (es relativamente frecuente al usar LPI a lo bestia). Pero resuelve el desafío (queda demostrado que encuentra la cadena mínima).

Obtener una cadena de longitud mínima que contenga todas las permutaciones de n símbolos.

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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
-- Usando GLPK, http://www.gnu.org/software/glpk/   
import System.Environment (getArgs) 
import Data.List   
import Control.Monad   
import Data.LinearProgram   
import Data.LinearProgram.GLPK   
import qualified Data.Map as M   
import Data.Map ((!)) 
 
{-- 
 
Tenemos n símbolos {1, 2, 3, ..., n}. 
 
Existen n! permutaciones. 
 
  permsCount = n! 
 
Como cota superior de la longitud mínima tenemos (podría mejorarse): 
 
  maxLen = n n! 
 
Por lo que la posición 0, 1, ... máxima en que empieza una permutación 
es la 
 
  maxPos = n (n! - 1) 
 
Así, como tenemos permsCount permutaciones y maxPos posiciones, tendremos 
 
  numVars = permsCount * maxPos 
 
variables que indiquen si una permutación empieza en una determinada 
posición. 
 
A dichas variables, las denominaremos 
 
  P{i,j} 
 
siendo i el índice permutación [1..permsCount] y j el índice de posición [0..maxPos]. 
 
Lógicamente, una permutación sólo puede estar en una posición simultáneamente, 
por tanto, deberán cumplirse las restricciones 
 
  Sum {j=0..maxPos} 
      P{i, j} = 1 
 
  para todo i = 1..permsCount 
 
Por otro lado, dos permutaciones con posiciones tales que compartan alguna posición 
de símbolo, deberán tener el mismo símbolo en tal posición o, lo que es lo mismo, 
en aquellas posiciones en que sus símbolos colisionen (sean diferentes) o una u 
otra (o ambas) no deberán estar. 
 
  P{i,j} + P{i',j'} <= 1 
 
  para todo 1 <= i < i' <= permsCount y cualesquiera j,j' en que colisionen. 
 
Como queremos minimizar la longitud total, debemos minimizar el mayor j existente. 
 
Si queremos ordenar linealmente grupos de números (siendo que dentro de cada 
grupo nos da igual el orden), asignaremos a cada grupo k-ésimo el peso 
 
  Ck = (n + 1)^k 
 
donde la función de optimización será 
 
  min: 
 
    Sum {j=0..maxPos} 
       
      Cj * Sum {i=1..permsCount} 
 
             P{i, j} 
 
Existen mejoras que pueden hacerse sobre las ecuaciones, como por ejemplo que 
al ser la cadena mínima simétrica, podemos reducir el número total de variables 
a la mitad, pues una permutación al principio conlleva su permutación simétrica 
al final. 
 
--} 
 
p :: Int -> Int -> (Int, Int)  
p i j = (i, j) 
 
{-- 
 
  Dadas dos listas de la misma longitud 'n' da todas aquellas 
  posiciones de la segunda en las que, se producen colisiones 
  en el trozo que intersectan 
 
    pos:    0 1 2 3 .. 
    xs:     A B C D ... F G 
    ys:       A B C D ... F G 
 
--} 
collisionsLengths :: Int -> [Int] -> [Int] -> [Int] 
collisionsLengths n xs ys = test 1 xs 
  where test _ [] = [] 
        test _ (_:[]) = [] 
        test i (_:ws) = if ws /= take (n - i) ys then i:next else next 
                        where next = test (i + 1) ws 
 
{-- 
 
  Dadas dos listas y un armario de 'm' cajas da las posiciones {0..m-1} 
  en las que las listas intersectan con colisión. 
 
  La lista xs siempre está a la izquierda de la lista ys. 
 
--} 
collisionsPos' :: Int -> Int -> [Int] -> [Int] -> [(Int, Int)] 
collisionsPos' m n xs ys = concatMap (\j -> [(i, i + j) | i <- [0..m - n - j]]) $ collisionsLengths n xs ys 
 
{-- 
 
  Como collisionsPos' pero en ambos sentidos. 
 
--} 
collisionsPos :: Int -> Int -> [Int] -> [Int] -> [(Int, Int)] 
collisionsPos m n xs ys = nub $ collisionsPos' m n xs ys ++ (map (\(a, b) -> (b, a)) $ collisionsPos' m n ys xs) 
 
{-- 
 
  Dada una lista de 's' listas de 'n' elementos, y un nº 'm' de posiciones, genera todos 
  los pares de colisiones entre todas las listas. 
 
    [((i, j), (i', j'))] 
 
  (incluye sin revisar que dos listas no pueden ocupar la misma posición) 
 
--} 
allCollisions :: Int -> Int -> M.Map Int [Int] -> Int -> [((Int, Int), (Int, Int))] 
allCollisions s n list m = concat [map (\(j, j') -> ((i, j), (i', j'))) (cols i i')| i <- [1..s], i' <- [i + 1..s]] 
  where cols i i' = collisionsPos m n (list!i) (list!i') ++ [(j, j) | j <- [0..m - 1]] 
 
minPerm' :: Int -> LP (Int, Int) Integer 
minPerm' n = execLPM $ do setDirection Min 
                          mapM_ (\i -> equalTo (varSum [p i j | j <- [0..maxPos]]) 1) [1..npermutations] 
                          mapM_ (\((i, j), (i', j')) -> leqTo (varSum [p i j, p i' j']) 1) colPairPos 
                          setObjective $ linCombination $ [coef i j | i <- [1..npermutations], j <- [0..maxPos]] 
                          mapM_ (\v -> setVarKind v BinVar) [p i j | i <- [1..npermutations], j <- [0..maxPos]] 
             where npermutations = product [1..n] 
                   permutations' :: M.Map Int [Int] 
                   permutations' = M.fromList $ zip [1..] $ permutations [1..n] 
                   maxPos = (-1) + (sum $ map (\k -> product [1..k]) [1..n]) 
                   colPairPos = allCollisions npermutations n permutations' (maxPos + 1) 
                   coef :: Int -> Int -> (Integer, (Int, Int)) 
                   coef i j = (((fromIntegral n + 1)^(fromIntegral j))::Integer, p i j) 
 
-- Wrapper suponiendo que siempre hay solución (aquí siempre)   
minPerm :: Int -> IO [(Int, Int)] 
minPerm n = do 
  (_, Just (_, m)) <- glpSolveVars (mipDefaults { msgLev = MsgErr }) $ minPerm' n 
  return $ map fst. M.toList. M.filter (==1) $ m 
 
main = getArgs >>= minPerm . read . head >>= print 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.