2votos

Snake en Haskell

por josejuan hace 6 años

Seguro es más verbose de los necesario, pero entre lo torpe que soy en Haskell y que necesitaba claridad, he preferido dejarlo así y no "simplificar" (aun así no es largo). He usado SDL, el wrapper para OpenGL ¡fuerza a programar imperativamente!. En "real" serían tres o cuatro archivos, aquí es más cómodo sólo uno.

Fernando de Genbetadev dice que si haces un Snake en un lenguaje, entonces, ese lenguaje ya casi no tiene secretos para tí.

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
{-- 
NOTA: para ver bien formateado el código aquí: https://gist.github.com/3228724 
 
 
  Keys: 
 
    Q - quit 
    A - move snake counterclockwise 
    S - move snake clockwise 
 
 Image files:  
 
  http://shared.computer-mind.com/JoseJuan/Snake/frog.png  
  http://shared.computer-mind.com/JoseJuan/Snake/head.png  
  http://shared.computer-mind.com/JoseJuan/Snake/body.png  
 
--} 
 
-- ==== import ============================================================================================== 
import Graphics.UI.SDL as G 
import Graphics.UI.SDL.Image as I 
import Graphics.UI.SDL.Time as T 
import Data.Bits 
import Data.List (nub) 
import System.Random (randomIO) 
import GHC.Word (Word32) 
 
-- ==== data types ========================================================================================== 
data Pos = Pos Int Int deriving (Eq) 
data Dir = Up | Down | Left | Right deriving (Eq) 
data Time = Time {ti :: GHC.Word.Word32, tf :: Double} 
data Context = Context {viewPort :: Pos, frameBuffer :: Surface, frogImage :: Surface, headImage :: Surface, bodyImage :: Surface} 
data Game = Game {boardSize :: Pos, foodPos :: Pos, snakePos :: [Pos], snakeDir :: Dir} 
data App = App {time :: Time, context :: Context, game :: Game} 
 
-- ==== some constants ====================================================================================== 
celPix = 16 -- cell image size 
sps = 0.2 -- seconds per steps 
backgroundColor = 0x054005 
 
-- ==== impure code ========================================================================================= 
main :: IO () 
main = snakeGame 25 
 
snakeGame :: Int -> IO () 
snakeGame size = initApp size size >>= eventLoop >> G.quit 
 
initApp :: Int -> Int -> IO App 
initApp w h = do 
    let {vw = celPix * w; vh = celPix * h; w2 = w `div` 2; ws = Pos w h} 
    G.init [G.InitEverything] 
    G.setVideoMode vw vh 32 [] 
    G.setCaption "Snake!" "snake" 
    b <- getVideoSurface 
    f <- I.load "frog.png" 
    e <- I.load "head.png" 
    i <- I.load "body.png" 
    t <- T.getTicks 
    r <- rnd 
    return $ App (Time t 0.0) (Context (Pos vw vh) b f e i) (Game ws (Pos w2 0) [Pos w2 (h `div` 2)] Up) 
 
rnd :: IO Int 
rnd = randomIO >>= return . abs 
 
eventLoop :: App -> IO () 
eventLoop app = 
 do 
    z <- T.getTicks 
    r <- rnd 
    let nextApp = computeStep app r $ updateTime (time app) z 
        checkEvent (KeyUp Keysym {symKey = key}) = 
          case key of 
            SDLK_q -> return () 
            SDLK_a -> eventLoop $ moveLeft nextApp 
            SDLK_s -> eventLoop $ moveRight nextApp 
            _      -> eventLoop nextApp 
        checkEvent _ = eventLoop nextApp 
    drawWorld app 
    if gameOver app 
      then putStrLn "Game over!" 
      else G.pollEvent >>= checkEvent 
 
drawWorld :: App -> IO () 
drawWorld (App _ (Context (Pos w h) b f e i) (Game _ (Pos fx fy) xs _)) = do 
    G.fillRect b (Just (Rect 0 0 w h)) (Pixel backgroundColor) 
    G.blitSurface f Nothing b (Just (Rect (celPix * fx) (celPix * fy) 0 0)) 
    G.blitSurface e Nothing b (Just (Rect (celPix * x) (celPix * y) 0 0)) 
    mapM (\(Pos x y) -> G.blitSurface i Nothing b (Just (Rect (celPix * x) (celPix * y) 0 0))) $ tail xs 
    G.flip b 
    where (Pos x y) = head xs 
 
-- ==== pure code =========================================================================================== 
selectOne :: (Eq b) => b -> [(b, a)] -> a 
selectOne f = snd.head.filter ((f==).fst)  
 
moveLeft :: App -> App 
moveLeft (App a b (Game c d e f)) = App a b (Game c d e r) 
  where r = selectOne f [(Up, Main.Left), (Down, Main.Right), (Main.Left, Down), (Main.Right, Up)] 
 
moveRight :: App -> App 
moveRight (App a b (Game c d e f)) = App a b (Game c d e r) 
  where r = selectOne f [(Up, Main.Right), (Down, Main.Left), (Main.Left, Up), (Main.Right, Down)] 
 
computeStep :: App -> Int -> Time -> App 
computeStep app r t' = App t' (context app) newGameState 
  where newGameState = 
          if floor ((tf$time app) / sps) /= floor ((tf t') / sps) 
            then performStep (game app) r 
            else game app 
 
performStep :: Game -> Int -> Game 
performStep (Game (Pos cw ch) food xs sd) r = 
        Game (Pos cw ch) nf ns sd 
        where (Pos x y) = head xs 
              n = selectOne sd [(Up, Pos x ((y + ch - 1) `mod` ch)), 
                                (Down, Pos x ((y + 1) `mod` ch)), 
                                (Main.Left, Pos ((x + cw - 1) `mod` cw) y), 
                                (Main.Right, Pos ((x + 1) `mod` cw) y)] 
              ns = if n /= food then (n:Prelude.init xs) else (n:xs) 
              nf = if n /= food then food else fpos!!(r `mod` length fpos) 
              fpos = filter (\x -> not$elem x ns) [Pos x y| x <- [0.. cw-1], y <- [0.. ch-1]] 
 
updateTime :: Time -> Word32 -> Time 
updateTime (Time t0 _) t = Time t0 (0.001 * fromIntegral (t - t0)) 
 
gameOver :: App -> Bool 
gameOver app = (length xs) /= (length $ nub xs) where xs = snakePos$game app 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.