-- DEPRECATED, we will switch to Owl :O

module Potato.Flow.Deprecated.Layers (
  reindexSEltLayerPosForRemoval
  , reindexSEltLayerPosForInsertion
  , hasScopingProperty
  , selectionHasScopingProperty
  , findMatchingScope
  , scopeSelection
  , insertElts
  , insertElt
  , removeElts
  , insertEltList_indexBeforeInsertion
  , insertEltList_indexAfterInsertion
  , removeEltList
  , moveEltList
  , undoMoveEltList
) where

import           Relude

import           Potato.Flow.Types

import           Control.Exception (assert)
import qualified Data.Bimap        as BM
import           Data.List.Ordered (isSorted)
import           Data.Sequence     ((><))
import qualified Data.Sequence     as Seq
import qualified Data.Set          as Set

-- copy pasta https://stackoverflow.com/questions/16108714/removing-duplicates-from-a-list-in-haskell-without-elem
sortUnique :: Ord a => [a] -> [a]
sortUnique :: forall a. Ord a => [a] -> [a]
sortUnique = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Ord a => Set a -> [a] -> [a]
rmdups' forall a. Set a
Set.empty where
  rmdups' :: Set a -> [a] -> [a]
rmdups' Set a
_ [] = []
  rmdups' Set a
a (a
b : [a]
c) = if forall a. Ord a => a -> Set a -> Bool
Set.member a
b Set a
a
    then Set a -> [a] -> [a]
rmdups' Set a
a [a]
c
    else a
b forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
rmdups' (forall a. Ord a => a -> Set a -> Set a
Set.insert a
b Set a
a) [a]
c

-- | reindexes list of LayerPos such that each element is indexed as if all previous elements have been removed
-- O(n^2) lol
reindexSEltLayerPosForRemoval :: [LayerPos] -> [LayerPos]
reindexSEltLayerPosForRemoval :: [LayerPos] -> [LayerPos]
reindexSEltLayerPosForRemoval [] = []
reindexSEltLayerPosForRemoval (LayerPos
r:[LayerPos]
xs) = LayerPos
rforall a. a -> [a] -> [a]
:[LayerPos] -> [LayerPos]
reindexSEltLayerPosForRemoval [LayerPos]
rest where
  -- if this asserts that means you tried to remove the same index twice
  rest :: [LayerPos]
rest = forall a b. (a -> b) -> [a] -> [b]
map (\LayerPos
x -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (LayerPos
x forall a. Eq a => a -> a -> Bool
/= LayerPos
r) forall a b. (a -> b) -> a -> b
$ if LayerPos
x forall a. Ord a => a -> a -> Bool
> LayerPos
r then LayerPos
xforall a. Num a => a -> a -> a
-LayerPos
1 else LayerPos
x) [LayerPos]
xs

-- | inverse of reindexSEltLayerPosForRemoval
-- input indices are before any elements are inserted
-- O(n^2) lol
reindexSEltLayerPosForInsertion :: [LayerPos] -> [LayerPos]
reindexSEltLayerPosForInsertion :: [LayerPos] -> [LayerPos]
reindexSEltLayerPosForInsertion = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LayerPos] -> [LayerPos]
reindexSEltLayerPosForRemoval forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse


hasScopingProperty :: (a -> Maybe Bool) -> Seq a -> Bool
hasScopingProperty :: forall a. (a -> Maybe Bool) -> Seq a -> Bool
hasScopingProperty a -> Maybe Bool
scopeTypeFn Seq a
xs = Bool -> Bool
not Bool
finalFail Bool -> Bool -> Bool
&& Integer
finalScope forall a. Eq a => a -> a -> Bool
== Integer
0 where
  foldfn :: a -> (Integer, Bool) -> (Integer, Bool)
foldfn a
x (Integer
scopes, Bool
didFail) = case a -> Maybe Bool
scopeTypeFn a
x of
    Maybe Bool
Nothing -> (Integer
scopes, Bool
didFail)
    Just Bool
f -> case Bool
f of
      Bool
True -> case Integer
scopes of
        Integer
0 -> (Integer
scopes, Bool
True)
        Integer
_ -> (Integer
scopesforall a. Num a => a -> a -> a
-Integer
1, Bool
didFail)
      Bool
False -> (Integer
scopesforall a. Num a => a -> a -> a
+Integer
1, Bool
didFail)
  (Integer
finalScope, Bool
finalFail) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (Integer, Bool) -> (Integer, Bool)
foldfn (Integer
0,Bool
False) Seq a
xs

