Browse Source

Defines Zipper and Grid. Both comonads yada yada

master
Joshua Moerman 6 years ago
commit
a71928382b
  1. 62
      Grid.elm
  2. 67
      Main.elm
  3. 108
      RandomAutomata.elm
  4. 58
      RingList.elm
  5. 15
      elm-package.json

62
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

67
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]]

108
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
)

58
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)

15
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"
}