0votos

Tetris en Haskell

por josejuan hace 4 años

En Haskell usando Gloss.

Con la mis idea que el desafío "Snake" hacer ¡un Tetris!.

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
import Graphics.Gloss 
import Graphics.Gloss.Interface.IO.Game 
import Data.Maybe 
import System.Random 
import System.Environment 
import Control.Arrow 
 
fi = fromIntegral 
 
data State = State [[Maybe Color]] (Int, Int) (Int, Int) Int Int StdGen 
data Config = Config [([Int], Color)] Float 
 
foldPiece :: (Int, Int) -> ((Int, Int) -> a -> a) -> a -> ([Int], Color) -> Int -> a 
foldPiece o f a p d = snd $ foldl (\(p@(x,y), a) i -> ((x + fst(b!!i), y + snd(b!!i)), f p a)) (o,a) (fst p ++ [0]) 
                      where b = drop d $ cycle [(1, 0), (0, -1), (-1, 0), (0, 1)] 
 
collidePiece (Config ps _) (State g (w, h) _ d i _) p = foldPiece p test False (ps!!i) d 
  where test (x, y) c = c || x < 0 || x >= w || y < 0 || isJust ((g!!y)!!x) 
 
standarPieces = [([1,0,1], green), ([0,1,2], red), ([1,1,1], blue), ([1,2,0,0], orange), ([2,0,1,1], yellow), ([0,2,1,1], aquamarine)] 
 
drawCell s c (x, y) = Translate (s * x) (s * y) $ Pictures [Color c $ rectangleSolid s s, Color white $ rectangleWire s s] 
 
drawPiece pos s d p@(_, c) = Color c $ Pictures $ map (drawCell s c) $ foldPiece pos ((:).(fi *** fi)) [] p d 
 
updateG (w, h) c p g = [[if (i,j) == p then Just c else (g!!j)!!i | i <- [0..w-1]] | j <- [0..h-1]] 
 
drawTetris    (Config ps pp) st@(State gs (w, h) pos d i _) = 
     Translate (0.5 * pp * (1 - cols)) (0.5 * pp * (1 - rows)) $ 
     Pictures [ drawPiece pos pp d (ps!!i) 
              , Pictures $ catMaybes [fmap (\k -> drawCell pp k (fi c, fi r)) ((gs!!r)!!c) | r <- [0..h-1], c <- [0..w-1]]] 
     where (cols, rows) = (fi w, fi h) 
 
controlTetris cfg (EventKey k Down _ _) st@(State g w (c, r) d i m) 
 | k == SpecialKey KeyUp    = move (State g w (c, r) ((d + 1) `mod` 4) i m) (c, r) 
 | k == SpecialKey KeyLeft  = move st (c - 1, r) 
 | k == SpecialKey KeyRight = move st (c + 1, r) 
 | k == SpecialKey KeyDown  = move st (c, r - 1) 
 | otherwise                = st 
 where move s@(State g w (c, r) d i m) p = if collidePiece cfg s p then s else (State g w p d i m) 
controlTetris _ _ s = s 
 
advanceTetris cfg@(Config ps pp) _ st@(State gs (w, h) (c, r) d i rnd) = 
  if collidePiece cfg st (c, r - 1) 
    then State (collapse (foldPiece (c, r) (updateG (w, h) (snd (ps!!i))) gs (ps!!i) d)) 
               (w, h) (w `div` 2, h - 1) 0 (i' `mod` (length ps)) rnd' 
    else State gs (w, h) (c, r - 1) d i rnd 
  where (i', rnd') = next rnd 
        collapse g = g' ++ (take (h - length g') $ repeat $ take w $ repeat Nothing) 
                     where g' = filter (any isNothing) g 
 
main = do 
  (w:h:s:speed:_) <- getArgs >>= return . map read 
  rnd <- getStdGen 
  let cfg = Config standarPieces $ fi s 
      stt = State (take h $ repeat $ take w $ repeat Nothing) (w, h) (w `div` 2, h - 1) 0 0 rnd 
  play (InWindow "Tetris!" (w * s, h * s) (0, 0)) black speed stt (drawTetris cfg) (controlTetris cfg) (advanceTetris cfg) 
2 comentarios
0votos

Escrito por josejuan hace 4 años

(por eso de que se vea algo)
Tetris
0votos

Escrito por ARIEL hace 4 años

No he probado ese lenguaje, se ve muy interesante. Excelente trabajo, gracias por compartir.

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.