-- | assumes selection is ordered and is valid
selectionHasScopingProperty :: (a -> Maybe Bool) -> Seq a -> [Int] -> Bool
selectionHasScopingProperty :: forall a. (a -> Maybe Bool) -> Seq a -> [LayerPos] -> Bool
selectionHasScopingProperty a -> Maybe Bool
scopeTypeFn Seq a
xs [LayerPos]
is = forall a. (a -> Maybe Bool) -> Seq a -> Bool
hasScopingProperty a -> Maybe Bool
scopeTypeFn Seq a
subSeq where
  subSeq :: Seq a
subSeq = forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\LayerPos
i -> forall a. Seq a -> LayerPos -> a
Seq.index Seq a
xs LayerPos
i) [LayerPos]
is

makePairMap :: (a -> Maybe Bool) -> Seq a -> BM.Bimap Int Int
makePairMap :: forall a. (a -> Maybe Bool) -> Seq a -> Bimap LayerPos LayerPos
makePairMap a -> Maybe Bool
scopeTypeFn Seq a
xs = forall a b. (a, b) -> a
fst (Bimap LayerPos LayerPos, [LayerPos])
r where
  -- map folders from start to end index
  pairmapfoldfn :: LayerPos
-> a
-> (Bimap LayerPos LayerPos, [LayerPos])
-> (Bimap LayerPos LayerPos, [LayerPos])
pairmapfoldfn LayerPos
i a
a (Bimap LayerPos LayerPos
pairs, [LayerPos]
scopes) = case a -> Maybe Bool
scopeTypeFn a
a of
    Maybe Bool
Nothing -> (Bimap LayerPos LayerPos
pairs, [LayerPos]
scopes)
    Just Bool
True -> case [LayerPos]
scopes of
      []        -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"mismatched scopes"
      LayerPos
x:[LayerPos]
scopes' -> (forall a b. (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b
BM.insert LayerPos
i LayerPos
x Bimap LayerPos LayerPos
pairs, [LayerPos]
scopes')
    Just Bool
False -> (Bimap LayerPos LayerPos
pairs, LayerPos
iforall a. a -> [a] -> [a]
:[LayerPos]
scopes)
  r :: (Bimap LayerPos LayerPos, [LayerPos])
r = forall a b. (LayerPos -> a -> b -> b) -> b -> Seq a -> b
Seq.foldrWithIndex LayerPos
-> a
-> (Bimap LayerPos LayerPos, [LayerPos])
-> (Bimap LayerPos LayerPos, [LayerPos])
pairmapfoldfn (forall a b. Bimap a b
BM.empty,[]) Seq a
xs

-- assumes input sequence satisfies scoping property
-- assumes input index is actually a folder
findMatchingScope :: (a -> Maybe Bool) -> Seq a -> Int -> Int
findMatchingScope :: forall a. (a -> Maybe Bool) -> Seq a -> LayerPos -> LayerPos
findMatchingScope a -> Maybe Bool
scopeTypeFn Seq a
xs LayerPos
i = LayerPos
r where
  pairmap :: Bimap LayerPos LayerPos
pairmap = forall a. (a -> Maybe Bool) -> Seq a -> Bimap LayerPos LayerPos
makePairMap a -> Maybe Bool
scopeTypeFn Seq a
xs
  r :: LayerPos
r = case a -> Maybe Bool
scopeTypeFn (forall a. Seq a -> LayerPos -> a
Seq.index Seq a
xs LayerPos
i) of
    Maybe Bool
Nothing -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"input index was not a folder"
    Just Bool
True -> case forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
BM.lookup LayerPos
i Bimap LayerPos LayerPos
pairmap of
      Maybe LayerPos
Nothing -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"pairmap missing elements, this means scopes were mismatched"
      Just LayerPos
x -> LayerPos
x
    Just Bool
False -> case forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
BM.lookupR LayerPos
i Bimap LayerPos LayerPos
pairmap of
      Maybe LayerPos
Nothing -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"pairmap missing elements, this means scopes were mismatched"
      Just LayerPos
x -> LayerPos
x

-- | converts selection so that it satisfies the scoping property by adding matching folders
-- assumes input sequence satisfies scoping property???
-- simple and inefficient implementation, do not use in prod
scopeSelection :: (a -> Maybe Bool) -> Seq a -> [Int] -> [Int]
scopeSelection :: forall a. (a -> Maybe Bool) -> Seq a -> [LayerPos] -> [LayerPos]
scopeSelection a -> Maybe Bool
scopeTypeFn Seq a
xs [LayerPos]
is = [LayerPos]
r where
  pairmap :: Bimap LayerPos LayerPos
