0votos

Llenando el tetris en Haskell

por josejuan hace 5 años

Solución directa usando LPI, permite resolver tableros estándar (ej. entorno 10x20 celdas) en tiempo razonable (con costes).

Realmente no se si resultará fácil o difícil. Consiste en, dando un precio (un coste) a cada tipo de ficha del tetris, obtener la forma más barata de llenar todo el tablero.

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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
{- 
 
      En general, este problema es un bin packing y admite trivialmente 
      una solución usando LPI, eso implica que, en realidad, debería 
      poderse mejorar, sino su complejidad, sí la constante multplva. 
       
      Pero yo no veo ninguna propiedad concreta del problema que permita, 
      de forma más o menos cómoda, mejorar el uso directo de LPI. 
       
      NOTA: si todas las piezas tienen el mismo coste, una mejora consiste 
      en dividir el tablero, resolver por partes y *SÓLO SI* las partes han 
      sido cubiertas completamente, la unión de las soluciones parciales es 
      una solución total. Pero claro, sin costes... (ej. 10x20 puede 
      resolverse como dos de 10x10) y, además, parece que tableros con lado 
      impar siempre dejan un hueco (ésto es fácil de ver, porque todas las 
      piezas tienen lado par) y habría que ver si la partición par/impar 
      permite mantener la estrategia (si obtenemos solución con un sólo 
      hueco parece que sí). 
 
      Usando GLPK, http://www.gnu.org/software/glpk/ 
       
      Debemos maximizar el nº de celdas cubiertas, por lo que maximizamos 
 
            "la suma del nº de celdas de las piezas seleccionadas" 
 
      Luego, debemos minimizar el coste de las piezas usadas, es decir, 
      restaremos a la maximización anterior la suma de los costes, pero de 
      tal forma, que el mayor coste posible (en piezas) nunca alcance a la 
      suma de una única casilla (pues cubrir éstas tiene prioridad) es decir, 
      debe ser inferior a 1. 
 
      Una cota superior del nº final de piezas es 
 
            rows * cols / Msize 
 
      siendo Msize el nº mayor de celdas que ocupa una pieza (en el Tetris 
      estandar este valor es 4). 
 
      Si el coste de la mayor ficha es Mcost, el coste máximo a restar es 
 
            rows * cols * Mcost / Msize 
 
      por lo que cada coste que restemos debe ser ponderado por un factor inferior a 
 
            Msize / rows * cols * Mcost 
 
      El sistema de ecuaciones anterior quedaría como: -}  
 
lpSolver :: Problem -> IO [[(Int, Int)]] 
lpSolver p = do 
  let piecePoses           = shapesTranslations p 
      allIndexedPiecePoses = zip [0..] piecePoses 
      maxFactor            = (0.9 * fromIntegral (maximum $ map (length.shape) $ pieces p)) / 
                             (fromIntegral (columns p * rows p) * (maximum $ map price $ pieces p)) 
      appFactor s          = ((fromIntegral.length.snd$snd s) - (fst$snd s) * maxFactor, fst s) 
      lpProblem :: LP Int Double 
      lpProblem = execLPM $ do 
        setDirection Max 
        mapM_ (\c -> (varSum [fst s | s <- allIndexedPiecePoses, c `elem` (snd$snd s)]) `leqTo` 1) boardCells 
        setObjective $ linCombination $ map appFactor allIndexedPiecePoses 
        mapM_ (\v -> setVarKind v BinVar) $ map fst allIndexedPiecePoses 
  (_, Just (_, solution)) <- glpSolveVars (mipDefaults { msgLev = MsgErr }) lpProblem 
  return $ map ((\i -> snd$piecePoses!!i).fst) $ filter ((1.0==).snd) $ M.toList solution 
 
 
 
-- Código completo --------------------------------------------------------------- 
 
import Data.List 
import Control.Monad 
import Data.LinearProgram 
import Data.LinearProgram.GLPK 
import qualified Data.Map as M 
import System.Environment 
 
-- Una celda puede estar ocupada 'W' o libre 'L' 
data Cell = W | L deriving (Read, Show, Eq) 
 
data Piece = Piece { price :: Double 
                   , shape :: [[Cell]] 
                   } deriving (Read, Show, Eq) 
                    
data Problem = Problem { columns :: Int 
                       , rows  :: Int 
                       , pieces  :: [Piece] 
                       } deriving (Read, Show) 
 
shapeWidth = length . head . shape 
shapeHeight = length . shape 
 
-- 90º clockwise 
rotateShape h@(Piece p s) = Piece p $ map rot $ reverse [0..shapeWidth h - 1] 
                            where rot c = [r!!c | r <- s] 
 
shapeRotations piece = nub $ scanl (const . rotateShape) piece [1..4] 
 
shapesRotations = concatMap shapeRotations . pieces 
 
shapeTranslation h (x, y) = [(x + c, y + r) | c <- [0..shapeWidth h - 1] 
                                            , r <- [0..shapeHeight h - 1] 
                                            , W == ((shape h)!!r)!!c] 
 
