q4c12-twofinger 0.1 → 0.2

raw patch · 5 files changed

+222/−971 lines, 5 filesdep +containersdep +lens-propertiesdep −streamsdep ~tastyPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, lens-properties

Dependencies removed: streams

Dependency ranges changed: tasty

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +10/−0
• q4c12-twofinger.cabal +9/−8
• src/Q4C12/TwoFinger.hs +5/−24
• src/Q4C12/TwoFinger/Internal.hs +105/−788
• test/Properties.hs +93/−151

@@ -1,3 +1,13 @@+q4c12-twofinger 0.2 (2018-01-17)+================================++* Fix a dangling section reference in the haddocks.+* Allow `tasty` 1.0 along with `tasty` 0.12.+* More tests!+* `Bitraversable1` and `Bifoldable1` for `TwoFingerOddE`.+* Re-use `Seq` from `containers` instead of rolling our own finger-trees. This changes some worst-case running time, some for the better and some for the worse.+* Drop `align*`, `infinite*` and `repeat*`. The `align*` functions did not work properly before in the infinite/infinite case, and `Seq` from `containers` does not support infinite trees; further, implementing aligning directly with `uncons` is often clearer.+ q4c12-twofinger 0.1 (2018-01-04) ================================ 

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: cfaafc91f91a1d5bd7d0f03ffc8396161daf405cceb049464062797076e523d8+-- hash: 9147922bd555a39a0328a96eb47b16251f2525a4a55b511dd08508caa5791a52  name:           q4c12-twofinger-version:        0.1+version:        0.2 synopsis:       Efficient alternating finger trees description:    This package provides efficient alternating sequences based on finger trees. These can represent sequences made up of two types of element, @e@ and @a@  where two of the same type of element cannot follow each other directly.                 .@@ -44,13 +44,13 @@       Q4C12.TwoFinger.Internal   hs-source-dirs:       src-  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators+  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings PatternGuards StandaloneDeriving TypeOperators ViewPatterns   ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations   build-depends:       base >=4.9.1.0 && <4.11+    , containers >=0.5.10.2 && <0.5.11     , deepseq >=1.4.3.0 && <1.5     , semigroupoids >=5.2.1 && <5.3-    , streams >=3.3 && <3.4   if impl(ghc < 8.2)     build-depends:         bifunctors >=5.4.2 && <5.6@@ -61,14 +61,13 @@   main-is: Doctest.hs   hs-source-dirs:       test-  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators+  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings PatternGuards StandaloneDeriving TypeOperators ViewPatterns   ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-missing-import-lists -Wno-missing-home-modules   build-depends:       base >=4.9.1.0 && <4.11     , doctest >=0.11.4 && <0.14     , lens >=4.15.4 && <4.16     , q4c12-twofinger-    , streams >=3.3 && <3.4   default-language: Haskell2010  test-suite properties@@ -76,11 +75,13 @@   main-is: Properties.hs   hs-source-dirs:       test-  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings StandaloneDeriving TypeOperators+  default-extensions: DataKinds DeriveGeneric DeriveLift DeriveTraversable EmptyCase LambdaCase KindSignatures OverloadedStrings PatternGuards StandaloneDeriving TypeOperators ViewPatterns   ghc-options: -Weverything -Wno-implicit-prelude -Wno-unsafe -Wno-safe -Wno-missed-specialisations -Wno-all-missed-specialisations   build-depends:       base >=4.9.1.0 && <4.11+    , lens >=4.15.4 && <4.16+    , lens-properties >=4.11.1 && <4.12     , q4c12-twofinger-    , tasty >=0.12.0.1 && <0.13+    , tasty >=0.12 && <0.13 || >=1.0 && <1.1     , tasty-quickcheck >=0.9.1 && <0.10   default-language: Haskell2010

