Did a lot. Not sure it compiles. Tried Laziness

2016-11-14 20:33:15 +01:00 · 2016-11-14 20:33:15 +01:00 · d6ea01b330
commit d6ea01b330
parent 520e314dbb
8 changed files with 259 additions and 132 deletions
--- 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
--    )
-
-
-
--- 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 =
--- a/Lazy/Zipper.elm
+++ 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)
--- 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"]]
--- a/RingList.elm
+++ b/RingList.elm
@ -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)
--- a/Test.elm
+++ 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
--- a/Zipper.elm
+++ 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)
--- 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"
 }