Browse Source

Did a lot. Not sure it compiles. Tried Laziness

master
Joshua Moerman 8 years ago
parent
commit
d6ea01b330
  1. 25
      Automaton.elm
  2. 38
      Grid.elm
  3. 65
      Lazy/Zipper.elm
  4. 87
      Main.elm
  5. 58
      RingList.elm
  6. 56
      Test.elm
  7. 58
      Zipper.elm
  8. 4
      elm-package.json

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

38
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 =

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

87
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"]]

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

56
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

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

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