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

Implement train compression

parent 714f71f1
......@@ -45,5 +45,9 @@ $ elm repl
* What's wrong with data_422/256.sol?
* Must one ignore the last move command? See data_422/170.sol, data_422/256.sol?
* Force-finish animation on Smv step.
* show shunt names in the model
......@@ -124,4 +124,17 @@ resultForAll =
|> Result.formatError ((::) x)
)
{-| Take elements as long fulfill a certain proposition
-}
takeWhile : (a -> Bool) -> List a -> List a
takeWhile prop list =
case list of
[] -> []
(x::xs) ->
if (prop x)
then x::(takeWhile prop xs)
else []
-- vim: ft=elm et ts=2 sw=2
......@@ -179,6 +179,9 @@ nextTraceCommand delta model =
Just (NuSmvInput.Move _) ->
{ model | traceline_idx = new_idx }
Just (NuSmvInput.CompressTrain) ->
{ model | traceline_idx = new_idx }
runTraceLine : NuSmvInput.TraceLine -> Model -> Model
runTraceLine line model =
case line of
......@@ -199,6 +202,18 @@ runTraceLine line model =
|> List.foldl RailPuzzle.update model.rails
|> (\rails -> { model | rails = rails })
NuSmvInput.CompressTrain ->
NuSmvInput.compressTrain
(RailPuzzle.carPositions model.rails)
(RailPuzzle.getQuery model.rails)
-- transform that into something of type RailPuzzle.Msg
|> List.map (uncurry RailPuzzle.updateMoveCar)
|> Debug.log "actions"
-- and apply it to the model
|> List.foldl RailPuzzle.update model.rails
|> (\rails -> { model | rails = rails })
stylesheet path =
Html.node "link"
[ HA.attribute "rel" "stylesheet"
......@@ -297,6 +312,11 @@ viewTraceResult traceline_idx res =
Html.div
[HA.class <| "traceMove" ++ suffix ]
[Html.text ("move = " ++ NuSmvInput.shuntMovementToString sm)]
NuSmvInput.CompressTrain ->
Html.div
[HA.class <| "traceCompressTrain" ++ suffix ]
[]
in
case res of
Result.Err err ->
......
......@@ -253,6 +253,7 @@ type TraceLine
= Specification (List Int) Bool
| State String
| Move ShuntMovement
| CompressTrain -- close gaps between the cars in a finished train
reg_submatches : Regex -> String -> Array (Maybe String)
reg_submatches reg str =
......@@ -335,6 +336,7 @@ parseTrace buf =
|> LU.resultForAll
|> Result.formatError (String.concat << List.intersperse "\n")
|> Result.map addMissingMoves
|> Result.map (flip (++) [CompressTrain])
{-|
......@@ -379,19 +381,63 @@ addMissingMoves list =
cm lastmove hadmove l =
case l of
[] -> []
((Move x)) :: xs ->
(Move x) :: xs ->
(Move x) :: (cm (Just (Move x)) True xs)
((Specification y z)) :: xs ->
(Specification y z) :: xs ->
(Specification y z) :: cm lastmove hadmove xs
((State s)) :: xs ->
(State s) :: xs ->
case (hadmove,lastmove) of
(False, Just m) ->
m :: (State s ) :: cm lastmove False xs
(_,_) ->
(State s) :: cm lastmove False xs
(CompressTrain) :: xs ->
(CompressTrain) :: cm lastmove hadmove xs
in cm Nothing True list
{-| Given the cars' positions, move the cars of the specified
train in such a way, that they are consecutive.
-}
compressTrain : Array RT.Path -> List Int -> List (Int,RT.Path)
compressTrain cars =
let
moveUp : Int -> (Maybe RT.Path, List (Int,RT.Path)) -> (Maybe RT.Path, List (Int,RT.Path))
moveUp idx (last_car_path,acc) =
case (last_car_path, Array.get idx (Debug.log "cars" cars)) of
(Nothing, car_path) ->
-- in case we don't have a last car, we dont need to move anything
(car_path, acc)
(_, Nothing) ->
-- if the index is not valid, just skip this.
(last_car_path, acc)
(Just last_car_path, Just car_path) ->
case (LU.unprefix car_path (last_car_path ++ [RT.Further])) of
Nothing ->
-- we can't do anything here if
(Just car_path, acc)
Just delta ->
-- last_car_path ++ [RT.Further] describes the track or junction
-- directly below the last car. However this may be a junction.
-- So we need to choose the first track on the path delta.
let
new_car_path =
LU.takeWhile ((/=) RT.Further) delta
|> (::) RT.Further
|> (++) last_car_path
in
(Just new_car_path
, if (new_car_path /= car_path)
then (idx, new_car_path) :: acc
else acc
)
in
List.reverse << snd << List.foldl moveUp (Nothing,[]) << Debug.log "train"
-- vim: ft=elm et ts=2 sw=2
module RailPuzzle exposing
( Model
, Msg, init, update, subscriptions, view
, railTree, carPositions, updateMoveCar
, setQuery
, railTree , carPositions , updateMoveCar
, setQuery , getQuery
)
-- The actual state of the Puzzle
......@@ -92,6 +92,9 @@ setQuery query model =
, train_preview = TrainPreview.render model.cars query
}
getQuery : Model -> List Int
getQuery = (.query)
arrayUpdate : Int -> (a -> a) -> (Array a -> Array a)
arrayUpdate idx updater array =
case Array.get idx array of
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment