Gol.elm

module Gol where

import Text
import Graphics.Input as Input
import Dict
import Set

import Benchmark (..)


-- Import reset events from JS
port init : Signal ()

main = sim <~ foldp step emptyState commands.signal
-- main = let ev s = displayGrid editorView (getGrid s) (getSelected s)
--            pv s = displayGrid projectionView (getGrid s) (getSelected s)
--            events = [Watch (2, 2), Born (1, 2), Born (2, 1), Born (2, 3), Watch (2, 4), Watch (2, 2), Born (1, 1), Kill (1, 2), Kill (2, 4)]
--            states = scanl step emptyState events
--        in run [
--                render "print editorView" ev states
--             -- ,  render "print projectionView" pv states
--               -- logic "step" (foldl step emptyState) (map reverse <| scanl (::) [] events)
--        ]

sim : State -> Element
sim s = flow down [
            flow right [
                displayGrid editorView (getGrid s) (getSelected s)
            ,   container buttonSize (buttonSize*gridSize) middle <| centered <| toText ">>="
            ,   displayGrid projectionView (nextGridGeneration <| getGrid s) (getSelected s)
        ]
        -- ,   asText s -- DEBUG
        , leftAligned <| (if (length <| Set.toList <| getSelected s) == 0
                            then toText ""
                            else explain (getGrid s) (Set.toList <| getSelected s))
    ]

nextGridGeneration : Grid -> Grid
nextGridGeneration g = Dict.fromList <| map (\(p, c) -> (p, nextCellGeneration c (countAliveNeighbours p g))) <| Dict.toList g

countAliveNeighbours : Pos -> Grid -> Int
countAliveNeighbours (xi, yi) g = length <| filter isAlive <| catMaybies <| map (flip Dict.get g) <| map (\(xm, ym) -> (xi+xm, yi+ym)) [
        (-1, -1), (-1, 0), (-1, 1)
    ,   (0, -1),           (0, 1)
    ,   (1, -1),  (1, 0),  (1, 1)
    ]

nextCellGeneration : Cell -> Int -> Cell
nextCellGeneration c n = case n of
    2 -> c
    3 -> Alive
    _ -> Dead

explain : Grid -> [Pos] -> Text
explain g = concatMap (\s -> s ++ (toText "\n")) << map (\p -> explainedNextCellGeneration p (Dict.getOrElse Dead p g) (countAliveNeighbours p g))

explainedNextCellGeneration : Pos -> Cell -> Int -> Text
explainedNextCellGeneration p c n = let msg i c b r = (bold <| toText <| show p) ++ (toText " Toute cellule ") ++ (italic <| toText i) ++ (toText " avec ") ++ (italic <| toText (c ++ " voisins vivant (" ++ (show n) ++ ") " ++ b)) ++ (toText " par ") ++ (bold <| toText r)
    in case c of
        Alive -> (case n of
                    0 -> msg  "vivante" "moins de 2" "meurt" "sous-population"
                    1 -> msg  "vivante" "moins de 2" "meurt" "sous-population"
                    2 -> msg  "vivante" "2 ou 3" "survit" "défaut"
                    3 -> msg  "vivante" "2 ou 3" "survit" "défaut"
                    _ -> msg  "vivante" "plus de 3" "meurt" "surpopulation")
        Dead -> (case n of
                    3 -> msg "morte" "exactement 3" "nait" "reproduction"
                    _ -> msg  "morte" "n <> 3" "reste morte" "défaut")

-- Any live cell with fewer than two live neighbours dies, as if caused by under-population.
-- Any live cell with two or three live neighbours lives on to the next generation.
-- Any live cell with more than three live neighbours dies, as if by overcrowding.
-- Any dead cell with exactly three live neighbours becomes a live cell, as if by reproduction.


displayGrid : Actions -> Grid -> Set.Set Pos -> Element
displayGrid actions g w = flow down <| map (flow right) <| getByLine <| Dict.fromList <| map (\(p, c) -> (p, displayCell actions p c (Set.member p w))) <| Dict.toList g

displayCell : Actions -> Pos -> Cell -> Bool -> Element
displayCell actions pos cell selected = let command = if cell == Dead then on else off
                                        in button cell selected (command actions pos) (show pos)

displayedCellsCache : Dict.Dict (String, String, Float) Element
displayedCellsCache =
    let bg c = if c == Alive then lightGreen else lightGrey
        bgb = buttonBackgroundFactory
        btn cell alpha selected =
            layers [ 
                        color black <| container buttonSize buttonSize midLeft <| bgb selected (bg cell) (buttonSize-1) (buttonSize-1)
                    ,   color (rgba 0 0 0 alpha) (spacer buttonSize buttonSize)
                    ]
    in Dict.fromList <| map (\(f, (c, a)) -> ((show c, show a, f), btn c f a)) <| listsProduct [0, 0.1, 0.2] <| listsProduct [Dead, Alive] [False, True]

buttonSize : number
buttonSize = 80

txt : Float -> Color -> String -> Element
txt p clr string =
    toText string
      |> Text.color clr
      |> typeface ["Helvetica Neue","Sans-serif"]
      |> Text.height (p * buttonSize)
      |> leftAligned

