From a71928382bb0a5b939eb309951c0347df66a2db5 Mon Sep 17 00:00:00 2001
From: Joshua Moerman <lakseru@gmail.com>
Date: Mon, 29 Aug 2016 23:11:44 +0200
Subject: [PATCH] Defines Zipper and Grid. Both comonads yada yada

---
 Grid.elm           |  62 ++++++++++++++++++++++++++
 Main.elm           |  67 ++++++++++++++++++++++++++++
 RandomAutomata.elm | 108 +++++++++++++++++++++++++++++++++++++++++++++
 RingList.elm       |  58 ++++++++++++++++++++++++
 elm-package.json   |  15 +++++++
 5 files changed, 310 insertions(+)
 create mode 100644 Grid.elm
 create mode 100644 Main.elm
 create mode 100644 RandomAutomata.elm
 create mode 100644 RingList.elm
 create mode 100644 elm-package.json

diff --git a/Grid.elm b/Grid.elm
new file mode 100644
index 0000000..2d42ef2
--- /dev/null
+++ b/Grid.elm
@@ -0,0 +1,62 @@
+module Grid exposing (..)
+
+import RingList exposing (..)
+
+type alias Grid a = RingList (RingList 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
+  in map (uncurry gen) grid
+
+toList : Grid a -> List (List a)
+toList grid = RingList.toList <| RingList.map RingList.toList <| grid
+
+{- Functor like functions -}
+map : (a -> b) -> Grid a -> Grid b
+map f grid = RingList.map (RingList.map f) grid
+
+edit : (a -> a) -> Grid a -> Grid a
+edit f grid = RingList.edit (RingList.edit f) grid
+
+{- Comonad functions -}
+extract : Grid a -> a
+extract grid = grid.focus.focus
+
+-- It was quite difficult to define duplicate. A simple RL.map RL.dup >> RL.dup
+-- 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
+
+extend : (Grid a -> b) -> Grid a -> Grid b
+extend f w = map f (duplicate w)
+
+(=>>) : Grid a -> (Grid a -> b) -> Grid b
+(=>>) = flip extend
+
+{- Domain functions -}
+shiftLeft : Grid a -> Grid a
+shiftLeft grid = RingList.map RingList.shiftLeft grid
+
+shiftRight : Grid a -> Grid a
+shiftRight grid = RingList.map RingList.shiftRight grid
+
+shiftUp : Grid a -> Grid a
+shiftUp grid = RingList.shiftLeft grid
+
+shiftDown : Grid a -> Grid a
+shiftDown grid = RingList.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
+    nf = newFocus grid
+    na = List.map newFocus <| RingList.iterate1N (List.length grid.focus.after) shiftLeft grid
+  in RingList nb nf na
diff --git a/Main.elm b/Main.elm
new file mode 100644
index 0000000..3930ee0
--- /dev/null
+++ b/Main.elm
@@ -0,0 +1,67 @@
+import Grid exposing (..)
+import RingList exposing (..)
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.App as App
+import Html.Events exposing (..)
+import Random
+import Color exposing (..)
+import Time exposing (Time, second)
+
+
+main =
+  App.program
+    { init = init
+    , view = view
+    , update = update
+    , subscriptions = subscriptions
+    }
+
+width = 21
+height = 16
+
+-- MODEL
+
+type alias World = Grid (Int, Float)
+type alias Model =
+    { grid : World
+    , history : List (Int, Float)
+    }
+
+init : (Model, Cmd Msg)
+init = (Model (Grid.generate width height (\x y -> (x, toFloat y))) [], Cmd.none)
+
+
+-- UPDATE
+
+type Msg
+  = Update World
+
+succ (n, m) = (n + 1, m * 2)
+
+update : Msg -> Model -> (Model, Cmd Msg)
+update msg model =
+  case msg of
+    Update grid -> (Model grid (Grid.extract grid :: model.history), Cmd.none)
+
+
+-- SUBSCRIPTIONS
+
+subscriptions : Model -> Sub Msg
+subscriptions model = Sub.none
+
+
+-- VIEW
+
+butt : World -> Html Msg
+--butt rl = button [ onClick (Update (RingList.edit succ rl)) ] [ RingList.extract rl |> toString |> text ]
+butt grid = button [ onClick (Update (Grid.edit succ grid)) ] [ Grid.extract grid |> toString |> text ]
+
+view : Model -> Html Msg
+view model = let
+    dupmodel = Grid.duplicate model.grid
+    butts = Grid.map butt dupmodel
+    listm = Grid.toList butts
+    viewm = List.map (\row -> div [] (br [] [] :: row)) listm
+  in div [] <| viewm ++ [div [] [model.history |> toString |> text]]
diff --git a/RandomAutomata.elm b/RandomAutomata.elm
new file mode 100644
index 0000000..073c7ea
--- /dev/null
+++ b/RandomAutomata.elm
@@ -0,0 +1,108 @@
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.App as App
+import Html.Events exposing (..)
+import Random
+import Color exposing (..)
+import Time exposing (Time, second)
+
+
+main =
+  App.program
+    { init = (init size)
+    , view = view
+    , update = update
+    , subscriptions = subscriptions
+    }
+
+size = 36
+
+-- MODEL
+
+type alias State = Maybe Int
+type alias Automaton = List (Int, Int)
+
+type alias Model =
+  { states : List State
+  , system : Automaton
+  }
+
+
+init : Int -> (Model, Cmd Msg)
+init n = (Model (List.map Just [1 .. size]) [], Random.generate Update (genAut n))
+
+
+
+-- UPDATE
+
+type Msg
+  = Step
+  | Regen
+  | Update Automaton
+  | Sort
+
+zip = List.map2 (,)
+
+genAut : Int -> Random.Generator Automaton
+genAut n = Random.map (zip [1 .. n]) (Random.list n <| Random.int 1 n)
+
+step : Automaton -> State -> State
+step ls s0 = case s0 of
+  Nothing -> Nothing
+  Just s -> List.filter (\(a,b) -> a == s) ls |> List.head |> Maybe.map snd
+
+cmp l r = case (l, r) of
+  (Nothing, Nothing) -> EQ
+  (Nothing, Just n) -> LT
+  (Just n, Nothing) -> GT
+  (Just n, Just m) -> compare n m
+
+update : Msg -> Model -> (Model, Cmd Msg)
+update msg model =
+  case msg of
+    Step -> (Model (List.map (step model.system) model.states) model.system, Cmd.none)
+
+    Regen ->
+      init size
+
+    Update newAut ->
+      (Model model.states newAut, Cmd.none)
+
+    Sort ->
+      (Model (List.sortWith cmp model.states) model.system, Cmd.none)
+
+
+-- SUBSCRIPTIONS
+
+subscriptions : Model -> Sub Msg
+subscriptions model =
+  Time.every (0.1 * second) (\a -> Step)
+
+
+
+-- VIEW
+
+(=>) = (,)
+
+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/RingList.elm b/RingList.elm
new file mode 100644
index 0000000..f35b601
--- /dev/null
+++ b/RingList.elm
@@ -0,0 +1,58 @@
+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/elm-package.json b/elm-package.json
new file mode 100644
index 0000000..34b77a8
--- /dev/null
+++ b/elm-package.json
@@ -0,0 +1,15 @@
+{
+    "version": "1.0.0",
+    "summary": "helpful summary of your project, less than 80 characters",
+    "repository": "https://github.com/user/project.git",
+    "license": "BSD3",
+    "source-directories": [
+        "."
+    ],
+    "exposed-modules": [],
+    "dependencies": {
+        "elm-lang/core": "4.0.5 <= v < 5.0.0",
+        "elm-lang/html": "1.1.0 <= v < 2.0.0"
+    },
+    "elm-version": "0.17.1 <= v < 0.18.0"
+}