diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Version history for ral + +## 0.1 + +- First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +SPDX-License-Identifier: GPL-2.0-or-later + +Copyright (c) 2019 Oleg Grenrus + + This library is free software: you may copy, redistribute and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation, either version 2 of the License, or (at your + option) any later version. + + This library is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program (see `LICENSE.GPLv2` and `LICENSE.GPLv3`). + If not, see . diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,59 @@ +module Main where + +import Criterion.Main (bench, bgroup, defaultMain, whnf) + +import qualified Data.List as L +import qualified Data.RAList as R +import qualified Data.RAList.NonEmpty as NER +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U + +list :: [Int] +list = [1 .. 10000] + +ralist :: R.RAList Int +ralist = R.fromList list + +vector :: V.Vector Int +vector = V.fromList list + +uvector :: U.Vector Int +uvector = U.fromList list + +rlast :: R.RAList a -> a +rlast (R.NonEmpty r) = NER.last r +rlast R.Empty = error "rlast Empty" + +main :: IO () +main = defaultMain + [ bgroup "Last" + [ bench "List" $ whnf L.last list + , bench "RAList" $ whnf rlast ralist + , bench "Vector" $ whnf V.last vector + , bench "Vector.Unboxed" $ whnf U.last uvector + ] + , bgroup "Index" + [ bench "List" $ whnf (\xs -> xs L.!! (L.length xs - 1)) list + , bench "RAList" $ whnf (\xs -> xs R.! (R.length xs - 1)) ralist + , bench "Vector" $ whnf (\xs -> xs V.! (V.length xs - 1)) vector + , bench "Vector.Unboxed" $ whnf (\xs -> xs U.! (U.length xs - 1)) uvector + ] + , bgroup "Cons" + [ bench "List" $ whnf (0 :) list + , bench "RAList" $ whnf (R.cons 0) ralist + , bench "Vector" $ whnf (V.cons 0) vector + , bench "Vector.Unboxed" $ whnf (U.cons 0) uvector + ] + , bgroup "Length" + [ bench "List" $ whnf L.length list + , bench "RAList" $ whnf R.length ralist + , bench "Vector" $ whnf V.length vector + , bench "Vector.Unboxed" $ whnf U.length uvector + ] + , bgroup "LastAfterCons" + [ bench "List" $ whnf (\xs -> L.last $ 0 : xs ) list + , bench "RAList" $ whnf (\xs -> rlast $ R.cons 0 xs) ralist + , bench "Vector" $ whnf (\xs -> V.last $ V.cons 0 xs) vector + , bench "Vector.Unboxed" $ whnf (\xs -> U.last $ U.cons 0 xs) uvector + ] + ] diff --git a/ral.cabal b/ral.cabal new file mode 100644 --- /dev/null +++ b/ral.cabal @@ -0,0 +1,123 @@ +cabal-version: 2.2 +name: ral +version: 0.1 +synopsis: Random access lists +category: Data, Dependent Types, Singletons +description: + This package provides ordinary random access list, 'RAList', and also + a length indexed variant, 'RAVec'. + . + The data structure allows fast cons-operation (like ordinary list) but also fast random access (like non-functional arrays). + . + For @lens@ or @optics@ support see [ral-lens](https://hackage.haskell.org/package/ral-lens) and [ral-optics](https://hackage.haskell.org/package/ral-optics) packages respectively. + . + === Similar packages + . + This packages don't provide length-indexed variant, and their 'RAList' has + opaque structure. + . + * https://hackage.haskell.org/package/ralist + * https://hackage.haskell.org/package/random-access-list + +homepage: https://github.com/phadej/vec +bug-reports: https://github.com/phadej/vec/issues +license: GPL-2.0-or-later +license-file: LICENSE +author: Oleg Grenrus +maintainer: Oleg.Grenrus +copyright: (c) 2019 Oleg Grenrus +build-type: Simple +extra-source-files: ChangeLog.md +tested-with: + GHC ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.1 + +source-repository head + type: git + location: https://github.com/phadej/vec.git + subdir: ral + +flag adjunctions + description: Depend on @adjunctions@ to provide its instances + manual: True + default: True + +flag distributive + description: + Depend on @distributive@ to provide its instances. Turning on, disables @adjunctions@ too. + + manual: True + default: True + +flag semigroupoids + description: + Depend on @semigroupoids@ to provide its instances, and `traverse1`. + + manual: True + default: True + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fprint-explicit-kinds + exposed-modules: + Data.RAList + Data.RAList.NonEmpty + Data.RAList.Tree + Data.RAVec + Data.RAVec.NonEmpty + Data.RAVec.Tree + + other-modules: + Data.RAList.Internal + Data.RAList.NonEmpty.Internal + Data.RAList.Tree.Internal + + -- GHC boot libs + build-depends: + , base >=4.7 && <4.14 + , deepseq >=1.3.0.1 && <1.5 + + if !impl(ghc >=8.0) + build-depends: semigroups >=0.18.4 && <0.20 + + -- siblings + build-depends: + , bin ^>=0.1 + , fin ^>=0.1.1 + + -- other dependencies + build-depends: + , hashable >=1.2.7.0 && <1.4 + , QuickCheck ^>=2.13.2 + + if flag(distributive) + build-depends: distributive >=0.5.3 && <0.7 + + if flag(adjunctions) + build-depends: adjunctions ^>=4.4 + + if flag(semigroupoids) + build-depends: semigroupoids >=5.2.2 && <5.4 + +-- dump-core +-- if impl(ghc >= 8.0) +-- build-depends: dump-core +-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html + +benchmark ral-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + ghc-options: -Wall -fprint-explicit-kinds -threaded + main-is: Bench.hs + build-depends: + , base + , criterion + , ral + , vector diff --git a/src/Data/RAList.hs b/src/Data/RAList.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList.hs @@ -0,0 +1,54 @@ +-- | Random access list. +-- +-- This module is designed to imported qualifed. +-- +module Data.RAList ( + RAList (..), + -- * Showing + explicitShow, + explicitShowsPrec, + -- * Construction + empty, + singleton, + cons, + -- * Indexing + (!), + (!?), + uncons, + length, + null, + -- * Conversions + toList, + fromList, + -- * Folding + ifoldMap, + -- * Mapping + adjust, + map, + imap, + itraverse, + ) where + +import Prelude (Maybe (..)) +import Data.RAList.Internal + +import qualified Data.RAList.NonEmpty as NE + +-- $setup +-- >>> import Prelude (($)) + +------------------------------------------------------------------------------- +-- Extras +------------------------------------------------------------------------------- + +-- | +-- +-- >>> uncons $ fromList [] +-- Nothing +-- +-- >>> uncons $ fromList "abcdef" +-- Just ('a',fromList "bcdef") +-- +uncons :: RAList a -> Maybe (a, RAList a) +uncons Empty = Nothing +uncons (NonEmpty r) = Just (NE.uncons r) diff --git a/src/Data/RAList/Internal.hs b/src/Data/RAList/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Internal.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.RAList.Internal ( + RAList (..), + -- * Showing + explicitShow, + explicitShowsPrec, + -- * Construction + empty, + singleton, + cons, + -- * Indexing + (!), + (!?), + length, + null, + -- * Conversions + toList, + fromList, + -- * Folding + ifoldMap, + -- * Mapping + adjust, + map, + imap, + itraverse, + ) where + +import Prelude + (Bool (..), Eq, Functor (..), Int, Maybe (..), Ord (..), Show (..), + ShowS, String, showParen, showString, ($), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Control.Exception (ArrayException (IndexOutOfBounds), throw) +import Data.Hashable (Hashable (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) + +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.Traversable as I (Traversable (..)) +import qualified Test.QuickCheck as QC + +import qualified Data.RAList.NonEmpty.Internal as NE + +-- $setup +-- >>> import Data.Char (toUpper) + +------------------------------------------------------------------------------- +-- Type +------------------------------------------------------------------------------- + +-- | Random access list. +data RAList a + = Empty + | NonEmpty (NE.NERAList a) + deriving (Eq, Ord, Functor, I.Traversable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +-- | +-- +-- >>> I.length $ fromList $ ['a' .. 'z'] +-- 26 +-- +instance I.Foldable RAList where + foldMap _ Empty = mempty + foldMap f (NonEmpty xs) = I.foldMap f xs + +#if MIN_VERSION_base(4,8,0) + length = length + null = null +#endif + +instance NFData a => NFData (RAList a) where + rnf Empty = () + rnf (NonEmpty xs) = rnf xs + +instance Hashable a => Hashable (RAList a) where + hashWithSalt salt Empty = hashWithSalt salt (0 :: Int) + hashWithSalt salt (NonEmpty r) = hashWithSalt salt r + + +-- | +-- +-- >>> fromList "abc" <> fromList "xyz" +-- fromList "abcxyz" +-- +instance Semigroup (RAList a) where + Empty <> ys = ys + xs <> Empty = xs + NonEmpty xs <> NonEmpty ys = NonEmpty (xs <> ys) + +instance Monoid (RAList a) where + mempty = Empty + mappend = (<>) + +-- TODO: Applicative, Monad + +#ifdef MIN_VERSION_semigroupoids +-- Apply, Bind +#endif + +------------------------------------------------------------------------------- +-- Showing +------------------------------------------------------------------------------- + +instance Show a => Show (RAList a) where + showsPrec d xs = showParen (d > 10) $ showString "fromList " . showsPrec 11 (toList xs) + +explicitShow :: Show a => RAList a -> String +explicitShow xs = explicitShowsPrec 0 xs "" + +explicitShowsPrec :: Show a => Int -> RAList a -> ShowS +explicitShowsPrec _ Empty = showString "Empty" +explicitShowsPrec d (NonEmpty xs) = showParen (d > 10) $ showString "NonEmpty " . NE.explicitShowsPrec 11 xs + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | Empty 'RAList'. +-- +-- >>> empty :: RAList Int +-- fromList [] +-- +empty :: RAList a +empty = Empty + +-- | Single element 'RAList'. +singleton :: a -> RAList a +singleton = NonEmpty . NE.singleton + +-- | 'cons' for non-empty rals. +cons :: a -> RAList a -> RAList a +cons x Empty = singleton x +cons x (NonEmpty xs) = NonEmpty (NE.cons x xs) + +toList :: RAList a -> [a] +toList Empty = [] +toList (NonEmpty xs) = I.foldr (:) [] xs + +-- | +-- +-- >>> fromList ['a' .. 'f'] +-- fromList "abcdef" +-- +-- >>> explicitShow $ fromList ['a' .. 'f'] +-- "NonEmpty (NE (Cons0 (Cons1 (Nd (Lf 'a') (Lf 'b')) (Last (Nd (Nd (Lf 'c') (Lf 'd')) (Nd (Lf 'e') (Lf 'f')))))))" +-- +fromList :: [a] -> RAList a +fromList [] = Empty +fromList (x:xs) = NonEmpty (NE.fromNonEmpty (x :| xs)) + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | List index. +-- +--- >>> fromList ['a'..'f'] ! 0 +-- 'a' +-- +-- >>> fromList ['a'..'f'] ! 5 +-- 'f' +-- +-- >>> fromList ['a'..'f'] ! 6 +-- *** Exception: array index out of range: RAList +-- ... +-- +(!) :: RAList a -> Int -> a +(!) Empty _ = throw $ IndexOutOfBounds "RAList" +(!) (NonEmpty xs) i = xs NE.! i + +-- | safe list index. +-- +-- >>> fromList ['a'..'f'] !? 0 +-- Just 'a' +-- +-- >>> fromList ['a'..'f'] !? 5 +-- Just 'f' +-- +-- >>> fromList ['a'..'f'] !? 6 +-- Nothing +-- +(!?) :: RAList a -> Int -> Maybe a +Empty !? _ = Nothing +NonEmpty xs !? i = xs NE.!? i + +length :: RAList a -> Int +length Empty = 0 +length (NonEmpty xs) = NE.length xs + +null :: RAList a -> Bool +null Empty = True +null (NonEmpty _) = False + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +ifoldMap :: Monoid m => (Int -> a -> m) -> RAList a -> m +ifoldMap _ Empty = mempty +ifoldMap f (NonEmpty r) = NE.ifoldMap f r + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +-- | +-- >>> map toUpper (fromList ['a'..'f']) +-- fromList "ABCDEF" +-- +map :: (a -> b) -> RAList a -> RAList b +map = fmap + +-- | +-- +-- >>> imap (,) $ fromList ['a' .. 'f'] +-- fromList [(0,'a'),(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')] +imap :: (Int -> a -> b) -> RAList a -> RAList b +imap f xs = unI (itraverse (\i x -> I (f i x)) xs) + +itraverse :: forall f a b. Applicative f => (Int -> a -> f b) -> RAList a -> f (RAList b) +itraverse _ Empty = pure Empty +itraverse f (NonEmpty xs) = NonEmpty <$> NE.itraverse f xs + +-- | Adjust a value in the list. +-- +-- >>> adjust 3 toUpper $ fromList "bcdef" +-- fromList "bcdEf" +-- +-- If index is out of bounds, the list is returned unmodified. +-- +-- >>> adjust 10 toUpper $ fromList "bcdef" +-- fromList "bcdef" +-- +-- >>> adjust (-1) toUpper $ fromList "bcdef" +-- fromList "bcdef" +-- +adjust :: forall a. Int -> (a -> a) -> RAList a -> RAList a +adjust _ _ Empty = Empty +adjust i f (NonEmpty xs) = NonEmpty (NE.adjust i f xs) + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance QC.Arbitrary1 RAList where + liftArbitrary = fmap fromList . QC.liftArbitrary + liftShrink shr = fmap fromList . QC.liftShrink shr . toList + +instance QC.Arbitrary a => QC.Arbitrary (RAList a) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +instance QC.CoArbitrary a => QC.CoArbitrary (RAList a) where + coarbitrary = QC.coarbitrary . toList + +instance QC.Function a => QC.Function (RAList a) where + function = QC.functionMap toList fromList + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +newtype I a = I a +unI :: I a -> a +unI (I a) = a + +instance Functor I where + fmap f (I x) = I (f x) + +instance Applicative I where + pure = I + I f <*> I x = I (f x) + _ *> x = x + x <* _ = x +#if MIN_VERSION_base(4,10,0) + liftA2 f (I x) (I y) = I (f x y) +#endif + diff --git a/src/Data/RAList/NonEmpty.hs b/src/Data/RAList/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/NonEmpty.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +-- | Non-empty random access list. +-- +-- This module is designed to imported qualifed. +-- +module Data.RAList.NonEmpty ( + NERAList (..), + NERAList' (..), + -- * Showing + explicitShow, + explicitShowsPrec, + -- * Construction + singleton, + cons, + -- * Indexing + (!), + (!?), + head, + last, + uncons, + tail, + length, + null, + -- * Conversions + toNonEmpty, + fromNonEmpty, + -- * Folding + foldMap1, + foldr1Map, + ifoldMap, + ifoldMap1, + ifoldr1Map, + -- * Mapping + adjust, + map, + imap, + itraverse, +#ifdef MIN_VERSION_semigroupoids + itraverse1, +#endif + ) where + +import Prelude (snd) +import Data.RAList.NonEmpty.Internal + +import Data.RAList.Tree (Leaf (..), Node (..)) +import Data.RAList.Internal (RAList (..)) + +-- $setup +-- >>> import Prelude (($)) +-- >>> import Data.List.NonEmpty (NonEmpty (..)) + +------------------------------------------------------------------------------- +-- Extras +------------------------------------------------------------------------------- + +-- | Tail of non-empty list can be empty. +-- +-- >>> tail $ fromNonEmpty $ 'a' :| "bcdef" +-- fromList "bcdef" +-- +tail :: NERAList a -> RAList a +tail r = snd (uncons r) + +-- | +-- >>> uncons $ fromNonEmpty $ 'a' :| "bcdef" +-- ('a',fromList "bcdef") +uncons :: NERAList a -> (a, RAList a) +uncons (NE (Last (Lf x))) = (x, Empty) +uncons (NE (Cons1 (Lf x) r)) = (x, NonEmpty (NE (Cons0 r))) +uncons (NE (Cons0 r)) = + let (Lf x, r') = unconsTree r in (x, NonEmpty (NE r')) + +unconsTree :: NERAList' (Node t) a -> (t a, NERAList' t a) +unconsTree (Last (Nd x y)) = (x, Last y) +unconsTree (Cons1 (Nd x y) r) = (x, Cons1 y (Cons0 r)) +unconsTree (Cons0 r) = + let (Nd x y, r') = unconsTree r in (x, Cons1 y r') diff --git a/src/Data/RAList/NonEmpty/Internal.hs b/src/Data/RAList/NonEmpty/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/NonEmpty/Internal.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.RAList.NonEmpty.Internal ( + NERAList (..), + NERAList' (..), + -- * Showing + explicitShow, + explicitShowsPrec, + -- * Construction + singleton, + cons, + -- * Indexing + (!), + (!?), + head, + last, + length, + null, + -- * Conversions + toNonEmpty, + toList, + fromNonEmpty, + -- * Folding + foldMap1, + foldr1Map, + ifoldMap, + ifoldMap1, + ifoldr1Map, + -- * Mapping + adjust, + map, + imap, + itraverse, +#ifdef MIN_VERSION_semigroupoids + itraverse1, +#endif + ) where + +import Prelude + (Bool (..), Eq, Functor (..), Int, Maybe, Num (..), Ord (..), Show (..), + ShowS, String, otherwise, seq, showParen, showString, ($), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Control.Exception (ArrayException (IndexOutOfBounds), throw) +import Data.Hashable (Hashable (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) + +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.List.NonEmpty as NEList +import qualified Data.Traversable as I (Traversable (..)) +import qualified Test.QuickCheck as QC + +#ifdef MIN_VERSION_semigroupoids +import Data.Functor.Apply (Apply (..)) + +import qualified Data.Semigroup.Foldable as I (Foldable1 (..)) +import qualified Data.Semigroup.Traversable as I (Traversable1 (..)) +#endif + +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (WrappedMonoid (..)) +#endif + +import qualified Data.RAList.Tree.Internal as Tr + +import Data.RAList.Tree (Leaf (..), Node (..)) + +-- $setup +-- >>> import Data.Char (toUpper) + +------------------------------------------------------------------------------- +-- Type +------------------------------------------------------------------------------- + +-- | Non-empty random access list. +newtype NERAList a = NE (NERAList' Leaf a) + deriving (Eq, Ord, Functor, I.Traversable) + +-- | Non-empty random access list, underlying representation. +-- +-- The structure doesn't need to be hidden, as polymorphic +-- recursion of 'Node's starting from 'Leaf' keeps the 'NERAList' values well-formed. +-- +data NERAList' f a + = Last (f a) + | Cons0 (NERAList' (Node f) a) + | Cons1 (f a) (NERAList' (Node f) a) + deriving (Eq, Show, Functor, I.Foldable, I.Traversable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +instance (Ord a, I.Foldable f, Eq (f a)) => Ord (NERAList' f a) where + compare xs ys = compare (I.foldr (:) [] xs) (I.foldr (:) [] ys) + +-- | +-- +-- >>> I.length $ fromNonEmpty $ 'x' :| ['a' .. 'z'] +-- 27 +-- +instance I.Foldable NERAList where + foldMap f (NE xs) = I.foldMap f xs + +#if MIN_VERSION_base(4,8,0) + length = length + null = null +#endif + +#ifdef MIN_VERSION_semigroupoids +instance I.Foldable1 NERAList where + foldMap1 f (NE xs) = I.foldMap1 f xs + +instance I.Foldable1 t => I.Foldable1 (NERAList' t) where + foldMap1 f (Last t) = I.foldMap1 f t + foldMap1 f (Cons0 r) = I.foldMap1 f r + foldMap1 f (Cons1 t r) = I.foldMap1 f t <> I.foldMap1 f r + +instance I.Traversable1 NERAList where + traverse1 f (NE xs) = NE <$> I.traverse1 f xs where + +instance I.Traversable1 t => I.Traversable1 (NERAList' t) where + traverse1 f (Last t) = Last <$> I.traverse1 f t + traverse1 f (Cons0 r) = Cons0 <$> I.traverse1 f r + traverse1 f (Cons1 t r) = Cons1 <$> I.traverse1 f t <.> I.traverse1 f r +#endif + +instance NFData a => NFData (NERAList a) where + rnf (NE r) = rnf r + +instance NFData (t a) => NFData (NERAList' t a) where + rnf (Last t) = rnf t + rnf (Cons0 r) = rnf r + rnf (Cons1 t r) = rnf t `seq` rnf r + +instance Hashable a => Hashable (NERAList a) where + hashWithSalt salt (NE r) = hashWithSalt salt r + +instance Hashable (t a) => Hashable (NERAList' t a) where + hashWithSalt salt (Last t) = salt `hashWithSalt` t + hashWithSalt salt (Cons0 r) = salt `hashWithSalt` r + hashWithSalt salt (Cons1 t r) = salt `hashWithSalt` t `hashWithSalt` r + +-- | +-- +-- >>> fromNonEmpty ('a' :| "bc") <> fromNonEmpty ('x' :| "yz") +-- fromNonEmpty ('a' :| "bcxyz") +-- +instance Semigroup (NERAList a) where + NE xs <> ys = I.foldr cons ys xs + +-- TODO: Applicative, Monad + +#ifdef MIN_VERSION_semigroupoids +-- Apply, Bind +#endif + +------------------------------------------------------------------------------- +-- Showing +------------------------------------------------------------------------------- + +instance Show a => Show (NERAList a) where + showsPrec d xs = showParen (d > 10) $ showString "fromNonEmpty " . showsPrec 11 (toNonEmpty xs) + +explicitShow :: Show a => NERAList a -> String +explicitShow xs = explicitShowsPrec 0 xs "" + +explicitShowsPrec :: Show a => Int -> NERAList a -> ShowS +explicitShowsPrec d (NE xs) = showParen (d > 10) $ showString "NE " . showsPrec 11 xs + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | Single element 'NERAList'. +singleton :: a -> NERAList a +singleton = NE . singleton' + +singleton' :: a -> NERAList' Leaf a +singleton' = Last . Lf + +-- | 'cons' for non-empty rals. +cons :: a -> NERAList a -> NERAList a +cons x (NE xs) = NE (consTree (Lf x) xs) + +consTree :: f a -> NERAList' f a -> NERAList' f a +consTree x (Last t) = Cons0 (Last (Nd x t)) +consTree x (Cons0 r) = Cons1 x r +consTree x (Cons1 t r) = Cons0 (consTree (Nd x t) r) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +toNonEmpty :: NERAList a -> NonEmpty a +toNonEmpty = foldr1Map NEList.cons (:|[]) + +toList :: NERAList a -> [a] +toList = I.foldr (:) [] + +-- | +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) +-- fromNonEmpty ('a' :| "bcdef") +-- +-- >>> explicitShow (fromNonEmpty ('a' :| ['b'..'f'])) +-- "NE (Cons0 (Cons1 (Nd (Lf 'a') (Lf 'b')) (Last (Nd (Nd (Lf 'c') (Lf 'd')) (Nd (Lf 'e') (Lf 'f'))))))" +-- +fromNonEmpty :: NonEmpty a -> NERAList a +fromNonEmpty (z :| zs) = go z zs where + go x [] = singleton x + go x (y:ys) = cons x (go y ys) + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | List index. +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 0 +-- 'a' +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 5 +-- 'f' +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 6 +-- *** Exception: array index out of range: NERAList +-- ... +-- +(!) :: NERAList a -> Int -> a +(!) (NE xs) i = fromMaybe (throw $ IndexOutOfBounds "NERAList") (safeIndex' xs i) + +-- | safe list index. +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 0 +-- Just 'a' +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 5 +-- Just 'f' +-- +-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 6 +-- Nothing +-- +(!?) :: NERAList a -> Int -> Maybe a +NE xs !? i = safeIndex' xs i + +safeIndex' :: Tr.IsTree f => NERAList' f a -> Int -> Maybe a +safeIndex' = go 1 where + go :: Tr.IsTree g => Int -> NERAList' g a -> Int -> Maybe a + go !s (Last t) i = Tr.safeIndex s t i + go s (Cons0 r) i = go (s * 2) r i + go s (Cons1 t r) i + | i < s = Tr.safeIndex s t i + | otherwise = go (s * 2) r (i - s) + +-- | First value, head of the list. +-- +-- >>> head $ fromNonEmpty $ 'a' :| ['b'..'f'] +-- 'a' +head :: NERAList a -> a +head (NE x) = head' x + +-- | Last value of the list +-- +-- >>> last $ fromNonEmpty $ 'a' :| ['b'..'f'] +-- 'f' +-- +last :: NERAList a -> a +last (NE x) = last' x + +head' :: Tr.IsTree f => NERAList' f a -> a +head' (Last t) = Tr.head t +head' (Cons0 r) = head' r +head' (Cons1 t _) = Tr.head t + +last' :: Tr.IsTree f => NERAList' f a -> a +last' (Last t) = Tr.last t +last' (Cons0 r) = last' r +last' (Cons1 _ r) = last' r + +length :: NERAList a -> Int +length (NE xs) = go 0 1 xs where + go :: Int -> Int -> NERAList' n a -> Int + go !acc s (Last _) = acc + s + go acc s (Cons0 r) = go acc (s + s) r + go acc s (Cons1 _ r) = go (acc + s) (s + s) r + +null :: NERAList a -> Bool +null _ = False + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +foldMap1 :: forall a s. Semigroup s => (a -> s) -> NERAList a -> s +foldMap1 f (NE xs) = go (\(Lf x) -> f x) xs where + go :: (t a -> s) -> NERAList' t a -> s + go g (Last t) = g t + go g (Cons0 r) = go (\(Nd x y) -> g x <> g y) r + go g (Cons1 t r) = g t <> go (\(Nd x y) -> g x <> g y) r + +foldr1Map :: (a -> b -> b) -> (a -> b) -> NERAList a -> b +foldr1Map f z (NE xs) = foldr1Map' f z xs + +foldr1Map' :: Tr.IsTree f => (a -> b -> b) -> (a -> b) -> NERAList' f a -> b +foldr1Map' f z (Last t) = Tr.foldr1Map f z t +foldr1Map' f z (Cons0 r) = foldr1Map' f z r +foldr1Map' f z (Cons1 t r) = I.foldr f (foldr1Map' f z r) t + +ifoldMap :: Monoid m => (Int -> a -> m) -> NERAList a -> m +#if MIN_VERSION_base(4,11,0) +ifoldMap = ifoldMap1 +#else +ifoldMap f = unwrapMonoid . ifoldMap1 (\i a -> WrapMonoid (f i a)) +#endif + +-- | +-- +-- >>> import Data.Semigroup (Min (..)) +-- +-- >>> ifoldMap1 (\_ x -> Min x) $ fromNonEmpty $ 5 :| [3,1,2,4] +-- Min {getMin = 1} +-- +-- >>> ifoldMap1 (\i x -> Min (i + x)) $ fromNonEmpty $ 5 :| [3,1,2,4] +-- Min {getMin = 3} +-- +ifoldMap1 :: forall a s. Semigroup s => (Int -> a -> s) -> NERAList a -> s +ifoldMap1 f (NE xs) = go 0 1 xs where + go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> s + go o s (Last t) = Tr.ifoldMap1 o s f t + go o s (Cons0 r) = go o (s + s) r + go o s (Cons1 t r) = Tr.ifoldMap1 o s f t <> go (o + s) (s + s) r + +ifoldr1Map :: forall a b. (Int -> a -> b -> b) -> (Int -> a -> b) -> NERAList a -> b +ifoldr1Map f z (NE xs) = go 0 1 xs where + go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> b + go o s (Last t) = Tr.ifoldr1Map o s f z t + go o s (Cons0 r) = go o (s * 2) r + go o s (Cons1 t r) = Tr.ifoldr o s f (go (o + s) (s + s) r) t + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +-- | +-- >>> map toUpper (fromNonEmpty ('a' :| ['b'..'f'])) +-- fromNonEmpty ('A' :| "BCDEF") +-- +map :: (a -> b) -> NERAList a -> NERAList b +map = fmap + +-- | +-- +-- >>> imap (,) (fromNonEmpty ('a' :| ['b'..'f'])) +-- fromNonEmpty ((0,'a') :| [(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')]) +imap :: (Int -> a -> b) -> NERAList a -> NERAList b +imap f xs = unI (itraverse (\i x -> I (f i x)) xs) + +itraverse :: forall f a b. Applicative f => (Int -> a -> f b) -> NERAList a -> f (NERAList b) +itraverse f (NE xs) = NE <$> go 0 1 xs where + go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> f (NERAList' t b) + go !o !s (Last t) = Last <$> Tr.itraverse o s f t + go o s (Cons0 r) = Cons0 <$> go o (2 * s) r + go o s (Cons1 t r) = Cons1 + <$> Tr.itraverse o s f t + <*> go (o + s) (2 * s) r + +#ifdef MIN_VERSION_semigroupoids +itraverse1 :: forall f a b. Apply f => (Int -> a -> f b) -> NERAList a -> f (NERAList b) +itraverse1 f (NE xs) = NE <$> go 0 1 xs where + go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> f (NERAList' t b) + go !o !s (Last t) = Last <$> Tr.itraverse1 o s f t + go o s (Cons0 r) = Cons0 <$> go o (2 * s) r + go o s (Cons1 t r) = Cons1 + <$> Tr.itraverse1 o s f t + <.> go (o + s) (2 * s) r +#endif + +-- | Adjust a value in the list. +-- +-- >>> adjust 3 toUpper $ fromNonEmpty $ 'a' :| "bcdef" +-- fromNonEmpty ('a' :| "bcDef") +-- +-- If index is out of bounds, the list is returned unmodified. +-- +-- >>> adjust 10 toUpper $ fromNonEmpty $ 'a' :| "bcdef" +-- fromNonEmpty ('a' :| "bcdef") +-- +-- >>> adjust (-1) toUpper $ fromNonEmpty $ 'a' :| "bcdef" +-- fromNonEmpty ('a' :| "bcdef") +-- +adjust :: forall a. Int -> (a -> a) -> NERAList a -> NERAList a +adjust i _ xs | i < 0 = xs +adjust i f (NE xs) = NE (go 0 1 xs) where + go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> NERAList' t a + go !o !s (Last t) = Last (Tr.adjust s (i - o) f t) + go o s (Cons0 r) = Cons0 (go o (s + s) r) + go o s (Cons1 t r) + | i - o < s = Cons1 (Tr.adjust s (i - o) f t) r + | otherwise = Cons1 t (go (o + s) (s + s) r) + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance QC.Arbitrary1 NERAList where + liftArbitrary arb = do + x <- arb + xs <- QC.liftArbitrary arb + pure (fromNonEmpty (x :| xs)) + + liftShrink shr + = fmap (\(x,xs) -> fromNonEmpty (x:|xs)) + . QC.liftShrink2 shr (QC.liftShrink shr) + . (\(x:|xs) -> (x,xs)) . toNonEmpty + +instance QC.Arbitrary a => QC.Arbitrary (NERAList a) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +instance QC.CoArbitrary a => QC.CoArbitrary (NERAList a) where + coarbitrary xs = QC.coarbitrary (y, ys) where + (y:|ys) = toNonEmpty xs + +instance QC.Function a => QC.Function (NERAList a) where + function = QC.functionMap (fwd . toNonEmpty) (fromNonEmpty . bwd) where + fwd (x :| xs) = (x, xs) + bwd (x, xs) = x :| xs + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +newtype I a = I a +unI :: I a -> a +unI (I a) = a + +instance Functor I where + fmap f (I x) = I (f x) + +instance Applicative I where + pure = I + I f <*> I x = I (f x) + _ *> x = x + x <* _ = x +#if MIN_VERSION_base(4,10,0) + liftA2 f (I x) (I y) = I (f x y) +#endif + diff --git a/src/Data/RAList/Tree.hs b/src/Data/RAList/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Tree.hs @@ -0,0 +1,7 @@ +module Data.RAList.Tree ( + Leaf (..), + Node (..), + Dir (..), + ) where + +import Data.RAList.Tree.Internal diff --git a/src/Data/RAList/Tree/Internal.hs b/src/Data/RAList/Tree/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Tree/Internal.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Data.RAList.Tree.Internal ( + Leaf (..), + Node (..), + Dir (..), + -- * Tree class + -- | TODO move to private module so new instances cannot be defined + IsTree (..), + Size, + Offset, + ) where + +import Prelude + (Bool (..), Eq (..), Functor (..), Int, Maybe (..), Num (..), Ord (..), + Show, div, otherwise, seq, (&&), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable (..)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) + +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.Traversable as I (Traversable (..)) + +#ifdef MIN_VERSION_distributive +import qualified Data.Distributive as I (Distributive (..)) + +#ifdef MIN_VERSION_adjunctions +import qualified Data.Functor.Rep as I (Representable (..)) +#endif +#endif + +#ifdef MIN_VERSION_semigroupoids +import Data.Functor.Apply (Apply (..)) + +import qualified Data.Semigroup.Foldable as I (Foldable1 (..)) +import qualified Data.Semigroup.Traversable as I (Traversable1 (..)) +#endif + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | A 'Leaf' is isomorphic to 'Identity', but we reimplement it here +-- to have domain specific type. The short constructor name is a bonus. +newtype Leaf a = Lf a + deriving (Eq, Ord, Show, Functor, I.Traversable) + +-- | 'Node' is a product of two @f@. This way we can form a perfect binary tree. +data Node f a = Nd (f a) (f a) + deriving (Eq, Ord, Show, Functor, I.Traversable) + +-- | Direction in 'Node'. +data Dir a = L a | R a + deriving (Eq, Ord, Show, Functor, I.Foldable, I.Traversable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +-- These instances are manually implemented, because we can have efficient +-- foldr and foldl +instance I.Foldable Leaf where + foldMap f (Lf x) = f x + foldr f z (Lf x) = f x z + foldl f z (Lf x) = f z x + foldr' f z (Lf x) = f x z + foldl' f z (Lf x) = f z x + +#if MIN_VERSION_base(4,8,0) + length _ = 1 + null _ = False +#endif + +instance I.Foldable f => I.Foldable (Node f) where + foldMap f (Nd x y) = mappend (I.foldMap f x) (I.foldMap f y) + + foldr f z (Nd x y) = I.foldr f (I.foldr f z y) x + foldl f z (Nd x y) = I.foldl f (I.foldl f z x) y + + foldr' f z (Nd x y) = let !acc = I.foldr' f z y in I.foldr' f acc x + foldl' f z (Nd x y) = let !acc = I.foldl' f z x in I.foldl' f acc y + +#if MIN_VERSION_base(4,8,0) + length (Nd x y) = I.length x + I.length y + null (Nd x y) = I.null x && I.null y +#endif + +#ifdef MIN_VERSION_semigroupoids +instance I.Foldable1 Leaf where + foldMap1 f (Lf x) = f x + +instance I.Traversable1 Leaf where + traverse1 f (Lf x) = Lf <$> f x + +instance I.Foldable1 f => I.Foldable1 (Node f) where + foldMap1 f (Nd x y) = I.foldMap1 f x <> I.foldMap1 f y + +instance I.Traversable1 f => I.Traversable1 (Node f) where + traverse1 f (Nd x y) = Nd <$> I.traverse1 f x <.> I.traverse1 f y +#endif + +instance NFData a => NFData (Leaf a) where + rnf (Lf a) = rnf a + +instance NFData (f a) => NFData (Node f a) where + rnf (Nd x y) = rnf x `seq` rnf y + +instance Hashable a => Hashable (Leaf a) where + hashWithSalt salt (Lf x) = hashWithSalt salt x + +instance Hashable (f a) => Hashable (Node f a) where + hashWithSalt salt (Nd x y) = salt + `hashWithSalt` x + `hashWithSalt` y + +#ifdef MIN_VERSION_distributive +instance I.Distributive Leaf where + distribute xs = Lf (fmap (\(Lf x) -> x) xs) + +instance I.Distributive f => I.Distributive (Node f) where + distribute xs = Nd + (I.distribute (fmap (\(Nd x _) -> x) xs)) + (I.distribute (fmap (\(Nd _ y) -> y) xs)) + +#ifdef MIN_VERSION_adjunctions +instance I.Representable Leaf where + type Rep Leaf = () + index (Lf x) _ = x + tabulate f = Lf (f ()) + +instance I.Representable f => I.Representable (Node f) where + type Rep (Node f) = Dir (I.Rep f) + + index (Nd x _) (L i) = I.index x i + index (Nd _ y) (R j) = I.index y j + + tabulate f = Nd (I.tabulate (f . L)) (I.tabulate (f . R)) +#endif +#endif + +------------------------------------------------------------------------------- +-- IsLeaf +------------------------------------------------------------------------------- + +-- | Size of a tree. +type Size = Int +type Offset = Int + +class ( +#ifdef MIN_VERSION_semigroupoids + I.Traversable1 t +#else + I.Traversable t +#endif + ) => IsTree t where + -- indexing + safeIndex :: Size -> t a -> Int -> Maybe a + + head :: t a -> a + last :: t a -> a + + -- folding + + ifoldr :: Offset -> Size + -> (Int -> a -> b -> b) -> b -> t a -> b + + ifoldMap1 :: Semigroup s => Offset -> Size + -> (Int -> a -> s) -> t a -> s + + foldr1Map :: ( a -> b -> b) -> (a -> b) -> t a -> b + ifoldr1Map :: Offset -> Size + -> (Int -> a -> b -> b) -> (Int -> a -> b) -> t a -> b + + -- mapping + + adjust :: Size -> Int -> (a -> a) -> t a -> t a + + itraverse + :: Applicative f + => Offset + -> Size + -> (Int -> a -> f b) -> t a -> f (t b) + +#ifdef MIN_VERSION_semigroupoids + traverse1 :: Apply f => (a -> f b) -> t a -> f (t b) + itraverse1 :: Apply f => Offset -> Size -> (Int -> a -> f b) -> t a -> f (t b) +#endif + +------------------------------------------------------------------------------- +-- IsTree Leaf +------------------------------------------------------------------------------- + +instance IsTree Leaf where + -- indexing + safeIndex _ (Lf x) 0 = Just x + safeIndex _ _ _ = Nothing + + head (Lf x) = x + last = head + + + -- folding + foldr1Map _ z (Lf x) = z x + + ifoldr !o _ f z (Lf x) = f o x z + ifoldMap1 !o _ f (Lf x) = f o x + ifoldr1Map !o _ _ z (Lf x) = z o x + + -- mapping + adjust _ !i f (Lf x) + | 0 == i = Lf (f x) + | otherwise = Lf x + + itraverse !o _ f (Lf x) = fmap Lf (f o x) + +#ifdef MIN_VERSION_semigroupoids + traverse1 f (Lf x) = fmap Lf (f x) + itraverse1 !o _ f (Lf x) = fmap Lf (f o x) +#endif + +------------------------------------------------------------------------------- +-- IsTree Node +------------------------------------------------------------------------------- + +instance IsTree f => IsTree (Node f) where + -- indexing + + safeIndex s (Nd x y) i + | i < s2 = safeIndex s2 x i + | otherwise = safeIndex s2 y (i - s2) + where + s2 = s `div` 2 + + head (Nd x _) = head x + last (Nd _ y) = last y + + -- folding + + foldr1Map f z (Nd x y) = I.foldr f (foldr1Map f z y) x + + ifoldr1Map !o !s f z (Nd x y) = ifoldr o s2 f (ifoldr1Map (o + s2) s2 f z y) x + where + s2 = s `div` 2 + + ifoldr !o !s f z (Nd x y) = ifoldr o s2 f (ifoldr (o + s2) s2 f z y) x + where + s2 = s `div` 2 + + ifoldMap1 !o !s f (Nd x y) = ifoldMap1 o s2 f x <> ifoldMap1 (o + s2) s2 f y + where + s2 = s `div` 2 + + -- mapping + + adjust s i f nd@(Nd x y) + | i < s2 = Nd (adjust s2 i f x) y + | i < s = Nd x (adjust s2 (i - s2) f y) + | otherwise = nd + where + s2 = s `div` 2 + + itraverse !o !s f (Nd x y) = Nd + <$> itraverse o s2 f x + <*> itraverse (o + s2) s2 f y + where + s2 = s `div` 2 + +#ifdef MIN_VERSION_semigroupoids + traverse1 f (Nd x y) = Nd <$> traverse1 f x <.> traverse1 f y + + itraverse1 !o !s f (Nd x y) = Nd + <$> itraverse1 o s2 f x + <.> itraverse1 (o + s2) s2 f y + where + s2 = s `div` 2 +#endif + diff --git a/src/Data/RAVec.hs b/src/Data/RAVec.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | Length-indexed random access list. +-- +-- See +module Data.RAVec ( + -- * Random access list + RAVec (..), + + -- * Construction + empty, + singleton, + cons, + withCons, + head, + last, + + -- * Conversion + toList, + toNonEmpty, + fromList, + reifyNonEmpty, + + -- * Indexing + (!), + tabulate, + + -- * Folds + foldMap, + foldMap1, + ifoldMap, + ifoldMap1, + foldr, + ifoldr, + + -- * Mapping + map, + imap, + traverse, + itraverse, +#ifdef MIN_VERSION_semigroupoids + traverse1, + itraverse1, +#endif + + -- * Zipping + zipWith, + izipWith, + + -- * Universe + universe, + repeat, + + -- * QuickCheck + liftArbitrary, + liftShrink, + ) where + +import Prelude + (Bool (..), Eq (..), Functor (..), Int, Maybe (..), Ord (..), Show, ($), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Data.Bin (Bin (..)) +import Data.Bin.Pos (Pos (..)) +import Data.Hashable (Hashable (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Type.Bin (SBin (..), SBinI (..), SBinPI (..)) +import Data.Type.Equality ((:~:) (..)) +import Data.Typeable (Typeable) + +import qualified Data.RAVec.NonEmpty as NE +import qualified Data.Type.Bin as B + +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.Traversable as I (Traversable (..)) +import qualified Test.QuickCheck as QC + +#ifdef MIN_VERSION_distributive +import qualified Data.Distributive as I (Distributive (..)) + +#ifdef MIN_VERSION_adjunctions +import qualified Data.Functor.Rep as I (Representable (..)) +#endif +#endif + +#ifdef MIN_VERSION_semigroupoids +import Data.Functor.Apply (Apply (..)) + +import qualified Data.Semigroup.Foldable as I (Foldable1 (..)) +import qualified Data.Semigroup.Traversable as I (Traversable1 (..)) +#endif + +import Data.RAVec.NonEmpty (NERAVec (..)) + +-- $setup +-- >>> :set -XScopedTypeVariables -XDataKinds +-- >>> import Prelude (print, Char, Bounded (..)) +-- >>> import Data.List (sort) +-- >>> import Data.Wrd (Wrd (..)) +-- >>> import Data.Bin.Pos (top, pop) +-- >>> import Data.BinP.PosP (PosP (..), PosP' (..)) +-- >>> import qualified Data.Bin.Pos as P + +------------------------------------------------------------------------------- +-- Random access vec +------------------------------------------------------------------------------- + +-- | Length indexed random access lists. +data RAVec (b :: Bin) a where + Empty :: RAVec 'BZ a + NonEmpty :: NERAVec b a -> RAVec ('BP b) a + deriving (Typeable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +deriving instance Eq a => Eq (RAVec b a) +deriving instance Show a => Show (RAVec b a) + +instance Ord a => Ord (RAVec b a) where + compare xs ys = compare (toList xs) (toList ys) + +instance Functor (RAVec b) where + fmap = map + +instance I.Foldable (RAVec b) where + foldMap = foldMap + foldr = foldr + +#if MIN_VERSION_base(4,8,0) + null = null +#endif + +instance I.Traversable (RAVec b) where + traverse = traverse + +#ifdef MIN_VERSION_semigroupoids +instance b ~ 'BP n => I.Foldable1 (RAVec b) where + foldMap1 = foldMap1 + toNonEmpty = toNonEmpty + +instance b ~ 'BP n => I.Traversable1 (RAVec b) where + traverse1 = traverse1 +#endif + +instance NFData a => NFData (RAVec b a) where + rnf Empty = () + rnf (NonEmpty ral) = rnf ral + +instance Hashable a => Hashable (RAVec b a) where + hashWithSalt salt = hashWithSalt salt . toList + +instance SBinI b => Applicative (RAVec b) where + pure = repeat + (<*>) = zipWith ($) + x <* _ = x + _ *> x = x +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWith +#endif + +-- TODO: Monad? + +#ifdef MIN_VERSION_distributive +instance SBinI b => I.Distributive (RAVec b) where + distribute f = tabulate (\k -> fmap (! k) f) + +#ifdef MIN_VERSION_adjunctions +instance SBinI b => I.Representable (RAVec b) where + type Rep (RAVec b) = Pos b + index = (!) + tabulate = tabulate + +#endif +#endif + +instance Semigroup a => Semigroup (RAVec b a) where + (<>) = zipWith (<>) + +instance (Monoid a, SBinI b) => Monoid (RAVec b a) where + mempty = repeat mempty + mappend = zipWith mappend + +#ifdef MIN_VERSION_semigroupoids +instance Apply (RAVec b) where + (<.>) = zipWith ($) + liftF2 = zipWith + _ .> x = x + x <. _ = x +#endif + +-- TODO: I.Bind? + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +empty :: RAVec B.Bin0 a +empty = Empty + +singleton :: a -> RAVec B.Bin1 a +singleton = NonEmpty . NE.singleton + +-- | Cons an element in front of 'RAVec'. +-- +-- >>> reifyList "xyz" (print . toList . cons 'a') +-- "axyz" +-- +cons :: a -> RAVec b a -> RAVec (B.Succ b) a +cons x Empty = singleton x +cons x (NonEmpty xs) = NonEmpty (NE.cons x xs) + +-- | Variant of 'cons' which computes the 'SBinI' dictionary at the same time. +withCons :: SBinI b => a -> RAVec b a -> (SBinPI (B.Succ' b) => RAVec (B.Succ b) a -> r) -> r +withCons = go sbin where + go :: SBin b -> a -> RAVec b a -> (SBinPI (B.Succ' b) => RAVec (B.Succ b) a -> r) -> r + go SBZ x Empty k = k (singleton x) + go SBP x (NonEmpty xs) k = NE.withCons x xs $ k . NonEmpty + +-- | The first element of a non-empty 'RAVec'. +-- +-- >>> reifyNonEmpty ('x' :| "yz") head +-- 'x' +-- +head :: RAVec ('BP b) a -> a +head (NonEmpty ral) = NE.head ral + +-- | The last element of a non-empty 'RAVec'. +-- +-- >>> reifyNonEmpty ('x' :| "yz") last +-- 'z' +-- +last :: RAVec ('BP b) a -> a +last (NonEmpty ral) = NE.last ral + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +toList :: RAVec b a -> [a] +toList Empty = [] +toList (NonEmpty ral) = NE.toList ral + +toNonEmpty :: RAVec ('BP b) a -> NonEmpty a +toNonEmpty (NonEmpty ral) = NE.toNonEmpty ral + +-- | Convert a list @[a]@ to @'RAVec' b a@. +-- Returns 'Nothing' if lengths don't match. +-- +-- >>> fromList "foo" :: Maybe (RAVec B.Bin3 Char) +-- Just (NonEmpty (NE (Cons1 (Leaf 'f') (Last (Node (Leaf 'o') (Leaf 'o')))))) +-- +-- >>> fromList "quux" :: Maybe (RAVec B.Bin3 Char) +-- Nothing +-- +-- >>> fromList "xy" :: Maybe (RAVec B.Bin3 Char) +-- Nothing +-- +fromList :: forall b a. SBinI b => [a] -> Maybe (RAVec b a) +fromList xs = reifyList xs mk where + mk :: forall c. SBinI c => RAVec c a -> Maybe (RAVec b a) + mk ral = do + Refl <- B.eqBin :: Maybe (b :~: c) + Just ral + +-- | +-- +-- >>> reifyList "foo" print +-- NonEmpty (NE (Cons1 (Leaf 'f') (Last (Node (Leaf 'o') (Leaf 'o'))))) +-- +-- >>> reifyList "xyzzy" toList +-- "xyzzy" +reifyList :: [a] -> (forall b. SBinI b => RAVec b a -> r) -> r +reifyList [] k = k Empty +reifyList (x:xs) k = reifyList xs $ \ral -> withCons x ral k + +reifyNonEmpty :: NonEmpty a -> (forall b. SBinPI b => RAVec ('BP b) a -> r) -> r +reifyNonEmpty xs k = NE.reifyNonEmpty xs $ k . NonEmpty + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | Indexing. +-- +-- >>> let ral :: RAVec B.Bin4 Char; Just ral = fromList "abcd" +-- +-- >>> ral ! minBound +-- 'a' +-- +-- >>> ral ! maxBound +-- 'd' +-- +-- >>> ral ! pop top +-- 'b' +-- +(!) :: RAVec b a -> Pos b -> a +(!) Empty p = case p of {} +(!) (NonEmpty b) (Pos i) = b NE.! i + +tabulate :: forall b a. SBinI b => (Pos b -> a) -> RAVec b a +tabulate f = case sbin :: SBin b of + SBZ -> Empty + SBP -> NonEmpty (NE.tabulate (f . Pos)) + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +foldMap :: Monoid m => (a -> m) -> RAVec n a -> m +foldMap _ Empty = mempty +foldMap f (NonEmpty r) = NE.foldMap f r + +ifoldMap :: Monoid m => (Pos b -> a -> m) -> RAVec b a -> m +ifoldMap _ Empty = mempty +ifoldMap f (NonEmpty r) = NE.ifoldMap (f . Pos) r + +foldMap1 :: Semigroup m => (a -> m) -> RAVec ('BP b) a -> m +foldMap1 f (NonEmpty r) = NE.foldMap1 f r + +ifoldMap1 :: Semigroup m => (Pos ('BP b) -> a -> m) -> RAVec ('BP b) a -> m +ifoldMap1 f (NonEmpty r) = NE.ifoldMap1 (f . Pos) r + +foldr :: (a -> b -> b) -> b -> RAVec n a -> b +foldr _ z Empty = z +foldr f z (NonEmpty ral) = NE.foldr f z ral + +ifoldr :: (Pos n -> a -> b -> b) -> b -> RAVec n a -> b +ifoldr _ z Empty = z +ifoldr f z (NonEmpty ral) = NE.ifoldr (f . Pos) z ral + +null :: RAVec n a -> Bool +null Empty = True +null (NonEmpty _) = False + +------------------------------------------------------------------------------- +-- Special folds +------------------------------------------------------------------------------- + +-- TBW + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +map :: (a -> b) -> RAVec n a -> RAVec n b +map _ Empty = Empty +map f (NonEmpty r) = NonEmpty (NE.map f r) + +imap :: (Pos n -> a -> b) -> RAVec n a -> RAVec n b +imap _ Empty = Empty +imap f (NonEmpty r) = NonEmpty (NE.imap (f . Pos) r) + +traverse :: Applicative f => (a -> f b) -> RAVec n a -> f (RAVec n b) +traverse _ Empty = pure empty +traverse f (NonEmpty ral) = NonEmpty <$> NE.traverse f ral + +itraverse :: Applicative f => (Pos n -> a -> f b) -> RAVec n a -> f (RAVec n b) +itraverse _ Empty = pure Empty +itraverse f (NonEmpty r) = NonEmpty <$> NE.itraverse (f . Pos) r + +#ifdef MIN_VERSION_semigroupoids +traverse1 :: Apply f => (a -> f b) -> RAVec ('BP n) a -> f (RAVec ('BP n) b) +traverse1 f (NonEmpty r) = NonEmpty <$> NE.traverse1 f r + +itraverse1 :: Apply f => (Pos ('BP n) -> a -> f b) -> RAVec ('BP n) a -> f (RAVec ('BP n) b) +itraverse1 f (NonEmpty r) = NonEmpty <$> NE.itraverse1 (f . Pos) r +#endif + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +-- | Zip two 'RAVec's with a function. +zipWith :: (a -> b -> c) -> RAVec n a -> RAVec n b -> RAVec n c +zipWith _ Empty Empty = Empty +zipWith f (NonEmpty xs) (NonEmpty ys) = NonEmpty (NE.zipWith f xs ys) + +-- | Zip two 'RAVec's with a function which also takes 'Pos' index. +izipWith :: (Pos n -> a -> b -> c) -> RAVec n a -> RAVec n b -> RAVec n c +izipWith _ Empty Empty = Empty +izipWith f (NonEmpty xs) (NonEmpty ys) = NonEmpty (NE.izipWith (f . Pos) xs ys) + +-- | Repeat a value. +-- +-- >>> repeat 'x' :: RAVec B.Bin5 Char +-- NonEmpty (NE (Cons1 (Leaf 'x') (Cons0 (Last (Node (Node (Leaf 'x') (Leaf 'x')) (Node (Leaf 'x') (Leaf 'x'))))))) +-- +repeat :: forall b a. SBinI b => a -> RAVec b a +repeat x = case sbin :: SBin b of + SBZ -> Empty + SBP -> NonEmpty (NE.repeat x) + +------------------------------------------------------------------------------- +-- Universe +------------------------------------------------------------------------------- + +-- | +-- +-- >>> universe :: RAVec B.Bin2 (Pos B.Bin2) +-- NonEmpty (NE (Cons0 (Last (Node (Leaf 0) (Leaf 1))))) +-- +-- >>> let u = universe :: RAVec B.Bin3 (Pos B.Bin3) +-- >>> u +-- NonEmpty (NE (Cons1 (Leaf 0) (Last (Node (Leaf 1) (Leaf 2))))) +-- +-- >>> P.explicitShow $ u ! Pos (PosP (Here WE)) +-- "Pos (PosP (Here WE))" +-- +-- >>> let u' = universe :: RAVec B.Bin5 (Pos B.Bin5) +-- +-- >>> toList u' == sort (toList u') +-- True +-- +universe :: forall b. SBinI b => RAVec b (Pos b) +universe = case sbin :: SBin b of + SBZ -> Empty + SBP -> NonEmpty (fmap Pos NE.universe) + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +liftArbitrary :: B.SBinI b => QC.Gen a -> QC.Gen (RAVec b a) +liftArbitrary = liftArbitrary + +liftShrink :: (a -> [a]) -> RAVec b a -> [RAVec b a] +liftShrink _ Empty = [] +liftShrink shr (NonEmpty r) = NonEmpty <$> NE.liftShrink shr r + +instance B.SBinI b => QC.Arbitrary1 (RAVec b) where + liftArbitrary = liftArbitrary + liftShrink = liftShrink + +instance (B.SBinI b, QC.Arbitrary a) => QC.Arbitrary (RAVec b a) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +instance QC.CoArbitrary a => QC.CoArbitrary (RAVec b a) where + coarbitrary Empty = QC.variant (0 :: Int) + coarbitrary (NonEmpty r) = QC.variant (1 :: Int) . QC.coarbitrary r + +instance (B.SBinI b, QC.Function a) => QC.Function (RAVec b a) where + function = case B.sbin :: B.SBin b of + SBZ -> QC.functionMap (\Empty -> ()) (\() -> Empty) + SBP -> QC.functionMap (\(NonEmpty r) -> r) NonEmpty diff --git a/src/Data/RAVec/NonEmpty.hs b/src/Data/RAVec/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec/NonEmpty.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- | Non-empty length-indexed random access list. +module Data.RAVec.NonEmpty ( + -- * Random access list + NERAVec (..), + NERAVec' (..), + + -- * Construction + singleton, singleton', + cons, consTree, + withCons, withConsTree, + + -- * Conversion + toList, toList', + toNonEmpty, toNonEmpty', + reifyNonEmpty, reifyNonEmpty', + + -- * Indexing + (!), index', + tabulate, tabulate', + + unsingleton, + head, head', + last, last', + + -- * Folds + foldMap, foldMap', + foldMap1, foldMap1', + ifoldMap, ifoldMap', + ifoldMap1, ifoldMap1', + foldr, foldr', + ifoldr, ifoldr', + foldr1Map, foldr1Map', + ifoldr1Map, ifoldr1Map', + + -- * Mapping + map, map', + imap, imap', + traverse, traverse', + itraverse, itraverse', +#ifdef MIN_VERSION_semigroupoids + traverse1, traverse1', + itraverse1, itraverse1', +#endif + + -- * Zipping + zipWith, zipWith', + izipWith, izipWith', + repeat, repeat', + + -- * Universe + universe, universe', + + -- * QuickCheck + liftArbitrary, liftArbitrary', + liftShrink, liftShrink', + ) where + +import Prelude (Bool (..), uncurry, Int, Eq (..), Functor (..), Ord (..), Show, seq, ($), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Data.Bin (BinP (..)) +import Data.BinP.PosP (PosP (..), PosP' (..)) +import Data.Coerce (coerce) +import Data.Hashable (Hashable (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Monoid (..)) +import Data.Nat (Nat (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Type.BinP (SBinP (..), SBinPI (..)) +import Data.Typeable (Typeable) + +import qualified Data.List.NonEmpty as NEList +import qualified Data.RAVec.Tree as Tree +import qualified Data.Type.BinP as BP +import qualified Data.Type.Nat as N + +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.Traversable as I (Traversable (..)) +import qualified Test.QuickCheck as QC + +#ifdef MIN_VERSION_distributive +import qualified Data.Distributive as I (Distributive (..)) + +#ifdef MIN_VERSION_adjunctions +import qualified Data.Functor.Rep as I (Representable (..)) +#endif +#endif + +#ifdef MIN_VERSION_semigroupoids +import Data.Functor.Apply (Apply (..)) + +import qualified Data.Semigroup.Foldable as I (Foldable1 (..)) +import qualified Data.Semigroup.Traversable as I (Traversable1 (..)) +#endif + +import Data.RAVec.Tree (Tree (..)) + +-- $setup +-- >>> :set -XScopedTypeVariables -XDataKinds +-- >>> import Prelude (print, Char, Bounded (..)) +-- >>> import Data.List (sort) +-- >>> import Data.Wrd (Wrd (..)) +-- >>> import Data.Bin.Pos (top, pop) +-- >>> import qualified Data.Bin.Pos as P + +------------------------------------------------------------------------------- +-- Random access vec +------------------------------------------------------------------------------- + +-- | Non-empty random access list. +newtype NERAVec (b :: BinP) a = NE (NERAVec' 'Z b a) + deriving (Eq, Ord, Show, Typeable) + +-- | Non-empty random access list, undelying representation. +data NERAVec' (n :: Nat) (b :: BinP) a where + Last :: Tree n a -> NERAVec' n 'BE a + Cons0 :: NERAVec' ('S n) b a -> NERAVec' n ('B0 b) a + Cons1 :: Tree n a -> NERAVec' ('S n) b a -> NERAVec' n ('B1 b) a + deriving (Typeable) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +deriving instance Eq a => Eq (NERAVec' n b a) +deriving instance Show a => Show (NERAVec' n b a) + +instance Ord a => Ord (NERAVec' n b a) where + compare xs ys = compare (toList' xs) (toList' ys) + +instance Functor (NERAVec b) where + fmap = map + +instance Functor (NERAVec' n b) where + fmap = map' + +instance I.Foldable (NERAVec b) where + foldMap = foldMap + foldr = foldr + +#if MIN_VERSION_base(4,8,0) + null _ = False +#endif + +instance I.Foldable (NERAVec' n b) where + foldMap = foldMap' + foldr = foldr' + +#if MIN_VERSION_base(4,8,0) + null _ = False +#endif + +instance I.Traversable (NERAVec b) where + traverse = traverse + +instance I.Traversable (NERAVec' n b) where + traverse = traverse' + +#ifdef MIN_VERSION_semigroupoids +instance I.Foldable1 (NERAVec b) where + foldMap1 = foldMap1 + toNonEmpty = toNonEmpty + +instance I.Foldable1 (NERAVec' n b) where + foldMap1 = foldMap1' + toNonEmpty = toNonEmpty' + +instance I.Traversable1 (NERAVec b) where + traverse1 = traverse1 + +instance I.Traversable1 (NERAVec' n b) where + traverse1 = traverse1' +#endif + +instance NFData a => NFData (NERAVec b a) where + rnf (NE xs) = rnf xs + +instance NFData a => NFData (NERAVec' n b a) where + rnf (Last t) = rnf t + rnf (Cons0 r) = rnf r + rnf (Cons1 t r) = rnf t `seq` rnf r + +instance Hashable a => Hashable (NERAVec b a) where + hashWithSalt salt (NE xs) = hashWithSalt salt xs + +instance Hashable a => Hashable (NERAVec' n b a) where + hashWithSalt salt = hashWithSalt salt . toList' + +instance SBinPI b => Applicative (NERAVec b) where + pure = repeat + (<*>) = zipWith ($) + x <* _ = x + _ *> x = x +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWith +#endif + +instance (SBinPI b, N.SNatI n) => Applicative (NERAVec' n b) where + pure = repeat' + (<*>) = zipWith' ($) + x <* _ = x + _ *> x = x +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWith' +#endif + +#ifdef MIN_VERSION_distributive +instance SBinPI b => I.Distributive (NERAVec b) where + distribute f = tabulate (\k -> fmap (! k) f) + +instance (SBinPI b, N.SNatI n) => I.Distributive (NERAVec' n b) where + distribute f = tabulate' (\k -> fmap (`index'` k) f) + +#ifdef MIN_VERSION_adjunctions +instance SBinPI b => I.Representable (NERAVec b) where + type Rep (NERAVec b) = PosP b + index = (!) + tabulate = tabulate + +instance (SBinPI b, N.SNatI n) => I.Representable (NERAVec' n b) where + type Rep (NERAVec' n b) = PosP' n b + index = index' + tabulate = tabulate' +#endif +#endif + +instance Semigroup a => Semigroup (NERAVec b a) where + (<>) = zipWith (<>) + +instance Semigroup a => Semigroup (NERAVec' n b a) where + (<>) = zipWith' (<>) + +instance (Monoid a, SBinPI b) => Monoid (NERAVec b a) where + mempty = repeat mempty + mappend = zipWith mappend + +instance (Monoid a, SBinPI b, N.SNatI n) => Monoid (NERAVec' n b a) where + mempty = repeat' mempty + mappend = zipWith' mappend + +#ifdef MIN_VERSION_semigroupoids +instance Apply (NERAVec b) where + (<.>) = zipWith ($) + liftF2 = zipWith + _ .> x = x + x <. _ = x + +instance Apply (NERAVec' n b) where + (<.>) = zipWith' ($) + liftF2 = zipWith' + _ .> x = x + x <. _ = x +#endif + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +singleton :: forall a. a -> NERAVec BP.BinP1 a +singleton = coerce (singleton' :: a -> NERAVec' 'Z BP.BinP1 a) + +singleton' :: a -> NERAVec' 'Z BP.BinP1 a +singleton' = Last . Tree.singleton + +-- | 'cons' for non-empty rals. +cons :: forall a b. a -> NERAVec b a -> NERAVec (BP.Succ b) a +cons x (NE xs) = NE (consTree (Leaf x) xs) + +consTree :: Tree n a -> NERAVec' n b a -> NERAVec' n (BP.Succ b) a +consTree x (Last t) = Cons0 (Last (Node x t)) +consTree x (Cons0 r) = Cons1 x r +consTree x (Cons1 t r) = Cons0 (consTree (Node x t) r) + +-- | 'withCons' for non-empty rals. +withCons :: SBinPI b => a -> NERAVec b a -> (SBinPI (BP.Succ b) => NERAVec (BP.Succ b) a -> r) -> r +withCons x (NE xs) k = withConsTree sbinp (Leaf x) xs $ k . NE + +withConsTree :: SBinP b -> Tree n a -> NERAVec' n b a -> (SBinPI (BP.Succ b) => NERAVec' n (BP.Succ b) a -> r) -> r +withConsTree SBE x (Last t) k = k (Cons0 (Last (Node x t))) +withConsTree SB0 x (Cons0 r) k = k (Cons1 x r) +withConsTree SB1 x (Cons1 t r) k = withConsTree sbinp (Node x t) r $ k . Cons0 + +unsingleton :: NERAVec 'BE a -> a +unsingleton (NE (Last (Tree.Leaf x))) = x + +head :: NERAVec b a -> a +head (NE x) = head' x + +head' :: NERAVec' n b a -> a +head' (Last t) = Tree.leftmost t +head' (Cons0 ral) = head' ral +head' (Cons1 t _) = Tree.leftmost t + +last :: NERAVec b a -> a +last (NE x) = last' x + +last' :: NERAVec' n b a -> a +last' (Last t) = Tree.rightmost t +last' (Cons0 ral) = head' ral +last' (Cons1 _ ral) = last' ral + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +toList :: NERAVec b a -> [a] +toList (NE xs) = toList' xs + +toList' :: NERAVec' n b a -> [a] +toList' = foldr' (:) [] + +toNonEmpty :: NERAVec b a -> NonEmpty a +toNonEmpty (NE xs) = toNonEmpty' xs + +toNonEmpty' :: NERAVec' n b a -> NonEmpty a +toNonEmpty' = foldr1Map' NEList.cons (:|[]) + +reifyNonEmpty :: NonEmpty a -> (forall b. SBinPI b => NERAVec b a -> r) -> r +reifyNonEmpty xs k = reifyNonEmpty' xs $ k . NE + +reifyNonEmpty' :: forall a r. NonEmpty a -> (forall b. SBinPI b => NERAVec' 'Z b a -> r) -> r +reifyNonEmpty' (x0 :| xs0) = go x0 xs0 where + go :: forall k. a -> [a] -> (forall b. SBinPI b => NERAVec' 'Z b a -> k) -> k + go x [] k = k (Last (Leaf x)) + go x (y:ys) k = go y ys $ \zs -> withConsTree sbinp (Leaf x) zs k + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +(!) :: NERAVec b a -> PosP b -> a +(!) (NE xs) (PosP p) = index' xs p + +index' :: NERAVec' n b a -> PosP' n b -> a +index' (Last t) (AtEnd i) = t Tree.! i +index' (Cons0 ral) (There0 i) = index' ral i +index' (Cons1 t _) (Here i) = t Tree.! i +index' (Cons1 _ ral) (There1 i) = index' ral i + +tabulate :: SBinPI b => (PosP b -> a) -> NERAVec b a +tabulate f = NE (tabulate' (f . PosP)) + +tabulate' :: forall b n a. (SBinPI b, N.SNatI n) => (PosP' n b -> a) -> NERAVec' n b a +tabulate' f = case sbinp :: SBinP b of + SBE -> Last (Tree.tabulate (f . AtEnd)) + SB0 -> Cons0 (tabulate' (f . There0)) + SB1 -> Cons1 (Tree.tabulate (f . Here)) (tabulate' (f . There1)) + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +foldMap :: Monoid m => (a -> m) -> NERAVec b a -> m +foldMap f (NE xs) = foldMap' f xs + +foldMap' :: Monoid m => (a -> m) -> NERAVec' n b a -> m +foldMap' f (Last t) = Tree.foldMap f t +foldMap' f (Cons0 r) = foldMap' f r +foldMap' f (Cons1 t r) = mappend (Tree.foldMap f t) (foldMap' f r) + +ifoldMap :: Monoid m => (PosP b -> a -> m) -> NERAVec b a -> m +ifoldMap f (NE xs) = ifoldMap' (f . PosP) xs + +ifoldMap' :: Monoid m => (PosP' n b -> a -> m) -> NERAVec' n b a -> m +ifoldMap' f (Last t) = Tree.ifoldMap (f . AtEnd) t +ifoldMap' f (Cons0 r) = ifoldMap' (f . There0) r +ifoldMap' f (Cons1 t r) = Tree.ifoldMap (f . Here) t `mappend` ifoldMap' (f . There1) r + +foldMap1 :: Semigroup m => (a -> m) -> NERAVec b a -> m +foldMap1 f (NE xs) = foldMap1' f xs + +foldMap1' :: Semigroup m => (a -> m) -> NERAVec' n b a -> m +foldMap1' f (Last t) = Tree.foldMap1 f t +foldMap1' f (Cons0 r) = foldMap1' f r +foldMap1' f (Cons1 t r) = Tree.foldMap1 f t <> foldMap1' f r + +ifoldMap1 :: Semigroup m => (PosP b -> a -> m) -> NERAVec b a -> m +ifoldMap1 f (NE xs) = ifoldMap1' (f . PosP) xs + +ifoldMap1' :: Semigroup m => (PosP' n b -> a -> m) -> NERAVec' n b a -> m +ifoldMap1' f (Last t) = Tree.ifoldMap1 (f . AtEnd) t +ifoldMap1' f (Cons0 r) = ifoldMap1' (f . There0) r +ifoldMap1' f (Cons1 t r) = Tree.ifoldMap1 (f . Here) t <> ifoldMap1' (f . There1) r + +foldr :: (a -> b -> b) -> b -> NERAVec m a -> b +foldr f z (NE xs) = foldr' f z xs + +foldr1Map :: (a -> b -> b) -> (a -> b) -> NERAVec m a -> b +foldr1Map f z (NE xs) = foldr1Map' f z xs + +ifoldr1Map :: (PosP m -> a -> b -> b) -> (PosP m -> a -> b) -> NERAVec m a -> b +ifoldr1Map f z (NE xs) = ifoldr1Map' (f . PosP) (z . PosP) xs + +foldr' :: (a -> b -> b) -> b -> NERAVec' n m a -> b +foldr' f z (Last t) = Tree.foldr f z t +foldr' f z (Cons0 r) = foldr' f z r +foldr' f z (Cons1 t r) = Tree.foldr f (foldr' f z r) t + +foldr1Map' :: (a -> b -> b) -> (a -> b) -> NERAVec' n m a -> b +foldr1Map' f z (Last t) = Tree.foldr1Map f z t +foldr1Map' f z (Cons0 r) = foldr1Map' f z r +foldr1Map' f z (Cons1 t r) = Tree.foldr f (foldr1Map' f z r) t + +ifoldr1Map' :: (PosP' n m -> a -> b -> b) -> (PosP' n m -> a -> b) -> NERAVec' n m a -> b +ifoldr1Map' f z (Last t) = Tree.ifoldr1Map (f . AtEnd) (z . AtEnd) t +ifoldr1Map' f z (Cons0 r) = ifoldr1Map' (f . There0) (z . There0) r +ifoldr1Map' f z (Cons1 t r) = Tree.ifoldr (f . Here) (ifoldr1Map' (f . There1) (z . There1) r) t + +ifoldr :: (PosP m -> a -> b -> b) -> b -> NERAVec m a -> b +ifoldr f z (NE xs) = ifoldr' (f . PosP) z xs + +ifoldr' :: (PosP' n m -> a -> b -> b) -> b -> NERAVec' n m a -> b +ifoldr' f z (Last t) = Tree.ifoldr (f . AtEnd) z t +ifoldr' f z (Cons0 r) = ifoldr' (f . There0) z r +ifoldr' f z (Cons1 t r) = Tree.ifoldr (f . Here) (ifoldr' (f . There1) z r) t + +------------------------------------------------------------------------------- +-- Special folds +------------------------------------------------------------------------------- + +-- TBW + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +map :: (a -> b) -> NERAVec m a -> NERAVec m b +map f (NE xs) = NE (map' f xs) + +map' :: (a -> b) -> NERAVec' n m a -> NERAVec' n m b +map' f (Last t ) = Last (Tree.map f t) +map' f (Cons0 r) = Cons0 (map' f r) +map' f (Cons1 t r) = Cons1 (Tree.map f t) (map' f r) + +imap :: (PosP m -> a -> b) -> NERAVec m a -> NERAVec m b +imap f (NE xs) = NE (imap' (f . PosP) xs) + +imap' :: (PosP' n m -> a -> b) -> NERAVec' n m a -> NERAVec' n m b +imap' f (Last t) = Last (Tree.imap (f . AtEnd) t) +imap' f (Cons0 r) = Cons0 (imap' (f . There0) r) +imap' f (Cons1 t r) = Cons1 (Tree.imap (f . Here) t) (imap' (f . There1) r) + +traverse :: Applicative f => (a -> f b) -> NERAVec m a -> f (NERAVec m b) +traverse f (NE xs) = fmap NE (traverse' f xs) + +traverse' :: Applicative f => (a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b) +traverse' f (Last t) = Last <$> Tree.traverse f t +traverse' f (Cons0 r) = Cons0 <$> traverse' f r +traverse' f (Cons1 t r) = Cons1 <$> Tree.traverse f t <*> traverse' f r + +itraverse :: Applicative f => (PosP m -> a -> f b) -> NERAVec m a -> f (NERAVec m b) +itraverse f (NE xs) = fmap NE (itraverse' (f . PosP) xs) + +itraverse' :: Applicative f => (PosP' n m -> a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b) +itraverse' f (Last t) = Last <$> Tree.itraverse (f . AtEnd) t +itraverse' f (Cons0 r) = Cons0 <$> itraverse' (f . There0) r +itraverse' f (Cons1 t r) = Cons1 <$> Tree.itraverse (f . Here) t <*> itraverse' (f . There1) r + +#ifdef MIN_VERSION_semigroupoids +traverse1 :: Apply f => (a -> f b) -> NERAVec m a -> f (NERAVec m b) +traverse1 f (NE xs) = fmap NE (traverse1' f xs) + +traverse1' :: Apply f => (a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b) +traverse1' f (Last t) = Last <$> Tree.traverse1 f t +traverse1' f (Cons0 r) = Cons0 <$> traverse1' f r +traverse1' f (Cons1 t r) = Cons1 <$> Tree.traverse1 f t <.> traverse1' f r + +itraverse1 :: Apply f => (PosP m -> a -> f b) -> NERAVec m a -> f (NERAVec m b) +itraverse1 f (NE xs) = fmap NE (itraverse1' (f . PosP) xs) + +itraverse1' :: Apply f => (PosP' n m -> a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b) +itraverse1' f (Last t) = Last <$> Tree.itraverse1 (f . AtEnd) t +itraverse1' f (Cons0 r) = Cons0 <$> itraverse1' (f . There0) r +itraverse1' f (Cons1 t r) = Cons1 <$> Tree.itraverse1 (f . Here) t <.> itraverse1' (f . There1) r +#endif + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +zipWith :: (a -> b -> c) -> NERAVec m a -> NERAVec m b -> NERAVec m c +zipWith f (NE xs) (NE ys) = NE (zipWith' f xs ys) + +-- | Zip two 'NERAVec''s with a function. +zipWith' :: (a -> b -> c) -> NERAVec' n m a -> NERAVec' n m b -> NERAVec' n m c +zipWith' f (Last t) (Last t') = Last (Tree.zipWith f t t') +zipWith' f (Cons0 r) (Cons0 r') = Cons0 (zipWith' f r r') +zipWith' f (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.zipWith f t t') (zipWith' f r r') + +izipWith :: (PosP m -> a -> b -> c) -> NERAVec m a -> NERAVec m b -> NERAVec m c +izipWith f (NE xs) (NE ys) = NE (izipWith' (f . PosP) xs ys) + +-- | Zip two 'NERAVec''s with a function which also takes 'PosP'' index. +izipWith' :: (PosP' n m -> a -> b -> c) -> NERAVec' n m a -> NERAVec' n m b -> NERAVec' n m c +izipWith' f (Last t) (Last t') = Last (Tree.izipWith (f . AtEnd) t t') +izipWith' f (Cons0 r) (Cons0 r') = Cons0 (izipWith' (f . There0) r r') +izipWith' f (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.izipWith (f . Here) t t') (izipWith' (f . There1) r r') + +repeat :: SBinPI b => a -> NERAVec b a +repeat = NE . repeat' + +repeat' :: forall b n a. (N.SNatI n, SBinPI b) => a -> NERAVec' n b a +repeat' x = case sbinp :: SBinP b of + SBE -> Last (Tree.repeat x) + SB0 -> Cons0 (repeat' x) + SB1 -> Cons1 (Tree.repeat x) (repeat' x) + +------------------------------------------------------------------------------- +-- Universe +------------------------------------------------------------------------------- + +universe :: forall b. SBinPI b => NERAVec b (PosP b) +universe = coerce (universe' :: NERAVec' 'Z b (PosP' 'Z b)) + +universe' :: forall n b. (N.SNatI n, SBinPI b) => NERAVec' n b (PosP' n b) +universe' = case sbinp :: SBinP b of + SBE -> Last (fmap AtEnd Tree.universe) + SB0 -> Cons0 (fmap There0 universe') + SB1 -> Cons1 (fmap Here Tree.universe) (fmap There1 universe') + +------------------------------------------------------------------------------- +-- Out-of-order combining +------------------------------------------------------------------------------- + +{- +appendB0 :: NERAVec b a -> NERAVec b a -> NERAVec ('B0 b) a +appendB0 (NE xs) (NE ys) = NE (Cons0 (appendB' xs ys)) where + +appendB1 :: a -> NERAVec b a -> NERAVec b a -> NERAVec ('B1 b) a +appendB1 x (NE ys) (NE zs) = NE (Cons1 (Tree.Leaf x) (appendB' ys zs)) + +appendB' :: NERAVec' n b a -> NERAVec' n b a -> NERAVec' ('S n) b a +appendB' (Last t) (Last t') = Last (Tree.Node t t') +appendB' (Cons0 r) (Cons0 r') = Cons0 (appendB' r r') +appendB' (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.Node t t') (appendB' r r') + +splitB0 :: NERAVec ('B0 b) a -> (NERAVec b a, NERAVec b a) +splitB0 (NE (Cons0 xs)) = + let (ys, zs) = splitB' xs in (NE ys, NE zs) + +splitB1 :: NERAVec ('B1 b) a -> (a, NERAVec b a, NERAVec b a) +splitB1 (NE (Cons1 (Tree.Leaf x) xs)) = + let (ys, zs) = splitB' xs in (x, NE ys, NE zs) + +splitB' :: NERAVec' ('S n) b a -> (NERAVec' n b a, NERAVec' n b a) +splitB' (Last (Tree.Node t t')) = (Last t, Last t') +splitB' (Cons0 r) = + let (a, b) = splitB' r in (Cons0 a, Cons0 b) +splitB' (Cons1 (Tree.Node t t') r) = + let (a, b) = splitB' r in (Cons1 t a, Cons1 t' b) +-} + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance BP.SBinPI b => QC.Arbitrary1 (NERAVec b) where + liftArbitrary = liftArbitrary + liftShrink = liftShrink + +liftArbitrary :: BP.SBinPI b => QC.Gen a -> QC.Gen (NERAVec b a) +liftArbitrary = fmap NE . liftArbitrary' + +liftShrink :: (a -> [a]) -> NERAVec b a -> [NERAVec b a] +liftShrink shr (NE r) = fmap NE (liftShrink' shr r) + +instance (BP.SBinPI b, N.SNatI n) => QC.Arbitrary1 (NERAVec' n b) where + liftArbitrary = liftArbitrary' + liftShrink = liftShrink' + +liftArbitrary' :: forall b n a. (BP.SBinPI b, N.SNatI n) => QC.Gen a -> QC.Gen (NERAVec' n b a) +liftArbitrary' arb = case BP.sbinp :: BP.SBinP b of + BP.SBE -> Last <$> QC.liftArbitrary arb + BP.SB0 -> Cons0 <$> liftArbitrary' arb + BP.SB1 -> Cons1 <$> QC.liftArbitrary arb <*> liftArbitrary' arb + +liftShrink' :: forall b n a. (a -> [a]) -> NERAVec' n b a -> [NERAVec' n b a] +liftShrink' shr (Last t) = Last <$> Tree.liftShrink shr t +liftShrink' shr (Cons0 r) = Cons0 <$> liftShrink' shr r +liftShrink' shr (Cons1 t r) = uncurry Cons1 <$> QC.liftShrink2 (Tree.liftShrink shr) (liftShrink' shr) (t, r) + +instance (BP.SBinPI b, QC.Arbitrary a) => QC.Arbitrary (NERAVec b a) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +instance QC.CoArbitrary a => QC.CoArbitrary (NERAVec b a) where + coarbitrary (NE r) = QC.coarbitrary r + +instance QC.CoArbitrary a => QC.CoArbitrary (NERAVec' n b a) where + coarbitrary (Last t) = QC.variant (0 :: Int) . QC.coarbitrary t + coarbitrary (Cons0 r) = QC.variant (1 :: Int) . QC.coarbitrary r + coarbitrary (Cons1 t r) = QC.variant (2 :: Int) . QC.coarbitrary (t, r) + +instance (BP.SBinPI b, QC.Function a) => QC.Function (NERAVec b a) where + function = QC.functionMap (\(NE r) -> r) NE + +instance (N.SNatI n, BP.SBinPI b, QC.Function a) => QC.Function (NERAVec' n b a) where + function = case BP.sbinp :: BP.SBinP b of + SBE -> QC.functionMap (\(Last t) -> t) Last + SB0 -> QC.functionMap (\(Cons0 r) -> r) Cons0 + SB1 -> QC.functionMap (\(Cons1 t r) -> (t, r)) (uncurry Cons1) diff --git a/src/Data/RAVec/Tree.hs b/src/Data/RAVec/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec/Tree.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | Depth indexed perfect binary tree. +module Data.RAVec.Tree ( + Tree (..), + + -- * Construction + singleton, + + -- * Conversions + toList, + + -- * Indexing + (!), + tabulate, + leftmost, + rightmost, + + -- * Folds + foldMap, + foldMap1, + ifoldMap, + ifoldMap1, + foldr, + ifoldr, + foldr1Map, + ifoldr1Map, + foldl, + ifoldl, + length, + + -- * Mapping + map, + imap, + traverse, + itraverse, +#ifdef MIN_VERSION_semigroupoids + traverse1, + itraverse1, +#endif + -- TODO: itraverse_, + + -- * Zipping + zipWith, + izipWith, + repeat, + + -- * Universe + universe, + + -- * QuickCheck + liftArbitrary, + liftShrink, + + ) where + +import Prelude + (Bool (..), Eq (..), Functor (..), Int, Ord (..), Show, id, seq, + uncurry, ($), (*), (.)) + +import Control.Applicative (Applicative (..), (<$>)) +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable (..)) +import Data.Monoid (Monoid (..)) +import Data.Nat (Nat (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Typeable (Typeable) +import Data.Wrd (Wrd (..)) + +import qualified Data.Type.Nat as N + +-- instances +import qualified Data.Foldable as I (Foldable (..)) +import qualified Data.Traversable as I (Traversable (..)) +import qualified Test.QuickCheck as QC + +#ifdef MIN_VERSION_distributive +import qualified Data.Distributive as I (Distributive (..)) + +#ifdef MIN_VERSION_adjunctions +import qualified Data.Functor.Rep as I (Representable (..)) +#endif +#endif + +#ifdef MIN_VERSION_semigroupoids +import Data.Functor.Apply (Apply (..)) + +import qualified Data.Semigroup.Foldable as I (Foldable1 (..)) +import qualified Data.Semigroup.Traversable as I (Traversable1 (..)) +#endif + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> import Data.Proxy (Proxy (..)) +-- >>> import Prelude (Char, not, uncurry, flip) + +------------------------------------------------------------------------------- +-- Data +------------------------------------------------------------------------------- + +-- | Perfectly balanced binary tree of depth @n@, with @2 ^ n@ elements. +data Tree (n :: Nat) a where + Leaf :: a -> Tree 'Z a + Node :: Tree n a -> Tree n a -> Tree ('S n) a + deriving (Typeable) + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +goLeft :: (Wrd ('S n) -> a) -> Wrd n -> a +goLeft f xs = f (W0 xs) + +goRight :: (Wrd ('S n) -> a) -> Wrd n -> a +goRight f xs = f (W1 xs) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +deriving instance Eq a => Eq (Tree n a) +deriving instance Ord a => Ord (Tree n a) +deriving instance Show a => Show (Tree n a) + +instance Functor (Tree n) where + fmap = map + +instance I.Foldable (Tree n) where + foldMap = foldMap + foldr = foldr + foldl = foldl +#if MIN_VERSION_base(4,8,0) + null _ = False + toList = toList + length = length +#endif + +instance I.Traversable (Tree n) where + traverse = traverse + +#ifdef MIN_VERSION_semigroupoids +instance I.Foldable1 (Tree n) where + foldMap1 = foldMap1 + +instance I.Traversable1 (Tree n) where + traverse1 = traverse1 +#endif + +instance NFData a => NFData (Tree n a) where + rnf (Leaf x) = rnf x + rnf (Node x y) = rnf x `seq` rnf y + +instance Hashable a => Hashable (Tree n a) where + hashWithSalt salt (Leaf x) = salt + `hashWithSalt` x + hashWithSalt salt (Node x y) = salt + `hashWithSalt` x + `hashWithSalt` y + +instance N.SNatI n => Applicative (Tree n) where + pure = repeat + (<*>) = zipWith ($) + x <* _ = x + _ *> x = x +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWith +#endif + +#ifdef MIN_VERSION_distributive +instance N.SNatI n => I.Distributive (Tree n) where + distribute f = tabulate (\k -> fmap (! k) f) + +#ifdef MIN_VERSION_adjunctions +instance N.SNatI n => I.Representable (Tree n) where + type Rep (Tree n) = Wrd n + + tabulate = tabulate + index = (!) +#endif +#endif + +instance Semigroup a => Semigroup (Tree n a) where + Leaf x <> Leaf y = Leaf (x <> y) + Node x y <> Node u v = Node (x <> u) (y <> v) + +#ifdef MIN_VERSION_semigroupoids +instance Apply (Tree n) where + (<.>) = zipWith ($) + _ .> x = x + x <. _ = x + liftF2 = zipWith +#endif + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | 'Tree' of zero depth, with single element. +-- +-- >>> singleton True +-- Leaf True +singleton :: a -> Tree 'Z a +singleton = Leaf + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | Convert 'Tree' to list. +-- +-- >>> toList $ Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'c') (Leaf 'd')) +-- "abcd" +toList :: Tree n a -> [a] +toList t = go t [] where + go :: Tree n a -> [a] -> [a] + go (Leaf x) = (x :) + go (Node x y) = go x . go y + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | Indexing. +(!) :: Tree n a -> Wrd n -> a +(!) (Leaf x) WE = x +(!) (Node x _) (W0 is) = x ! is +(!) (Node _ y) (W1 is) = y ! is + +tabulate :: forall n a. N.SNatI n => (Wrd n -> a) -> Tree n a +tabulate f = case N.snat :: N.SNat n of + N.SZ -> Leaf (f WE) + N.SS -> Node (tabulate (goLeft f)) (tabulate (goRight f)) + +leftmost :: Tree n a -> a +leftmost (Leaf a) = a +leftmost (Node x _) = leftmost x + +rightmost :: Tree n a -> a +rightmost (Leaf a) = a +rightmost (Node _ y) = rightmost y + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +foldMap :: Monoid m => (a -> m) -> Tree n a -> m +foldMap f (Leaf x) = f x +foldMap f (Node x y) = mappend (foldMap f x) (foldMap f y) + +ifoldMap :: Monoid m => (Wrd n -> a -> m) -> Tree n a -> m +ifoldMap f (Leaf x) = f WE x +ifoldMap f (Node x y) = mappend (ifoldMap (goLeft f) x) (ifoldMap (goRight f) y) + +foldMap1 :: Semigroup s => (a -> s) -> Tree n a -> s +foldMap1 f (Leaf x) = f x +foldMap1 f (Node x y) = foldMap1 f x <> foldMap1 f y + +ifoldMap1 :: Semigroup s => (Wrd n -> a -> s) -> Tree n a -> s +ifoldMap1 f (Leaf x) = f WE x +ifoldMap1 f (Node x y) = ifoldMap1 (goLeft f) x <> ifoldMap1 (goRight f) y + +-- | >>> foldr (:) [] $ Node (Leaf True) (Leaf False) +-- [True,False] +foldr :: (a -> b -> b) -> b -> Tree n a -> b +foldr f z (Leaf x) = f x z +foldr f z (Node x y) = foldr f (foldr f z y) x + +ifoldr :: (Wrd n -> a -> b -> b) -> b -> Tree n a -> b +ifoldr f z (Leaf x) = f WE x z +ifoldr f z (Node x y) = ifoldr (goLeft f) (ifoldr (goRight f) z y) x + +foldr1Map :: (a -> b -> b) -> (a -> b) -> Tree n a -> b +foldr1Map _ z (Leaf x) = z x +foldr1Map f z (Node x y) = foldr f (foldr1Map f z y) x + +ifoldr1Map :: (Wrd n -> a -> b -> b) -> (Wrd n -> a -> b) -> Tree n a -> b +ifoldr1Map _ z (Leaf x) = z WE x +ifoldr1Map f z (Node x y) = ifoldr (goLeft f) (ifoldr1Map (goRight f) (goRight z) y) x + +-- | >>> foldl (flip (:)) [] $ Node (Leaf True) (Leaf False) +-- [False,True] +foldl :: (b -> a -> b) -> b -> Tree n a -> b +foldl f z (Leaf x) = f z x +foldl f z (Node x y) = foldl f (foldl f z x) y + +ifoldl :: (Wrd n -> b -> a -> b) -> b -> Tree n a -> b +ifoldl f z (Leaf x) = f WE z x +ifoldl f z (Node x y) = ifoldl (goLeft f) (ifoldl (goRight f) z x) y + +-- TODO: foldl + +-- | >>> length (universe :: Tree N.Nat3 (Wrd N.Nat3)) +-- 8 +-- +length :: Tree n a -> Int +length = go 1 where + go :: Int -> Tree n a -> Int + go !acc (Leaf _) = acc + go acc (Node x _) = go (2 * acc) x + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +-- | >>> map not $ Node (Leaf True) (Leaf False) +-- Node (Leaf False) (Leaf True) +map :: (a -> b) -> Tree n a -> Tree n b +map f (Leaf x) = Leaf (f x) +map f (Node x y) = Node (map f x) (map f y) + +-- | >>> imap (,) $ Node (Leaf True) (Leaf False) +-- Node (Leaf (0b0,True)) (Leaf (0b1,False)) +imap :: (Wrd n -> a -> b) -> Tree n a -> Tree n b +imap f (Leaf x) = Leaf (f WE x) +imap f (Node x y) = Node (imap (goLeft f) x) (imap (goRight f) y) + +traverse :: Applicative f => (a -> f b) -> Tree n a -> f (Tree n b) +traverse f (Leaf x) = Leaf <$> f x +traverse f (Node x y) = Node <$> traverse f x <*> traverse f y + +itraverse :: Applicative f => (Wrd n -> a -> f b) -> Tree n a -> f (Tree n b) +itraverse f (Leaf x) = Leaf <$> f WE x +itraverse f (Node x y) = Node <$> itraverse (goLeft f) x <*> itraverse (goRight f) y + +#ifdef MIN_VERSION_semigroupoids +traverse1 :: Apply f => (a -> f b) -> Tree n a -> f (Tree n b) +traverse1 f (Leaf x) = Leaf <$> f x +traverse1 f (Node x y) = Node <$> traverse1 f x <.> traverse1 f y + +itraverse1 :: Apply f => (Wrd n -> a -> f b) -> Tree n a -> f (Tree n b) +itraverse1 f (Leaf x) = Leaf <$> f WE x +itraverse1 f (Node x y) = Node <$> itraverse1 (goLeft f) x <.> itraverse1 (goRight f) y +#endif + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +-- | Zip two 'Vec's with a function. +zipWith :: (a -> b -> c) -> Tree n a -> Tree n b -> Tree n c +zipWith f (Leaf x) (Leaf y) = Leaf (f x y) +zipWith f (Node x y) (Node u v) = Node (zipWith f x u) (zipWith f y v) + +-- | Zip two 'Tree's. with a function that also takes the elements' indices. +izipWith :: (Wrd n -> a -> b -> c) -> Tree n a -> Tree n b -> Tree n c +izipWith f (Leaf x) (Leaf y) = Leaf (f WE x y) +izipWith f (Node x y) (Node u v) = Node (izipWith (goLeft f) x u) (izipWith (goRight f) y v) + +-- | Repeat a value. +-- +-- >>> repeat 'x' :: Tree N.Nat2 Char +-- Node (Node (Leaf 'x') (Leaf 'x')) (Node (Leaf 'x') (Leaf 'x')) +-- +repeat :: N.SNatI n => a -> Tree n a +repeat x = N.induction1 (Leaf x) (\t -> Node t t) + +------------------------------------------------------------------------------- +-- Universe +------------------------------------------------------------------------------- + +-- | Get all @'Vec' n 'Bool'@ indices in @'Tree' n@. +-- +-- >>> universe :: Tree N.Nat2 (Wrd N.Nat2) +-- Node (Node (Leaf 0b00) (Leaf 0b01)) (Node (Leaf 0b10) (Leaf 0b11)) +-- +universe :: N.SNatI n => Tree n (Wrd n) +universe = tabulate id + +------------------------------------------------------------------------------- +-- QuickCheck +------------------------------------------------------------------------------- + +instance N.SNatI n => QC.Arbitrary1 (Tree n) where + liftArbitrary = liftArbitrary + liftShrink = liftShrink + +liftArbitrary :: forall n a. N.SNatI n => QC.Gen a -> QC.Gen (Tree n a) +liftArbitrary arb = getArb $ N.induction1 (Arb (fmap Leaf arb)) step where + step :: Arb m a -> Arb ('S m) a + step (Arb rec) = Arb $ Node <$> rec <*> rec + +newtype Arb n a = Arb { getArb :: QC.Gen (Tree n a) } + +liftShrink :: forall n a. (a -> [a]) -> Tree n a -> [Tree n a] +liftShrink shr (Leaf x) = Leaf <$> shr x +liftShrink shr (Node l r) = uncurry Node <$> QC.liftShrink2 rec rec (l, r) where + rec = liftShrink shr + +instance (N.SNatI n, QC.Arbitrary a) => QC.Arbitrary (Tree n a) where + arbitrary = QC.arbitrary1 + shrink = QC.shrink1 + +instance QC.CoArbitrary a => QC.CoArbitrary (Tree n a) where + coarbitrary (Leaf x) = QC.variant (0 :: Int) . QC.coarbitrary x + coarbitrary (Node l r) = QC.variant (1 :: Int) . QC.coarbitrary (l, r) + +instance (N.SNatI n, QC.Function a) => QC.Function (Tree n a) where + function = case N.snat :: N.SNat n of + N.SZ -> QC.functionMap (\(Leaf x) -> x) Leaf + N.SS -> QC.functionMap (\(Node l r ) -> (l, r)) (uncurry Node)