試験の出来が悪かったので、ムシャクシャして2時間くらいキーボードを叩いていたらテトリスができていました。

完成品は以下のURLに上げています。

http://monamonamonad.github.io/tetris/

Elmはこれくらいの小規模なアプリケーションを書くのに便利ですね。

追記: よくよく考えたら横一列そろったブロック消すの忘れてた。
テトリス下手だから気づかなかった

さらに追記: ↑さすがに直しました。

以下ソースコード
適当に書きなぐったやつなので<table>タグでレイアウトしてたりコード汚かったりしますが直すつもりはありません。

module Main exposing (..)

import Html exposing (..)
import Html.Events exposing (..)
import Html.Attributes exposing (..)

import Array exposing (Array)
import Random
import Time
import Json.Decode
import Keyboard exposing (KeyCode)


-- テトリスの操作に関するAPI
type Color
    = Red
    | Blue
    | Green
    | Yellow
    | Purple
    | Skyblue
    | Orange

type alias Point =
    { x : Int
    , y : Int
    }

type alias Direction = Point

type alias Block =
    { base : Point
    , points : List Point
    , color : Color
    }

type alias Tetris =
    { width : Int
    , height : Int
    , movingBlock : Maybe Block
    , points : Array (Array (Maybe Color))
    , gameOver : Bool
    }

direction =
    { left = { x = -1, y =  0 }
    , right = { x = 1, y = 0 }
    , up = { x = 0, y = -1 }
    , down = { x = 0, y = 1 }
    }

initialTetris : Int -> Int -> Tetris
initialTetris width height =
    { width = width
    , height = height
    , movingBlock = Nothing
    , points = Array.repeat height (Array.repeat width Nothing)
    , gameOver = False
    }

-- 位置 (x, y) のブロックの色を取得
-- Nothing -> 範囲外
-- Just Nothing -> 範囲内だけどブロックが無い
-- Just (Just c) -> 色 c のブロックがある
colorAt : Int -> Int -> Tetris -> Maybe (Maybe Color)
colorAt x y tetris =
    Array.get y tetris.points
        |> Maybe.andThen (Array.get x)

-- topY <= y を満たすエリアを実際に使える
-- それより上 (y 座標が小さいエリア) は初期ブロック出現場所
topY : Int
topY = 2

-- topY より上にブロックが来てたらアウト
isGameOver : Tetris -> Bool
isGameOver tetris =
    let colors = List.concat
                 <| List.map (\y -> List.map (\x -> colorAt x y tetris)
                                  <| List.range 0 (tetris.width - 1))
                 <| List.range 0 (topY - 1)
        pred color =
            case color of
                Just (Just _) -> True
                _ -> False
    in List.any pred colors

movePoint : Point -> Direction -> Point
movePoint point dir =
    { x = point.x + dir.x
    , y = point.y + dir.y
    }

toPoints : Block -> List Point
toPoints b = List.map (movePoint b.base) b.points

moveBlock : Block -> Direction -> Block
moveBlock block dir =
    { block |
          base = { x = block.base.x + dir.x
                 , y = block.base.y + dir.y }
    }

canPointPut : Point -> Tetris -> Bool
canPointPut p tetris =
    case colorAt p.x p.y tetris of
        Nothing -> False
        Just Nothing -> True
        Just (Just c) -> False

canBlockPut : Block -> Tetris -> Bool
canBlockPut block tetris = List.all (\p -> canPointPut p tetris) <| toPoints block

doesBlockHavePoint : Block -> Point -> Bool
doesBlockHavePoint block point =
    List.member point <| toPoints block

-- ブロックの回転、反転用

-- 行列 a = (a11 a12)
--          (a21 a22)
-- を表す
type alias Mat =
    { a11 : Int, a12 : Int
    , a21 : Int, a22 : Int
    }

apply : Mat -> Point -> Point
apply mat point =
    { x = mat.a11 * point.x + mat.a12 * point.y
    , y = mat.a21 * point.x + mat.a22 * point.y
    }

applyToBlock : Mat -> Block -> Block
applyToBlock mat block =
    { block | points = List.map (apply mat) block.points }