boardCells problem = [(x, y) | x <- [0..columns problem - 1], y <- [0..rows problem - 1]] 
 
shapesTranslations p = concatMap pos $ shapesRotations p 
                       where pos h = [(price h, shapeTranslation h (x, y)) 
                                           | x <- [0..columns p - shapeWidth h] 
                                           , y <- [0..rows p - shapeHeight h]] 
 
-- Una forma sencilla de dibujar el resultado es asignar un carácter diferente a cada forma 
drawSolution p s = [[c s' (x, y) | x <- [0..columns p - 1]] | y <- [0..rows p - 1]] 
                   where s' = zip s $ cycle $ ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] 
                         c ((xs, q):qs) xy = if xy `elem` xs then q else c qs xy 
                         c _ _ = '·' 
 
lpSolver :: Problem -> IO [[(Int, Int)]] 
lpSolver p = do 
  let piecePoses           = shapesTranslations p 
      allIndexedPiecePoses = zip [0..] piecePoses 
      maxFactor            = (0.9 * fromIntegral (maximum $ map (length.shape) $ pieces p)) / 
                             (fromIntegral (columns p * rows p) * (maximum $ map price $ pieces p)) 
      appFactor s          = ((fromIntegral.length.snd$snd s) - (fst$snd s) * maxFactor, fst s) 
      lpProblem :: LP Int Double 
      lpProblem = execLPM $ do 
        setDirection Max 
        mapM_ (\c -> (varSum [fst s | s <- allIndexedPiecePoses, c `elem` (snd$snd s)]) `leqTo` 1) $ boardCells p 
        setObjective $ linCombination $ map appFactor allIndexedPiecePoses 
        mapM_ (\v -> setVarKind v BinVar) $ map fst allIndexedPiecePoses 
  (_, Just (_, solution)) <- glpSolveVars (mipDefaults { msgLev = MsgErr }) lpProblem 
  return $ map ((\i -> snd$piecePoses!!i).fst) $ filter ((1.0==).snd) $ M.toList solution 
 
 
renderLpSolver p = lpSolver p >>= mapM_ putStrLn . drawSolution p 
 
standardProblem cols rows = 
  Problem { 
    columns = cols, 
    rows    = rows, 
    pieces  = [ 
      Piece { price = 1.0, shape = [[ W,W,W ] ,[ L,W,L ]] }, -- T 
      Piece { price = 1.0, shape = [[ W,W,L ] ,[ L,W,W ]] }, -- Z 
      Piece { price = 1.0, shape = [[ L,W,W ] ,[ W,W,L ]] }, -- S 
      Piece { price = 1.0, shape = [[ W,W   ] ,[ W,W   ]] }, -- O 
      Piece { price = 1.0, shape = [[ W,W,W ] ,[ L,L,W ]] }, -- J 
      Piece { price = 1.0, shape = [[ W,W,W ] ,[ W,L,L ]] }, -- L 
      Piece { price = 1.0, shape = [[ W,W,W,W ]] }           -- I 
 
main = do 
  args <- getArgs 
  problem <- if null args 
               then getContents >>= return . read 
               else getArgs >>= return . \(c:r:_) -> standardProblem (read c) (read r) 
  renderLpSolver problem 
 
 
{- 
 
    solveet$ for i in 2 3 4 5 6; do echo "== $i x $i =="; ./tetris $i $i; done 
    == 2 x 2 == 
    00 
    00 
    == 3 x 3 == 
    000 
    10· 
    111 
    == 4 x 4 == 
    1100 
    1200 
    1222 
    3333 
    == 5 x 5 == 
    0224· 
    00245 
    01245 
    11145 
    33335 
    == 6 x 6 == 
    555668 
    524468 
    224468 
    200118 
    330011 
    337777 
 
Un tablero estandar (10x20) sale fácilmente al dividir 
 
    solveet$ ./tetris 4 5 
    3222 
    3332 
    0001 
    4011 
    4441 
 
repetido 5 veces en anchura y 2 en altura nos sale el de 10x20 
 
Utilizando costes, podemos escribir un archivo con el problema deseado. 
Por ejemplo: 
 
    solveet$ cat withCosts.tetrisProblem 
    Problem { 
      columns = 5, 
      rows    = 5, 
      pieces  = [ 
        Piece { price = 1.0, shape = [[ W,W,L ] ,[ L,W,W ]] }, 
        Piece { price = 1.0, shape = [[ L,W,W ] ,[ W,W,L ]] }, 
        Piece { price = 2.0, shape = [[ W,W,W ] ,[ L,W,L ]] }, 
        Piece { price = 3.0, shape = [[ W,W,W ] ,[ L,L,W ]] }, 
        Piece { price = 3.0, shape = [[ W,W,W ] ,[ W,L,L ]] }, 
        Piece { price = 4.0, shape = [[ W,W   ] ,[ W,W   ]] }, 
        Piece { price = 5.0, shape = [[ W,W,W,W ]] } 
 
    solveet$ ./tetris < withCosts.tetrisProblem 
    23330 
    22300 
    52401 
    54411 
    5541· 
 
-} 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.