{-# LANGUAGE DerivingStrategies , GeneralizedNewtypeDeriving , PatternSynonyms , ViewPatterns #-} module No.Set.Word ( Color (..) , other , NoSet (Mono, ..) , No.Set.Word.lookup , lookupL , findL , lookupR , findR , Range (..) , monoL , monoR , monoRange , size , sizeL , sizeR , sizeRange , fillL , fillR , fillRange , No.Set.Word.foldl , No.Set.Word.foldl' , No.Set.Word.foldr , No.Set.Word.foldr' , foldlL , foldlL' , foldrL , foldrL' , foldlR , foldlR' , foldrR , foldrR' , foldlRange , foldlRange' , foldrRange , foldrRange' , complement , union , disjoint , intersection , difference , symmetricDifference , PartialOrdering (..) , No.Set.Word.compare ) where import Data.Zebra.Word (Color (..), PartialOrdering (..)) import Data.Zebra.Word.Unsafe (Range (..)) import Data.Foldable import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Numeric.Natural other :: Color -> Color other Black = White other White = Black newtype NoSet = NoSet { getNoSet :: Seq (Color, Word, Word) } deriving newtype Eq instance Show NoSet where showsPrec _ (NoSet xs) = showList . fmap (\(_, kL, kR) -> (kL, kR)) . filter (\(c, _, _) -> c == White) $ toList xs pattern Mono :: Color -> NoSet pattern Mono c <- (monotone -> Just c) where Mono c = NoSet $ Seq.singleton (c, 0, maxBound) monotone :: NoSet -> Maybe Color monotone (NoSet (Seq.Empty Seq.:|> (c, _, _))) = Just c monotone _ = Nothing lookup :: Word -> NoSet -> Color lookup w no = let ~(NoSet l, _) = unsafeSplitL w no in case l of _ :|> (c, _, _) -> c Empty -> error $ "No.Set.Word.lookup: out of bounds (" <> shows w ")" lookupL :: Color -> Word -> NoSet -> Maybe Word lookupL x w no = let ~(NoSet l, _) = unsafeSplitL w no in case l of _ :|> _ -> go l Empty -> error $ "No.Set.Word.lookupL: out of bounds (" <> shows w ")" where go (l :|> (c, _, b)) | c == x = Just b | otherwise = go l go Empty = Nothing findL :: Word -> Color -> Word -> NoSet -> Word findL d x w no = case lookupL x w no of Just a -> a Nothing -> d lookupR :: Color -> Word -> NoSet -> Maybe Word lookupR x w no = let ~(_, NoSet r) = unsafeSplitR w no in case r of _ :<| _ -> go r Empty -> error $ "No.Set.Word.lookupR: out of bounds (" <> shows w ")" where go ((c, a, _) :<| r) | c == x = Just a | otherwise = go r go Empty = Nothing findR :: Word -> Color -> Word -> NoSet -> Word findR d x w no = case lookupR x w no of Just a -> a Nothing -> d monoL :: Word -> NoSet -> Maybe Color monoL k = monotone . fst . unsafeSplitL k monoR :: Word -> NoSet -> Maybe Color monoR k = monotone . snd . unsafeSplitR k monoRange :: Range -> NoSet -> Maybe Color monoRange r = monotone . (\(_, m, _) -> m) . unsafeSplitRange r size :: Color -> NoSet -> Natural size x = let f (c, a, b) z | c == x = fromIntegral (b - a) + 1 + z | otherwise = z in Data.Foldable.foldr f 0 . getNoSet sizeL :: Color -> Word -> NoSet -> Natural sizeL x k = size x . fst . unsafeSplitL k sizeR :: Color -> Word -> NoSet -> Natural sizeR x k = size x . snd . unsafeSplitR k sizeRange :: Color -> Range -> NoSet -> Natural sizeRange x r = size x . (\(_, m, _) -> m) . unsafeSplitRange r fillL :: Word -> Color -> NoSet -> NoSet fillL w x no = let ~(_, NoSet _r) = unsafeSplitL w no in case _r of (c, _, b) :<| r | c == x -> NoSet $ (c, 0, b) :<| r | otherwise -> NoSet $ (x, 0, w) :<| _r _ -> Mono x fillR :: Word -> Color -> NoSet -> NoSet fillR w x no = let ~(NoSet _l, _) = unsafeSplitR w no in case _l of l :|> (c, a, _) | c == x -> NoSet $ l :|> (c, a, maxBound) | otherwise -> NoSet $ _l :|> (x, w, maxBound) _ -> Mono x fillRange :: Range -> Color -> NoSet -> NoSet fillRange rng@(Range kL kR) x no = let ~(NoSet _l, _, NoSet _r) = unsafeSplitRange rng no in case (_l, _r) of (l :|> (cL, a, _), (cR, _, b) :<| r) -> case (cL == cR, cL == x) of (True , True ) -> NoSet $ l <> ((x, a, b) :<| r) (True , False) -> NoSet $ _l <> ((x, kL, kR) :<| _r) (False, True ) -> NoSet $ (l :|> (x, a, kR)) <> _r (False, False) -> NoSet $ _l <> ((x, a, b) :<| r) (l :|> (cL, a, _), Empty) | cL == x -> NoSet $ l :|> (cL, a, maxBound) | otherwise -> NoSet $ _l :|> (x, kL, maxBound) (Empty, (cR, _, b) :<| r) | cR == x -> NoSet $ (cR, 0, b) :<| r | otherwise -> NoSet $ (x, 0, kR) :<| _r (Empty, Empty) -> Mono x unsafeSplitL :: Word -> NoSet -> (NoSet, NoSet) unsafeSplitL k (NoSet xs) = let ~(_l, r) = Seq.spanl (\(_, a, _) -> a <= k) xs in case _l of l :|> (c, a, b) | b > k -> (NoSet $ l :|> (c, a, k), NoSet $ (c, k + 1, b) :<| r) _ -> (NoSet _l, NoSet r) unsafeSplitR :: Word -> NoSet -> (NoSet, NoSet) unsafeSplitR k (NoSet xs) = let ~(_r, l) = Seq.spanr (\(_, _, b) -> b >= k) xs in case _r of (c, a, b) :<| r | a < k -> (NoSet $ l :|> (c, a, k - 1), NoSet $ (c, k, b) :<| r) _ -> (NoSet l, NoSet _r) unsafeSplitRange :: Range -> NoSet -> (NoSet, NoSet, NoSet) unsafeSplitRange (Range kL kR) no = let ~(l, no') = unsafeSplitR kL no ~(m, r) = unsafeSplitL kR no' in (l, m, r) foldl, foldl' :: (a -> Range -> Color -> a) -> a -> NoSet -> a foldl f z0 = Data.Foldable.foldl (\z (c, a, b) -> f z (UnsafeRange a b) c) z0 . getNoSet foldl' f z0 = Data.Foldable.foldl' (\z (c, a, b) -> f z (UnsafeRange a b) c) z0 . getNoSet foldr, foldr' :: (Range -> Color -> a -> a) -> a -> NoSet -> a foldr f z0 = Data.Foldable.foldr (\(c, a, b) -> f (UnsafeRange a b) c) z0 . getNoSet foldr' f z0 = Data.Foldable.foldr' (\(c, a, b) -> f (UnsafeRange a b) c) z0 . getNoSet foldlL, foldlL' :: Word -> (a -> Range -> Color -> a) -> a -> NoSet -> a foldlL w f z = No.Set.Word.foldl f z . fst . unsafeSplitL w foldlL' w f z = No.Set.Word.foldl' f z . fst . unsafeSplitL w foldrL, foldrL' :: Word -> (Range -> Color -> a -> a) -> a -> NoSet -> a foldrL w f z = No.Set.Word.foldr f z . fst . unsafeSplitL w foldrL' w f z = No.Set.Word.foldr' f z . fst . unsafeSplitL w foldlR, foldlR' :: Word -> (a -> Range -> Color -> a) -> a -> NoSet -> a foldlR w f z = No.Set.Word.foldl f z . snd . unsafeSplitR w foldlR' w f z = No.Set.Word.foldl' f z . snd . unsafeSplitR w foldrR, foldrR' :: Word -> (Range -> Color -> a -> a) -> a -> NoSet -> a foldrR w f z = No.Set.Word.foldr f z . snd . unsafeSplitR w foldrR' w f z = No.Set.Word.foldr' f z . snd . unsafeSplitR w foldlRange, foldlRange' :: Range -> (a -> Range -> Color -> a) -> a -> NoSet -> a foldlRange r f z = No.Set.Word.foldl f z . (\(_, m, _) -> m) . unsafeSplitRange r foldlRange' r f z = No.Set.Word.foldl' f z . (\(_, m, _) -> m) . unsafeSplitRange r foldrRange, foldrRange' :: Range -> (Range -> Color -> a -> a) -> a -> NoSet -> a foldrRange r f z = No.Set.Word.foldr f z . (\(_, m, _) -> m) . unsafeSplitRange r foldrRange' r f z = No.Set.Word.foldr' f z . (\(_, m, _) -> m) . unsafeSplitRange r -- | Combines two sets into an ascending non-overlapping list of -- consecutive double-colored ranges. -- -- Both sets must be defined over the same ranges for this function to make sense. crush :: NoSet -> NoSet -> [(Color, Range, Color)] crush (NoSet xs) (NoSet ys) = go xs ys where go Empty Empty = [] go ((cL, aL, bL) :<| l) ((cR, aR, bR) :<| r) = case bL `Prelude.compare` bR of LT -> (cL, UnsafeRange aL bL, cR) : go l ((cR, bL + 1, bR) :<| r) GT -> (cL, UnsafeRange aR bR, cR) : go ((cL, bR + 1, bL) :<| l) r EQ -> (cL, UnsafeRange aL bL, cR) : go l r go _ _ = error "No.Set.Word.crush: unequally sized sets" complement :: NoSet -> NoSet complement = NoSet . fmap (\(c, a, b) -> (other c, a, b)) . getNoSet union :: Color -> NoSet -> NoSet -> NoSet union x = merge $ \cL cR -> if cL == cR && cL /= x then cL else x disjoint :: Color -> NoSet -> NoSet -> Bool disjoint x a b = case intersection x a b of Mono y -> x /= y _ -> False intersection :: Color -> NoSet -> NoSet -> NoSet intersection x = merge $ \cL cR -> if cL == cR && cL == x then x else other x difference :: Color -> NoSet -> NoSet -> NoSet difference x = merge $ \cL cR -> if cL /= cR && cL == x then x else other x symmetricDifference :: Color -> NoSet -> NoSet -> NoSet symmetricDifference x = merge $ \cL cR -> if cL == cR then other x else x data Carry = Carry Color Word | NoCarry merge :: (Color -> Color -> Color) -> NoSet -> NoSet -> NoSet merge f as bs = NoSet . Seq.fromList . unify NoCarry $ crush as bs where unify carry [] = case carry of NoCarry -> [] Carry c k -> (c, k, maxBound) : [] unify carry ((cL, Range a _, cR) : rest) = let cM = f cL cR in case carry of NoCarry -> unify (Carry cM a) rest Carry c k | c == cM -> unify carry rest | otherwise -> (c, k, a - 1) : unify (Carry cM a) rest compare :: Color -> NoSet -> NoSet -> PartialOrdering compare x as bs = Data.Foldable.foldr go Equal $ crush as bs where go (cL, _, cR) p = case p of Subset | cL == cR || cR == x -> Subset | otherwise -> Incomparable Superset | cL == cR || cL == x -> Superset | otherwise -> Incomparable Equal | cL == cR -> Equal | cR == x -> Subset | otherwise -> Superset Incomparable -> Incomparable