176 lines
5.4 KiB
Elm
176 lines
5.4 KiB
Elm
import Html exposing (Html, button, text, div, hr, span)
|
|
import Html.Events exposing (onClick)
|
|
import Html.Attributes exposing (style)
|
|
import List exposing (..)
|
|
import Color exposing (..)
|
|
import Time exposing (Time, second)
|
|
|
|
main = Html.program
|
|
{ init = (reset 0, Cmd.none)
|
|
, view = view
|
|
, update = update
|
|
, subscriptions = subscription
|
|
}
|
|
|
|
-- MODEL
|
|
|
|
type alias Index = Int
|
|
type alias Model =
|
|
{ state : List Int
|
|
, goto : List Int
|
|
, score : Int
|
|
, history : List (List Int)
|
|
}
|
|
|
|
type alias Problem =
|
|
{ from : List Int
|
|
, to : List Int
|
|
}
|
|
|
|
-- non empty
|
|
type NonEmptyList a = NonEmptyList a (List a)
|
|
|
|
problems : NonEmptyList Problem
|
|
problems = NonEmptyList
|
|
{ from = [0,0,0,0,3,0,0,0,0], to = [2,2,2,2,0,2,2,2,2] }
|
|
[ { from = [2,1,2,1,0,1,2,1,2], to = [0,3,0,3,1,3,0,3,0] }
|
|
, { from = [2,1,2,1,1,1,2,1,2], to = [2,1,2,1,0,1,2,1,2] }
|
|
, { from = [3,3,3,3,0,3,3,3,3], to = [0,3,0,3,0,3,0,3,0] }
|
|
, { from = [0,2,2,0,0,3,0,0,3], to = [3,0,1,0,3,2,2,2,3] }
|
|
, { from = [0,2,2,3,2,2,1,1,0], to = [0,2,2,3,1,0,2,2,3] }
|
|
, { from = [3,0,1,1,0,0,1,3,0], to = [1,1,1,0,2,2,3,1,2] }
|
|
, { from = [3,0,2,3,3,3,1,1,2], to = [2,3,2,0,2,2,1,1,1] }
|
|
]
|
|
|
|
|
|
(!!) : NonEmptyList a -> Int -> a
|
|
(!!) ls n = case ls of
|
|
NonEmptyList x [] -> x
|
|
NonEmptyList x (y::xs) -> if n <= 0
|
|
then x
|
|
else (NonEmptyList y xs) !! (n-1)
|
|
|
|
mod : Int -> List a -> List (List a)
|
|
mod n ls =
|
|
let go n ls = case (take n ls, drop n ls) of
|
|
(l1, []) -> [l1]
|
|
(l1, l2) -> l1 :: go n l2
|
|
in go n ls
|
|
|
|
reset : Int -> Model
|
|
reset n = let prob = problems !! n
|
|
in { state = prob.from
|
|
, goto = prob.to
|
|
, score = 0
|
|
, history = [prob.from]
|
|
}
|
|
|
|
-- UPDATE
|
|
|
|
type Msg = Reset Int | AddAt Int | Fix | Undo
|
|
|
|
update : Msg -> Model -> (Model, Cmd Msg)
|
|
update msg model =
|
|
case msg of
|
|
Reset n -> (reset n, Cmd.none)
|
|
AddAt m ->
|
|
let
|
|
l1 = take m model.state
|
|
l1b = drop m model.state
|
|
x = take 1 l1b
|
|
l2 = drop 1 l1b
|
|
newL = l1 ++ (map (\n -> n+1) x) ++ l2
|
|
newH = model.state :: model.history
|
|
in ({ model | state = newL, score = model.score + 1, history = newH }, Cmd.none)
|
|
Fix ->
|
|
let
|
|
rems = map (\v -> v % 4) model.state
|
|
divs = map (\v -> v // 4) model.state
|
|
dividx = map (\(v, i) -> scale v (neighbours i)) <| zip divs idxs
|
|
adds = foldr add zero dividx
|
|
newState = add rems adds
|
|
in ({ model | state = newState }, Cmd.none)
|
|
Undo -> case model.history of
|
|
[] -> ({ model | history = [model.state]}, Cmd.none)
|
|
[x] -> ({ model | state = x }, Cmd.none)
|
|
x::xs -> ({ model | state = x, history = xs }, Cmd.none)
|
|
|
|
subscription : Model -> Sub Msg
|
|
subscription _ = Time.every (0.2*second) (always Fix)
|
|
|
|
zip = map2 (,)
|
|
idxs = range 0 8
|
|
zero = List.repeat 9 0
|
|
add l1 l2 = map2 (+) l1 l2
|
|
scale n ls = map (\v -> n*v) ls
|
|
neighbours n = case n of
|
|
0 -> [0,1,0,1,0,0,0,0,0]
|
|
1 -> [1,0,1,0,1,0,0,0,0]
|
|
2 -> [0,1,0,0,0,1,0,0,0]
|
|
3 -> [1,0,0,0,1,0,1,0,0]
|
|
4 -> [0,1,0,1,0,1,0,1,0]
|
|
5 -> [0,0,1,0,1,0,0,0,1]
|
|
6 -> [0,0,0,1,0,0,0,1,0]
|
|
7 -> [0,0,0,0,1,0,1,0,1]
|
|
8 -> [0,0,0,0,0,1,0,1,0]
|
|
_ -> []
|
|
correct model = model.state == model.goto
|
|
|
|
-- VIEW
|
|
|
|
color n = case n of
|
|
0 -> rgb 255 255 255
|
|
1 -> rgb 255 255 100
|
|
2 -> rgb 255 200 50
|
|
3 -> rgb 255 100 0
|
|
_ -> rgb 100 255 255
|
|
|
|
toRgbaString : Color -> String
|
|
toRgbaString color =
|
|
let {red, green, blue, alpha} = Color.toRgb color
|
|
in "rgba(" ++ toString red ++ ", " ++ toString green ++ ", " ++ toString blue ++ ", " ++ toString alpha ++ ")"
|
|
|
|
fst (a, b) = a
|
|
|
|
view : Model -> Html Msg
|
|
view model =
|
|
let
|
|
intro = div [] [ text "Can you transform the top grid into the bottom grid?" ]
|
|
but n = button [ onClick (Reset n) ] [ text (toString (n+1))]
|
|
puzzleSelect = div [] ( [ text "Choose puzzle " ] ++ map but (List.range 0 7) )
|
|
undoButton = button [ onClick Undo ] [ text "undo move" ]
|
|
finTxt = case model.state == model.goto of
|
|
True -> ". Yay!"
|
|
False -> ""
|
|
scoreView = div [] [ undoButton, text ("Taps: " ++ toString model.score), text finTxt ]
|
|
tile c f n = div [ style
|
|
[ ("backgroundColor", c n)
|
|
, ("width", "37px")
|
|
, ("height", "37px")
|
|
, ("display", "inline-block")
|
|
, ("textAlign", "center")
|
|
, ("padding", "30px")
|
|
]
|
|
] [f n]
|
|
row c f r = div [] (map (tile c f) r)
|
|
grid c f g = div [] (map (row c f) g)
|
|
pile c f p = grid c f (mod 3 p)
|
|
tstr = text << toString
|
|
tstr2 (n, m) = button [ style
|
|
[ ("backgroundColor", c n)
|
|
, ("width", "37px")
|
|
, ("height", "37px")
|
|
], onClick (AddAt m) ] [ tstr n ]
|
|
c = toRgbaString << color
|
|
c2 = if correct model
|
|
then always "#00FF00"
|
|
else toRgbaString << color << fst
|
|
in
|
|
div [] [ intro
|
|
, puzzleSelect
|
|
, hr [] []
|
|
, scoreView
|
|
, pile c2 tstr2 (map2 (,) model.state idxs)
|
|
, hr [] []
|
|
, pile c tstr model.goto
|
|
]
|