Simple Tetris in elm.

tetris.elm

import Html exposing (Html)
import Html.Attributes exposing (style)
import Svg exposing (Svg, svg, rect)
import Svg.Attributes exposing (x, y, width, height, fill, viewBox)
import Array exposing (Array)
import Keyboard exposing (presses, KeyCode)
import Random
import Time exposing (Time, second)

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



-- TETROMINO
type alias Tetromino  =
  { class   : TetrominoClass
  , origin  : GridCoord
  , squares : TetrominoCoords
  }
type TetrominoClass = TA | TB | TC | TD | TE | TF | TG
type alias TetrominoCoord = (Int, Int)
type alias TetrominoCoords = List TetrominoCoord
type TetrominoMove =
    Clockwise
  | CounterClockwise
  | Down
  | Left
  | Right
  | None

tetrominoInit : Int -> Tetromino
tetrominoInit nbr =
  let
    maybeTetrominoClass : Maybe TetrominoClass
    maybeTetrominoClass =
      [TA, TB, TC, TD, TE, TF, TG]
      |> Array.fromList
      |> Array.get nbr

    tcls : TetrominoClass
    tcls =
      case maybeTetrominoClass of
        Just x -> x
        _      -> TA

    origin : GridCoord
    origin = (4, 19)

    z : TetrominoCoord
    z = (0, 0)

    squares : TetrominoCoords
    squares =
      case tcls of
        TA -> [z, (0, -1), (1, 0), (1, 1)] -- z
        TB -> [z, (0, -1), (0, 1), (1, 1)] -- j
        TC -> [z, (-1, 0), (1, 0), (0, 1)] -- t
        TD -> [z, (0, -1), (0, 1), (0, 2)] -- i
        TE -> [z, (0, -1), (0, 1), (-1, 1)] -- l
        TF -> [z, (0, -1), (-1, 0), (-1, 1)] -- s
        TG -> [z, (1, 0), (0, 1), (1, 1)] -- o
  in
    Tetromino tcls origin squares

tetrominoMove : Tetromino -> TetrominoMove -> Tetromino
tetrominoMove tetromino move =
    let
      (col, row) = tetromino.origin
      origin =
        case move of
          Down -> (col, row - 1)
          Left -> (col - 1, row)
          Right -> (col + 1, row)
          _ -> tetromino.origin
      squares =
        case move of
          Clockwise -> List.map (\(x, y) -> (y, -x)) tetromino.squares
          CounterClockwise -> List.map (\(x, y) -> (-y, x)) tetromino.squares
          _ -> tetromino.squares
    in
      {tetromino | origin = origin, squares = squares}

tetrominoGridCoords : Tetromino -> GridCoords
tetrominoGridCoords t =
  let
    (ocol, orow) = t.origin
  in
    List.map (\(col, row) -> (ocol + col, orow + row)) t.squares

tetrominoGridIndices : Tetromino -> GridIndices
tetrominoGridIndices t =
  List.map (\(col, row) -> row * 10 + col) (tetrominoGridCoords t)




-- GRID
type GridSquare = Empty | FilledSquare TetrominoClass
type alias Grid = Array GridSquare
type alias GridIndex = Int
type alias GridIndices = List GridIndex
type alias GridCoord = (Int, Int)
type alias GridCoords = List GridCoord

gridInit : Grid
gridInit = Array.repeat 200 Empty

