Commit ed6693ba authored by Thorsten Wißmann's avatar Thorsten Wißmann 🐧
Browse files

Upgrade to elm 0.18.0

parent 150dcb1d
......@@ -8,10 +8,10 @@
],
"exposed-modules": [],
"dependencies": {
"elm-lang/animation-frame": "1.0.0 <= v < 2.0.0",
"elm-lang/core": "4.0.3 <= v < 5.0.0",
"elm-lang/html": "1.1.0 <= v < 2.0.0",
"elm-lang/svg": "1.1.1 <= v < 2.0.0"
"elm-lang/animation-frame": "1.0.1 <= v < 2.0.0",
"elm-lang/core": "5.0.0 <= v < 6.0.0",
"elm-lang/html": "2.0.0 <= v < 3.0.0",
"elm-lang/svg": "2.0.0 <= v < 3.0.0"
},
"elm-version": "0.17.1 <= v < 0.18.0"
"elm-version": "0.18.0 <= v < 0.19.0"
}
......@@ -41,7 +41,7 @@ fromArray arr parent =
withParents =
Array.indexedMap (\idx el -> Node idx el (parent el) []) arr
hasFst : (Maybe a, b) -> Maybe (a,b)
hasFst : (Maybe x, b) -> Maybe (x,b)
hasFst (maybe_a, b) = Maybe.map (flip (,) b) maybe_a
registerAtParents : List (Int, Int) -- List of parent,child pairs
......@@ -79,7 +79,7 @@ mapNode f arr =
parent : ArrayTree a -> Node a -> Maybe (Node a)
parent arr node =
Maybe.andThen node.parent (flip Array.get arr)
Maybe.andThen (flip Array.get arr) node.parent
children : ArrayTree a -> Node a -> List (Node a)
children arr node =
......
......@@ -63,19 +63,19 @@ hasError car =
{-|
activate the error field using the current time
-}
setError' : Time -> CarriageFlags -> CarriageFlags
setError' now flags =
setError_ : Time -> CarriageFlags -> CarriageFlags
setError_ now flags =
-- mark the car as errornous for the next 2 seconds
{ flags | error_until = Just (now + 2 * second) }
setError : Time -> Carriage -> Carriage
setError now car =
{ car | flags = setError' now car.flags }
{ car | flags = setError_ now car.flags }
{-| Clear the error field if the time has progressed enough
-}
clearError' : Time -> CarriageFlags -> CarriageFlags
clearError' now flags =
clearError_ : Time -> CarriageFlags -> CarriageFlags
clearError_ now flags =
{ flags
| error_until =
case flags.error_until of
......@@ -89,7 +89,7 @@ clearError now car =
case car.flags.error_until of
Just time ->
if time <= now
then { car | flags = clearError' now car.flags }
then { car | flags = clearError_ now car.flags }
else car
Nothing ->
car
......@@ -164,7 +164,7 @@ renderCarriageAt : CarriageFlags -> List (Svg.Attribute msg)
renderCarriageAt flags attributes (a1,p1) (a2,p2) =
let
car_center = segment p1 p2 0.5
delta = p2 `minus` p1
delta = minus p2 p1
car_angle = (atan2 delta.y delta.x) / 2.0 / pi * 360.0
selected_class : List String -> List String
selected_class =
......@@ -225,7 +225,7 @@ renderCarriageOnPath offset path attributes car =
offset2point offset =
RT.queryDistanceDown path offset
`Maybe.andThen` (\(track,offs) ->
|> Maybe.andThen (\(track,offs) ->
TrackA.trackWalkDistance track (
--(if car.flags.selected then Debug.log "offset" else identity)
offs
......@@ -303,7 +303,7 @@ sendCarriageToSafe arg =
Nothing
Just delta ->
RT.verifyPathToTrack importer arg.restingplace delta
`Maybe.andThen` \(verified_delta,_) ->
|> Maybe.andThen (\(verified_delta,_) ->
let
delta_len =
RT.pathLength verified_delta
......@@ -323,6 +323,7 @@ sendCarriageToSafe arg =
, time_passed = 0
, total_time = Time.second * (delta_len / carConfig.speed)
}
)
Nothing ->
case (List.unprefix arg.restingpath arg.new_path) of
Nothing ->
......@@ -331,7 +332,7 @@ sendCarriageToSafe arg =
Nothing
Just delta ->
RT.verifyPathToTrack importer arg.targetplace delta
`Maybe.andThen` \(verified_delta,_) ->
|> Maybe.andThen (\(verified_delta,_) ->
let
delta_len =
RT.pathLength verified_delta
......@@ -351,6 +352,7 @@ sendCarriageToSafe arg =
, time_passed = 0
, total_time = Time.second * (delta_len / carConfig.speed)
}
)
sendCarriageTo : RT.LayoutedRailTree t j -> RT.Path -> Carriage -> Carriage
sendCarriageTo rt new_path car =
......@@ -364,10 +366,12 @@ sendCarriageTo rt new_path car =
--targetplace : Maybe (RT.LayoutedRailTree t j)
targetplace = RT.query rt new_path
restingtrack =
restingplace `Maybe.andThen` RT.isTrack
restingplace
|> Maybe.andThen RT.isTrack
|> Maybe.map Has.witness
targettrack =
targetplace `Maybe.andThen` RT.isTrack
targetplace
|> Maybe.andThen RT.isTrack
|> Maybe.map Has.witness
in
case (restingplace,targetplace,restingtrack,targettrack) of
......@@ -391,23 +395,23 @@ carriageOnInterval : RT.Path -> RT.Path -> Carriage -> Bool
carriageOnInterval p1 p2 car =
let
(upper,lower) =
if (p1 `List.prefix_of` p2)
if (List.prefix_of p1 p2)
then (p1,p2)
else (p2,p1)
in
case car.motion of
Resting p ->
(upper `List.prefix_of` p) && (p `List.prefix_of` lower)
(List.prefix_of upper p) && (List.prefix_of p lower)
Moving m ->
let
-- tells wether path p is on the track when going down from u to l
is_on : RT.Path -> (RT.Path,RT.Path) -> Bool
is_on p (u,l) = ((u `List.prefix_of` p) && (p `List.prefix_of` l))
is_on p (u,l) = ((List.prefix_of u p) && (List.prefix_of p l))
x1 = m.upper_point
real_delta =
-- m.delta contains an additional RT.Further at the end
m.delta
|> List.map fst
|> List.map Tuple.first
|> List.reverse
|> List.drop 1
|> List.reverse
......@@ -417,20 +421,20 @@ carriageOnInterval p1 p2 car =
in
-- we have an intersection of the tracks (upper,lower) and (x1,x2)
-- if any of the endpoints lies on the other track
if (upper `is_on` (x1,x2))
|| (lower `is_on` (x1,x2))
|| (x1 `is_on` (upper,lower))
|| (x2 `is_on` (upper,lower))
if (is_on upper (x1,x2))
|| (is_on lower (x1,x2))
|| (is_on x1 (upper,lower))
|| (is_on x2 (upper,lower))
then
-- in case there is an intersection, ignore it
-- if the motion is 'parallel',
if (p1 `is_below` x2
&& p2 `is_below` x1
if (is_below p1 x2
&& is_below p2 x1
&& m.upper_point == m.final_point) -- motion upwards
then False -- no conflict because no 'overtake' can happen
else
if (p1 `is_above` x1
&& p2 `is_above` x2
if (is_above p1 x1
&& is_above p2 x2
&& m.upper_point /= m.final_point) -- motion downwards
then False -- no conflict
else True -- conflict
......
......@@ -29,12 +29,12 @@ setWitness (HasContainer a b) c = HasContainer c b
unit : a -> Has a ()
unit a = HasContainer a ()
swap: Has a (Has a' b) -> Has a' (Has a b)
swap(HasContainer a (HasContainer a' b)) =
HasContainer a' (HasContainer a b)
swap: Has a (Has a_ b) -> Has a_ (Has a b)
swap(HasContainer a (HasContainer a_ b)) =
HasContainer a_ (HasContainer a b)
merge : Has a (Has a' b) -> Has (a,a') b
merge (HasContainer a (HasContainer a' b)) =
HasContainer (a,a') b
merge : Has a (Has a_ b) -> Has (a,a_) b
merge (HasContainer a (HasContainer a_ b)) =
HasContainer (a,a_) b
-- vim: ft=elm et ts=2 sw=2
......@@ -2,6 +2,7 @@ module ListUtils exposing (..)
import Array
import Array exposing (Array)
import Tuple
-- returns something if the second list is the prefix of the first
unprefix : List a -> List a -> Maybe (List a)
......@@ -57,7 +58,7 @@ isSorted le list =
[] -> True
(_::[]) -> True
(a1::a2::tail) ->
if a1 `le` a2
if le a1 a2
then isSorted le (a2::tail)
else False
......@@ -71,7 +72,7 @@ differentValue : List a -> List a -> List (Int,a,a)
differentValue xs ys =
List.map2 (,) xs ys
|> List.indexedMap (,)
|> List.filter (uncurry (/=) << snd)
|> List.filter (uncurry (/=) << Tuple.second)
|> List.map (\(a,(b,c)) -> (a,b,c))
......@@ -122,12 +123,13 @@ resultForAll =
flip List.foldr (Result.Ok []) (\cur tl ->
case (cur) of
(Result.Ok a) ->
tl `Result.andThen` (Result.Ok << (::) a)
tl
|> Result.andThen (Result.Ok << (::) a)
(Result.Err x) ->
tl
`Result.andThen` (always (Result.Err []))
|> Result.formatError ((::) x)
|> Result.andThen (always (Result.Err []))
|> Result.mapError ((::) x)
)
{-| Take elements as long fulfill a certain proposition
......
import Html exposing (Html, button, div, text, a, img)
import Html as Html
import Html.App as Html
import Html.Lazy as Html
import Html.Attributes as HA
import Html.Events exposing (onClick)
......@@ -155,7 +154,7 @@ update msg model =
)
SwitchNet str_idx ->
case (String.toInt str_idx `Result.andThen` validateIndex model.archive) of
case (String.toInt str_idx |> Result.andThen (validateIndex model.archive)) of
Err m ->
Debug.log "Selected index not valid" m
|> always (model, Cmd.none)
......@@ -191,7 +190,7 @@ update msg model =
, Cmd.none
)
SwitchQuery str_idx ->
case (String.toInt str_idx `Result.andThen` validateIndex model.queries) of
case (String.toInt str_idx |> Result.andThen (validateIndex model.queries)) of
Err m ->
Debug.log "Selected index not valid" m
|> always (model, Cmd.none)
......@@ -200,7 +199,7 @@ update msg model =
new_hist : RPHist.History
new_hist =
Array.get model.network_index model.archive
`Maybe.andThen` (Array.get query_idx << snd)
|> Maybe.andThen (Array.get query_idx << Tuple.second)
|> Maybe.withDefault RPHist.init
in
( { model
......
......@@ -10,7 +10,7 @@ type NonEmptyList a
Meaning that:
foldl f [x, y, z] == (x `f` y) `f` z
foldl f [x, y, z] == f (f x y) f z
-}
foldl : (a -> a -> a) -> NonEmptyList a -> a
foldl =
......@@ -18,9 +18,9 @@ foldl =
foldl_with : (a -> a -> a) -> a -> NonEmptyList a -> a
foldl_with f x1 xs1 =
case xs1 of
Nil x2 -> x1 `f` x2
Nil x2 -> f x1 x2
Cons x2 xs2 ->
foldl_with f (x1 `f` x2) xs2
foldl_with f (f x1 x2) xs2
in
\f l ->
case l of
......@@ -31,13 +31,13 @@ foldl =
foldr f l =
List.foldr f (head l) (tail l)
foldr f [x, y, z] == x `f` (y `f` z)
foldr f [x, y, z] == f x (f y z)
-}
foldr : (a -> a -> a) -> NonEmptyList a -> a
foldr f l =
case l of
Nil x -> x
Cons x xs -> x `f` (foldr f xs)
Cons x xs -> f x (foldr f xs)
map : (a -> b) -> NonEmptyList a -> NonEmptyList b
map f l =
......@@ -49,13 +49,13 @@ indexedMap : (Int -> a -> b) -> NonEmptyList a -> NonEmptyList b
indexedMap =
let
-- a helper that additionally gets the index of the first element
indexedMap' : Int -> (Int -> a -> b) -> NonEmptyList a -> NonEmptyList b
indexedMap' idx f l =
indexedMapWithFirst : Int -> (Int -> a -> b) -> NonEmptyList a -> NonEmptyList b
indexedMapWithFirst idx f l =
case l of
Nil x -> Nil (f idx x)
Cons x xs -> Cons (f idx x) (indexedMap' (idx+1) f xs)
Cons x xs -> Cons (f idx x) (indexedMapWithFirst (idx+1) f xs)
in
indexedMap' 0
indexedMapWithFirst 0
{-|
Maybe.map head (fromList l) == List.head l
......
......@@ -266,8 +266,8 @@ viewQuery query =
-}
decoderDropMaybe : Json.Decoder (Maybe a) -> Json.Decoder a
decoderDropMaybe d =
d `Json.andThen`
(Maybe.withDefault (Json.fail "") << Maybe.map Json.succeed)
d
|> Json.andThen (Maybe.withDefault (Json.fail "") << Maybe.map Json.succeed)
onKeyDown : (Int -> Maybe msg) -> Html.Attribute msg
onKeyDown tagger =
......@@ -368,7 +368,7 @@ viewSmvOptions model =
[ Html.td [HA.class "smvruncommand" ]
[ Html.div []
[ Html.input
[ HA.type' "text"
[ HA.type_ "text"
, onKeyDown (onEnter CommandRun)
, HE.onInput (\t -> UpdateField (\m -> { m | next_command = t }))
] []
......@@ -377,7 +377,7 @@ viewSmvOptions model =
, viewShuntCommandHelp
, Html.div []
[ Html.input
[ HA.type' "text"
[ HA.type_ "text"
, onKeyDown (onEnter QueryRun)
, HE.onInput (\t -> UpdateField (\m -> { m | next_query = t }))
, HA.placeholder "A list of car indices, e.g. 3 1 2"
......@@ -394,7 +394,7 @@ viewSmvOptions model =
, Html.div []
[ Html.label []
[ Html.input
[ HA.type' "checkbox"
[ HA.type_ "checkbox"
, HE.onCheck StickToBottom
, HA.checked model.stickToBottom
] []
......
......@@ -56,7 +56,7 @@ parseShuntMovement str =
x -> Result.Err <|
"The first charater must be f or b but not \""
++ String.cons x "\"."
) `Result.andThen` (\dir ->
) |> Result.andThen (\dir ->
let idx = Char.toCode s - Char.toCode 'a' in
if 0 <= idx && idx < 26
then Result.Ok <|
......@@ -89,7 +89,7 @@ shuntMovementToString sm =
parseCompileCarMovements : RT.RailTree t j -> Array RT.Path -> String -> List (Int,RT.Path)
parseCompileCarMovements rt cars command =
parseShuntMovement command
|> Result.formatError (Debug.log "can not parse command")
|> Result.mapError (Debug.log "can not parse command")
|> Result.map (\cmd ->
-- get the first car movement
Shunt.compileCarMovements rt cars cmd
......@@ -133,8 +133,10 @@ try_spec line =
in
case (m <| Array.get 0 params, m <| Array.get 1 params) of
(Just query, Just str_res) ->
parseTrainOrder query `Result.andThen` (\query ->
try_bool str_res `Result.andThen` (\res ->
parseTrainOrder query
|> Result.andThen (\query ->
try_bool str_res
|> Result.andThen (\res ->
Result.Ok (Specification query res)))
(_, _) ->
......@@ -146,7 +148,7 @@ try_state = Result.map State << extract_param state_regex
try_move : String -> Result String TraceLine
try_move line =
extract_param move_regex line
`Result.andThen` (Result.formatError ((++)"Invalid move parameter: ") << parseShuntMovement)
|> Result.andThen (Result.mapError ((++)"Invalid move parameter: ") << parseShuntMovement)
|> Result.map Move
parseTraceLine : String -> Result String TraceLine
......@@ -164,19 +166,19 @@ parseTraceLine line =
or = resultOr semicoloned
in
try_spec trimmed `or` try_move trimmed `or` try_state trimmed
or (or (try_spec trimmed) (try_move trimmed)) (try_state trimmed)
parseTrace : String -> Result String (List TraceLine)
parseTrace buf =
Regex.split Regex.All (regex "\n") buf
|> List.indexedMap (,) -- annotate with line numbers
|> List.filter (lineHasRelevantInformation << snd) -- only keep relevant lines
|> List.filter (lineHasRelevantInformation << Tuple.second) -- only keep relevant lines
|> List.map (\(i,l) ->
parseTraceLine l
|> Result.formatError ((++) ("Line " ++ toString i ++ ": "))
|> Result.mapError ((++) ("Line " ++ toString i ++ ": "))
)
|> LU.resultForAll
|> Result.formatError (String.concat << List.intersperse "\n")
|> Result.mapError (String.concat << List.intersperse "\n")
|> Result.map addMissingMoves
|> Result.map disableLastMove
|> Result.map (flip (++) [CompressTrain])
......@@ -198,7 +200,7 @@ parseTrainOrder str =
|> List.filterMap identity
|> List.map (String.toInt)
|> LU.resultForAll
|> Result.formatError (String.concat << List.intersperse ", ")
|> Result.mapError (String.concat << List.intersperse ", ")
|> Result.map (LU.dropDuplicates)
......
......@@ -112,7 +112,7 @@ alignUpwards shunt =
var_uppermost = Var (NEL.head shunt)
len = NEL.length shunt
shunt_str = showShunt <| NEL.toList shunt
shunt_idx = fst (NEL.head shunt)
shunt_idx = Tuple.first (NEL.head shunt)
ith_track : Int -> TrackIdx
ith_track i =
Array.get i (Array.fromList (NEL.toList shunt))
......@@ -225,7 +225,7 @@ alignDownwards shunt =
, first_occupied = NEL.last shunt -- the bottommost track is filled first
, last_occupied = NEL.head shunt -- the topmost track is filled last
, tracks = shunt
, index = fst (NEL.head shunt)
, index = Tuple.first (NEL.head shunt)
, afterNewCarFromAbove =
reversedAlignment.afterNewCarFromBelow << reversed_idx
, afterNewCarFromBelow =
......@@ -240,7 +240,7 @@ alignDownwards shunt =
cars_here = List.take len cars
leftover_cars = List.drop len cars
in
( fst <| reversedAlignment.hasCarsCondition <| List.reverse cars_here
( Tuple.first <| reversedAlignment.hasCarsCondition <| List.reverse cars_here
, leftover_cars
)
)
......@@ -318,8 +318,10 @@ compile rail_example additional_queries =
|> List.filterMap identity -- drop all shunts with no parent
|> ListUtils.product directions
|> List.filterMap (\(dir,(idx,parent_idx)) ->
Array.get parent_idx shuntAccess `Maybe.andThen` (\parent_shunt ->
Array.get idx shuntAccess `Maybe.andThen` (\this_shunt ->
Array.get parent_idx shuntAccess
|> Maybe.andThen (\parent_shunt ->
Array.get idx shuntAccess
|> Maybe.andThen (\this_shunt ->
Just <| DetailedShuntMovement
(Shunt.ShuntMovement dir idx)
parent_shunt
......@@ -344,9 +346,9 @@ compile rail_example additional_queries =
|> Maybe.map NEL.toList
)
-- get the track piece's path
`Maybe.andThen` (Array.get t << Array.fromList)
|> Maybe.andThen (Array.get t << Array.fromList)
-- find a car at this path
`Maybe.andThen` (ListUtils.find rail_example.car_positions)
|> Maybe.andThen (ListUtils.find rail_example.car_positions)
-- the condition that a shunt movement is possible
move_possible : DetailedShuntMovement -> Condition
......
......@@ -25,7 +25,7 @@ determinant a b = a.x * b.y - a.y * b.x
type alias Segment = Float -> P2D
segment : P2D -> P2D -> Segment
segment p1 p2 pos = ((1.0 - pos) `dot` p1) `shift` (pos `dot` p2)
segment p1 p2 pos = shift (dot (1.0 - pos) p1) (dot pos p2)
segmentCat : Segment -> Segment -> Segment
segmentCat s1 s2 at = if at <= 0.5 then s1 (2.0 * at) else s2 (2.0 * (at - 0.5))
......
......@@ -51,10 +51,10 @@ type alias Endo a = a -> a
bot = RT.Junction (Has.unit RT.AutoAngles) []
t : Endo (RT.RailTree (Has RT.Hint ()) (Has RT.Angles ()))
t = RT.Track <| Has.unit RT.Straight
t' : Float -> Endo (RT.RailTree (Has RT.Hint ()) (Has RT.Angles ()))
t' angle = RT.Track << Has.unit <| RT.Bent angle
t_ : Float -> Endo (RT.RailTree (Has RT.Hint ()) (Has RT.Angles ()))
t_ angle = RT.Track << Has.unit <| RT.Bent angle
j args = RT.Junction (Has.unit RT.AutoAngles) args
j' from to args = RT.Junction (Has.unit (RT.FirstLast from to)) args
j_ from to args = RT.Junction (Has.unit (RT.FirstLast from to)) args
big : RailExample
......@@ -71,19 +71,19 @@ big =
, []
]
, rail_net =
t <| t' -30 <| t
<| j' 20 -60
[ t' -20 <| t <|
j' 0 -45
[ t' -30 <| t <| bot
t <| t_ -30 <| t
<| j_ 20 -60
[ t_ -20 <| t <|
j_ 0 -45
[ t_ -30 <| t <| bot
, t <| bot
]
, t <| t <| bot
, t <| t' 20 <|
, t <| t_ 20 <|
j
[ t' 75 <| t' -90.0 <| t' 30.0 <| bot
, t' 50 <| t' 40 <| t <| t' 40 <| t' 20.0 <|
t' 30 <| t' 40 <| bot
[ t_ 75 <| t_ -90.0 <| t_ 30.0 <| bot
, t_ 50 <| t_ 40 <| t <| t_ 40 <| t_ 20.0 <|
t_ 30 <| t_ 40 <| bot
]
]
, queries = []
......@@ -121,7 +121,7 @@ one_junction head subs =
{ name =
"Inglenook " ++ toString head.len
++ (String.concat <| List.map (toString << (.len)) subs)
, rail_net = (shunt2net head) (j' angle1 angle2 <| List.indexedMap ith_subshunt subs)
, rail_net = (shunt2net head) (j_ angle1 angle2 <| List.indexedMap ith_subshunt subs)
, car_positions =
let
head_prefix = List.repeat head.len RT.Further
......@@ -148,11 +148,11 @@ one_junction head subs =
inglenook_422 =
{ name = "Inglenook 422"
, rail_net =
t <| t <| j' 0 -40
[ t <| t' -10 <| t' -20 <| t <| bot
, j' 25 -15
[ t' 10 <| t <| bot
, t' 30 <| t' 20 <| bot
t <| t <| j_ 0 -40
[ t <| t_ -10 <| t_ -20 <| t <| bot
, j_ 25 -15
[ t_ 10 <| t <| bot
, t_ 30 <| t_ 20 <| bot
]
]
, car_positions =
......@@ -170,11 +170,11 @@ inglenook_422 =
inglenook_533 =
{ name = "Inglenook 533"
, rail_net =
t <| t <| t <| j' 0 -40
[ t' -5 <| t' -25 <| t' -25 <| t' -25 <| t <| bot
, j' 25 -25
[ t' -20 <| t' -15 <| t' -15 <| bot
, t' 25 <| t' 0 <| t' -20 <| bot
t <| t <| t <| j_ 0 -40
[ t_ -5 <| t_ -25 <| t_ -25 <| t_ -25 <| t <| bot
, j_ 25 -25
[ t_ -20 <| t_ -15 <| t_ -15 <| bot
, t_ 25 <| t_ 0 <| t_ -20 <| bot
]
]
, car_positions =
......@@ -261,7 +261,7 @@ getQuery re idx =
re.queries
|> Array.fromList
|> Array.get idx
|> Maybe.withDefault (List.indexedMap (curry fst) re.car_positions)
|> Maybe.withDefault (List.indexedMap (curry Tuple.first) re.car_positions)
queryCount : RailExample -> Int
......