@@ -1,9 +1,8 @@--- | This module provides alternating finger trees, which are similar--- to "Data.Sequence" in the @containers@ package, or--- "Data.FingerTree" in the @fingertree@ package, except that, between--- every element (of type @e@) in the \'normal\' finger tree, there is--- a \'separator\' of type @a@. @'TwoFingerOddA' e ()@ is isomorphic--- to @[e]@, and @'TwoFingerOddA' e a@ is isomorphic to @([(a, e)], a)@.+-- | This module provides alternating finger trees, based on+-- 'Data.Seq.Seq' from the @containers@ package. Between every element+-- (of type @e@) in the \'normal\' finger tree, there is a+-- \'separator\' of type @a@. @'TwoFingerOddA' e ()@ is isomorphic to+-- @[e]@, and @'TwoFingerOddA' e a@ is isomorphic to @([(a, e)], a)@. -- (The type variables are in that order because that permits a -- 'Traversable1' instance for 'TwoFingerOddA'.) --@@ -48,9 +47,6 @@ --      /Journal of Functional Programming/ 16:2 (2006) pp 197-217. --      <http://staff.city.ac.uk/~ross/papers/FingerTree.html> ----- This package's alternating finger trees are not annotated with--- sizes as described in section 4 of the paper.--- -- Many of the functions in this package follow laws, which are not -- documented inline. [tests/Properties.hs](https://github.com/quasicomputational/mega/blob/master/packages/twofinger/test/Properties.hs) --is an  automatically-tested QuickCheck suite of properties.@@ -86,20 +82,11 @@     -- ** Half conses     halfconsEvenE, halfsnocEvenE, halfunconsEvenE, halfunsnocEvenE,     -- * Appending different flavours-    -- $monoid_action_properties     -- ** Monoid actions     appendEvenAOddA, appendOddEEvenA,     appendOddAEvenE, appendEvenEOddE,     -- ** Two odds make an even     appendOddAOddE, appendOddEOddA,-    -- * Aligning (zipping)-    alignLeftOddAOddA, alignLeftOddAEvenA,-    alignLeftOddEOddE, alignLeftOddEEvenE,-    -- * Infinite trees-    repeatOddA, repeatOddE,-    repeatEvenA, repeatEvenE,-    infiniteOddA, infiniteOddE,-    infiniteEvenA, infiniteEvenE   )   where @@ -123,10 +110,4 @@     appendEvenAOddA, appendOddEEvenA,     appendOddAEvenE, appendEvenEOddE,     appendOddAOddE, appendOddEOddA,-    alignLeftOddAOddA, alignLeftOddAEvenA,-    alignLeftOddEOddE, alignLeftOddEEvenE,-    repeatOddA, repeatOddE,-    repeatEvenA, repeatEvenE,-    infiniteOddA, infiniteOddE,-    infiniteEvenA, infiniteEvenE   )

@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_HADDOCK not-home #-} -- | -- Stability: unstable --@@ -15,7 +15,7 @@ import Control.DeepSeq (NFData) import Control.Monad (ap) import Data.Bifunctor (Bifunctor (bimap), first, second)-import Data.Bifoldable (Bifoldable (bifoldMap), biall)+import Data.Bifoldable (Bifoldable (bifoldMap)) import Data.Bitraversable   (Bitraversable (bitraverse), bifoldMapDefault, bimapDefault) import Data.Functor.Alt (Alt ((<!>)))@@ -31,7 +31,6 @@ import Data.Functor.Plus (Plus (zero)) import Data.List (foldl') import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Maybe (isNothing) import Data.Semigroup (Semigroup ((<>))) import Data.Semigroup.Bifoldable (Bifoldable1 (bifoldMap1)) import Data.Semigroup.Bitraversable@@ -39,9 +38,8 @@ import Data.Semigroup.Foldable (Foldable1 (foldMap1)) import Data.Semigroup.Traversable   (Traversable1 (traverse1), foldMap1Default)-import Data.Stream.Infinite-  (Stream ((:>)))-import qualified Data.Stream.Infinite as Stream+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import Data.Traversable (foldMapDefault, fmapDefault) import GHC.Generics (Generic) @@ -64,6 +62,10 @@  --TODO: the tuples are annoying. Consider moving to HLists. +--TODO: revise the naming scheme of functions? In particular, singletonOddA -> emptyOddA??++--TODO: efficient unzips? The fmap-based approach can be a space leak.+ --TODO: send this upstream to semigroupoids? Opened issue: https://github.com/ekmett/semigroupoids/issues/66 (<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b ff <.*> MaybeApply (Left fa) = ff <.> fa@@ -88,70 +90,8 @@ -- * Types, EqN?\/ShowN?\/(Bi)Functor\/Foldable1?\/Traversable1? -- instances, and odd traversals. -data Digit e a-  = One e-  | Two e a e-  | Three e a e a e-  | Four e a e a e a e-  deriving (Functor, Foldable, Traversable, Generic)--instance (NFData e, NFData a) => NFData (Digit e a)--instance Bifunctor Digit where-  bimap = bimapDefault--instance Bifoldable Digit where-  bifoldMap = bifoldMapDefault--instance Bifoldable1 Digit where-  bifoldMap1 = bifoldMap1Default--instance Bitraversable Digit where-  bitraverse = bitraverseDefault--instance Bitraversable1 Digit where-  bitraverse1 f _ (One e) = One <$> f e-  bitraverse1 f g (Two e1 a1 e2) = Two <$> f e1 <.> g a1 <.> f e2-  bitraverse1 f g (Three e1 a1 e2 a2 e3) =-    Three <$> f e1 <.> g a1 <.> f e2 <.> g a2 <.> f e3-  bitraverse1 f g (Four e1 a1 e2 a2 e3 a3 e4) =-    Four <$> f e1 <.> g a1 <.> f e2 <.> g a2 <.> f e3 <.> g a3 <.> f e4--data Node e a = Node2 e a e | Node3 e a e a e-  deriving (Functor, Foldable, Traversable, Eq, Generic)--instance (NFData e, NFData a) => NFData (Node e a)--instance Foldable1 (Node e) where-  foldMap1 = foldMap1Default--instance Traversable1 (Node e) where-  traverse1 f (Node2 e1 a1 e2) = Node2 e1 <$> f a1 <.*> pure e2-  traverse1 f (Node3 e1 a1 e2 a2 e3) =-    Node3 e1 <$> f a1 <.*> pure e2 <.> f a2 <.*> pure e3--instance Bifunctor Node where-  bimap = bimapDefault--instance Bifoldable Node where-  bifoldMap = bifoldMapDefault--instance Bifoldable1 Node where-  bifoldMap1 = bifoldMap1Default--instance Bitraversable Node where-  bitraverse = bitraverseDefault--instance Bitraversable1 Node where-  bitraverse1 f g (Node2 e1 a1 e2) = Node2 <$> f e1 <.> g a1 <.> f e2-  bitraverse1 f g (Node3 e1 a1 e2 a2 e3) =-    Node3 <$> f e1 <.> g a1 <.> f e2 <.> g a2 <.> f e3- -- | Isomorphic to @a, (e, a)*@-data TwoFingerOddA e a-  = EmptyOddA a-  | SingleOddA a e a-  | DeepOddA a !(Digit e a) (TwoFingerOddA (Node e a) a) !(Digit e a) a+data TwoFingerOddA e a = TwoFingerOddA (Seq (a, e)) a   deriving (Generic)  instance Show2 TwoFingerOddA where@@ -172,12 +112,8 @@   showsPrec = showsPrec2  instance Eq2 TwoFingerOddA where-  liftEq2 f g as bs = case alignLeftOddAOddA as bs of-    (aligned, rest) ->-      biall (uncurry f) (uncurry g) aligned && noMore rest-    where-      noMore :: Either (TwoFingerEvenE a b) (TwoFingerEvenE c d) -> Bool-      noMore = either (isNothing . unconsEvenE) (isNothing . unconsEvenE)+  liftEq2 f g (TwoFingerOddA as a) (TwoFingerOddA bs b) =+    liftEq (liftEq2 g f) as bs && g a b  instance (Eq e) => Eq1 (TwoFingerOddA e) where   liftEq = liftEq2 (==)@@ -220,14 +156,9 @@   traverse = bitraverse pure  instance Traversable1 (TwoFingerOddA e) where-  traverse1 f (EmptyOddA a) = EmptyOddA <$> f a-  traverse1 f (SingleOddA a1 e1 a2) = SingleOddA <$> f a1 <.*> pure e1 <.> f a2-  traverse1 f (DeepOddA a0 pr m sf a1) = DeepOddA-     <$> f a0-    <.*> traverse (MaybeApply . Left . f) pr-     <.> bitraverse1 (traverse1 f) f m-    <.*> traverse (MaybeApply . Left . f) sf-     <.> f a1+  traverse1 f (TwoFingerOddA as a) = TwoFingerOddA+     <$> traverse (bitraverse (MaybeApply . Left . f) pure) as+    <*.> f a  instance Bifunctor TwoFingerOddA where   bimap = bimapDefault@@ -242,19 +173,12 @@   bitraverse = bitraverseDefault  instance Bitraversable1 TwoFingerOddA where-  bitraverse1 _ g (EmptyOddA a) = EmptyOddA <$> g a-  bitraverse1 f g (SingleOddA a1 e1 a2) = SingleOddA <$> g a1 <.> f e1 <.> g a2-  bitraverse1 f g (DeepOddA a0 pr m sf a1) = DeepOddA-    <$> g a0-    <.> bitraverse1 f g pr-    <.> bitraverse1 (bitraverse1 f g) g m-    <.> bitraverse1 f g sf-    <.> g a1+  bitraverse1 f g (TwoFingerOddA as a) = TwoFingerOddA+     <$> traverse (MaybeApply . Left . bitraverse1 g f) as+    <*.> g a  -- | Isomorphic to @e, (a, e)*@-data TwoFingerOddE e a-  = SingleOddE e-  | DeepOddE !(Digit e a) (TwoFingerOddA (Node e a) a) !(Digit e a)+data TwoFingerOddE e a = TwoFingerOddE e (Seq (a, e))   deriving (Generic)  instance Show2 TwoFingerOddE where@@ -275,11 +199,8 @@   showsPrec = showsPrec2  instance Eq2 TwoFingerOddE where-  liftEq2 f g as bs = case alignLeftOddEOddE as bs of-    (aligned, rest) -> biall (uncurry f) (uncurry g) aligned && noMore rest-    where-      noMore :: Either (TwoFingerEvenA a b) (TwoFingerEvenA c d) -> Bool-      noMore = either (isNothing . unconsEvenA) (isNothing . unconsEvenA)+  liftEq2 f g (TwoFingerOddE a as) (TwoFingerOddE b bs) =+    liftEq (liftEq2 g f) as bs && f a b  instance (Eq e) => Eq1 (TwoFingerOddE e) where   liftEq = liftEq2 (==)@@ -302,18 +223,24 @@ instance Bifoldable TwoFingerOddE where   bifoldMap = bifoldMapDefault +instance Bifoldable1 TwoFingerOddE where+  bifoldMap1 = bifoldMap1Default+ instance Bitraversable TwoFingerOddE where-  bitraverse f _ (SingleOddE e) = SingleOddE <$> f e-  bitraverse f g (DeepOddE pr m sf) = DeepOddE <$> bitraverse f g pr <*> bitraverse (bitraverse f g) g m <*> bitraverse f g sf+  bitraverse = bitraverseDefault +instance Bitraversable1 TwoFingerOddE where+  bitraverse1 f g (TwoFingerOddE a as) = TwoFingerOddE+     <$> f a+    <.*> traverse (MaybeApply . Left . bitraverse1 g f) as+ instance (NFData e, NFData a) => NFData (TwoFingerOddE e a)  --TODO: cleaner to offer TwoFingerEvenE1, without EmptyL? -- | Isomorphic to @(e, a)*@ data TwoFingerEvenE e a   = EmptyEvenE-  | SingleEvenE e a-  | DeepEvenE !(Digit e a) (TwoFingerOddA (Node e a) a) !(Digit e a) a+  | TwoFingerEvenE e (Seq (a, e)) a   deriving (Generic)  instance Show2 TwoFingerEvenE where@@ -336,11 +263,11 @@   showsPrec = showsPrec2  instance Eq2 TwoFingerEvenE where-  liftEq2 f g as bs = case alignLeftEvenEEvenE as bs of-    (aligned, rest) -> biall (uncurry f) (uncurry g) aligned && noMore rest-    where-      noMore :: Either (TwoFingerEvenE a b) (TwoFingerEvenE c d) -> Bool-      noMore = either (isNothing . unconsEvenE) (isNothing . unconsEvenE)+  liftEq2 _ _ EmptyEvenE EmptyEvenE = True+  liftEq2 _ _ EmptyEvenE (TwoFingerEvenE {}) = False+  liftEq2 _ _ (TwoFingerEvenE {}) EmptyEvenE = False+  liftEq2 f g (TwoFingerEvenE a as e) (TwoFingerEvenE a' as' e') =+    g e e' && f a a' && liftEq (liftEq2 g f) as as'  instance (Eq e) => Eq1 (TwoFingerEvenE e) where   liftEq = liftEq2 (==)@@ -367,18 +294,13 @@  instance Bitraversable TwoFingerEvenE where   bitraverse _ _ EmptyEvenE = pure EmptyEvenE-  bitraverse f g (SingleEvenE e a) = SingleEvenE <$> f e <*> g a-  bitraverse f g (DeepEvenE pr m sf a) = DeepEvenE-    <$> bitraverse f g pr-    <*> bitraverse (bitraverse f g) g m-    <*> bitraverse f g sf+  bitraverse f g (TwoFingerEvenE e as a) = TwoFingerEvenE+    <$> f e+    <*> traverse (bitraverse g f) as     <*> g a  -- | Isomorphic to @(a, e)*@-data TwoFingerEvenA e a-  = EmptyEvenA-  | SingleEvenA a e-  | DeepEvenA a !(Digit e a) (TwoFingerOddA (Node e a) a) !(Digit e a)+data TwoFingerEvenA e a = TwoFingerEvenA (Seq (a, e))   deriving (Generic)  instance Show2 TwoFingerEvenA where@@ -399,11 +321,8 @@   showsPrec = showsPrec2  instance Eq2 TwoFingerEvenA where-  liftEq2 f g as bs = case alignLeftEvenAEvenA as bs of-    (aligned, rest) -> biall (uncurry f) (uncurry g) aligned && noMore rest-    where-      noMore :: Either (TwoFingerEvenA a b) (TwoFingerEvenA c d) -> Bool-      noMore = either (isNothing . unconsEvenA) (isNothing . unconsEvenA)+  liftEq2 f g (TwoFingerEvenA as) (TwoFingerEvenA bs) =+    liftEq (liftEq2 g f) as bs  instance (Eq e) => Eq1 (TwoFingerEvenA e) where   liftEq = liftEq2 (==)@@ -429,67 +348,7 @@   bifoldMap = bifoldMapDefault  instance Bitraversable TwoFingerEvenA where-  bitraverse _ _ EmptyEvenA = pure EmptyEvenA-  bitraverse f g (SingleEvenA a e) = SingleEvenA <$> g a <*> f e-  bitraverse f g (DeepEvenA a pr m sf) = DeepEvenA-    <$> g a-    <*> bitraverse f g pr-    <*> bitraverse (bitraverse f g) g m-    <*> bitraverse f g sf---- * Digit operations.--digitToTree :: Digit e a -> TwoFingerOddE e a-digitToTree (One e) = SingleOddE e-digitToTree (Two e1 a1 e2) = DeepOddE (One e1) (EmptyOddA a1) (One e2)-digitToTree (Three e1 a1 e2 a2 e3) =-  DeepOddE (Two e1 a1 e2) (EmptyOddA a2) (One e3)-digitToTree (Four e1 a1 e2 a2 e3 a3 e4) =-  DeepOddE (Two e1 a1 e2) (EmptyOddA a2) (Two e3 a3 e4)--digitCons :: e -> a -> Digit e a -> Either (Digit e a, a, Node e a) (Digit e a)-digitCons e1 a1 (One e2) = Right $ Two e1 a1 e2-digitCons e1 a1 (Two e2 a2 e3) = Right $ Three e1 a1 e2 a2 e3-digitCons e1 a1 (Three e2 a2 e3 a3 e4) = Right $ Four e1 a1 e2 a2 e3 a3 e4-digitCons e1 a1 (Four e2 a2 e3 a3 e4 a4 e5) =-  Left (Two e1 a1 e2, a2, Node3 e3 a3 e4 a4 e5)--digitSnoc :: Digit e a -> a -> e -> Either (Node e a, a, Digit e a) (Digit e a)-digitSnoc (One e1) a1 e2 = Right $ Two e1 a1 e2-digitSnoc (Two e1 a1 e2) a2 e3 = Right $ Three e1 a1 e2 a2 e3-digitSnoc (Three e1 a1 e2 a2 e3) a3 e4 = Right $ Four e1 a1 e2 a2 e3 a3 e4-digitSnoc (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 =-  Left (Node3 e1 a1 e2 a2 e3, a3, Two e4 a4 e5)--digitUncons :: Digit e a -> (e, Maybe (a, Digit e a))-digitUncons (One e1) = (e1, Nothing)-digitUncons (Two e1 a1 e2) = (e1, Just (a1, One e2))-digitUncons (Three e1 a1 e2 a2 e3) = (e1, Just (a1, Two e2 a2 e3))-digitUncons (Four e1 a1 e2 a2 e3 a3 e4) =-  (e1, Just (a1, Three e2 a2 e3 a3 e4))--digitUnsnoc :: Digit e a -> (Maybe (Digit e a, a), e)-digitUnsnoc (One e1) = (Nothing, e1)-digitUnsnoc (Two e1 a1 e2) = (Just (One e1, a1), e2)-digitUnsnoc (Three e1 a1 e2 a2 e3) = (Just (Two e1 a1 e2, a2), e3)-digitUnsnoc (Four e1 a1 e2 a2 e3 a3 e4) =-  (Just (Three e1 a1 e2 a2 e3, a3), e4)---- * Node operations.-nodeToDigit :: Node e a -> Digit e a-nodeToDigit (Node2 e1 a1 e2) = Two e1 a1 e2-nodeToDigit (Node3 e1 a1 e2 a2 e3) = Three e1 a1 e2 a2 e3---- * Tree rotations-rotl :: TwoFingerOddA (Node e a) a -> Digit e a -> TwoFingerEvenA e a-rotl m sf = case unconsOddA m of-  Left a -> halfconsOddE a $ digitToTree sf-  Right ((a, e), m') -> DeepEvenA a (nodeToDigit e) m' sf--rotr :: Digit e a -> TwoFingerOddA (Node e a) a -> TwoFingerEvenE e a-rotr pr m = case unsnocOddA m of-  Left a -> halfsnocOddE (digitToTree pr) a-  Right (m', (e, a)) -> DeepEvenE pr m' (nodeToDigit e) a+  bitraverse f g (TwoFingerEvenA as) = TwoFingerEvenA <$> traverse (bitraverse g f) as  -- * (Un)conses/snocs for TwoFingerOddA. consOddA :: a -> e -> TwoFingerOddA e a -> TwoFingerOddA e a@@ -508,35 +367,23 @@   (Nothing, a) -> Left a   (Just (tree', e), a) -> Right (tree', (e, a)) --- | \(O(\log n)\) worst case. Inverse: 'halfunconsEvenE'+-- | \(O(1)\) worst case. Inverse: 'halfunconsEvenE' halfconsOddA :: e -> TwoFingerOddA e a -> TwoFingerEvenE e a-halfconsOddA e (EmptyOddA a) = SingleEvenE e a-halfconsOddA e (SingleOddA a1 e1 a2) =-  DeepEvenE (One e) (EmptyOddA a1) (One e1) a2-halfconsOddA e (DeepOddA a0 pr m sf a1) = case digitCons e a0 pr of-  Right pr' -> DeepEvenE pr' m sf a1-  Left (pr', a', node) -> DeepEvenE pr' (consOddA a' node m) sf a1+halfconsOddA e (TwoFingerOddA as a) = TwoFingerEvenE e as a  -- | \(O(\log n)\) worst case. Inverse: 'halfunsnocEvenA' halfsnocOddA :: TwoFingerOddA e a -> e -> TwoFingerEvenA e a-halfsnocOddA (EmptyOddA a) e = SingleEvenA a e-halfsnocOddA (SingleOddA a e1 a1) e2 =-  DeepEvenA a (One e1) (EmptyOddA a1) (One e2)-halfsnocOddA (DeepOddA a0 pr m sf a1) e = case digitSnoc sf a1 e of-  Right sf' -> DeepEvenA a0 pr m sf'-  Left (node, a', sf') -> DeepEvenA a0 pr (snocOddA m node a') sf'+halfsnocOddA (TwoFingerOddA as a) e = TwoFingerEvenA $ as Seq.|> (a, e) --- | \(O(1)\) worst case. Inverse: 'halfconsEvenE'+-- | \(O(\log n)\) worst case. Inverse: 'halfconsEvenE' halfunconsOddA :: TwoFingerOddA e a -> (a, TwoFingerEvenE e a)-halfunconsOddA (EmptyOddA a) = (a, EmptyEvenE)-halfunconsOddA (SingleOddA a e1 a1) = (a, SingleEvenE e1 a1)-halfunconsOddA (DeepOddA a0 pr m sf a1) = (a0, DeepEvenE pr m sf a1)+halfunconsOddA (TwoFingerOddA as a) = case Seq.viewl as of+  Seq.EmptyL -> (a, mempty)+  (a', e') Seq.:< as' -> (a', TwoFingerEvenE e' as' a) --- | \(O(1)\) worst case. Inverse: 'halfsnocOddA'+-- | \(O(1)\) worst case. Inverse: 'halfsnocEvenA' halfunsnocOddA :: TwoFingerOddA e a -> (TwoFingerEvenA e a, a)-halfunsnocOddA (EmptyOddA a) = (EmptyEvenA, a)-halfunsnocOddA (SingleOddA a1 e1 a2) = (SingleEvenA a1 e1, a2)-halfunsnocOddA (DeepOddA a0 pr m sf a1) = (DeepEvenA a0 pr m sf, a1)+halfunsnocOddA (TwoFingerOddA as a) = (TwoFingerEvenA as, a)  -- * (Un)conses/snocs for TwoFingerOddE. consOddE :: e -> a -> TwoFingerOddE e a -> TwoFingerOddE e a@@ -555,29 +402,23 @@   (Nothing, e) -> Left e   (Just (tree', a), e) -> Right (tree', (a, e)) --- | \(O(1)\) worst case. Inverse: 'halfunconsEvenA'+-- | \(O(\log n)\) worst case. Inverse: 'halfunconsEvenA' halfconsOddE :: a -> TwoFingerOddE e a -> TwoFingerEvenA e a-halfconsOddE a (SingleOddE e) = SingleEvenA a e-halfconsOddE a (DeepOddE pr m sf) = DeepEvenA a pr m sf+halfconsOddE a (TwoFingerOddE e as) = TwoFingerEvenA $ (a, e) Seq.<| as  -- | \(O(1)\) worst case. Inverse: 'halfunsnocEvenE' halfsnocOddE :: TwoFingerOddE e a -> a -> TwoFingerEvenE e a-halfsnocOddE (SingleOddE e) a = SingleEvenE e a-halfsnocOddE (DeepOddE pr m sf) a = DeepEvenE pr m sf a+halfsnocOddE (TwoFingerOddE e as) a = TwoFingerEvenE e as a --- | \(O(\log n)\) worst case. Inverse: 'halfconsEvenA'+-- | \(O(1)\) worst case. Inverse: 'halfconsEvenA' halfunconsOddE :: TwoFingerOddE e a -> (e, TwoFingerEvenA e a)-halfunconsOddE (SingleOddE e) = (e, EmptyEvenA)-halfunconsOddE (DeepOddE pr m sf) = case digitUncons pr of-  (e, Nothing) -> (e, rotl m sf)-  (e, Just (a, pr')) -> (e, DeepEvenA a pr' m sf)+halfunconsOddE (TwoFingerOddE e as) = (e, TwoFingerEvenA as)  -- | \(O(\log n)\) worst case. Inverse: 'halfsnocEvenE' halfunsnocOddE :: TwoFingerOddE e a -> (TwoFingerEvenE e a, e)-halfunsnocOddE (SingleOddE e) = (EmptyEvenE, e)-halfunsnocOddE (DeepOddE pr m sf) = case digitUnsnoc sf of-  (Nothing, e) -> (rotr pr m, e)-  (Just (sf', a), e) -> (DeepEvenE pr m sf' a, e)+halfunsnocOddE (TwoFingerOddE e as) = case Seq.viewr as of+  Seq.EmptyR -> (mempty, e)+  as' Seq.:> (a', e') -> (TwoFingerEvenE e as' a', e')  -- * (Un)conses/snocs for TwoFingerEvenE. consEvenE :: e -> a -> TwoFingerEvenE e a -> TwoFingerEvenE e a@@ -596,34 +437,25 @@   Nothing -> Nothing   Just ((tree', a), e) -> Just (tree', (a, e)) --- | \(O(1)\) worst case. Inverse: 'halfunconsOddA'+-- | \(O(\log n)\) worst case. Inverse: 'halfunconsOddA' halfconsEvenE :: a -> TwoFingerEvenE e a -> TwoFingerOddA e a-halfconsEvenE a EmptyEvenE = EmptyOddA a-halfconsEvenE a0 (SingleEvenE e1 a1) = SingleOddA a0 e1 a1-halfconsEvenE a0 (DeepEvenE pr m sf a1) = DeepOddA a0 pr m sf a1+halfconsEvenE a EmptyEvenE = TwoFingerOddA mempty a+halfconsEvenE a (TwoFingerEvenE e as a') = TwoFingerOddA ((a, e) Seq.<| as) a'  -- | \(O(\log n)\) worst case. Inverse: 'halfunsnocOddE'. halfsnocEvenE :: TwoFingerEvenE e a -> e -> TwoFingerOddE e a-halfsnocEvenE EmptyEvenE e = SingleOddE e-halfsnocEvenE (SingleEvenE e1 a1) e2 =-  DeepOddE (One e1) (EmptyOddA a1) (One e2)-halfsnocEvenE (DeepEvenE pr m sf a) e = case digitSnoc sf a e of-  Right sf' -> DeepOddE pr m sf'-  Left (node, a', sf') -> DeepOddE pr (snocOddA m node a') sf'+halfsnocEvenE EmptyEvenE e = TwoFingerOddE e mempty+halfsnocEvenE (TwoFingerEvenE e as a') e' = TwoFingerOddE e $ as Seq.|> (a', e') --- | \(O(\log n)\) worst case. Inverse: 'halfconsOddA'.+-- | \(O(1)\) worst case. Inverse: 'halfconsOddA'. halfunconsEvenE :: TwoFingerEvenE e a -> Maybe (e, TwoFingerOddA e a) halfunconsEvenE EmptyEvenE = Nothing-halfunconsEvenE (SingleEvenE e a) = Just (e, EmptyOddA a)-halfunconsEvenE (DeepEvenE pr m sf a1) = Just $ case digitUncons pr of-  (e, Nothing) -> (e, halfsnocEvenA (rotl m sf) a1)-  (e, Just (a0, pr')) -> (e, DeepOddA a0 pr' m sf a1)+halfunconsEvenE (TwoFingerEvenE e as a) = Just (e, TwoFingerOddA as a)  -- | \(O(1)\) worst case. Inverse: 'halfsnocOddE'. halfunsnocEvenE :: TwoFingerEvenE e a -> Maybe (TwoFingerOddE e a, a) halfunsnocEvenE EmptyEvenE = Nothing-halfunsnocEvenE (SingleEvenE e a) = Just (SingleOddE e, a)-halfunsnocEvenE (DeepEvenE pr m sf a) = Just (DeepOddE pr m sf, a)+halfunsnocEvenE (TwoFingerEvenE e as a) = Just (TwoFingerOddE e as, a)  -- * (Un)conses/snocs for TwoFingerEvenA. consEvenA :: a -> e -> TwoFingerEvenA e a -> TwoFingerEvenA e a@@ -642,34 +474,25 @@   Nothing -> Nothing   Just ((tree', e), a) -> Just (tree', (e, a)) --- | \(O(\log n)\) worst case. Inverse: 'halfunconsOddE'.+-- | \(O(1)\) worst case. Inverse: 'halfunconsOddE'. halfconsEvenA :: e -> TwoFingerEvenA e a -> TwoFingerOddE e a-halfconsEvenA e EmptyEvenA = SingleOddE e-halfconsEvenA e1 (SingleEvenA a1 e2) =-  DeepOddE (One e1) (EmptyOddA a1) (One e2)-halfconsEvenA e (DeepEvenA a pr m sf) = case digitCons e a pr of-  Right pr' -> DeepOddE pr' m sf-  Left (pr', a', node) -> DeepOddE pr' (consOddA a' node m) sf+halfconsEvenA e (TwoFingerEvenA as) = TwoFingerOddE e as  -- | \(O(1)\) worst case. Inverse: 'halfunsnocOddA'. halfsnocEvenA :: TwoFingerEvenA e a -> a -> TwoFingerOddA e a-halfsnocEvenA EmptyEvenA a = EmptyOddA a-halfsnocEvenA (SingleEvenA a1 e1) a2 = SingleOddA a1 e1 a2-halfsnocEvenA (DeepEvenA a0 pr m sf) a = DeepOddA a0 pr m sf a+halfsnocEvenA (TwoFingerEvenA as) a = TwoFingerOddA as a --- | \(O(1)\) worst case. Inverse: 'halfconsOddE'.+-- | \(O(\log n)\) worst case. Inverse: 'halfconsOddE'. halfunconsEvenA :: TwoFingerEvenA e a -> Maybe (a, TwoFingerOddE e a)-halfunconsEvenA EmptyEvenA = Nothing-halfunconsEvenA (SingleEvenA a e) = Just (a, SingleOddE e)-halfunconsEvenA (DeepEvenA a pr m sf) = Just (a, DeepOddE pr m sf)+halfunconsEvenA (TwoFingerEvenA as) = case Seq.viewl as of+  Seq.EmptyL -> Nothing+  (a, e) Seq.:< as' -> Just (a, TwoFingerOddE e as')  -- | \(O(\log n)\) worst case. Inverse: 'halfsnocOddA'. halfunsnocEvenA :: TwoFingerEvenA e a -> Maybe (TwoFingerOddA e a, e)-halfunsnocEvenA EmptyEvenA = Nothing-halfunsnocEvenA (SingleEvenA a e) = Just (EmptyOddA a, e)-halfunsnocEvenA (DeepEvenA a1 pr m sf) = case digitUnsnoc sf of-  (Nothing, e) -> Just (halfconsEvenE a1 (rotr pr m), e)-  (Just (sf', a2), e) -> Just (DeepOddA a1 pr m sf' a2, e)+halfunsnocEvenA (TwoFingerEvenA as) = case Seq.viewr as of+  Seq.EmptyR -> Nothing+  as' Seq.:> (a, e) -> Just (TwoFingerOddA as' a, e)  -- * Monad and Applicative instances, and related operations @@ -710,7 +533,7 @@  -- * Construction and deconstruction of TwoFingerOddA. singletonOddA :: a -> TwoFingerOddA e a-singletonOddA = EmptyOddA+singletonOddA = TwoFingerOddA mempty  -- | Surrounds the argument with 'mempty'. --@@ -725,8 +548,9 @@ -- >>> onlyOddA (consOddA True 3 $ singletonOddA False) -- Nothing onlyOddA :: TwoFingerOddA e a -> Maybe a-onlyOddA (EmptyOddA a) = Just a-onlyOddA _ = Nothing+onlyOddA (TwoFingerOddA as a) = case Seq.viewl as of+  Seq.EmptyL -> Just a+  _ -> Nothing  -- | -- >>> interleavingOddA "sep" (3 :| [4, 5])@@ -737,348 +561,26 @@  -- * Construction of TwoFingerOddE singletonOddE :: e -> TwoFingerOddE e a-singletonOddE = SingleOddE+singletonOddE e = TwoFingerOddE e mempty  -- * Concatenation of TwoFingerOddA.  instance (Semigroup a) => Semigroup (TwoFingerOddA e a) where-  (<>) = appendOddA0+  (<>) = appendOddA  instance (Monoid a, Semigroup a) => Monoid (TwoFingerOddA e a) where   mempty = singletonOddA mempty   mappend = (<>) -appendOddA0+appendOddA   :: (Semigroup a)   => TwoFingerOddA e a   -> TwoFingerOddA e a   -> TwoFingerOddA e a-appendOddA0 (EmptyOddA a) (halfunconsOddA -> (a', m)) =-  halfconsEvenE (a <> a') m-appendOddA0 (SingleOddA a1 e1 a) (halfunconsOddA -> (a', m)) =-  consOddA a1 e1 $ halfconsEvenE (a <> a') m-appendOddA0 (halfunsnocOddA -> (m, a)) (EmptyOddA a') =-  halfsnocEvenA m (a <> a')-appendOddA0 (halfunsnocOddA -> (m, a)) (SingleOddA a' a1 e1) =-  snocOddA (halfsnocEvenA m (a <> a')) a1 e1-appendOddA0 (DeepOddA aa1 pr1 m1 sf1 az1) (DeepOddA aa2 pr2 m2 sf2 az2) =-  DeepOddA aa1 pr1 (addDigits0 m1 sf1 (az1 <> aa2) pr2 m2) sf2 az2--addDigits0-  :: TwoFingerOddA (Node e a) a-  -> Digit e a -> a -> Digit e a-  -> TwoFingerOddA (Node e a) a-  -> TwoFingerOddA (Node e a) a-addDigits0 m1 (One e1) a1 (One e2) m2 =-  appendOddA1 m1 (Node2 e1 a1 e2) m2-addDigits0 m1 (One e1) a1 (Two e2 a2 e3) m2 =-  appendOddA1 m1 (Node3 e1 a1 e2 a2 e3) m2-addDigits0 m1 (One e1) a1 (Three e2 a2 e3 a3 e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits0 m1 (One e1) a1 (Four e2 a2 e3 a3 e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits0 m1 (Two e1 a1 e2) a2 (One e3) m2 =-  appendOddA1 m1 (Node3 e1 a1 e2 a2 e3) m2-addDigits0 m1 (Two e1 a1 e2) a2 (Two e3 a3 e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits0 m1 (Two e1 a1 e2) a2 (Three e3 a3 e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits0 m1 (Two e1 a1 e2) a2 (Four e3 a3 e4 a4 e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits0 m1 (Three e1 a1 e2 a2 e3) a3 (One e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits0 m1 (Three e1 a1 e2 a2 e3) a3 (Two e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits0 m1 (Three e1 a1 e2 a2 e3) a3 (Three e4 a4 e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits0 m1 (Three e1 a1 e2 a2 e3) a3 (Four e4 a4 e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits0 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 (One e5) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) m2-addDigits0 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 (Two e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits0 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 (Three e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) a4-    (Node3 e5 a5 e6 a6 e7) m2-addDigits0 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 (Four e5 a5 e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2--appendOddA1 :: TwoFingerOddA e a -> e -> TwoFingerOddA e a -> TwoFingerOddA e a-appendOddA1 (EmptyOddA a) e m = consOddA a e m-appendOddA1 (SingleOddA a1 e1 a2) e2 m = consOddA a1 e1 $ consOddA a2 e2 m-appendOddA1 m e (EmptyOddA a) = snocOddA m e a-appendOddA1 m e1 (SingleOddA a1 e2 a2) = snocOddA (snocOddA m e1 a1) e2 a2-appendOddA1 (DeepOddA a0 pr1 m1 sf1 a1) e (DeepOddA a2 pr2 m2 sf2 az) =-  DeepOddA a0 pr1 (addDigits1 m1 sf1 a1 e a2 pr2 m2) sf2 az--addDigits1-  :: TwoFingerOddA (Node e a) a-  -> Digit e a -> a -> e -> a -> Digit e a-  -> TwoFingerOddA (Node e a) a-  -> TwoFingerOddA (Node e a) a-addDigits1 m1 (One e1) a1 e2 a2 (One e3) m2 =-  appendOddA1 m1 (Node3 e1 a1 e2 a2 e3) m2-addDigits1 m1 (One e1) a1 e2 a2 (Two e3 a3 e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits1 m1 (One e1) a1 e2 a2 (Three e3 a3 e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits1 m1 (One e1) a1 e2 a2 (Four e3 a3 e4 a4 e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits1 m1 (Two e1 a1 e2) a2 e3 a3 (One e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits1 m1 (Two e1 a1 e2) a2 e3 a3 (Two e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits1 m1 (Two e1 a1 e2) a2 e3 a3 (Three e4 a4 e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits1 m1 (Two e1 a1 e2) a2 e3 a3 (Four e4 a4 e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits1 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 (One e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits1 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 (Two e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits1 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 (Three e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits1 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 (Four e5 a5 e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits1 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 (One e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits1 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 (Two e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits1 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 (Three e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits1 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5-  (Four e6 a6 e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2--appendOddA2-  :: TwoFingerOddA e a-  -> e -> a -> e-  -> TwoFingerOddA e a-  -> TwoFingerOddA e a-appendOddA2 (EmptyOddA a1) e1 a2 e2 m =-  consOddA a1 e1 $ consOddA a2 e2 m-appendOddA2 (SingleOddA a1 e1 a2) e2 a3 e3 m =-  consOddA a1 e1 $ consOddA a2 e2 $ consOddA a3 e3 m-appendOddA2 m e1 a1 e2 (EmptyOddA a2) =-  snocOddA (snocOddA m e1 a1) e2 a2-appendOddA2 m e1 a1 e2 (SingleOddA a2 e3 a3) =-  snocOddA (snocOddA (snocOddA m e1 a1) e2 a2) e3 a3-appendOddA2 (DeepOddA a0 pr1 m1 sf1 a1) e1 a2 e2 (DeepOddA a3 pr2 m2 sf2 az) =-  DeepOddA a0 pr1 (addDigits2 m1 sf1 a1 e1 a2 e2 a3 pr2 m2) sf2 az--addDigits2-  :: TwoFingerOddA (Node e a) a-  -> Digit e a -> a -> e -> a -> e -> a -> Digit e a-  -> TwoFingerOddA (Node e a) a-  -> TwoFingerOddA (Node e a) a-addDigits2 m1 (One e1) a1 e2 a2 e3 a3 (One e4) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node2 e3 a3 e4) m2-addDigits2 m1 (One e1) a1 e2 a2 e3 a3 (Two e4 a4 e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits2 m1 (One e1) a1 e2 a2 e3 a3 (Three e4 a4 e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits2 m1 (One e1) a1 e2 a2 e3 a3 (Four e4 a4 e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits2 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 (One e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits2 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 (Two e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits2 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 (Three e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits2 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 (Four e5 a5 e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits2 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 (One e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits2 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 (Two e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits2 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 (Three e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits2 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5-  (Four e6 a6 e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits2 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 (One e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits2 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 (Two e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits2 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6-  (Three e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits2 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6-  (Four e7 a7 e8 a8 e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2--appendOddA3-  :: TwoFingerOddA e a-  -> e -> a -> e -> a -> e-  -> TwoFingerOddA e a-  -> TwoFingerOddA e a-appendOddA3 (EmptyOddA a1) e1 a2 e2 a3 e3 m =-  consOddA a1 e1 $ consOddA a2 e2 $ consOddA a3 e3 m-appendOddA3 m e1 a1 e2 a2 e3 (EmptyOddA a3) =-  snocOddA (snocOddA (snocOddA m e1 a1) e2 a2) e3 a3-appendOddA3 (SingleOddA a1 e1 a2) e2 a3 e3 a4 e4 m =-  consOddA a1 e1 $ consOddA a2 e2 $ consOddA a3 e3 $ consOddA a4 e4 m-appendOddA3 m e1 a1 e2 a2 e3 (SingleOddA a3 e4 a4) =-  snocOddA (snocOddA (snocOddA (snocOddA m e1 a1) e2 a2) e3 a3) e4 a4-appendOddA3 (DeepOddA a0 pr1 m1 sf1 a1) e1 a2 e2 a3 e3-  (DeepOddA a4 pr2 m2 sf2 az) =-    DeepOddA a0 pr1 (addDigits3 m1 sf1 a1 e1 a2 e2 a3 e3 a4 pr2 m2) sf2 az--addDigits3-  :: TwoFingerOddA (Node e a) a-  -> Digit e a -> a -> e -> a -> e -> a -> e -> a -> Digit e a-  -> TwoFingerOddA (Node e a) a-  -> TwoFingerOddA (Node e a) a-addDigits3 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 (One e5) m2 =-  appendOddA2 m1 (Node2 e1 a1 e2) a2 (Node3 e3 a3 e4 a4 e5) m2-addDigits3 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 (Two e5 a5 e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits3 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 (Three e5 a5 e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits3 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 (Four e5 a5 e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits3 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 (One e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits3 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 (Two e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits3 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 (Three e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits3 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5-  (Four e6 a6 e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits3 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 (One e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits3 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 (Two e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits3 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6-  (Three e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits3 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6-  (Four e7 a7 e8 a8 e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2-addDigits3 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7 (One e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits3 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7-  (Two e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits3 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7-  (Three e8 a8 e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2-addDigits3 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7-  (Four e8 a8 e9 a9 e10 a10 e11) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node3 e9 a9 e10 a10 e11) m2--appendOddA4-  :: TwoFingerOddA e a-  -> e -> a -> e -> a -> e -> a -> e-  -> TwoFingerOddA e a-  -> TwoFingerOddA e a-appendOddA4 (EmptyOddA a1) e1 a2 e2 a3 e3 a4 e4 m =-  consOddA a1 e1 $ consOddA a2 e2 $ consOddA a3 e3 $ consOddA a4 e4 m-appendOddA4 m e1 a1 e2 a2 e3 a3 e4 (EmptyOddA a4) =-  snocOddA (snocOddA (snocOddA (snocOddA m e1 a1) e2 a2) e3 a3) e4 a4-appendOddA4 (SingleOddA a1 e1 a2) e2 a3 e3 a4 e4 a5 e5 m =-  consOddA a1 e1 $ consOddA a2 e2 $ consOddA a3 e3 $ consOddA a4 e4 $-    consOddA a5 e5 m-appendOddA4 m e1 a1 e2 a2 e3 a3 e4 (SingleOddA a4 e5 a5) =-  snocOddA (snocOddA (snocOddA (snocOddA (snocOddA m e1 a1) e2 a2) e3 a3) e4 a4) e5 a5-appendOddA4 (DeepOddA a0 pr1 m1 sf1 a1) e1 a2 e2 a3 e3 a4 e4-  (DeepOddA a5 pr2 m2 sf2 an) =-    DeepOddA a0 pr1 (addDigits4 m1 sf1 a1 e1 a2 e2 a3 e3 a4 e4 a5 pr2 m2) sf2 an--addDigits4-  :: TwoFingerOddA (Node e a) a-  -> Digit e a -> a -> e -> a -> e -> a -> e -> a -> e -> a -> Digit e a-  -> TwoFingerOddA (Node e a) a-  -> TwoFingerOddA (Node e a) a-addDigits4 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 e5 a5 (One e6) m2 =-  appendOddA2 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) m2-addDigits4 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 e5 a5 (Two e6 a6 e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits4 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 e5 a5 (Three e6 a6 e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits4 m1 (One e1) a1 e2 a2 e3 a3 e4 a4 e5 a5-  (Four e6 a6 e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits4 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 e6 a6 (One e7) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node2 e6 a6 e7) m2-addDigits4 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 e6 a6 (Two e7 a7 e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits4 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 e6 a6-  (Three e7 a7 e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits4 m1 (Two e1 a1 e2) a2 e3 a3 e4 a4 e5 a5 e6 a6-  (Four e7 a7 e8 a8 e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2-addDigits4 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 e7 a7 (One e8) m2 =-  appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node2 e4 a4 e5) a5-    (Node3 e6 a6 e7 a7 e8) m2-addDigits4 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 e7 a7-  (Two e8 a8 e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits4 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 e7 a7-  (Three e8 a8 e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2-addDigits4 m1 (Three e1 a1 e2 a2 e3) a3 e4 a4 e5 a5 e6 a6 e7 a7-  (Four e8 a8 e9 a9 e10 a10 e11) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node3 e9 a9 e10 a10 e11) m2-addDigits4 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7 e8 a8-  (One e9) m2 =-    appendOddA3 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) m2-addDigits4 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7 e8 a8-  (Two e9 a9 e10) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node2 e9 a9 e10) m2-addDigits4 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7 e8 a8-  (Three e9 a9 e10 a10 e11) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node2 e7 a7 e8) a8 (Node3 e9 a9 e10 a10 e11) m2-addDigits4 m1 (Four e1 a1 e2 a2 e3 a3 e4) a4 e5 a5 e6 a6 e7 a7 e8 a8-  (Four e9 a9 e10 a10 e11 a11 e12) m2 =-    appendOddA4 m1 (Node3 e1 a1 e2 a2 e3) a3 (Node3 e4 a4 e5 a5 e6) a6-      (Node3 e7 a7 e8 a8 e9) a9 (Node3 e10 a10 e11 a11 e12) m2+appendOddA (TwoFingerOddA as a) (TwoFingerOddA bs z) =+  case Seq.viewl bs of+    Seq.EmptyL -> TwoFingerOddA as (a <> z)+    (b, e) Seq.:< bs' -> TwoFingerOddA (as <> ((a <> b, e) Seq.<| bs')) z  -- * Concatenation of TwoFingerEvenE. @@ -1098,10 +600,8 @@ appendEvenE :: TwoFingerEvenE e a -> TwoFingerEvenE e a -> TwoFingerEvenE e a appendEvenE EmptyEvenE m = m appendEvenE m EmptyEvenE = m-appendEvenE (SingleEvenE e a) m = consEvenE e a m-appendEvenE m (SingleEvenE e a) = snocEvenE m e a-appendEvenE (DeepEvenE pr1 m1 sf1 b1) (DeepEvenE pr2 m2 sf2 b2) =-  DeepEvenE pr1 (addDigits0 m1 sf1 b1 pr2 m2) sf2 b2+appendEvenE (TwoFingerEvenE e as a) (TwoFingerEvenE e' as' a') =+  TwoFingerEvenE e (as <> ((a, e') Seq.<| as')) a'  -- * Concatenation of TwoFingerEvenA. @@ -1112,222 +612,39 @@   (<!>) = appendEvenA  instance Monoid (TwoFingerEvenA e a) where-  mempty = EmptyEvenA+  mempty = TwoFingerEvenA mempty   mappend = (<>)  instance Plus (TwoFingerEvenA e) where-  zero = EmptyEvenA+  zero = TwoFingerEvenA mempty  appendEvenA :: TwoFingerEvenA e a -> TwoFingerEvenA e a -> TwoFingerEvenA e a-appendEvenA EmptyEvenA m = m-appendEvenA m EmptyEvenA = m-appendEvenA (SingleEvenA a e) m = consEvenA a e m-appendEvenA m (SingleEvenA a e) = snocEvenA m a e-appendEvenA (DeepEvenA a1 pr1 m1 sf1) (DeepEvenA a2 pr2 m2 sf2) =-  DeepEvenA a1 pr1 (addDigits0 m1 sf1 a2 pr2 m2) sf2+appendEvenA (TwoFingerEvenA as) (TwoFingerEvenA bs) = TwoFingerEvenA (as <> bs)  -- * Monoid actions  appendOddAEvenE :: TwoFingerOddA e a -> TwoFingerEvenE e a -> TwoFingerOddA e a-appendOddAEvenE (EmptyOddA a) m = halfconsEvenE a m appendOddAEvenE m EmptyEvenE = m-appendOddAEvenE (SingleOddA a1 e a2) m = consOddA a1 e $ halfconsEvenE a2 m-appendOddAEvenE m (SingleEvenE e a) = snocOddA m e a-appendOddAEvenE (DeepOddA a1 pr1 m1 sf1 a2) (DeepEvenE pr2 m2 sf2 a3) =-  DeepOddA a1 pr1 (addDigits0 m1 sf1 a2 pr2 m2) sf2 a3+appendOddAEvenE (TwoFingerOddA as a) (TwoFingerEvenE e bs z) =+  TwoFingerOddA (as <> ((a, e) Seq.<| bs)) z  appendEvenAOddA :: TwoFingerEvenA e a -> TwoFingerOddA e a -> TwoFingerOddA e a-appendEvenAOddA EmptyEvenA m = m-appendEvenAOddA m (EmptyOddA a) = halfsnocEvenA m a-appendEvenAOddA (SingleEvenA a e) m = consOddA a e m-appendEvenAOddA m (SingleOddA a1 e1 a2) = snocOddA (halfsnocEvenA m a1) e1 a2-appendEvenAOddA (DeepEvenA a1 pr1 m1 sf1) (DeepOddA a2 pr2 m2 sf2 b) =-  DeepOddA a1 pr1 (addDigits0 m1 sf1 a2 pr2 m2) sf2 b+appendEvenAOddA (TwoFingerEvenA as) (TwoFingerOddA bs z) =+  TwoFingerOddA (as <> bs) z  appendOddAOddE :: TwoFingerOddA e a -> TwoFingerOddE e a -> TwoFingerEvenA e a-appendOddAOddE (EmptyOddA a) m = halfconsOddE a m-appendOddAOddE (SingleOddA a1 e a2) m = consEvenA a1 e $ halfconsOddE a2 m-appendOddAOddE m (SingleOddE e) = halfsnocOddA m e-appendOddAOddE (DeepOddA a1 pr1 m1 sf1 a2) (DeepOddE pr2 m2 sf2) =-  DeepEvenA a1 pr1 (addDigits0 m1 sf1 a2 pr2 m2) sf2+appendOddAOddE (TwoFingerOddA as a) (TwoFingerOddE e bs) =+  TwoFingerEvenA (as <> ((a, e) Seq.<| bs))  appendOddEOddA :: TwoFingerOddE e a -> TwoFingerOddA e a -> TwoFingerEvenE e a-appendOddEOddA m (EmptyOddA a) = halfsnocOddE m a-appendOddEOddA (SingleOddE e) m = halfconsOddA e m-appendOddEOddA m (SingleOddA a1 e a2) = snocEvenE (halfsnocOddE m a1) e a2-appendOddEOddA (DeepOddE pr1 m1 sf1) (DeepOddA a1 pr2 m2 sf2 a2) =-  DeepEvenE pr1 (addDigits0 m1 sf1 a1 pr2 m2) sf2 a2+appendOddEOddA (TwoFingerOddE e as) (TwoFingerOddA bs a) =+  TwoFingerEvenE e (as <> bs) a  appendOddEEvenA :: TwoFingerOddE e a -> TwoFingerEvenA e a -> TwoFingerOddE e a-appendOddEEvenA m EmptyEvenA = m-appendOddEEvenA (SingleOddE e) m = halfconsEvenA e m-appendOddEEvenA m (SingleEvenA a e) = snocOddE m a e-appendOddEEvenA (DeepOddE pr1 m1 sf1) (DeepEvenA a pr2 m2 sf2) =-  DeepOddE pr1 (addDigits0 m1 sf1 a pr2 m2) sf2+appendOddEEvenA (TwoFingerOddE e as) (TwoFingerEvenA bs) =+  TwoFingerOddE e (as <> bs)  appendEvenEOddE :: TwoFingerEvenE e a -> TwoFingerOddE e a -> TwoFingerOddE e a appendEvenEOddE EmptyEvenE m = m-appendEvenEOddE (SingleEvenE a e) m = consOddE a e m-appendEvenEOddE m (SingleOddE e) = halfsnocEvenE m e-appendEvenEOddE (DeepEvenE pr1 m1 sf1 a) (DeepOddE pr2 m2 sf2) =-  DeepOddE pr1 (addDigits0 m1 sf1 a pr2 m2) sf2---- * Aligning/zipping.---- | Align two 'TwoFingerOddA' sequences elementwise, and return the excess remainder.------ >>> alignLeftOddAOddA (consOddA 'a' 1 $ consOddA 'b' 2 $ singletonOddA 'c') (consOddA "foo" 10 $ singletonOddA "bar")--- (consOddA ('a',"foo") (1,10) (singletonOddA ('b',"bar")),Left (consEvenE 2 'c' mempty))------ >>> alignLeftOddAOddA (consOddA 'a' 1 $ singletonOddA 'b') (consOddA "foo" 10 $ consOddA "bar" 20 $ singletonOddA "baz")--- (consOddA ('a',"foo") (1,10) (singletonOddA ('b',"bar")),Right (consEvenE 20 "baz" mempty))-alignLeftOddAOddA :: TwoFingerOddA e a -> TwoFingerOddA e' a' -> (TwoFingerOddA (e, e') (a, a'), Either (TwoFingerEvenE e a) (TwoFingerEvenE e' a'))-alignLeftOddAOddA as (halfunsnocOddA -> (bs, a')) = case alignLeftOddAEvenA as bs of-  Left (aligned, halfunconsOddA -> (a, rest)) ->-    (halfsnocEvenA aligned (a, a'), Left rest)-  Right (aligned, rest) -> (aligned, Right $ halfsnocOddE rest a')----TODO: if we had TwoFingerEvenE1, we could avoid the arbitrary Left/Right selection in the Left/Nothing case.--- |--- >>> alignLeftOddAEvenA (consOddA 'a' 1 $ consOddA 'b' 2 $ singletonOddA 'c') (consEvenA "foo" 10 mempty)--- Left (consEvenA ('a',"foo") (1,10) mempty,consOddA 'b' 2 (singletonOddA 'c'))------ >>> alignLeftOddAEvenA (consOddA 'a' 1 $ singletonOddA 'b') (consEvenA "foo" 10 $ consEvenA "bar" 20 $ consEvenA "baz" 30 mempty)--- Right (consOddA ('a',"foo") (1,10) (singletonOddA ('b',"bar")),consOddE 20 "baz" (singletonOddE 30))-alignLeftOddAEvenA :: TwoFingerOddA e a -> TwoFingerEvenA e' a' -> Either (TwoFingerEvenA (e, e') (a, a'), TwoFingerOddA e a) (TwoFingerOddA (e, e') (a, a'), TwoFingerOddE e' a')-alignLeftOddAEvenA as bs = case (unconsOddA as, unconsEvenA bs) of-  (Right ((a, e), as'), Just ((a', e'), bs')) -> case alignLeftOddAEvenA as' bs' of-    Left (aligned, rest) -> Left (consEvenA (a, a') (e, e') aligned, rest)-    Right (aligned, rest) -> Right (consOddA (a, a') (e, e') aligned, rest)-  (_, Nothing) -> Left (mempty, as)-  (Left a, Just ((a', e'), bs')) -> Right (singletonOddA (a, a'), halfconsEvenA e' bs')--alignLeftEvenAEvenA :: TwoFingerEvenA e a -> TwoFingerEvenA e' a' -> (TwoFingerEvenA (e, e') (a, a'), Either (TwoFingerEvenA e a) (TwoFingerEvenA e' a'))-alignLeftEvenAEvenA as bs = case (unconsEvenA as, unconsEvenA bs) of-  (Just ((a, e), as'), Just ((a', e'), bs')) -> case alignLeftEvenAEvenA as' bs' of-    (aligned, rest) -> (consEvenA (a, a') (e, e') aligned, rest)-  (_, Nothing) -> (mempty, Left as)-  (Nothing, _) -> (mempty, Right bs)---- |--- >>> alignLeftOddEOddE (consOddE 'a' 1 $ consOddE 'b' 2 $ singletonOddE 'c') (consOddE "foo" 10 $ singletonOddE "bar")--- (consOddE ('a',"foo") (1,10) (singletonOddE ('b',"bar")),Left (consEvenA 2 'c' mempty))------ >>> alignLeftOddEOddE (consOddE 'a' 1 $ singletonOddE 'b') (consOddE "foo" 10 $ consOddE "bar" 20 $ singletonOddE "baz")--- (consOddE ('a',"foo") (1,10) (singletonOddE ('b',"bar")),Right (consEvenA 20 "baz" mempty))-alignLeftOddEOddE :: TwoFingerOddE e a -> TwoFingerOddE e' a' -> (TwoFingerOddE (e, e') (a, a'), Either (TwoFingerEvenA e a) (TwoFingerEvenA e' a'))-alignLeftOddEOddE as (halfunsnocOddE -> (bs, e')) = case alignLeftOddEEvenE as bs of-  Left (aligned, halfunconsOddE -> (e, rest)) -> (halfsnocEvenE aligned (e, e'), Left rest)-  Right (aligned, rest) -> (aligned, Right $ halfsnocOddA rest e')--alignLeftOddEEvenE :: TwoFingerOddE e a -> TwoFingerEvenE e' a' -> Either (TwoFingerEvenE (e, e') (a, a'), TwoFingerOddE e a) (TwoFingerOddE (e, e') (a, a'), TwoFingerOddA e' a')-alignLeftOddEEvenE as bs = case (unconsOddE as, unconsEvenE bs) of-  (Right ((e, a), as'), Just ((e', a'), bs')) -> case alignLeftOddEEvenE as' bs' of-    Left (aligned, rest) -> Left (consEvenE (e, e') (a, a') aligned, rest)-    Right (aligned, rest) -> Right (consOddE (e, e') (a, a') aligned, rest)-  (_, Nothing) -> Left (mempty, as)-  (Left e, Just ((e', a'), bs')) -> Right (singletonOddE (e, e'), halfconsEvenE a' bs')--alignLeftEvenEEvenE :: TwoFingerEvenE e a -> TwoFingerEvenE e' a' -> (TwoFingerEvenE (e, e') (a, a'), Either (TwoFingerEvenE e a) (TwoFingerEvenE e' a'))-alignLeftEvenEEvenE as bs = case (unconsEvenE as, unconsEvenE bs) of-  (Just ((e, a), as'), Just ((e', a'), bs')) -> case alignLeftEvenEEvenE as' bs' of-    (aligned, rest) -> (consEvenE (e, e') (a, a') aligned, rest)-  (_, Nothing) -> (mempty, Left as)-  (Nothing, _) -> (mempty, Right bs)---- * Creating infinite sequences.----TODO: we can actually work with either finite or infinite sequences here, right? Oh, not quite: if both sides are finite, we'll have a parity mismatch, so that can't work even in theory. One side infinite and one side finite could be wonky: if we peer too deeply into the finite side, we'll bottom out. So maybe it makes sense for either both to be finite (with an extra a to balance), or both to be infinite; but, in the finite case, if the things are flagrantly different lengths, we'd be better off building with cons/snoc rather than structurally. On the other hand, it might be useful to be able to build a tree without committing to it being finite or infinite. The worry is the unexpected bottoming.--takeNodeLeft :: (Stream a -> es -> (e, Stream a, es)) -> Stream a -> es -> (Node e a, Stream a, es)-takeNodeLeft f as es =-  let (x, a :> as', es') = f as es-      (y, as'', es'') = f as' es'-  in (Node2 x a y, as'', es'')--takeNodeRight :: (es -> Stream a -> (e, es, Stream a)) -> es -> Stream a -> (Node e a, es, Stream a)-takeNodeRight f es as =-  let (x, es', a :> as') = f es as-      (y, es'', as'') = f es' as'-  in (Node2 y a x, es'', as'')--takeSingleNodeLeft :: Stream a -> Stream e -> (Node e a, Stream a, Stream e)-takeSingleNodeLeft = takeNodeLeft (\as (e :> es) -> (e, as, es))--takeSingleNodeRight :: Stream e -> Stream a -> (Node e a, Stream e, Stream a)-takeSingleNodeRight = takeNodeRight (\(e :> es) as -> (e, es, as))--infiniteOddA'-  :: (Stream a -> Stream e -> (Node e' a, Stream a, Stream e))-  -> (Stream e -> Stream a -> (Node e' a, Stream e, Stream a))-  -> Stream a -> Stream e-  -> Stream e -> Stream a-  -> TwoFingerOddA e' a-infiniteOddA' f g (a0 :> leftA) leftE rightE (an :> rightA) =-  let (prNode, leftA', leftE') = f leftA leftE-      (sfNode, rightE', rightA') = g rightE rightA-      inner = infiniteOddA' (takeNodeLeft f) (takeNodeRight g) leftA' leftE' rightE' rightA'-  in DeepOddA a0 (nodeToDigit prNode) inner (nodeToDigit sfNode) an---- | Infinitely repeat the given @a@ and @e@.-repeatOddA :: a -> e -> TwoFingerOddA e a-repeatOddA a e = infiniteOddA (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id e) (Stream.iterate id a)---- | From streams of leftward @a@, leftward @e@, rightward @e@ and--- rightward @a@, build an infinite 'TwoFingerOddA'.------ >>> let infinite = infiniteOddA (Stream.iterate (+ 1) 0) (Stream.iterate (+ 1) 10) (Stream.iterate (+ 1) 20) (Stream.iterate (+ 1) 30)--- >>> take 5 $ unfoldr (hush . unconsOddA) infinite--- [(0,10),(1,11),(2,12),(3,13),(4,14)]--- >>> take 5 $ unfoldr (fmap swap . hush . unsnocOddA) infinite--- [(20,30),(21,31),(22,32),(23,33),(24,34)]-infiniteOddA :: Stream a -> Stream e -> Stream e -> Stream a -> TwoFingerOddA e a-infiniteOddA = infiniteOddA' takeSingleNodeLeft takeSingleNodeRight---- | Infinitely repeat the given @a@ and @e@.-repeatOddE :: e -> a -> TwoFingerOddE e a-repeatOddE e a = infiniteOddE (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id a) (Stream.iterate id e)---- |------ >>> let infinite = infiniteOddE (Stream.iterate (+ 1) 0) (Stream.iterate (+ 1) 10) (Stream.iterate (+ 1) 20) (Stream.iterate (+ 1) 30)--- >>> take 5 $ unfoldr (hush . unconsOddE) infinite--- [(0,10),(1,11),(2,12),(3,13),(4,14)]--- >>> take 5 $ unfoldr (fmap swap . hush . unsnocOddE) infinite--- [(20,30),(21,31),(22,32),(23,33),(24,34)]-infiniteOddE :: Stream e -> Stream a -> Stream a -> Stream e -> TwoFingerOddE e a-infiniteOddE leftE leftA rightA rightE =-  DeepOddE (nodeToDigit prNode) inner (nodeToDigit sfNode)-  where-    (prNode, leftE', leftA') = takeSingleNodeLeft leftA leftE-    (sfNode, rightA', rightE') = takeSingleNodeRight rightE rightA-    inner = infiniteOddA' (takeNodeLeft takeSingleNodeLeft) (takeNodeRight takeSingleNodeRight) leftE' leftA' rightA' rightE'---- | Infinitely repeat the given @a@ and @e@.-repeatEvenA :: a -> e -> TwoFingerEvenA e a-repeatEvenA a e = infiniteEvenA (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id e)---- |------ >>> let infinite = infiniteEvenA (Stream.iterate (+ 1) 0) (Stream.iterate (+ 1) 10) (Stream.iterate (+ 1) 20) (Stream.iterate (+ 1) 30)--- >>> take 5 $ unfoldr unconsEvenA infinite--- [(0,10),(1,11),(2,12),(3,13),(4,14)]--- >>> take 5 $ unfoldr (fmap swap . unsnocEvenA) infinite--- [(20,30),(21,31),(22,32),(23,33),(24,34)]-infiniteEvenA :: Stream a -> Stream e -> Stream a -> Stream e -> TwoFingerEvenA e a-infiniteEvenA (a :> leftA) leftE rightA rightE =-  halfconsOddE a $ infiniteOddE leftE leftA rightA rightE--repeatEvenE :: e -> a -> TwoFingerEvenE e a-repeatEvenE e a = infiniteEvenE (Stream.iterate id e) (Stream.iterate id a) (Stream.iterate id e) (Stream.iterate id a)---- |------ >>> let infinite = infiniteEvenE (Stream.iterate (+ 1) 0) (Stream.iterate (+ 1) 10) (Stream.iterate (+ 1) 20) (Stream.iterate (+ 1) 30)--- >>> take 5 $ unfoldr unconsEvenE infinite--- [(0,10),(1,11),(2,12),(3,13),(4,14)]--- >>> take 5 $ unfoldr (fmap swap . unsnocEvenE) infinite--- [(20,30),(21,31),(22,32),(23,33),(24,34)]-infiniteEvenE :: Stream e -> Stream a -> Stream e -> Stream a -> TwoFingerEvenE e a-infiniteEvenE leftE leftA rightE (a :> rightA) =-  halfsnocOddE (infiniteOddE leftE leftA rightA rightE) a+appendEvenEOddE (TwoFingerEvenE e as a) (TwoFingerOddE e' bs) =+  TwoFingerOddE e (as <> ((a, e') Seq.<| bs))

@@ -1,108 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+--TODO: It's nice being able to edit the properties as code, which we couldn't have if they were haddocks, but it'd also be nice to have some way to cross-link them to the relevant functions in the Q4C12.TwoFinger's generated haddocks; maybe even to generate pretty documentation of the properties? module Main   ( main   )   where +import Control.Lens (Lens', makePrisms)+import Control.Lens.Properties (isLens) import Control.Monad (join)-import Data.Bifunctor (bimap) import Data.Semigroup ((<>)) import Test.Tasty (TestTree, testGroup, defaultMain)-import Test.Tasty.QuickCheck (Gen, Arbitrary, testProperty)+import Test.Tasty.QuickCheck (Gen, Arbitrary, Arbitrary1, Arbitrary2, testProperty, shrink2, arbitrary2, liftArbitrary, liftArbitrary2, liftShrink, liftShrink2) import qualified Test.Tasty.QuickCheck as QC -import Q4C12.TwoFinger.Internal (Digit (One, Two, Three, Four), TwoFingerOddA (SingleOddA, EmptyOddA, DeepOddA), TwoFingerOddE (SingleOddE, DeepOddE), TwoFingerEvenA (SingleEvenA, EmptyEvenA, DeepEvenA), TwoFingerEvenE (SingleEvenE, EmptyEvenE, DeepEvenE), Node (Node2, Node3), unconsEvenA, unconsEvenE, digitToTree, halfsnocOddA, halfsnocOddE, halfunsnocOddA, halfconsEvenE, halfunconsOddA, halfconsOddE, halfsnocEvenA, repeatEvenA, repeatEvenE, repeatOddA, repeatOddE, alignLeftOddAOddA, alignLeftOddAEvenA, alignLeftOddEOddE, alignLeftOddEEvenE, alignLeftEvenAEvenA, alignLeftEvenEEvenE, appendOddEOddA, appendEvenEOddE, appendOddEEvenA, appendOddAOddE, appendEvenAOddA, appendOddAEvenE, halfunsnocEvenA, halfunsnocEvenE, halfsnocEvenE, halfunconsEvenA, halfunsnocOddE, halfunconsEvenE, halfconsOddA, halfunconsOddE, halfconsEvenA)--genDigit :: Gen e -> Gen a -> Gen (Digit e a)-genDigit e a = QC.oneof-  [ One <$> e-  , Two <$> e <*> a <*> e-  , Three <$> e <*> a <*> e <*> a <*> e-  , Four <$> e <*> a <*> e <*> a <*> e <*> a <*> e-  ]+import Q4C12.TwoFinger.Internal (TwoFingerOddA (TwoFingerOddA), TwoFingerOddE (TwoFingerOddE), TwoFingerEvenA (TwoFingerEvenA), TwoFingerEvenE (EmptyEvenE, TwoFingerEvenE), halfsnocOddA, halfsnocOddE, halfunsnocOddA, halfconsEvenE, halfunconsOddA, halfconsOddE, halfsnocEvenA, appendOddEOddA, appendEvenEOddE, appendOddEEvenA, appendOddAOddE, appendEvenAOddA, appendOddAEvenE, halfunsnocEvenA, halfunsnocEvenE, halfsnocEvenE, halfunconsEvenA, halfunsnocOddE, halfunconsEvenE, halfconsOddA, halfunconsOddE, halfconsEvenA, firstOddA, lastOddA) -genNode :: Gen e -> Gen a -> Gen (Node e a)-genNode e a = QC.oneof-  [ Node2 <$> e <*> a <*> e-  , Node3 <$> e <*> a <*> e <*> a <*> e-  ]+newtype AnyOddA e a = AnyOddA { getAnyOddA :: TwoFingerOddA e a }+  deriving (Show, Eq) --- | The 'Int' parameter is expontential size: for a value \(n\), the generated tree will have (slightly more than) \(2^n\) to \(3^n\) elements.-genOddA :: Gen e -> Gen a -> Int -> Gen (TwoFingerOddA e a)-genOddA e a 1 = SingleOddA <$> a <*> e <*> a-genOddA _ a n | n <= 0 = EmptyOddA <$> a-genOddA e a n =-  DeepOddA <$> a <*> genDigit e a <*> genOddA (genNode e a) a (n - 2) <*> genDigit e a <*> a+instance Arbitrary2 AnyOddA where+  liftArbitrary2 e a = fmap AnyOddA $+    TwoFingerOddA <$> liftArbitrary (liftArbitrary2 a e) <*> a+  liftShrink2 f g (AnyOddA (TwoFingerOddA as a)) = do+    as' <- liftShrink (liftShrink2 g f) as+    a' <- g a+    pure $ AnyOddA $ TwoFingerOddA as' a' ---TODO: better shrinks? This isn't wrong, and it's better than the default, but we could be doing better (e.g., trying just the middle tree in Deep; also possibly just dropping things off the ends...).-shrinkOddA :: TwoFingerOddA e a -> [TwoFingerOddA e a]-shrinkOddA = \case-  EmptyOddA _ -> []-  SingleOddA a1 _ a2 ->-    [ EmptyOddA a1-    , EmptyOddA a2-    ]-  DeepOddA a0 pr m sf a1 -> mconcat-    [ [ halfsnocEvenA (halfconsOddE a0 $ digitToTree pr) (fst $ halfunconsOddA m)-      , halfconsEvenE (snd $ halfunsnocOddA m) (halfsnocOddE (digitToTree sf) a1)-      ]-    , [EmptyOddA a0]-    , [EmptyOddA a1]-    , (\m' -> DeepOddA a0 pr m' sf a1) <$> shrinkOddA m-    ]+instance (Arbitrary e) => Arbitrary1 (AnyOddA e) where+  liftArbitrary = liftArbitrary2 QC.arbitrary+  liftShrink = liftShrink2 pure -shrinkOddE :: TwoFingerOddE e a -> [TwoFingerOddE e a]-shrinkOddE (SingleOddE _) = []-shrinkOddE (DeepOddE pr m sf) = (\m' -> DeepOddE pr m' sf) <$> shrinkOddA m+instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddA e a) where+  arbitrary = arbitrary2+  shrink = shrink2 -shrinkEvenA :: TwoFingerEvenA e a -> [TwoFingerEvenA e a]-shrinkEvenA tree = case unconsEvenA tree of-  Nothing -> []-  Just (_, tree') -> [tree']+newtype AnyOddE e a = AnyOddE { _getAnyOddE :: TwoFingerOddE e a }+  deriving (Show, Eq) -shrinkEvenE :: TwoFingerEvenE e a -> [TwoFingerEvenE e a]-shrinkEvenE tree = case unconsEvenE tree of-  Nothing -> []-  Just (_, tree') -> [tree']+instance Arbitrary2 AnyOddE where+  liftArbitrary2 e a = fmap AnyOddE $ TwoFingerOddE <$> e <*> liftArbitrary (liftArbitrary2 a e)+  liftShrink2 f g (AnyOddE (TwoFingerOddE e as)) = do+    e' <- f e+    as' <- liftShrink (liftShrink2 g f) as+    pure $ AnyOddE $ TwoFingerOddE e' as' -newtype AnyOddA e a = AnyOddA { getAnyOddA :: TwoFingerOddA e a }-  deriving (Show)+instance (Arbitrary e) => Arbitrary1 (AnyOddE e) where+  liftArbitrary = liftArbitrary2 QC.arbitrary+  liftShrink = liftShrink2 pure -instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddA e a) where-  arbitrary = fmap AnyOddA $ genOddA QC.arbitrary QC.arbitrary =<< QC.choose (0, 10)-  shrink = fmap AnyOddA . shrinkOddA . getAnyOddA+instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddE e a) where+  arbitrary = arbitrary2+  shrink = shrink2 -newtype AnyOddE e a = AnyOddE { getAnyOddE :: TwoFingerOddE e a }-  deriving (Show)+newtype AnyEvenA e a = AnyEvenA { _getAnyEvenA :: TwoFingerEvenA e a }+  deriving (Show, Eq) -instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyOddE e a) where-  arbitrary = AnyOddE <$> QC.oneof-    [ SingleOddE <$> QC.arbitrary-    , DeepOddE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary-    ]-  shrink = fmap AnyOddE . shrinkOddE . getAnyOddE+instance Arbitrary2 AnyEvenA where+  liftArbitrary2 e a = AnyEvenA . TwoFingerEvenA <$> liftArbitrary (liftArbitrary2 a e)+  liftShrink2 f g (AnyEvenA (TwoFingerEvenA as)) =+    AnyEvenA . TwoFingerEvenA <$> liftShrink (liftShrink2 g f) as -newtype AnyEvenA e a = AnyEvenA { getAnyEvenA :: TwoFingerEvenA e a }-  deriving (Show)+instance (Arbitrary e) => Arbitrary1 (AnyEvenA e) where+  liftArbitrary = liftArbitrary2 QC.arbitrary+  liftShrink = liftShrink2 pure  instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyEvenA e a) where-  arbitrary = AnyEvenA <$> QC.oneof-    [ pure EmptyEvenA-    , SingleEvenA <$> QC.arbitrary <*> QC.arbitrary-    , DeepEvenA <$> QC.arbitrary <*> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary-    ]-  shrink = fmap AnyEvenA . shrinkEvenA . getAnyEvenA+  arbitrary = arbitrary2+  shrink = shrink2 -newtype AnyEvenE e a = AnyEvenE { getAnyEvenE :: TwoFingerEvenE e a }-  deriving (Show)+newtype AnyEvenE e a = AnyEvenE { _getAnyEvenE :: TwoFingerEvenE e a }+  deriving (Show, Eq) -instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyEvenE e a) where-  arbitrary = AnyEvenE <$> QC.oneof+instance Arbitrary2 AnyEvenE where+  liftArbitrary2 e a = AnyEvenE <$> QC.oneof     [ pure EmptyEvenE-    , SingleEvenE <$> QC.arbitrary <*> QC.arbitrary-    , DeepEvenE <$> genDigit QC.arbitrary QC.arbitrary <*> (genOddA (genNode QC.arbitrary QC.arbitrary) QC.arbitrary =<< QC.choose (0, 10)) <*> genDigit QC.arbitrary QC.arbitrary <*> QC.arbitrary+    , TwoFingerEvenE <$> e <*> liftArbitrary (liftArbitrary2 a e) <*> a     ]-  shrink = fmap AnyEvenE . shrinkEvenE . getAnyEvenE+  liftShrink2 _ _ (AnyEvenE EmptyEvenE) = []+  liftShrink2 f g (AnyEvenE (TwoFingerEvenE e as a)) = fmap AnyEvenE $ do+    e' <- f e+    as' <- liftShrink (liftShrink2 g f) as+    a' <- g a+    [ mempty, TwoFingerEvenE e' as' a' ] +instance (Arbitrary e) => Arbitrary1 (AnyEvenE e) where+  liftArbitrary = liftArbitrary2 QC.arbitrary+  liftShrink = liftShrink2 pure++instance (Arbitrary e, Arbitrary a) => Arbitrary (AnyEvenE e a) where+  arbitrary = arbitrary2+  shrink = shrink2++makePrisms ''AnyOddA+makePrisms ''AnyOddE+makePrisms ''AnyEvenA+makePrisms ''AnyEvenE+ intFields :: (p Int [Int] -> r) -> p Int [Int] -> r intFields = id @@ -113,46 +106,46 @@         halfunconsEvenE (halfconsOddA e as) == Just (e, as)     , testProperty "OddE" $ \a -> intFields $ \(AnyOddE as) ->         halfunconsEvenA (halfconsOddE a as) == Just (a, as)-    , testProperty "EvenA" $ \a -> intFields $ \(AnyEvenE as) ->-        halfunconsOddA (halfconsEvenE a as) == (a, as)-    , testProperty "EvenE" $ \e -> intFields $ \(AnyEvenA as) ->+    , testProperty "EvenA" $ \e -> intFields $ \(AnyEvenA as) ->         halfunconsOddE (halfconsEvenA e as) == (e, as)+    , testProperty "EvenE" $ \a -> intFields $ \(AnyEvenE as) ->+        halfunconsOddA (halfconsEvenE a as) == (a, as)     ]   , testGroup "halfsnoc"     [ testProperty "OddA" $ \e -> intFields $ \(AnyOddA as) ->         halfunsnocEvenA (halfsnocOddA as e) == Just (as, e)     , testProperty "OddE" $ \a -> intFields $ \(AnyOddE as) ->         halfunsnocEvenE (halfsnocOddE as a) == Just (as, a)-    , testProperty "EvenA" $ \e -> intFields $ \(AnyEvenE as) ->-        halfunsnocOddE (halfsnocEvenE as e) == (as, e)-    , testProperty "EvenE" $ \a -> intFields $ \(AnyEvenA as) ->+    , testProperty "EvenA" $ \a -> intFields $ \(AnyEvenA as) ->         halfunsnocOddA (halfsnocEvenA as a) == (as, a)+    , testProperty "EvenE" $ \e -> intFields $ \(AnyEvenE as) ->+        halfunsnocOddE (halfsnocEvenE as e) == (as, e)     ]   , testGroup "halfuncons"     [ testProperty "OddA" $ intFields $ \(AnyOddA as) ->         as == uncurry halfconsEvenE (halfunconsOddA as)     , testProperty "OddE" $ intFields $  \(AnyOddE as) ->         as == uncurry halfconsEvenA (halfunconsOddE as)-    , testProperty "EvenA" $ intFields $ \(AnyEvenE as) ->-        as == maybe mempty (uncurry halfconsOddA) (halfunconsEvenE as)-    , testProperty "EvenE" $ intFields $ \(AnyEvenA as) ->+    , testProperty "EvenA" $ intFields $ \(AnyEvenA as) ->         as == maybe mempty (uncurry halfconsOddE) (halfunconsEvenA as)+    , testProperty "EvenE" $ intFields $ \(AnyEvenE as) ->+        as == maybe mempty (uncurry halfconsOddA) (halfunconsEvenE as)     ]   , testGroup "halfunsnoc"     [ testProperty "OddA" $ intFields $ \(AnyOddA as) ->         as == uncurry halfsnocEvenA (halfunsnocOddA as)     , testProperty "OddE" $ intFields $  \(AnyOddE as) ->         as == uncurry halfsnocEvenE (halfunsnocOddE as)-    , testProperty "EvenA" $ intFields $ \(AnyEvenE as) ->-        as == maybe mempty (uncurry halfsnocOddE) (halfunsnocEvenE as)-    , testProperty "EvenE" $ intFields $ \(AnyEvenA as) ->+    , testProperty "EvenA" $ intFields $ \(AnyEvenA as) ->         as == maybe mempty (uncurry halfsnocOddA) (halfunsnocEvenA as)+    , testProperty "EvenE" $ intFields $ \(AnyEvenE as) ->+        as == maybe mempty (uncurry halfsnocOddE) (halfunsnocEvenE as)     ]   ]  associativeProperties :: TestTree associativeProperties = testGroup "associativity"-  [ testGroup "leftmost AnyOddA"+  [ testGroup "leftmost OddA"     [ testProperty "OddA OddA" $ intFields $ \(AnyOddA a) (AnyOddA b) (AnyOddA c) ->         a <> (b <> c) == (a <> b) <> c     , testProperty "OddA EvenE" $ intFields $ \(AnyOddA a) (AnyOddA b) (AnyEvenE c) ->@@ -224,68 +217,12 @@       a == appendOddEEvenA a mempty   ] -alignProperties :: TestTree-alignProperties = testGroup "aligning is lossless"-  [ testProperty "OddA OddA" $ intFields $ \(AnyOddA as) -> intFields $ \(AnyOddA bs) ->-      let (aligned, rest) = alignLeftOddAOddA as bs-          as' = appendOddAEvenE (bimap fst fst aligned) (either id (const mempty) rest)-          bs' = appendOddAEvenE (bimap snd snd aligned) (either (const mempty) id rest)-      in as == as' && bs == bs'-  , testProperty "OddA EvenA" $ intFields $ \(AnyOddA as) -> intFields $ \(AnyEvenA bs) ->-      let (as', bs') = case alignLeftOddAEvenA as bs of-            Left (aligned, rest) ->-              (appendEvenAOddA (bimap fst fst aligned) rest, bimap snd snd aligned)-            Right (aligned, rest) ->-              (bimap fst fst aligned, appendOddAOddE (bimap snd snd aligned) rest)-      in as == as' && bs == bs'-  , testProperty "OddE OddE" $ intFields $ \(AnyOddE as) -> intFields $ \(AnyOddE bs) ->-      let (aligned, rest) = alignLeftOddEOddE as bs-          as' = appendOddEEvenA (bimap fst fst aligned) (either id (const mempty) rest)-          bs' = appendOddEEvenA (bimap snd snd aligned) (either (const mempty) id rest)-      in as == as' && bs == bs'-  , testProperty "OddE EvenE" $ intFields $ \(AnyOddE as) -> intFields $ \(AnyEvenE bs) ->-      let (as', bs') = case alignLeftOddEEvenE as bs of-            Left (aligned, rest) ->-              (appendEvenEOddE (bimap fst fst aligned) rest, bimap snd snd aligned)-            Right (aligned, rest) ->-              (bimap fst fst aligned, appendOddEOddA (bimap snd snd aligned) rest)-      in as == as' && bs == bs'-  ]--alignIdentityProperties :: TestTree-alignIdentityProperties = testGroup "align identities"-  [ testProperty "left OddA OddA" $ intFields $ \(AnyOddA as) ->-      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddAOddA (repeatOddA id id) as)-  , testProperty "right OddA OddA" $ intFields $ \(AnyOddA as) ->-      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftOddAOddA as (repeatOddA id id))-  , testProperty "left OddA EvenA" $ intFields $ \(AnyEvenA as) ->-      either ((as ==) . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) (alignLeftOddAEvenA (repeatOddA id id) as)-  , testProperty "right OddA EvenA" $ intFields $ \(AnyOddA as) ->-      either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddAEvenA as (repeatEvenA id id)-  , testProperty "left OddE OddE" $ intFields $ \(AnyOddE as) ->-      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftOddEOddE (repeatOddE id id) as)-  , testProperty "right OddE OddE" $ intFields $ \(AnyOddE as) ->-      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftOddEOddE as (repeatOddE id id))-  , testProperty "left OddE EvenE" $ intFields $ \(AnyEvenE as) ->-      either ((==) as . bimap (uncurry ($)) (uncurry ($)) . fst) (const False) $ alignLeftOddEEvenE (repeatOddE id id) as-  , testProperty "right OddE EvenE" $ intFields $ \(AnyOddE as) ->-      either (const False) ((==) as . bimap (uncurry $ flip ($)) (uncurry $ flip ($)) . fst) $ alignLeftOddEEvenE as (repeatEvenE id id)-  , testProperty "left EvenA EvenA" $ intFields $ \(AnyEvenA as) ->-      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenAEvenA (repeatEvenA id id) as)-  , testProperty "right EvenA EvenA" $ intFields $ \(AnyEvenA as) ->-      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftEvenAEvenA as (repeatEvenA id id))-  , testProperty "left EvenE EvenE" $ intFields $ \(AnyEvenE as) ->-      as == bimap (uncurry ($)) (uncurry ($)) (fst $ alignLeftEvenEEvenE (repeatEvenE id id) as)-  , testProperty "right EvenE EvenE" $ intFields $ \(AnyEvenE as) ->-      as == bimap (uncurry $ flip ($)) (uncurry $ flip ($)) (fst $ alignLeftEvenEEvenE as (repeatEvenE id id))-  ]- monadProperties :: TestTree monadProperties = testGroup "OddA monad laws"   [ testProperty "join . join === join . fmap join" $-      --Since we generate 3 layers deep, the things can get big with the default settings.+      --Cut size, since we generate three layers multiplicatively.       let gen :: Gen a -> Gen (TwoFingerOddA Int a)-          gen a = genOddA QC.arbitrary a =<< QC.choose (0, 3)+          gen x = QC.scale (`mod` 50) $ getAnyOddA <$> QC.liftArbitrary x       in QC.forAll (gen $ gen $ gen QC.arbitrary) $ \as ->            join (join as) == (join (fmap join as) :: TwoFingerOddA Int Int)   , testProperty "join . pure === id" $ \(AnyOddA as) ->@@ -294,13 +231,18 @@       as == (join (fmap pure as) :: TwoFingerOddA Int Int)   ] +--TODO: test isTraversal on the various traversals? Is there an isTraversal1? isTraversal for the bitraversals??+lensProperties :: TestTree+lensProperties = testGroup "lens laws"+  [ testProperty "firstOddA" $ isLens $ (_AnyOddA . firstOddA :: Lens' (AnyOddA Int Int) Int)+  , testProperty "lastOddA" $ isLens $ (_AnyOddA . lastOddA :: Lens' (AnyOddA Int Int) Int)+  ]+ main :: IO () main = defaultMain $ testGroup "property tests"   [ halfconsProperties   , associativeProperties   , monoidIdentityProperties-  , alignProperties-  , alignIdentityProperties   , monadProperties+  , lensProperties   ]-