Don't trimOrdLists, filter on times already taken instead, #536.

GlideAngle · Apr 23, 2021 · 63064ff · 63064ff
1 parent 6a8b4c9
commit 63064ff
Show file tree

Hide file tree

Showing 2 changed files with 46 additions and 9 deletions.
diff --git a/lang-haskell/mask/library/Flight/Mask/Tag/Double.hs b/lang-haskell/mask/library/Flight/Mask/Tag/Double.hs
@@ -5,7 +5,7 @@ module Flight.Mask.Tag.Double where
 import Prelude hiding (span)
 import Data.Coerce (coerce)
 import Data.Maybe (listToMaybe, catMaybes, fromMaybe)
-import Data.List ((\\), filter, inits)
+import Data.List ((\\), filter, inits, foldl')
 import Control.Arrow (first)
 import Control.Monad (join)
 
@@ -51,8 +51,7 @@ import Flight.Mask.Internal.Cross
     )
 import Flight.Mask.Interpolate (GeoTagInterpolate(..))
 import Flight.Mask.Tag (FnTask, selectZoneCross)
-import Flight.Mask.Tag.Prove (prove, proveCrossing)
-import Flight.Mask.Tag.OrdLists (trimOrdLists)
+import Flight.Mask.Tag.Prove (keepCrossing, prove, proveCrossing)
 import Flight.Mask.Tag.Motion (flyingSection, secondsRange, timeRange)
 
 import Flight.ShortestPath.Double ()
@@ -288,7 +287,7 @@ instance GeoTagInterpolate Double a => GeoTag Double a where
                         Nothing
 
             yss :: [[OrdCrossing]]
-            yss = trimOrdLists ((fmap . fmap) OrdCrossing xss'')
+            yss = ((fmap . fmap) OrdCrossing xss'')
 
             yss' :: [[Crossing]]
             yss' = (fmap . fmap) unOrdCrossing yss
@@ -298,11 +297,30 @@ instance GeoTagInterpolate Double a => GeoTag Double a where
                 let tsys :: [(TimePass, [Crossing] -> Maybe Crossing, [Crossing])]
                     tsys = zip3 timechecks selectors yss'
 
-                    pickTag (timecheck, selector, ys) =
+                    pickTag
+                        :: TimePass
+                        -> ([Crossing] -> Maybe Crossing)
+                        -> [Crossing]
+                        -> Maybe ZoneCross
+                    pickTag timecheck selector ys =
                         let prover = proveCrossing timecheck mark0 fixes
-                        in selectZoneCross prover selector ys
-
-                in fmap pickTag tsys
+                            ys' = filter (keepCrossing timecheck mark0 fixes) ys
+                        in
+                            selectZoneCross prover selector ys'
+
+                    pickTags
+                        :: [Maybe ZoneCross]
+                        -> (TimePass, [Crossing] -> Maybe Crossing, [Crossing])
+                        -> [Maybe ZoneCross]
+                    pickTags acc (timePass, selector, ys) =
+                        case acc of
+                            [] -> pickTag timePass selector ys : acc
+                            Nothing : _ -> Nothing : acc
+                            Just ZoneCross{crossingPair = [_, Fix{time = tM}]} : _ ->
+                                pickTag (\t -> t > tM && timePass t) selector ys : acc
+                            Just _ : _ -> fail "Crossing pairs should be pairs"
+
+                in reverse $ foldl' pickTags [] tsys
 
             fs =
                 (\x ->

diff --git a/lang-haskell/mask/library/Flight/Mask/Tag/Prove.hs b/lang-haskell/mask/library/Flight/Mask/Tag/Prove.hs
@@ -1,6 +1,7 @@
-module Flight.Mask.Tag.Prove (prove, proveCrossing) where
+module Flight.Mask.Tag.Prove (keepCrossing, prove, proveCrossing) where
 
 import Prelude hiding (span)
+import Data.Maybe (fromMaybe)
 import Data.Time.Clock (UTCTime)
 import Control.Lens ((^?), element)
 
@@ -18,6 +19,24 @@ import Flight.Mask.Internal.Zone
     , fixFromFix
     )
 
+keepCrossing :: TimePass -> UTCTime -> [Kml.Fix] -> Crossing -> Bool
+
+keepCrossing pass mark0 fixes (Left (ZoneEntry i@(ZoneIdx i') j@(ZoneIdx j'))) =
+    fromMaybe False $ do
+        fixM <- fixes ^? element i'
+        fixN <- fixes ^? element j'
+        let f = fixFromFix mark0
+        let [Fix{time = ti}, Fix{time = tj}] = [f i fixM, f j fixN]
+        return $ pass ti || pass tj
+
+keepCrossing pass mark0 fixes (Right (ZoneExit i@(ZoneIdx i') j@(ZoneIdx j'))) =
+    fromMaybe False $ do
+        fixM <- fixes ^? element i'
+        fixN <- fixes ^? element j'
+        let f = fixFromFix mark0
+        let [Fix{time = ti}, Fix{time = tj}] = [f i fixM, f j fixN]
+        return $ pass ti || pass tj
+
 -- | Prove from the fixes and mark that the crossing exits. We don't know the
 -- interpolated crossing point and time yet so we'll accept a crossing where
 -- one of the fixes passes the time check.