gridCoordFromIndex : GridIndex -> GridCoord
gridCoordFromIndex gridIndex =
  (rem gridIndex 10, gridIndex // 10)

gridSetSquares :  GridSquare -> GridIndices -> Grid -> Grid
gridSetSquares square indices grid =
  let
    first : Maybe Int
    first = List.head indices

    rest : List Int
    rest = List.drop 1 indices
  in
    case first of
      Nothing ->
        grid
      Just first ->
        Array.set first square grid
        |> gridSetSquares square rest



gridClearFullRows : Grid -> Grid
gridClearFullRows grid =
  let

    gridRows = List.map (\i -> Array.toList (Array.slice (i*10) (i*10 + 10) grid)) (List.range 0 19)

    squareIsEmpty = \s ->
      case s of
        Empty -> True
        _ -> False

    rowIsNotFull = \row -> List.foldl (\sq b -> ((squareIsEmpty sq) || b)) False row

    remaining = List.filter (rowIsNotFull) gridRows

    replenishment =
      List.repeat 10 Empty
      |> List.repeat (20 - (List.length remaining))

    newRowSet = List.concat [remaining, replenishment]

    newGrid = Array.fromList (List.concat newRowSet)

  in
    newGrid


gridTetrominoInBounds : Tetromino -> Bool
gridTetrominoInBounds tetromino =
  tetrominoGridCoords tetromino
  |> List.map (\(col, row) ->
    if col < 0 then False
    else if col > 9 then False
    else if row < 0 then False
    else True
    )
  |> List.foldl (\a b -> (a && b)) True



gridTetrominoCollision : Grid -> Tetromino -> Bool
gridTetrominoCollision grid tetromino =
    tetrominoGridIndices tetromino
    |> List.map (\index -> (Array.get index grid))
    |> List.map
      (\square ->
        case square of
          Nothing    -> False
          Just Empty -> False
          _          -> True
      )
    |> List.foldl (\a b -> (a || b)) False



gridFixTetromino: Grid -> Tetromino -> Grid
gridFixTetromino grid tetromino =
  gridSetSquares (FilledSquare tetromino.class) (tetrominoGridIndices tetromino) grid



-- GAME

type alias Game =
  { grid      : Grid
  , tetromino : Tetromino
  }

type alias GameNeedsNewTetromino = Bool



gameInit : Game
gameInit = Game gridInit (tetrominoInit 0)
-- TODO: make first tetromino be random



gameSetTetromino : Game -> Tetromino -> Game
gameSetTetromino game tetromino =
  { game | tetromino = tetromino }


gameFixTetromino : Game -> Game
gameFixTetromino game =
  let
    grid =
      gridFixTetromino game.grid game.tetromino
      |> gridClearFullRows
  in
    { game | grid = grid }



gameMoveTetromino : TetrominoMove -> Game -> (Game, GameNeedsNewTetromino)
gameMoveTetromino move game =
  let
    moved      = tetrominoMove game.tetromino move
    inBounds   = gridTetrominoInBounds moved
    collision  = gridTetrominoCollision game.grid moved
    legal      = inBounds && (not collision)
    gameUpdate =
      case move of
        Down ->
          if legal
          then {game | tetromino = moved}
          else gameFixTetromino game
        _ ->
          if legal
          then {game | tetromino = moved}
          else game
    needNewTetromino =
      case move of
        Down ->
          if legal
          then False
          else True
        _ -> False
  in
    (gameUpdate, needNewTetromino)




-- MODEL INIT & UPDATE

type Msg =
    MsgMove         TetrominoMove
  | MsgNewTetromino Int

init : (Game, Cmd Msg)
init = (gameInit, Cmd.none)

update : Msg -> Game -> (Game, Cmd Msg)
update msg game =
  case msg of
    MsgMove move ->
      let
        (gameUpdate, needsNewTetromino) = gameMoveTetromino move game
        cmd =
          if needsNewTetromino
          then cmdRandomNewTetromino
          else Cmd.none
      in
        (gameUpdate, cmd)
    MsgNewTetromino i ->
      let
        gameUpdate =
          tetrominoInit i
          |> gameSetTetromino game
      in
        (gameUpdate, Cmd.none)

cmdRandomNewTetromino : Cmd Msg
cmdRandomNewTetromino =
  Random.generate (\i -> (MsgNewTetromino i)) (Random.int 0  6)




-- SUBSCRIPTIONS

keyToMessage : KeyCode -> Msg
keyToMessage k =
  let
    move : TetrominoMove
    move =
      if      k == 106  then  Left
      else if k == 108  then  Right
      else if k == 107  then  Down
      else if k == 105  then  Clockwise
      else if k == 117  then  CounterClockwise
      else None
  in
    MsgMove move

subscriptions : Game -> Sub Msg
subscriptions game =
  let
    subKeypress = presses keyToMessage
    subTimedDrop = Time.every second (\t -> MsgMove Down)
  in
    Sub.batch
      [ subKeypress
      , subTimedDrop
      ]





-- VIEW
view : Game -> Html Msg
view game =
  gridFixTetromino game.grid game.tetromino
  |> Array.indexedMap (\index square -> ((gridCoordFromIndex index), square))
  |> Array.toList
  |> List.map (\((col, row), square) ->
      let
        irow = 19 - row
        color =
          case square of
            Empty -> "#000"
            FilledSquare TA -> "#f00"
            FilledSquare TB -> "#0f0"
            FilledSquare TC -> "#00f"
            FilledSquare TD -> "#ff0"
            FilledSquare TE -> "#f0f"
            FilledSquare TF -> "#0ff"
            FilledSquare TG -> "#888"
      in
        rect
          [ x (toString (col * 10))
          , y (toString (irow * 10))
          , width "10"
          , height "10"
          , fill color
          ]
          []
      )
  |> svg [ viewBox "0, 0, 100, 200" , style [ ("height", "500px") ] ]

Nice 👍