Elm 0.19 のライフゲーム（スマホ非対応バージョン）

lifgame.elm

module Main exposing (main)

import Browser exposing (Document)
import Browser.Navigation exposing (Key)
import Html exposing (Html, button, div, text)
import Html.Events exposing (onClick)
import Html.Events.Extra.Pointer as Pointer
import Html.Attributes exposing (style, src)
import Array exposing (Array)
import SingleSlider
import Time
import Url exposing (Url)
import Url.Parser as Url exposing ((</>), (<?>))
import Url.Parser.Query as UrlQuery

main =
    Browser.application
        { init = init
        , update = update
        , view = view
        , subscriptions = subscriptions
        , onUrlRequest = always (ChangeUrl defaultLinks)
        , onUrlChange = \url -> ChangeUrl (parseUrl url)
        }

type alias Model =
  { board : Board
  , sizeSlider : SingleSlider.Model
  , tickSlider : SingleSlider.Model
  }

init : () -> Url -> Key -> (Model, Cmd Msg)
init _ url _ = (initModel url, Cmd.none)

initModel : Url -> Model
initModel url =
    let
        size =
            30

        defaultSlider =
            SingleSlider.defaultModel

        sizeSlider =
            { defaultSlider
                | min = 5.0
                , max = 50.0
                , step = 1.0
                , value = size
                , minFormatter = always ""
                , maxFormatter = always ""
                , currentValueFormatter =
                    \n _ -> String.concat [ "1列のマス数: ", String.fromFloat n ]
            }

        tickSlider =
            { defaultSlider
                | min = 50.0
                , max = 1000.0
                , step = 10.0
                , value = 100.0
                , minFormatter = always ""
                , maxFormatter = always ""
                , currentValueFormatter =
                    \n _ -> String.concat [ "更新間隔: ", String.fromFloat n, "ms" ]
            }
    in
    { board = initBoard size (parseUrl url)
    , sizeSlider = sizeSlider
    , tickSlider = tickSlider
    }

defaultLinks =
    { alive = "https://github.com/matsubara0507/lifegame/blob/master/docs/static/image/alive.png?raw=true"
    , dead = "https://github.com/matsubara0507/lifegame/blob/master/docs/static/image/dead.png?raw=true"
    }

parseUrl : Url -> Links
parseUrl url =
    let
        queryParser =
            UrlQuery.map2
                Links
                (UrlQuery.string "alive" |> UrlQuery.map (Maybe.withDefault defaultLinks.alive))
                (UrlQuery.string "dead" |> UrlQuery.map (Maybe.withDefault defaultLinks.dead))

        parser =
            Url.top <?> queryParser
    in
    { url | path = "" }
        |> Url.parse parser
        |> Maybe.withDefault defaultLinks

type alias Board =
    { size : Int
    , cells : Array Cell
    , planting : Bool
    , links : Links
    }

type alias Links =
    { alive : String
    , dead : String
    }

type Cell = Alive | Dead

initBoard : Int -> Links -> Board
initBoard n links =
    { size = n
    , cells = Array.repeat (n * n) Dead
    , planting = False
    , links = links
    }

type Msg
    = SizeSliderMsg SingleSlider.Msg
    | TickSliderMsg SingleSlider.Msg
    | BoardMsg BoardMsg
    | NextTick
    | ChangeUrl Links

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
    case msg of
        SizeSliderMsg subMsg ->
            let
                ( updatedSlider, cmd, _ ) =
                    SingleSlider.update subMsg model.sizeSlider

                updatedBoard =
                    initBoard (truncate updatedSlider.value) model.board.links
            in
            ( { model | board = updatedBoard, sizeSlider = updatedSlider }
            , Cmd.map SizeSliderMsg cmd
            )

        TickSliderMsg subMsg ->
            let
                ( updatedSlider, cmd, _ ) =
                    SingleSlider.update subMsg model.tickSlider
            in
            ( { model | tickSlider = updatedSlider }
            , Cmd.batch [ Cmd.map TickSliderMsg cmd ]
            )

        BoardMsg subMsg ->
            let
                ( updatedBoard, cmd ) =
                    updateBoard subMsg model.board
            in
            ( { model | board = updatedBoard }, Cmd.map BoardMsg cmd )
        
        NextTick ->
            ( { model | board = nextBoard model.board }, Cmd.none )

        ChangeUrl links ->
            let
                board =
                    model.board

                updatedBoard =
                    { board | links = links }
            in
            ( { model | board = updatedBoard }, Cmd.none )

