![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
Changeset 20004 for lang/haskell/nario
- Timestamp:
- 09/27/08 10:16:04 (5 years ago)
- Location:
- lang/haskell/nario
- Files:
-
- 1 added
- 4 modified
Legend:
- Unmodified
- Added
- Removed
-
lang/haskell/nario/Const.hs
r19999 r20004 8 8 chrSize = 16 :: Int 9 9 10 -- 重力 11 gravity = one `div` 2 10 12 11 13 -- 画像 -
lang/haskell/nario/Main.hs
r19999 r20004 11 11 import Util 12 12 import Player 13 import Field 13 14 import Const 14 15 … … 24 25 -- 背景色 25 26 backColor = 0x2891ff -- 青 26 27 28 29 30 31 32 -- マップ33 34 fieldMap = [35 " ",36 " ",37 " ",38 " ",39 " ",40 " ",41 " O?O ",42 " ",43 " ",44 " O?O?O ",45 " ",46 " ",47 " ",48 "@@@@@@@@@@@@@@@@",49 "@@@@@@@@@@@@@@@@"50 ]51 52 chr2img '@' = ImgBlock153 chr2img 'O' = ImgBlock254 chr2img '?' = ImgBlock455 56 renderMap sur imgres = sequence_ $ concatMap lineProc $ zip [0..] fieldMap57 where58 lineProc (y, ln) = map (cellProc y) $ zip [0..] ln59 cellProc y (x, c) = do60 if c == ' '61 then return ()62 else do63 blitSurface (getImageSurface imgres $ chr2img c) Nothing sur $ pt (x*16) (y*16)64 return ()65 66 67 27 68 28 … … 92 52 ev <- pollEvent 93 53 case ev of 94 Just QuitEvent 54 Just QuitEvent -> return True 95 55 Just (KeyboardEvent { kbPress = True, kbKeysym = Keysym { ksSym = ks, ksMod = km } }) 96 56 | ks == SDLK_ESCAPE -> return True 97 57 | ks == SDLK_F4 && (KMOD_LALT `elem` km || 98 58 KMOD_RALT `elem` km) -> return True 99 Nothing 100 _ 59 Nothing -> return False 60 _ -> checkEvent 101 61 102 62 … … 111 71 data GameState = 112 72 GameState { 113 pl :: Player 73 pl :: Player, 74 fld :: Field 114 75 } 115 76 … … 118 79 initState = 119 80 GameState { 120 pl = newPlayer 81 pl = newPlayer, 82 fld = getField stage 121 83 } 84 where 85 stage = 0 122 86 123 87 … … 125 89 onProcess :: KeyProc -> GameState -> GameState 126 90 onProcess kp gs 127 | otherwise = gs { pl = updatePlayer kp ( pl gs) }91 | otherwise = gs { pl = updatePlayer kp (fld gs) (pl gs) } 128 92 129 93 … … 133 97 fillRect sur Nothing backColor 134 98 135 render Mapsur imgres99 renderField sur imgres 136 100 renderPlayer sur (pl gs) imgres 137 101 -
lang/haskell/nario/Player.hs
r19999 r20004 14 14 import SDLUtil 15 15 import Const 16 import Field 17 18 19 maxVx = one * 3 20 maxVy = one * 8 21 acc = one `div` 6 22 jumpVy = -17 * gravity 16 23 17 24 … … 30 37 newPlayer = Player { 31 38 x = 1 * chrSize * one, 32 y = 1 3 * chrSize * one - 1,39 y = 1 * chrSize * one, 33 40 vx = 0, 34 41 vy = 0, 35 stand = True,42 stand = False, 36 43 37 44 lr = 1, … … 39 46 anm = 0 40 47 } 41 42 maxVx = one * 343 acc = one `div` 644 48 45 49 … … 56 60 57 61 -- 横移動 58 moveLR :: KeyProc -> Player -> Player 59 moveLR kp player = 60 player { x = x', vx = vx', lr = lr', pat = pat', anm = anm' } 62 moveX :: KeyProc -> Player -> Player 63 moveX kp player = 64 if (stand player) 65 then player' { lr = lr', pat = pat', anm = anm' } 66 else player' 61 67 where 62 68 ax = (-padl + padr) * acc … … 70 76 | isPressed (kp PadB) = maxVx * 2 71 77 | otherwise = maxVx 78 79 player' = player { x = x', vx = vx' } 72 80 73 81 lr' = … … 85 93 86 94 87 -- 縦移動 88 jumpOrFall :: KeyProc -> Player -> Player 89 jumpOrFall kp player = 90 player { y = y' } 91 where 92 y' 93 | isPressed (kp PadU) = (y player) - 1 * one 94 | isPressed (kp PadD) = (y player) + 1 * one 95 | otherwise = y player 95 cellCrd :: Int -> Int 96 cellCrd x = x `div` (chrSize * one) 96 97 97 98 98 updatePlayer :: KeyProc -> Player -> Player 99 updatePlayer kp = 100 jumpOrFall kp . moveLR kp 99 -- ジャンプ中 100 jump :: Field -> Player -> Player 101 jump fld player = 102 player { y = y', vy = vy', stand = stand' } 103 where 104 vytmp = min maxVy $ (vy player) + gravity 105 ytmp = (y player) + vytmp 106 107 y' = if isGround ytmp then yground ytmp else ytmp 108 vy' = if isGround ytmp then 0 else vytmp 109 stand' = isGround ytmp 110 111 isGround y = isBlock $ fieldRef fld (cellCrd (x player)) (cellCrd y) 112 yground y = (cellCrd y) * (chrSize * one) 113 114 115 -- 通常時：地面をチェック 116 checkFall :: KeyProc -> Field -> Player -> Player 117 checkFall kp fld player = 118 player { stand = stand', vy = vy', pat = pat' } 119 where 120 ytmp = (y player) + one 121 122 stand' 123 | isGround ytmp = not dojump 124 | otherwise = False -- 落下開始 125 vy' 126 | not stand' && dojump = jumpVy 127 | otherwise = 0 128 pat' 129 | dojump = patJump 130 | otherwise = pat player 131 132 dojump = kp PadA == Pushed 133 134 isGround y = isBlock $ fieldRef fld (cellCrd (x player)) (cellCrd y) 135 yground y = (cellCrd y) * (chrSize * one) 136 137 138 updatePlayer :: KeyProc -> Field -> Player -> Player 139 updatePlayer kp fld player = 140 moveY $ moveX kp player 141 where 142 moveY 143 | (stand player) = checkFall kp fld 144 | otherwise = jump fld 101 145 102 146 … … 104 148 blitSurface (getImageSurface imgres imgtype) Nothing sur pos 105 149 where 106 pos = pt ((x player) `div` one ) ((y player) `div` one - chrSize)150 pos = pt ((x player) `div` one - chrSize `div` 2) ((y player) `div` one - chrSize) 107 151 imgtype = imgTable !! (lr player) !! (pat player) -
lang/haskell/nario/Util.hs
r19999 r20004 15 15 -- もとから範囲外だったときはそれ以上遠ざからないように 16 16 rangeadd x d x0 x1 17 | d > 0 = if x < x1 then min (x + d) x1 else x18 | d < 0 = if x > x0 then max (x + d) x0 else x17 | d > 0 && x < x1 = min (x + d) x1 18 | d < 0 && x > x0 = max (x + d) x0 19 19 | otherwise = x 20 20
