diff --git a/Automaton.elm b/Automaton.elm index 0cad912..a04a379 100644 --- a/Automaton.elm +++ b/Automaton.elm @@ -21,28 +21,3 @@ step : Automaton s i -> Maybe s -> i -> Maybe s step ls s0 i = case s0 of Nothing -> Nothing Just s -> List.filter (\((t, j), b) -> t == s && i == j) ls |> List.head |> Maybe.map snd - ---(=>) = (,) - ---state2Color : State -> Color ---state2Color s = case s of --- Nothing -> Color.black --- Just n -> hsl (degrees (toFloat n)*77) 1.0 (0.8 - 0.6 * (toFloat n)/size) - ---color2String : Color -> String ---color2String c = let rgb = toRgb c in "rgb(" ++ toString rgb.red ++ ", " ++ toString rgb.green ++ ", " ++ toString rgb.blue ++ ")" - ---block : Color -> Html msg ---block c = div [style ["background-color" => color2String c, "width" => "100px", "height" => "100px", "display" => "inline-block"]] [] - ---view : Model -> Html Msg ---view model = --- div [] --- ( button [ onClick Regen ] [ text "Regenerate" ] --- :: button [ onClick Sort ] [ text "Sort" ] --- :: br [] [] --- :: List.map (block << state2Color) model.states --- ) - - - diff --git a/Grid.elm b/Grid.elm index 4f76639..6004112 100644 --- a/Grid.elm +++ b/Grid.elm @@ -1,26 +1,26 @@ module Grid exposing (..) -import RingList exposing (..) +import Zipper exposing (..) -type alias Grid a = RingList (RingList a) +type alias Grid a = Zipper (Zipper a) {- Basic conversion -} generate : Int -> Int -> (Int -> Int -> a) -> Grid a generate width height gen = let - row = RingList.fromList 1 [2..width] - cols = RingList.fromList 1 [2..height] - grid = RingList.map (\y -> RingList.map (\x -> (x, y)) row) cols + row = Zipper.fromList 1 [2..width] + cols = Zipper.fromList 1 [2..height] + grid = Zipper.map (\y -> Zipper.map (\x -> (x, y)) row) cols in map (uncurry gen) grid toList : Grid a -> List (List a) -toList grid = RingList.toList <| RingList.map RingList.toList <| grid +toList grid = Zipper.toList <| Zipper.map Zipper.toList <| grid {- Functor like functions -} map : (a -> b) -> Grid a -> Grid b -map f grid = RingList.map (RingList.map f) grid +map f grid = Zipper.map (Zipper.map f) grid edit : (a -> a) -> Grid a -> Grid a -edit f grid = RingList.edit (RingList.edit f) grid +edit f grid = Zipper.edit (Zipper.edit f) grid {- Comonad functions -} extract : Grid a -> a @@ -30,7 +30,7 @@ extract grid = grid.focus.focus -- is not the right definition (this would be too simple). With the transpose -- trick it is quite ok to reason about (draw the diagrams yourself!) duplicate : Grid a -> Grid (Grid a) -duplicate grid = grid |> RingList.map RingList.duplicate |> transpose |> RingList.map RingList.duplicate |> transpose +duplicate grid = grid |> Zipper.map Zipper.duplicate |> transpose |> Zipper.map Zipper.duplicate |> transpose extend : (Grid a -> b) -> Grid a -> Grid b extend f w = map f (duplicate w) @@ -40,26 +40,26 @@ extend f w = map f (duplicate w) {- Domain functions -} shiftLeft : Grid a -> Grid a -shiftLeft grid = RingList.map RingList.shiftLeft grid +shiftLeft grid = Zipper.map Zipper.shiftLeft grid shiftRight : Grid a -> Grid a -shiftRight grid = RingList.map RingList.shiftRight grid +shiftRight grid = Zipper.map Zipper.shiftRight grid shiftUp : Grid a -> Grid a -shiftUp grid = RingList.shiftLeft grid +shiftUp grid = Zipper.shiftLeft grid shiftDown : Grid a -> Grid a -shiftDown grid = RingList.shiftRight grid +shiftDown grid = Zipper.shiftRight grid transpose : Grid a -> Grid a transpose grid = let - newBefore grid = List.map RingList.extract grid.before - newAfter grid = List.map RingList.extract grid.after - newFocus rl = RingList (newBefore rl) (extract rl) (newAfter rl) - nb = List.map newFocus <| RingList.iterate1N (List.length grid.focus.before) shiftRight grid + newBefore grid = List.map Zipper.extract grid.before + newAfter grid = List.map Zipper.extract grid.after + newFocus rl = Zipper (newBefore rl) (extract rl) (newAfter rl) + nb = List.map newFocus <| Zipper.iterate1N (List.length grid.focus.before) shiftRight grid nf = newFocus grid - na = List.map newFocus <| RingList.iterate1N (List.length grid.focus.after) shiftLeft grid - in RingList nb nf na + na = List.map newFocus <| Zipper.iterate1N (List.length grid.focus.after) shiftLeft grid + in Zipper nb nf na getNeighbours : Grid a -> List a getNeighbours grid = diff --git a/Lazy/Zipper.elm b/Lazy/Zipper.elm new file mode 100644 index 0000000..4915b14 --- /dev/null +++ b/Lazy/Zipper.elm @@ -0,0 +1,65 @@ +module Lazy.Zipper exposing (..) + +import Lazy exposing (Lazy) +import Lazy.List exposing (LazyList, (:::)) + +type alias Zipper a = + { before : LazyList a + , focus : Lazy a + , after : LazyList a + } + + +{- Basic conversion -} +fromList : a -> List a -> Zipper a +fromList a l = Zipper Lazy.List.empty (pure a) (Lazy.List.fromList l) + +toList : Zipper a -> List a +toList rl = Lazy.List.toList (Lazy.List.reverse rl.before) ++ [Lazy.force rl.focus] ++ Lazy.List.toList rl.after + +{- Functor like things -} +map : (a -> b) -> Zipper a -> Zipper b +map f rl = Zipper (Lazy.List.map f rl.before) (Lazy.map f rl.focus) (Lazy.List.map f rl.after) + +edit : (a -> a) -> Zipper a -> Zipper a +edit f rl = Zipper rl.before (Lazy.map f rl.focus) rl.after + +{- Comonad functions -} +extract : Zipper a -> a +extract rl = rl.focus |> Lazy.force + +duplicate : Zipper a -> Zipper (Zipper a) +duplicate rl = let + lefts = iterate1N (Lazy.List.length rl.before) shiftRight rl + rights = iterate1N (Lazy.List.length rl.after) shiftLeft rl + in Zipper lefts (pure rl) rights + +extend : (Zipper a -> b) -> Zipper a -> Zipper b +extend f w = map f (duplicate w) + +(=>>) : Zipper a -> (Zipper a -> b) -> Zipper b +(=>>) = flip extend + +{- Domain functions -} +shiftLeft : Zipper a -> Zipper a +shiftLeft rl = case Lazy.List.headAndTail rl.after of + Just (x, xs) -> Zipper (Lazy.force rl.focus ::: rl.before) (pure x) xs + Nothing -> case Lazy.List.headAndTail (Lazy.List.reverse rl.before) of + Just (x, xs) -> Zipper (Lazy.List.singleton (Lazy.force rl.focus)) (pure x) xs + Nothing -> Zipper nil rl.focus nil + +shiftRight : Zipper a -> Zipper a +shiftRight rl = case Lazy.List.headAndTail rl.before of + Just (x, xs) -> Zipper xs (pure x) (Lazy.force rl.focus ::: rl.after) + Nothing -> case Lazy.List.headAndTail (Lazy.List.reverse rl.after) of + Just (x, xs) -> Zipper xs (pure x) (Lazy.List.singleton (Lazy.force rl.focus)) + Nothing -> Zipper nil rl.focus nil + +{- From here we have private functions -} +iterate1N : Int -> (a -> a) -> a -> LazyList a +iterate1N n f a = case n of + 0 -> nil + m -> f a ::: Lazy.List.map f (iterate1N (m - 1) f a) + +nil = Lazy.List.empty +pure x = Lazy.lazy (always x) diff --git a/Main.elm b/Main.elm index 5b1a03b..9cedcdb 100644 --- a/Main.elm +++ b/Main.elm @@ -1,15 +1,15 @@ -import Grid exposing (..) -import RingList exposing (..) import Automaton exposing (..) +import Grid exposing (..) +import Lazy.Zipper +import Color exposing (Color) +import Dict exposing (Dict) import Html exposing (..) -import Html.Attributes exposing (..) import Html.App as App -import Html.Events exposing (..) +import Html.Attributes exposing (style) +import Html.Events exposing (onClick) import Random -import Color exposing (..) -import Time exposing (Time, second) - +import Time main = App.program @@ -19,13 +19,13 @@ main = , subscriptions = subscriptions } -width = 62 -height = 33 -states = 3 -inputs = 2 +width = 34 +height = 31 +states = 10 +inputs = 3 outputs = 3 visSize = "20px" -freq = 0.3 * second +freq = 0.3 * Time.second -- MODEL @@ -39,16 +39,16 @@ type alias Model = init : (Model, Cmd Msg) init = - ( { grid = Grid.generate width height initCell + ( { grid = generate width height initCell , system = [] , neighbours = [] }, Random.generate NewRandomAut (genAut states inputs) ) -initCell x y = case (x > 5, y > 5) of - (True, _) -> Just 1 - (_, True) -> Just 1 - _ -> Just (1 + (x + y * width) % states) +initCell x y = case (x, y) of + (18, 16) -> Just 3 + (17, 16) -> Just 1 + _ -> Just 2 -- UPDATE @@ -56,21 +56,50 @@ type Msg = Update World | NewRandomAut AutomatonT | Regen + | Init | BigStep output m = case m of Nothing -> 1 Just s -> 1 + s % outputs -getNBOutputs grid = let - ret = grid |> Grid.getNeighbours |> List.map output |> List.sum - in 1 + ret % inputs +counts : List Int -> Dict Int Int +counts ls = let + succ n = case n of + Just m -> Just (m + 1) + Nothing -> Just 1 + in List.foldr (\x m -> Dict.update x succ m) Dict.empty ls + +uniqSingleton : List Int -> Maybe Int +uniqSingleton ls = let cs = counts ls + in case Dict.toList cs of + [(n, 1), (m, 3)] -> Just n + [(n, 3), (m, 1)] -> Just m + [(1, 2), (2, 2)] -> Just 3 + [(1, 2), (3, 2)] -> Just 2 + [(2, 2), (3, 2)] -> Just 1 + _ -> Nothing + +getNBOutputs : World -> Maybe Int +getNBOutputs grid = grid + |> getNeighbours + |> List.filterMap identity + |> uniqSingleton + --|> List.map output + --|> List.map2 (\x y -> x * y) [2,2,1,0] + --|> List.sum + --|> \x -> 1 + x % inputs + +step2 : AutomatonT -> Maybe Int -> Maybe Int -> Maybe Int +step2 aut s i = case i of + Nothing -> s + Just i2 -> Automaton.step aut s i2 cellStep : AutomatonT -> World -> Maybe Int cellStep aut grid = let i = getNBOutputs grid - s = grid |> Grid.extract - t = Automaton.step aut s i + s = extract grid + t = step2 aut s i in t update : Msg -> Model -> (Model, Cmd Msg) @@ -79,7 +108,8 @@ update msg model = Update grid -> ({ model | grid = grid }, Cmd.none) NewRandomAut aut -> ({ model | system = aut }, Cmd.none) Regen -> (model, Random.generate NewRandomAut (genAut states inputs)) - BigStep -> ({ model | grid = Grid.extend (cellStep model.system) model.grid }, Cmd.none) + BigStep -> ({ model | grid = model.grid =>> cellStep model.system }, Cmd.none) + Init -> ({ model | grid = generate width height initCell }, Cmd.none) -- SUBSCRIPTIONS @@ -93,19 +123,18 @@ subscriptions model = Time.every freq (\a -> BigStep) (=>) = (,) output2Color : Int -> Color -output2Color n = hsl (degrees (toFloat n)*77) 1.0 (0.8 - 0.6 * (toFloat n + 0.5)/outputs) +output2Color n = Color.hsl (degrees (toFloat n)*77) 1.0 (0.8 - 0.6 * (toFloat n + 0.5)/outputs) color2String : Color -> String -color2String c = let rgb = toRgb c in "rgb(" ++ toString rgb.red ++ ", " ++ toString rgb.green ++ ", " ++ toString rgb.blue ++ ")" +color2String c = let rgb = Color.toRgb c in "rgb(" ++ toString rgb.red ++ ", " ++ toString rgb.green ++ ", " ++ toString rgb.blue ++ ")" block aut grid = let - col = output2Color <| output <| Grid.extract grid + col = output2Color <| output <| extract grid but = text "" -- button [ onClick (Update (Grid.edit (\_ -> cellStep aut grid) grid)) ] [ text "." ] in div [style ["background-color" => color2String col, "width" => visSize, "height" => visSize, "display" => "inline-block"]] [ but ] view model = let - dupmodel = Grid.duplicate model.grid - butts = Grid.map (block model.system) dupmodel + butts = model.grid =>> block model.system listm = Grid.toList butts viewm = List.map (\row -> div [style ["height" => visSize]] row) listm - in div [] <| viewm ++ [button [onClick BigStep] [text "big step"], button [onClick Regen] [text "regenerate"]] + in div [] <| viewm ++ [button [onClick BigStep] [text "big step"], button [onClick Regen] [text "regenerate"], button [onClick Init] [text "restart"]] diff --git a/RingList.elm b/RingList.elm deleted file mode 100644 index f35b601..0000000 --- a/RingList.elm +++ /dev/null @@ -1,58 +0,0 @@ -module RingList exposing (..) - -type alias RingList a = - { before : List a - , focus : a - , after : List a - } - -{- Basic conversion -} -fromList : a -> List a -> RingList a -fromList a l = RingList [] a l - -toList : RingList a -> List a -toList rl = List.reverse rl.before ++ [rl.focus] ++ rl.after - -{- Functor like things -} -map : (a -> b) -> RingList a -> RingList b -map f rl = RingList (List.map f rl.before) (f rl.focus) (List.map f rl.after) - -edit : (a -> a) -> RingList a -> RingList a -edit f rl = RingList rl.before (rl.focus |> f) rl.after - -{- Comonad functions -} -extract : RingList a -> a -extract rl = rl.focus - -duplicate : RingList a -> RingList (RingList a) -duplicate rl = let - lefts = iterate1N (List.length rl.before) shiftRight rl - rights = iterate1N (List.length rl.after) shiftLeft rl - in RingList lefts rl rights - -extend : (RingList a -> b) -> RingList a -> RingList b -extend f w = map f (duplicate w) - -(=>>) : RingList a -> (RingList a -> b) -> RingList b -(=>>) = flip extend - -{- Domain functions -} -shiftLeft : RingList a -> RingList a -shiftLeft rl = case rl.after of - [] -> case List.reverse rl.before of - [] -> RingList [] rl.focus [] - x::xs -> RingList [rl.focus] x xs - x::xs -> RingList (rl.focus :: rl.before) x xs - -shiftRight : RingList a -> RingList a -shiftRight rl = case rl.before of - [] -> case List.reverse rl.after of - [] -> RingList [] rl.focus [] - x::xs -> RingList xs x [rl.focus] - x::xs -> RingList xs x (rl.focus :: rl.after) - -{- From here we have private functions -} -iterate1N : Int -> (a -> a) -> a -> List a -iterate1N n f a = case n of - 0 -> [] - m -> f a :: List.map f (iterate1N (m - 1) f a) diff --git a/Test.elm b/Test.elm new file mode 100644 index 0000000..a088453 --- /dev/null +++ b/Test.elm @@ -0,0 +1,56 @@ +import Zipper exposing (..) + +import Color exposing (Color) +import Dict exposing (Dict) +import Html exposing (..) +import Html.App as App +import Html.Attributes exposing (style) +import Html.Events exposing (onClick) +import Random +import Time + +main = + App.program + { init = init + , view = view + , update = update + , subscriptions = subscriptions + } + +size = 1000 + +-- MODEL + +type alias Model = Zipper Int + +init : (Model, Cmd Msg) +init = (fromList 0 [1..size], Cmd.none) + + +-- UPDATE + +type Msg = Update (Zipper Int) + +succ n = n + 1 + +update : Msg -> Model -> (Model, Cmd Msg) +update msg model = + case msg of + Update grid -> (edit succ grid, Cmd.none) + + +-- SUBSCRIPTIONS + +subscriptions : Model -> Sub Msg +subscriptions model = Sub.none + + +-- VIEW + +buttonView : Zipper Int -> Html Msg +buttonView zppr = button [onClick (Update zppr)] [text <| toString <| extract zppr] + +view model = let + butts = model =>> buttonView + listm = List.intersperse (br [] []) (toList butts) + in div [] listm diff --git a/Zipper.elm b/Zipper.elm new file mode 100644 index 0000000..bd71e50 --- /dev/null +++ b/Zipper.elm @@ -0,0 +1,58 @@ +module Zipper exposing (..) + +type alias Zipper a = + { before : List a + , focus : a + , after : List a + } + +{- Basic conversion -} +fromList : a -> List a -> Zipper a +fromList a l = Zipper [] a l + +toList : Zipper a -> List a +toList rl = List.reverse rl.before ++ [rl.focus] ++ rl.after + +{- Functor like things -} +map : (a -> b) -> Zipper a -> Zipper b +map f rl = Zipper (List.map f rl.before) (f rl.focus) (List.map f rl.after) + +edit : (a -> a) -> Zipper a -> Zipper a +edit f rl = Zipper rl.before (rl.focus |> f) rl.after + +{- Comonad functions -} +extract : Zipper a -> a +extract rl = rl.focus + +duplicate : Zipper a -> Zipper (Zipper a) +duplicate rl = let + lefts = iterate1N (List.length rl.before) shiftRight rl + rights = iterate1N (List.length rl.after) shiftLeft rl + in Zipper lefts rl rights + +extend : (Zipper a -> b) -> Zipper a -> Zipper b +extend f w = map f (duplicate w) + +(=>>) : Zipper a -> (Zipper a -> b) -> Zipper b +(=>>) = flip extend + +{- Domain functions -} +shiftLeft : Zipper a -> Zipper a +shiftLeft rl = case rl.after of + [] -> case List.reverse rl.before of + [] -> Zipper [] rl.focus [] + x::xs -> Zipper [rl.focus] x xs + x::xs -> Zipper (rl.focus :: rl.before) x xs + +shiftRight : Zipper a -> Zipper a +shiftRight rl = case rl.before of + [] -> case List.reverse rl.after of + [] -> Zipper [] rl.focus [] + x::xs -> Zipper xs x [rl.focus] + x::xs -> Zipper xs x (rl.focus :: rl.after) + +{- From here we have private functions -} +iterate1N : Int -> (a -> a) -> a -> List a +iterate1N n f a = case n of + 0 -> [] + m -> f a :: List.map f (iterate1N (m - 1) f a) diff --git a/elm-package.json b/elm-package.json index 34b77a8..adf919b 100644 --- a/elm-package.json +++ b/elm-package.json @@ -8,8 +8,10 @@ ], "exposed-modules": [], "dependencies": { + "elm-community/elm-lazy-list": "1.3.0 <= v < 2.0.0", "elm-lang/core": "4.0.5 <= v < 5.0.0", - "elm-lang/html": "1.1.0 <= v < 2.0.0" + "elm-lang/html": "1.1.0 <= v < 2.0.0", + "elm-lang/lazy": "1.0.0 <= v < 2.0.0" }, "elm-version": "0.17.1 <= v < 0.18.0" }