type BoardMsg
    = Born Int
    | Planting

updateBoard : BoardMsg -> Board -> ( Board, Cmd BoardMsg )
updateBoard msg board =
    case msg of
        Born idx ->
            ( born idx board, Cmd.none )

        Planting ->
            ( { board | planting = xor board.planting True }, Cmd.none )

born : Int -> Board -> Board
born idx board =
    { board | cells = Array.set idx Alive board.cells }

nextBoard : Board -> Board
nextBoard board =
    { board | cells = Array.indexedMap (nextCell board) board.cells }

nextCell : Board -> Int -> Cell -> Cell
nextCell board idx cell =
    case ( countAroundAliveCell board idx, cell ) of
        ( 2, Alive ) ->
            Alive

        ( 3, _ ) ->
            Alive

        _ ->
            Dead

countAroundAliveCell : Board -> Int -> Int
countAroundAliveCell board idx =
    aroundCell board idx |> List.filter ((==) Alive) |> List.length

aroundCell : Board -> Int -> List Cell
aroundCell board idx =
    [ if modBy board.size idx == 0 then
        [] -- 左端にいる場合

      else
        [ idx - board.size - 1, idx - 1, idx + board.size - 1 ]
    , [ idx - board.size, idx + board.size ] -- 上下は `Array.get` で `Nothing` になる
    , if modBy board.size idx == board.size - 1 then        
        [] -- 右端にいる場合

      else
        [ idx - board.size + 1, idx + 1, idx + board.size + 1 ]
    ]
        |> List.concat
        |> List.filterMap (\n -> Array.get n board.cells)

view : Model -> Document Msg
view model =
    let
        sliderAttrs =
            [ style "margin-left" "10px"
            , style "margin-right" "10px"
            ]
    in
    { title = "Life Game"
    , body =
        [ div
            [ style "text-align" "center"
            , style "display" "flex"
            , style "justify-content" "center"
            ]
            [ div sliderAttrs
                [ Html.map SizeSliderMsg (SingleSlider.view model.sizeSlider) ]
            , div sliderAttrs
                [ Html.map TickSliderMsg (SingleSlider.view model.tickSlider) ]
            ]
        , Html.map BoardMsg (viewBoard model.board)
        ]
    }

viewBoard : Board -> Html BoardMsg
viewBoard board =
    let
        attr =
            [ style "width" (maxLength |> vmin)
            , style "height" (maxLength |> vmin)
            ]
    in
    concatIndexedMapWith (Html.div attr) (viewCell board) board

viewCell : Board -> Int -> Cell -> Html BoardMsg
viewCell board idx cell =
    let
        styleAttrs =
            [ style "width" (maxLength / toFloat board.size |> vmin)
            , style "height" (maxLength / toFloat board.size |> vmin)
            , style "margin" "0"
            , style "box-sizing" "border-box"
            , style "border" "0.2vmin solid gray"
            ]

        bornAttr =
            if board.planting then
                [ Pointer.onDown (always Planting)
                , Pointer.onOver (always (Born idx))
                ]

            else
                [ Pointer.onDown (always Planting) ]

        imageLink =
            case cell of
                Dead ->
                    [ src board.links.dead ]

                Alive ->
                    [ src board.links.alive ]

    in
    Html.img (List.concat [ styleAttrs, bornAttr, imageLink ]) []

subscriptions : Model -> Sub Msg
subscriptions model =
    if model.board.planting then
        Sub.none

    else
        Time.every model.tickSlider.value (always NextTick)

concatIndexedMapWith : (List a -> b) -> (Int -> Cell -> a) -> Board -> b
concatIndexedMapWith f g board =
    board.cells
        |> Array.indexedMap g
        |> Array.toList
        |> f

maxLength : Float
maxLength = 90.0

vmin : Float -> String
vmin n =
    String.append (String.fromFloat n) "vmin"