rotate : Mat
rotate =
    { a11 = 0,  a12 = 1
    , a21 = -1, a22 = 0 }

-- ゲーム内で使用するブロック
-- ブロックの形
blocks : List Block
blocks =
    let base = { x = 0, y = 0 } -- ダミー
    in  [{ base = base -- I
         , color = Purple
         , points = [ { x = -1, y = 0 }
                    , { x = -0, y = 0 }
                    , { x =  1, y = 0 }
                    , { x =  2, y = 0 }
                    ]
         }
        , { base = base -- Z
          , color = Red
          , points = [ { x = -1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- S
          , color = Skyblue
          , points = [ { x =  1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x =  0, y =  0 }
                     , { x = -1, y =  0 }]
          }
        , { base = base -- T
          , color = Green
          , points = [ { x =  0, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- J
          , color = Yellow
          , points = [ { x = -1, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- L
          , color = Orange
          , points = [ { x =  1, y = -1 }
                     , { x =  1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x = -1, y =  0 }]
          }
        , { base = base -- O
          , color = Blue
          , points = [ { x = -1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }]
          }
        ]

-- 次のブロックをランダムに生成する
generateBlock : Tetris -> Random.Generator Block
generateBlock tetris =
    let base = { x = tetris.width // 2
               , y = 1
               }
    in randomChoose blocks
        |> Random.map (\b -> { b | base = base })

randomChoose : List a -> Random.Generator a
randomChoose xs =
    let len = List.length xs
        get i = xs |> List.drop i |> List.head |> fromJust
    in Random.int 0 (len - 1)
        |> Random.map get

-- ゲーム本体のロジック

-- キーコード
keys =
    { left = 37
    , up = 38
    , right = 39
    , down = 40
    , space = 32
    }

putBlock : Tetris -> Tetris
putBlock tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let points = tetris.points
                cell x y default =
                    if doesBlockHavePoint block { x = x, y = y }
                    then Just block.color
                    else default
                newPoints = Array.indexedMap
                            (\y row -> Array.indexedMap
                                 (\x d -> cell x y d) row) points
                -- TODO: 以下の2つの処理はここで行うべきではない
                newTetris = clearRows { tetris |
                                        points = newPoints
                                      , movingBlock = Nothing
                                      }
            in { newTetris | gameOver = isGameOver tetris }

moveBlockIfCan : Direction -> Tetris -> Tetris
moveBlockIfCan dir tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let moved = moveBlock block dir
            in if canBlockPut moved tetris
               then { tetris | movingBlock = Just moved }
               else tetris

rotateMovingBlock : Tetris -> Tetris
rotateMovingBlock tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let newBlock = applyToBlock rotate block
            in if canBlockPut newBlock tetris
               then { tetris | movingBlock = Just newBlock }
               else tetris

fallOrPut : Tetris -> Tetris
fallOrPut tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let fallen = moveBlock block direction.down
            in if canBlockPut fallen tetris
               then { tetris | movingBlock = Just fallen }
               else putBlock tetris

-- ユーザーの入力
userInput : KeyCode -> Tetris -> Tetris
userInput code tetris =
    switch
    [ (code == keys.left, moveBlockIfCan direction.left tetris)
    , (code == keys.right, moveBlockIfCan direction.right tetris)
    , (code == keys.down, moveBlockIfCan direction.down tetris)
    , (code == keys.space, rotateMovingBlock tetris)
    , (otherwise, tetris)
    ]

shouldRowClear : Array (Maybe Color) -> Bool
shouldRowClear row =
    let isNotEmpty c = Maybe.map (\_ -> True) c
                     |> Maybe.withDefault False
    in List.all isNotEmpty <| Array.toList row

remainingRows : Tetris -> Array (Array (Maybe Color))
remainingRows tetris =
    Array.filter (\row -> not (shouldRowClear row)) tetris.points

clearRows : Tetris -> Tetris
clearRows tetris =
    let rows = remainingRows tetris
        numRows = Array.length rows
        emptyRows = Array.repeat (tetris.height - numRows)
                    <| Array.repeat tetris.width Nothing
        newPoints = Array.append emptyRows rows
    in { tetris | points = newPoints }

-- モデル
type alias Model = Tetris

type Msg
    = KeyPress Int
    | Fall
    | NewBlock Block

initialModel : Model
initialModel = initialTetris 10 22

init : (Model, Cmd Msg)
init = ( initialModel
       , Random.generate NewBlock (generateBlock initialModel)
       )

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
    case msg of
        NewBlock block ->
            if model.gameOver
            then (model, Cmd.none)
            else ( { model | movingBlock = Just block }
                 , Cmd.none)
        KeyPress code ->
            ( userInput code model
            , Cmd.none)
        Fall -> nextTurn model

nextTurn : Tetris -> (Tetris, Cmd Msg)
nextTurn tetris =
    case tetris.movingBlock of
        Nothing -> (tetris, Random.generate NewBlock (generateBlock initialModel))
        Just _ -> (fallOrPut tetris, Cmd.none)

subscriptions : Model -> Sub Msg
subscriptions model =
    if model.gameOver
    then Sub.none
    else Sub.batch
        [ Time.every (Time.second) (\_ -> Fall)
        , Keyboard.downs KeyPress
        ]

view : Model -> Html Msg
view model =
    div []
        [ tetrisView model
        , buttons
        , message model
        ]

buttons : Html Msg
buttons =
    div []
        [ button [ style buttonStyle, onClick (KeyPress keys.left) ]
              [ text "<-" ]
        , button [ style buttonStyle, onClick ( KeyPress keys.space) ]
              [ text "O" ]
        , button [ style buttonStyle, onClick (KeyPress keys.right) ]
              [ text "->" ]
        ]

buttonStyle : List (String, String)
buttonStyle =
    [ ("width", "80px")
    ]

message : Model -> Html Msg
message model =
    div [ style messageStyle ]
        [ if model.gameOver
          then text "Game Over"
          else text ""
        ]

messageStyle : List (String, String)
messageStyle =
    [ ("font-size", "x-large")
    , ("font-weight", "bold")
    , ("color", "red")
    ]

tetrisView : Tetris -> Html Msg
tetrisView tetris =
    table [] <| List.map (\y -> tetrisRowView y tetris)
        <| List.range 0 (tetris.height - 1)

tetrisRowView : Int -> Tetris -> Html Msg
tetrisRowView y tetris  =
    tr [] <| List.map (\x -> tetrisCellView x y tetris)
        <| List.range 0 (tetris.width - 1)

tetrisCellView : Int -> Int -> Tetris -> Html Msg
tetrisCellView x y tetris =
    td [ style (cellStyle x y tetris) ] []

cellStyle : Int -> Int -> Tetris -> List (String, String)
cellStyle x y tetris =
    [ ("background-color", cellColor x y tetris)
    , ("width", "20px")
    , ("height", "20px")
    , ("border-radius", "2px")
    ]

cellColor : Int -> Int -> Tetris -> String
cellColor x y tetris =
    let point = colorAt x y tetris
        defaultColor =
            case point of
                Just (Just c) -> colorToString c
                _ -> "burlywood"
    in case tetris.movingBlock of
           Just b -> if doesBlockHavePoint b { x = x, y = y }
                     then colorToString b.color
                     else defaultColor
           Nothing -> defaultColor

colorToString : Color -> String
colorToString c =
    case c of
        Red -> "red"
        Blue -> "blue"
        Green -> "green"
        Yellow -> "yellow"
        Purple -> "purple"
        Skyblue -> "deepskyblue"
        Orange -> "orangered"

main =
    Html.program
        { init = init
        , view = view
        , update = update
        , subscriptions = subscriptions
        }

-- その他
fromJust : Maybe a -> a
fromJust a = case a of
                 Just x -> x
                 Nothing -> Debug.crash "Nothing"

-- lisp でいう cond みたいなやつ
switch : List (Bool, a) -> a
switch xs =
    case xs of
        [] -> Debug.crash "switch: no option"
        (cond, val) :: xs -> if cond then val
                             else switch xs

otherwise : Bool
otherwise = True

標準ライブラリの他に elm-lang/keyboard も使っています。