pairmap = forall a. (a -> Maybe Bool) -> Seq a -> Bimap LayerPos LayerPos
makePairMap a -> Maybe Bool
scopeTypeFn Seq a
xs
  -- go through and lookup matches
  foldfn :: LayerPos -> [LayerPos] -> [LayerPos]
foldfn LayerPos
i [LayerPos]
acc = case a -> Maybe Bool
scopeTypeFn (forall a. Seq a -> LayerPos -> a
Seq.index Seq a
xs LayerPos
i) of
    Maybe Bool
Nothing -> [LayerPos]
acc
    Just Bool
True -> case forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
a -> Bimap a b -> m b
BM.lookup LayerPos
i Bimap LayerPos LayerPos
pairmap of
      Maybe LayerPos
Nothing -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"pairmap missing elements, this means scopes were mismatched"
      Just LayerPos
x -> LayerPos
xforall a. a -> [a] -> [a]
:[LayerPos]
acc
    Just Bool
False -> case forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
BM.lookupR LayerPos
i Bimap LayerPos LayerPos
pairmap of
      Maybe LayerPos
Nothing -> forall a t. (?callStack::CallStack, IsText t) => t -> a
error Text
"pairmap missing elements, this means scopes were mismatched"
      Just LayerPos
x -> LayerPos
xforall a. a -> [a] -> [a]
:[LayerPos]
acc
  newElts :: [LayerPos]
newElts = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LayerPos -> [LayerPos] -> [LayerPos]
foldfn [] [LayerPos]
is
  r :: [LayerPos]
r = forall a. Ord a => [a] -> [a]
sortUnique ([LayerPos]
newElts forall a. Semigroup a => a -> a -> a
<> [LayerPos]
is)


-- | inserts ys at index i into xs
insertElts :: Int -> Seq a -> Seq a -> Seq a
insertElts :: forall a. LayerPos -> Seq a -> Seq a -> Seq a
insertElts LayerPos
i Seq a
ys Seq a
xs = Seq a
newSeq where
  (Seq a
l, Seq a
r) = forall a. LayerPos -> Seq a -> (Seq a, Seq a)
Seq.splitAt LayerPos
i Seq a
xs
  newSeq :: Seq a
newSeq = Seq a
l forall a. Seq a -> Seq a -> Seq a
>< Seq a
ys forall a. Seq a -> Seq a -> Seq a
>< Seq a
r

-- | inserts y at index y into xs
insertElt :: Int -> a -> Seq a -> Seq a
insertElt :: forall a. LayerPos -> a -> Seq a -> Seq a
insertElt LayerPos
i a
y Seq a
xs = forall a. LayerPos -> Seq a -> Seq a -> Seq a
insertElts LayerPos
i (forall a. a -> Seq a
Seq.singleton a
y) Seq a
xs

-- | removes n elts at index i from xs
removeElts :: Int -> Int -> Seq a -> Seq a
removeElts :: forall a. LayerPos -> LayerPos -> Seq a -> Seq a
removeElts LayerPos
n LayerPos
i Seq a
xs = Seq a
newSeq where
  (Seq a
keepl  , Seq a
rs) = forall a. LayerPos -> Seq a -> (Seq a, Seq a)
Seq.splitAt LayerPos
i Seq a
xs
  (Seq a
_, Seq a
keepr) = forall a. LayerPos -> Seq a -> (Seq a, Seq a)
Seq.splitAt LayerPos
n Seq a
rs
  newSeq :: Seq a
newSeq           = Seq a
keepl forall a. Seq a -> Seq a -> Seq a
>< Seq a
keepr

-- | removes elt at index i from xs
removeElt :: Int -> Seq a -> Seq a
removeElt :: forall a. LayerPos -> Seq a -> Seq a
removeElt LayerPos
i Seq a
xs = forall a. LayerPos -> Seq a -> Seq a
Seq.deleteAt LayerPos
i Seq a
xs

-- | inserts ys into xs, positions are before insertion
insertEltList_indexBeforeInsertion :: [(Int, a)] -> Seq a -> Seq a
insertEltList_indexBeforeInsertion :: forall a. [(LayerPos, a)] -> Seq a -> Seq a
insertEltList_indexBeforeInsertion [(LayerPos, a)]
ys Seq a
xs = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Ord a => [a] -> Bool
isSorted [LayerPos]
is') forall a b. (a -> b) -> a -> b
$ Seq a
newSeq where
  is' :: [LayerPos]
is' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LayerPos, a)]
ys
  elts :: [a]
elts = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(LayerPos, a)]
ys
  is :: [LayerPos]
is = [LayerPos] -> [LayerPos]
reindexSEltLayerPosForInsertion [LayerPos]
is'
  newSeq :: Seq a