type BackgroundBuilder = Color -> Int -> Int -> Element

buttonBackgroundSelected : BackgroundBuilder
buttonBackgroundSelected background h w = let stripe = rotate (degrees -45) <| alpha 0.5 <| filled lightBlue <| rect 10 (toFloat w*2)
    in collage h w [
            filled background <| rect (toFloat h) (toFloat w)
        ,                     stripe
        ,   move (-15, 10) <| stripe
        ,   move (-30, 25) <| stripe
        ,   move (-45, 35) <| stripe
        ,   move (15, -10) <| stripe
        ,   move (30, -25) <| stripe
        ,   move (45, -35) <| stripe
        ]

buttonBackgroundNotSelected : BackgroundBuilder
buttonBackgroundNotSelected background w h = color background <| container w h bottomRight <| txt 0 white ""

buttonBackgroundFactory : Bool -> BackgroundBuilder
buttonBackgroundFactory f = case f of
    True    -> buttonBackgroundSelected
    _       -> buttonBackgroundNotSelected

button : Cell -> Bool -> Command -> String -> Element
button cell selected command label =
    let btn alpha =
            layers [ 
                        Dict.getOrFail (show cell, show selected, alpha) displayedCellsCache
                    ,   container buttonSize buttonSize middle (txt 0.3 grey label) |> container (buttonSize-1) (buttonSize-1) midLeft
                    ]
    in  Input.customButton commands.handle command (btn 0) (btn 0.1) (btn 0.2)

commands : Input.Input Command
commands = Input.input <| Initialise

-- State
data State = State Grid (Set.Set Pos)

emptyState : State
emptyState = State emptyGrid Set.empty

getGrid : State -> Grid
getGrid s = case s of
    State g _ -> g

getSelected : State -> Set.Set Pos
getSelected s = case s of
    State _ w -> w

step : Command -> State -> State
step command s =
    case command of
      Initialise -> s
      Born p -> updateCellState p Alive s
      Kill p -> updateCellState p Dead s
      Watch p -> watchCell p s

updateCellState : Pos -> Cell -> State -> State
updateCellState p c s = case s of
    State g w -> State (Dict.insert p c g) w

watchCell : Pos -> State -> State
watchCell p s = case s of
    State g w -> State g <| if Set.member p w
                               then Set.remove p w
                               else Set.insert p w

-- Actions
data Actions = Actions (Pos -> Command) (Pos -> Command)

on : Actions -> Pos -> Command
on a = case a of
    Actions f _ -> f

off : Actions -> Pos -> Command
off a = case a of
        Actions _ f -> f

editorView : Actions
editorView = Actions Born Kill

projectionView : Actions
projectionView = Actions Watch Watch

-- MODEL

data Command = Initialise | Watch Pos | Born Pos | Kill Pos

data Cell = Alive | Dead

isAlive : Cell -> Bool
isAlive c = case c of
  Alive -> True
  _     -> False

type Pos = (Int, Int)
type Grid = Dict.Dict Pos Cell

grid : Int -> Grid
grid s = Dict.fromList <| zip (listProduct s) (repeat (s*s) Dead)

gridSize : number
gridSize = 5

emptyGrid : Grid
emptyGrid = grid gridSize

getByLine : Dict.Dict Pos a -> [[a]]
getByLine es = map reverse <| Dict.values <| foldl (\((i, _), x) a -> Dict.insert i (x::Dict.getOrElse [] i a) a) Dict.empty <| Dict.toList es

-- helpers
listProduct : Int -> [(Int, Int)]
listProduct s = let l = [0..(s-1)]
                in listsProduct l l

listsProduct : [a] -> [b] -> [(a, b)]
listsProduct xs ys = let l = length ys
                     in concatMap (\x -> zip (repeat l x) ys) xs

nub : [comparable] -> [comparable]
nub = nubBy (==)

nubBy      : (a -> a -> Bool) -> [a] -> [a]
nubBy eq s = case s of
  []      -> []
  (x::xs) -> x :: nubBy eq (filter (\ y -> not (eq x y)) xs)

catMaybies : [Maybe a] -> [a]
catMaybies = reverse << foldl (\x a -> case x of
                                        Just v -> v :: a
                                        Nothing -> a) []

index.html

<html>

<head>
  <title>Embedding Elm</title>
  <script src="resources/elm-runtime.js"></script>
  <script src="build/Gol.js"></script>
  <style>
  body {
    background-image: url('resources/texture.png');
    background-color: #d3d7cf;
    font-family: "Lucida Grande","Trebuchet MS","Bitstream Vera Sans",Verdana,Helvetica,sans-serif;
    font-size: 14px;
  }
  #elm-stamps {
    width:  400px;
    height: 400px;
    background-color: white;
    border: 1px solid #babdb6;
  }
  #column {
     width: 420px;
     display: block;
     margin-left: auto;
     margin-right: auto;
  }
  </style>
</head>

<body>
<div id="column">
  <h1>Stamps</h1>

  <div id="elm-stamps"></div>
</div>
</body>

<script type="text/javascript">
  // Show the stamp module in the "elm-stamps" div.
  var div = document.getElementById('elm-stamps');
  var stamps = Elm.embed(Elm.Gol, div, { init:[] });
</script>

</html>