newSeq = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. LayerPos -> a -> Seq a -> Seq a
insertElt) Seq a
xs (forall a b. [a] -> [b] -> [(a, b)]
zip [LayerPos]
is [a]
elts)

-- | inserts ys into xs, positions are after insertion
insertEltList_indexAfterInsertion :: [(Int, a)] -> Seq a -> Seq a
insertEltList_indexAfterInsertion :: forall a. [(LayerPos, a)] -> Seq a -> Seq a
insertEltList_indexAfterInsertion [(LayerPos, a)]
ys Seq a
xs = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Ord a => [a] -> Bool
isSorted [LayerPos]
is) forall a b. (a -> b) -> a -> b
$ Seq a
newSeq where
  is :: [LayerPos]
is = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(LayerPos, a)]
ys
  newSeq :: Seq a
newSeq = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. LayerPos -> a -> Seq a -> Seq a
insertElt)) Seq a
xs [(LayerPos, a)]
ys

-- | removes is' from xs, positions are before removal
removeEltList :: [Int] -> Seq a -> Seq a
removeEltList :: forall a. [LayerPos] -> Seq a -> Seq a
removeEltList [LayerPos]
is' Seq a
xs = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Ord a => [a] -> Bool
isSorted [LayerPos]
is) forall a b. (a -> b) -> a -> b
$ Seq a
newSeq where
  is :: [LayerPos]
is = [LayerPos] -> [LayerPos]
reindexSEltLayerPosForRemoval [LayerPos]
is'
  newSeq :: Seq a
newSeq = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. LayerPos -> Seq a -> Seq a
removeElt) Seq a
xs [LayerPos]
is

-- | moves all elts, new position is before removal, ys must be sorted
moveEltList :: [Int] -> Int -> Seq a -> Seq a
moveEltList :: forall a. [LayerPos] -> LayerPos -> Seq a -> Seq a
moveEltList [LayerPos]
is LayerPos
i Seq a
xs = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Ord a => [a] -> Bool
isSorted [LayerPos]
is) forall a b. (a -> b) -> a -> b
$ Seq a
newSeq where
  nBefore :: LayerPos
nBefore = forall (t :: * -> *) a. Foldable t => t a -> LayerPos
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
< LayerPos
i) forall a b. (a -> b) -> a -> b
$ [LayerPos]
is
  ys :: [a]
ys = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Seq a -> LayerPos -> a
Seq.index Seq a
xs) [LayerPos]
is
  newSeq' :: Seq a
newSeq' = forall a. [LayerPos] -> Seq a -> Seq a
removeEltList [LayerPos]
is Seq a
xs
  newSeq :: Seq a
newSeq = forall a. LayerPos -> Seq a -> Seq a -> Seq a
insertElts (LayerPos
iforall a. Num a => a -> a -> a
-LayerPos
nBefore) (forall a. [a] -> Seq a
Seq.fromList [a]
ys) Seq a
newSeq'

-- inverse of `moveEltList`
undoMoveEltList :: [Int] -> Int -> Seq a -> Seq a
undoMoveEltList :: forall a. [LayerPos] -> LayerPos -> Seq a -> Seq a
undoMoveEltList [LayerPos]
is LayerPos
i Seq a
xs = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall a. Ord a => [a] -> Bool
isSorted [LayerPos]
is) forall a b. (a -> b) -> a -> b
$ Seq a
newSeq where
  nMoved :: LayerPos
nMoved = forall (t :: * -> *) a. Foldable t => t a -> LayerPos
length [LayerPos]
is
  moveToIndex :: LayerPos
moveToIndex = LayerPos
i forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> LayerPos
length (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\LayerPos
x -> LayerPos
x forall a. Ord a => a -> a -> Bool
< LayerPos
i) [LayerPos]
is))
  (Seq a
leftL,Seq a
rightL') = forall a. LayerPos -> Seq a -> (Seq a, Seq a)
Seq.splitAt LayerPos
moveToIndex Seq a
xs
  (Seq a
toMove,Seq a
rightL) = forall a. LayerPos -> Seq a -> (Seq a, Seq a)
Seq.splitAt LayerPos
nMoved Seq a
rightL'
  newSeq' :: Seq a
newSeq' = Seq a
leftL forall a. Seq a -> Seq a -> Seq a
>< Seq a
rightL
  newSeq :: Seq a
newSeq = forall a. [(LayerPos, a)] -> Seq a -> Seq a
insertEltList_indexAfterInsertion (forall a b. [a] -> [b] -> [(a, b)]
zip [LayerPos]
is (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
toMove)) Seq a
newSeq'