diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,18 @@ +dist/ +.hsenv/ +docs +wiki +TAGS +tags +wip +old +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.cabal-sandbox/ +cabal.sandbox.config +codex.tags diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,3 @@ +0 +- +* Initialized repository diff --git a/HLint.hs b/HLint.hs new file mode 100644 --- /dev/null +++ b/HLint.hs @@ -0,0 +1,1 @@ +ignore "Eta reduce" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (C) 2014 Edward Kmett (ekmett@gmail.com) + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,18 @@ +discrimination +============== + +[![Build Status](https://secure.travis-ci.org/ekmett/discrimination.png?branch=master)](http://travis-ci.org/ekmett/discrimination) + +This package provides linear time sorting, partitioning, and joins for a wide array of Haskell data types. This work is based on a +"final encoding" of the ideas presented in [multiple](http://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011a.pdf) [papers](http://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011c.pdf) and [talks](https://www.youtube.com/watch?v=sz9ZlZIRDAg) by [Fritz Henglein](http://www.diku.dk/hjemmesider/ansatte/henglein/). + +By adopting a final encoding we can enjoy many instances for standard classes, lawfully, without quotienting. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/discrimination.cabal b/discrimination.cabal new file mode 100644 --- /dev/null +++ b/discrimination.cabal @@ -0,0 +1,54 @@ +name: discrimination +category: Data, Sorting +version: 0 +license: BSD3 +cabal-version: >= 1.10 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: experimental +homepage: http://github.com/ekmett/discrimination/ +bug-reports: http://github.com/ekmett/discrimination/issues +copyright: Copyright (C) 2014-2015 Edward A. Kmett +build-type: Simple +tested-with: GHC == 7.8.4 +synopsis: Fast generic linear-time sorting, joins and container construction. +description: + This package provides fast, generic, linear-time discrimination and sorting. + . + The techniques applied are based on and by . + +extra-source-files: + .gitignore + README.markdown + CHANGELOG.markdown + HLint.hs + +source-repository head + type: git + location: git://github.com/ekmett/discrimination.git + +library + default-language: Haskell2010 + ghc-options: -Wall -O2 + hs-source-dirs: src + + exposed-modules: + Data.Discrimination + Data.Discrimination.Class + Data.Discrimination.Grouping + Data.Discrimination.Internal + Data.Discrimination.Sorting + + build-depends: + array >= 0.5 && < 0.6, + base >= 4.7 && < 5, + containers >= 0.5 && < 0.6, + contravariant >= 1.3.1 && < 2, + deepseq >= 1.4 && < 1.5, + ghc-prim, + profunctors >= 5 && < 6, + semigroups >= 0.16.2 && < 1, + transformers >= 0.2 && < 0.5, + vector >= 0.10 && < 0.11, + void >= 0.6 && < 1 diff --git a/src/Data/Discrimination.hs b/src/Data/Discrimination.hs new file mode 100644 --- /dev/null +++ b/src/Data/Discrimination.hs @@ -0,0 +1,45 @@ +module Data.Discrimination + ( + -- * Discrimination + Discriminating(..) + -- * Unordered + , Group(..) + , Grouping(..) + , Grouping1(..) + , nub + , nubWith + , group + , groupWith + , groupingBag + , groupingSet + , groupingEq + -- * Ordered + , Sort(..) + , Sorting(..) + , Sorting1(..) + , desc + , sort + , sortWith + , sortingBag + , sortingSet + , sortingCompare + -- * Container Construction + , toMap + , toMapWith + , toMapWithKey + , toIntMap + , toIntMapWith + , toIntMapWithKey + , toSet + , toIntSet + -- * Joins + , joining + , inner + , outer + , leftOuter + , rightOuter + ) where + +import Data.Discrimination.Class +import Data.Discrimination.Grouping +import Data.Discrimination.Sorting diff --git a/src/Data/Discrimination/Class.hs b/src/Data/Discrimination/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Discrimination/Class.hs @@ -0,0 +1,128 @@ +module Data.Discrimination.Class + ( Discriminating(..) + -- * Joins + , joining + , inner + , outer + , leftOuter + , rightOuter + ) where + +import Control.Applicative +import Control.Arrow +import Data.Functor.Contravariant.Divisible +import Data.Discrimination.Grouping +import Data.Discrimination.Internal +import Data.Discrimination.Sorting +import Data.Maybe (catMaybes) + +class Decidable f => Discriminating f where + disc :: f a -> [(a, b)] -> [[b]] + +instance Discriminating Sort where + disc = runSort + +instance Discriminating Group where + disc = runGroup + +-------------------------------------------------------------------------------- +-- * Joins +-------------------------------------------------------------------------------- + +-- | /O(n)/. Perform a full outer join while explicit merging of the two result tables a table at a time. +-- +-- The results are grouped by the discriminator. +joining + :: Discriminating f + => f d -- ^ the discriminator to use + -> ([a] -> [b] -> c) -- ^ how to join two tables + -> (a -> d) -- ^ selector for the left table + -> (b -> d) -- ^ selector for the right table + -> [a] -- ^ left table + -> [b] -- ^ right table + -> [c] +joining m abc ad bd as bs = spanEither abc <$> disc m (((ad &&& Left) <$> as) ++ ((bd &&& Right) <$> bs)) +{-# INLINE joining #-} + +-- | /O(n)/. Perform an inner join, with operations defined one row at a time. +-- +-- The results are grouped by the discriminator. +-- +-- This takes operation time linear in both the input and result sets. +inner + :: Discriminating f + => f d -- ^ the discriminator to use + -> (a -> b -> c) -- ^ how to join two rows + -> (a -> d) -- ^ selector for the left table + -> (b -> d) -- ^ selector for the right table + -> [a] -- ^ left table + -> [b] -- ^ right table + -> [[c]] +inner m abc ad bd as bs = catMaybes $ joining m go ad bd as bs where + go ap bp + | Prelude.null ap || Prelude.null bp = Nothing + | otherwise = Just (liftA2 abc ap bp) + +-- | /O(n)/. Perform a full outer join with operations defined one row at a time. +-- +-- The results are grouped by the discriminator. +-- +-- This takes operation time linear in both the input and result sets. +outer + :: Discriminating f + => f d -- ^ the discriminator to use + -> (a -> b -> c) -- ^ how to join two rows + -> (a -> c) -- ^ row present on the left, missing on the right + -> (b -> c) -- ^ row present on the right, missing on the left + -> (a -> d) -- ^ selector for the left table + -> (b -> d) -- ^ selector for the right table + -> [a] -- ^ left table + -> [b] -- ^ right table + -> [[c]] +outer m abc ac bc ad bd as bs = joining m go ad bd as bs where + go ap bp + | Prelude.null ap = bc <$> bp + | Prelude.null bp = ac <$> ap + | otherwise = liftA2 abc ap bp + +-- | /O(n)/. Perform a left outer join with operations defined one row at a time. +-- +-- The results are grouped by the discriminator. +-- +-- This takes operation time linear in both the input and result sets. +leftOuter + :: Discriminating f + => f d -- ^ the discriminator to use + -> (a -> b -> c) -- ^ how to join two rows + -> (a -> c) -- ^ row present on the left, missing on the right + -> (a -> d) -- ^ selector for the left table + -> (b -> d) -- ^ selector for the right table + -> [a] -- ^ left table + -> [b] -- ^ right table + -> [[c]] +leftOuter m abc ac ad bd as bs = catMaybes $ joining m go ad bd as bs where + go ap bp + | Prelude.null ap = Nothing + | Prelude.null bp = Just (ac <$> ap) + | otherwise = Just (liftA2 abc ap bp) + +-- | /O(n)/. Perform a right outer join with operations defined one row at a time. +-- +-- The results are grouped by the discriminator. +-- +-- This takes operation time linear in both the input and result sets. +rightOuter + :: Discriminating f + => f d -- ^ the discriminator to use + -> (a -> b -> c) -- ^ how to join two rows + -> (b -> c) -- ^ row present on the right, missing on the left + -> (a -> d) -- ^ selector for the left table + -> (b -> d) -- ^ selector for the right table + -> [a] -- ^ left table + -> [b] -- ^ right table + -> [[c]] +rightOuter m abc bc ad bd as bs = catMaybes $ joining m go ad bd as bs where + go ap bp + | Prelude.null bp = Nothing + | Prelude.null ap = Just (bc <$> bp) + | otherwise = Just (liftA2 abc ap bp) diff --git a/src/Data/Discrimination/Grouping.hs b/src/Data/Discrimination/Grouping.hs new file mode 100644 --- /dev/null +++ b/src/Data/Discrimination/Grouping.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} + +module Data.Discrimination.Grouping + ( Group(..) + , Grouping(..) + , Grouping1(..) + -- * Combinators + , nub, nubWith + , group, groupWith + , groupingEq + -- * Internals + , groupingBag + , groupingSet + , groupingShort + , groupingNat + ) where + +import Control.Arrow +import Control.Monad +import Data.Bits +import Data.Complex +import Data.Discrimination.Internal +import Data.Foldable hiding (concat) +import Data.Functor +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Functor.Contravariant.Generic +import Data.IORef (IORef, newIORef, atomicModifyIORef) +import Data.Int +import Data.Monoid hiding (Any) +import Data.Proxy +import Data.Ratio +import Data.Typeable +import qualified Data.Vector.Mutable as UM +import Data.Void +import Data.Word +import GHC.Prim (Any, RealWorld) +import Prelude hiding (read, concat) +import System.IO.Unsafe +import Unsafe.Coerce +{- +import Data.Coerce +import Data.Primitive.Types (Addr(..)) +import GHC.IO (IO(IO)) +import qualified Data.Vector.Primitive as P +import qualified Data.Vector.Primitive.Mutable as PM +import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) +import GHC.Prim (Any, State#, RealWorld, MutableByteArray#, Int#) +import GHC.IORef (IORef(IORef)) +import GHC.STRef (STRef(STRef)) +-} + +-- | Discriminator + +-- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety? +newtype Group a = Group { runGroup :: forall b. [(a,b)] -> [[b]] } + deriving Typeable + +#ifndef HLINT +type role Group representational +#endif + +instance Contravariant Group where + contramap f (Group g) = Group $ g . map (first f) + +instance Divisible Group where + conquer = Group $ return . fmap snd + divide k (Group l) (Group r) = Group $ \xs -> + l [ (b, (c, d)) | (a,d) <- xs, let (b, c) = k a] >>= r + +instance Decidable Group where + lose k = Group $ fmap (absurd.k.fst) + choose f (Group l) (Group r) = Group $ \xs -> let + ys = zipWith (\n (a,d) -> (f a, (n, d))) [0..] xs + in l [ (k,p) | (Left k, p) <- ys ] `mix` + r [ (k,p) | (Right k, p) <- ys ] + +mix :: [[(Int,b)]] -> [[(Int,b)]] -> [[b]] +mix [] bs = fmap snd <$> bs +mix as [] = fmap snd <$> as +mix asss@(((n,a):as):ass) bsss@(((m,b):bs):bss) + | n < m = (a:fmap snd as) : mix ass bsss + | otherwise = (b:fmap snd bs) : mix asss bss +mix _ _ = error "bad discriminator" + +instance Monoid (Group a) where + mempty = conquer + mappend (Group l) (Group r) = Group $ \xs -> l [ (fst x, x) | x <- xs ] >>= r + +-------------------------------------------------------------------------------- +-- Primitives +-------------------------------------------------------------------------------- + +-- | Perform stable unordered discrimination by bucket. +-- +-- This reuses arrays unlike the more obvious ST implementation, so it wins by +-- a huge margin in a race, especially when we have a large +-- keyspace, sparsely used, with low contention. +-- This will leak a number of arrays equal to the maximum concurrent +-- contention for this resource. If this becomes a bottleneck we can +-- make multiple stacks of working pads and index the stack with the +-- hash of the current thread id to reduce contention at the expense +-- of taking more memory. +-- +-- You should create a thunk that holds the discriminator from @groupingNat n@ +-- for a known @n@ and then reuse it. +groupingNat :: Int -> Group Int +groupingNat n = unsafePerformIO $ do + ts <- newIORef ([] :: [UM.MVector RealWorld [Any]]) + return $ Group $ go ts + where + step1 t keys (k, v) = UM.read t k >>= \vs -> case vs of + [] -> (k:keys) <$ UM.write t k [v] + _ -> keys <$ UM.write t k (v:vs) + step2 t vss k = do + es <- UM.read t k + (reverse es : vss) <$ UM.write t k [] + go :: IORef [UM.MVector RealWorld [Any]] -> [(Int, b)] -> [[b]] + go ts xs = unsafePerformIO $ do + mt <- atomicModifyIORef ts $ \case + (y:ys) -> (ys, Just y) + [] -> ([], Nothing) + t <- maybe (UM.replicate n []) (return . unsafeCoerce) mt + ys <- foldM (step1 t) [] xs + zs <- foldM (step2 t) [] ys + atomicModifyIORef ts $ \ws -> (unsafeCoerce t:ws, ()) + return zs + {-# NOINLINE go #-} +{-# NOINLINE groupingNat #-} + +-- | Shared bucket set for small integers +groupingShort :: Group Int +groupingShort = groupingNat 65536 +{-# NOINLINE groupingShort #-} + +{- +foreign import prim "walk" walk :: Any -> MutableByteArray# s -> State# s -> (# State# s, Int# #) + +groupingSTRef :: Group Addr -> Group (STRef s a) +groupingSTRef (Group f) = Group $ \xs -> + let force !n !(!(STRef !_,_):ys) = force (n + 1) ys + force !n [] = n + in case force 0 xs of + !n -> unsafePerformIO $ do + mv@(PM.MVector _ _ (MutableByteArray mba)) <- PM.new n :: IO (PM.MVector RealWorld Addr) + IO $ \s -> case walk (unsafeCoerce xs) mba s of (# s', _ #) -> (# s', () #) + ys <- P.freeze mv + return $ f [ (a,snd kv) | kv <- xs | a <- P.toList ys ] +{-# NOINLINE groupingSTRef #-} + +groupingIORef :: forall a. Group Addr -> Group (IORef a) +groupingIORef = coerce (groupingSTRef :: Group Addr -> Group (STRef RealWorld a)) +-} + +-------------------------------------------------------------------------------- +-- * Unordered Discrimination (for partitioning) +-------------------------------------------------------------------------------- + +-- | 'Eq' equipped with a compatible stable unordered discriminator. +class Grouping a where + -- | For every surjection @f@, + -- + -- @ + -- 'contramap' f 'grouping' ≡ 'grouping' + -- @ + + grouping :: Group a +#ifndef HLINT + default grouping :: Deciding Grouping a => Group a + grouping = deciding (Proxy :: Proxy Grouping) grouping +#endif + +instance Grouping Void where + grouping = lose id + +instance Grouping Word8 where + grouping = contramap fromIntegral groupingShort + +instance Grouping Word16 where + grouping = contramap fromIntegral groupingShort + +instance Grouping Word32 where + grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . map radices) where + radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16), (x,b))) + +instance Grouping Word64 where + grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . join + . runGroup groupingShort . join . runGroup groupingShort . map radices) + where + radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16) .&. 0xffff + , (fromIntegral (unsafeShiftR x 32) .&. 0xffff, (fromIntegral (unsafeShiftR x 48) + , (x,b))))) + + +instance Grouping Word where + grouping + | (maxBound :: Word) == 4294967295 = contramap (fromIntegral :: Word -> Word32) grouping + | otherwise = contramap (fromIntegral :: Word -> Word64) grouping + +instance Grouping Int8 where + grouping = contramap (\x -> fromIntegral x + 128) groupingShort + +instance Grouping Int16 where + grouping = contramap (\x -> fromIntegral x + 32768) groupingShort + +instance Grouping Int32 where + grouping = contramap (\x -> fromIntegral (x - minBound) :: Word32) grouping + +instance Grouping Int64 where + grouping = contramap (\x -> fromIntegral (x - minBound) :: Word64) grouping + +instance Grouping Int where + grouping = contramap (\x -> fromIntegral (x - minBound) :: Word) grouping + +instance Grouping Bool +instance (Grouping a, Grouping b) => Grouping (a, b) +instance (Grouping a, Grouping b, Grouping c) => Grouping (a, b, c) +instance (Grouping a, Grouping b, Grouping c, Grouping d) => Grouping (a, b, c, d) +instance Grouping a => Grouping [a] +instance Grouping a => Grouping (Maybe a) +instance (Grouping a, Grouping b) => Grouping (Either a b) +instance Grouping a => Grouping (Complex a) where + grouping = divide (\(a :+ b) -> (a, b)) grouping grouping +instance (Grouping a, Integral a) => Grouping (Ratio a) where + grouping = divide (\r -> (numerator r, denominator r)) grouping grouping +instance (Grouping1 f, Grouping1 g, Grouping a) => Grouping (Compose f g a) where + grouping = getCompose `contramap` grouping1 (grouping1 grouping) + +class Grouping1 f where + grouping1 :: Group a -> Group (f a) +#ifndef HLINT + default grouping1 :: Deciding1 Grouping f => Group a -> Group (f a) + grouping1 = deciding1 (Proxy :: Proxy Grouping) grouping +#endif + +instance Grouping1 [] +instance Grouping1 Maybe +instance Grouping a => Grouping1 (Either a) +instance Grouping a => Grouping1 ((,) a) +instance (Grouping a, Grouping b) => Grouping1 ((,,) a b) +instance (Grouping a, Grouping b, Grouping c) => Grouping1 ((,,,) a b c) +instance (Grouping1 f, Grouping1 g) => Grouping1 (Compose f g) where + grouping1 f = getCompose `contramap` grouping1 (grouping1 f) +instance Grouping1 Complex where + grouping1 f = divide (\(a :+ b) -> (a, b)) f f + +-- | Valid definition for @('==')@ in terms of 'Grouping'. +groupingEq :: Grouping a => a -> a -> Bool +groupingEq a b = case runGroup grouping [(a,()),(b,())] of + _:_:_ -> False + _ -> True +{-# INLINE groupingEq #-} + +-------------------------------------------------------------------------------- +-- * Combinators +-------------------------------------------------------------------------------- + +-- | /O(n)/. Similar to 'Data.List.group', except we do not require groups to be clustered. +-- +-- This combinator still operates in linear time, at the expense of productivity. +-- +-- The result equivalence classes are _not_ sorted, but the grouping is stable. +-- +-- @ +-- 'group' = 'groupWith' 'id' +-- @ +group :: Grouping a => [a] -> [[a]] +group as = runGroup grouping [(a, a) | a <- as] + +-- | /O(n)/. This is a replacement for 'GHC.Exts.groupWith' using discrimination. +-- +-- The result equivalence classes are _not_ sorted, but the grouping is stable. +groupWith :: Grouping b => (a -> b) -> [a] -> [[a]] +groupWith f as = runGroup grouping [(f a, a) | a <- as] + +-- | /O(n)/. This upgrades 'Data.List.nub' from @Data.List@ from /O(n^2)/ to /O(n)/ by using +-- unordered discrimination. +-- +-- @ +-- 'nub' = 'nubWith' 'id' +-- 'nub' as = 'head' 'Control.Applicative.<$>' 'group' as +-- @ +nub :: Grouping a => [a] -> [a] +nub as = head <$> group as + +-- | /O(n)/. 'nub' with a Schwartzian transform. +-- +-- @ +-- 'nubWith' f as = 'head' 'Control.Applicative.<$>' 'groupWith' f as +-- @ +nubWith :: Grouping b => (a -> b) -> [a] -> [a] +nubWith f as = head <$> groupWith f as + +-------------------------------------------------------------------------------- +-- * Collections +-------------------------------------------------------------------------------- + +-- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a multiset. +groupingBag :: Foldable f => Group k -> Group (f k) +groupingBag = groupingColl updateBag + +-- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a set. +groupingSet :: Foldable f => Group k -> Group (f k) +groupingSet = groupingColl updateSet + +groupingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Group k -> Group (f k) +groupingColl update r = Group $ \xss -> let + (kss, vs) = unzip xss + elemKeyNumAssocs = groupNum (toList <$> kss) + keyNumBlocks = runGroup r elemKeyNumAssocs + keyNumElemNumAssocs = groupNum keyNumBlocks + sigs = bdiscNat (length kss) update keyNumElemNumAssocs + yss = zip sigs vs + in filter (not . null) $ grouping1 (groupingNat (length keyNumBlocks)) `runGroup` yss diff --git a/src/Data/Discrimination/Internal.hs b/src/Data/Discrimination/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Discrimination/Internal.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ParallelListComp #-} +module Data.Discrimination.Internal + ( runs + , groupNum + , bdiscNat + , updateBag + , updateSet + , spanEither + ) where + +import Data.Array as Array +import Data.Functor +import Data.Int +import qualified Data.List as List +import Prelude hiding (read, concat) + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +bdiscNat :: Int -> ([v] -> v -> [v]) -> [(Int,v)] -> [[v]] +bdiscNat n update xs = reverse <$> Array.elems (Array.accumArray update [] (0,n) xs) +{-# INLINE bdiscNat #-} + +runs :: Eq a => [(a,b)] -> [[b]] +runs [] = [] +runs ((a,b):xs0) = (b:ys0) : runs zs0 + where + (ys0,zs0) = go xs0 + go [] = ([],[]) + go xs@((a', b'):xs') + | a == a' = case go xs' of + (ys, zs) -> (b':ys,zs) + | otherwise = ([], xs) + +groupNum :: [[k]] -> [(k,Int)] +groupNum kss = List.concat [ (,n) <$> ks | n <- [0..] | ks <- kss ] + +updateBag :: [Int] -> Int -> [Int] +updateBag vs v = v : vs + +updateSet :: [Int] -> Int -> [Int] +updateSet [] w = [w] +updateSet vs@(v:_) w + | v == w = vs + | otherwise = w : vs + +-- | Optimized and CPS'd version of 'Data.Either.partitionEithers', where all lefts are known to come before all rights +spanEither :: ([a] -> [b] -> c) -> [Either a b] -> c +spanEither k xs0 = go [] xs0 where + go acc (Left x:xs) = go (x:acc) xs + go acc rights = k (reverse acc) (fromRight <$> rights) + +fromRight :: Either a b -> b +fromRight (Right y) = y +fromRight _ = error "unstable discriminator" diff --git a/src/Data/Discrimination/Sorting.hs b/src/Data/Discrimination/Sorting.hs new file mode 100644 --- /dev/null +++ b/src/Data/Discrimination/Sorting.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} +module Data.Discrimination.Sorting + ( Sort(..) + -- * Sorting + , Sorting(..) + , Sorting1(..) + -- * Combinators + -- $common + , sort, sortWith, desc + , sortingCompare + -- * Container Construction + , toMap + , toMapWith + , toMapWithKey + , toIntMap + , toIntMapWith + , toIntMapWithKey + , toSet + , toIntSet + -- * Internals + , sortingNat + , sortingBag + , sortingSet + ) where + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Data.Bits +import Data.Discrimination.Grouping +import Data.Discrimination.Internal +import Data.Foldable as Foldable hiding (concat) +import Data.Functor.Compose +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Functor.Contravariant.Generic +import Data.Int +import Data.IntMap.Lazy as IntMap +import Data.IntSet as IntSet +import qualified Data.List as List +import Data.Map as Map +import Data.Monoid hiding (Any) +import Data.Proxy +import Data.Set as Set +import Data.Typeable +import Data.Void +import Data.Word +import Prelude hiding (read, concat) + +-------------------------------------------------------------------------------- +-- * Common +-------------------------------------------------------------------------------- + + +-- | Stable Ordered Discriminator + +-- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety? +newtype Sort a = Sort { runSort :: forall b. [(a,b)] -> [[b]] } + deriving Typeable + +#ifndef HLINT +type role Sort representational +#endif + +instance Contravariant Sort where + contramap f (Sort g) = Sort $ g . fmap (first f) + +instance Divisible Sort where + conquer = Sort $ return . fmap snd + divide k (Sort l) (Sort r) = Sort $ \xs -> + l [ (b, (c, d)) | (a,d) <- xs, let (b, c) = k a] >>= r + +instance Decidable Sort where + lose k = Sort $ fmap (absurd.k.fst) + choose f (Sort l) (Sort r) = Sort $ \xs -> let + ys = fmap (first f) xs + in l [ (k,v) | (Left k, v) <- ys] + ++ r [ (k,v) | (Right k, v) <- ys] + +instance Monoid (Sort a) where + mempty = conquer + mappend (Sort l) (Sort r) = Sort $ \xs -> l [ (fst x, x) | x <- xs ] >>= r + +-------------------------------------------------------------------------------- +-- * Ordered Discrimination +-------------------------------------------------------------------------------- + +-- | 'Ord' equipped with a compatible stable, ordered discriminator. +class Grouping a => Sorting a where + -- | For every strictly monotone-increasing function @f@: + -- + -- @ + -- 'contramap' f 'sorting' ≡ 'sorting' + -- @ + sorting :: Sort a +#ifndef HLINT + default sorting :: Deciding Sorting a => Sort a + sorting = deciding (Proxy :: Proxy Sorting) sorting +#endif + +instance Sorting Word8 where + sorting = contramap fromIntegral (sortingNat 256) + +instance Sorting Word16 where + sorting = contramap fromIntegral (sortingNat 65536) + +instance Sorting Word32 where + sorting = Sort (runs <=< runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . fmap radices) where + radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16), (x,b))) + + +instance Sorting Word64 where + sorting = Sort (runs <=< runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . join + . runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . fmap radices) + where + radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16) .&. 0xffff + , (fromIntegral (unsafeShiftR x 32) .&. 0xffff, (fromIntegral (unsafeShiftR x 48) + , (x,b))))) + + +instance Sorting Word where + sorting + | (maxBound :: Word) == 4294967295 = contramap (fromIntegral :: Word -> Word32) sorting + | otherwise = contramap (fromIntegral :: Word -> Word64) sorting + +instance Sorting Int8 where + sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 256) + +instance Sorting Int16 where + sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 65536) + +instance Sorting Int32 where + sorting = contramap (\x -> fromIntegral (x - minBound) :: Word32) sorting + +instance Sorting Int64 where + sorting = contramap (\x -> fromIntegral (x - minBound) :: Word64) sorting + +instance Sorting Int where + sorting = contramap (\x -> fromIntegral (x - minBound) :: Word) sorting + +-- TODO: Integer and Natural? + +instance Sorting Void +instance Sorting Bool +instance Sorting a => Sorting [a] +instance Sorting a => Sorting (Maybe a) +instance (Sorting a, Sorting b) => Sorting (Either a b) +instance (Sorting a, Sorting b) => Sorting (a, b) +instance (Sorting a, Sorting b, Sorting c) => Sorting (a, b, c) +instance (Sorting a, Sorting b, Sorting c, Sorting d) => Sorting (a, b, c, d) +instance (Sorting1 f, Sorting1 g, Sorting a) => Sorting (Compose f g a) where + sorting = getCompose `contramap` sorting1 (sorting1 sorting) + +class Grouping1 f => Sorting1 f where + sorting1 :: Sort a -> Sort (f a) +#ifndef HLINT + default sorting1 :: Deciding1 Sorting f => Sort a -> Sort (f a) + sorting1 = deciding1 (Proxy :: Proxy Sorting) sorting +#endif + +instance (Sorting1 f, Sorting1 g) => Sorting1 (Compose f g) where + sorting1 f = getCompose `contramap` sorting1 (sorting1 f) + +instance Sorting1 [] +instance Sorting1 Maybe +instance Sorting a => Sorting1 (Either a) + +-- | Valid definition for 'compare' in terms of 'Sorting'. +sortingCompare :: Sorting a => a -> a -> Ordering +sortingCompare a b = case runSort sorting [(a,LT),(b,GT)] of + [r]:_ -> r + _ -> EQ +{-# INLINE sortingCompare #-} + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +sortingNat :: Int -> Sort Int +sortingNat n = Sort $ \xs -> List.filter (not . List.null) (bdiscNat n upd xs) where + upd vs v = v : vs +{-# INLINE sortingNat #-} + +-------------------------------------------------------------------------------- +-- * Collections +-------------------------------------------------------------------------------- + +-- | Construct a stable ordered discriminator that sorts a list as multisets of elements from another stable ordered discriminator. +-- +-- The resulting discriminator only cares about the set of keys and their multiplicity, and is sorted as if we'd +-- sorted each key in turn before comparing. +sortingBag :: Foldable f => Sort k -> Sort (f k) +sortingBag = sortingColl updateBag + +-- | Construct a stable ordered discriminator that sorts a list as sets of elements from another stable ordered discriminator. +-- +-- The resulting discriminator only cares about the set of keys, and is sorted as if we'd +-- sorted each key in turn before comparing. +sortingSet :: Foldable f => Sort k -> Sort (f k) +sortingSet = sortingColl updateSet + +sortingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Sort k -> Sort (f k) +sortingColl upd r = Sort $ \xss -> let + (kss, vs) = unzip xss + elemKeyNumAssocs = groupNum (Foldable.toList <$> kss) + keyNumBlocks = runSort r elemKeyNumAssocs + keyNumElemNumAssocs = groupNum keyNumBlocks + sigs = bdiscNat (length kss) upd keyNumElemNumAssocs + yss = zip sigs vs + in List.filter (not . List.null) $ sorting1 (sortingNat (length keyNumBlocks)) `runSort` yss + +-------------------------------------------------------------------------------- +-- * Combinators +-------------------------------------------------------------------------------- + +desc :: Sort a -> Sort a +desc (Sort l) = Sort (reverse . l) + +-- $common +-- Useful combinators. + +-- | / O(n)/. Sort a list using discrimination. +-- +-- @ +-- 'sort' = 'sortWith' 'id' +-- @ +sort :: Sorting a => [a] -> [a] +sort as = List.concat $ runSort sorting [ (a,a) | a <- as ] + +-- | /O(n)/. Sort a list with a Schwartzian transformation by using discrimination. +-- +-- This linear time replacement for 'GHC.Exts.sortWith' and 'Data.List.sortOn' uses discrimination. +sortWith :: Sorting b => (a -> b) -> [a] -> [a] +sortWith f as = List.concat $ runSort sorting [ (f a, a) | a <- as ] + +-------------------------------------------------------------------------------- +-- * Containers +-------------------------------------------------------------------------------- + +-- | /O(n)/. Construct a 'Map'. +-- +-- This is an asymptotically faster version of 'Data.Map.fromList', which exploits ordered discrimination. +-- +-- >>> toMap [] == empty +-- True +-- +-- >>> toMap [(5,"a"), (3 :: Int,"b"), (5, "c")] +-- fromList [(5,"c"), (3,"b")] +-- +-- >>> toMap [(5,"c"), (3,"b"), (5 :: Int, "a")] +-- fromList [(5,"a"), (3,"b")] +toMap :: Sorting k => [(k, v)] -> Map k v +toMap kvs = Map.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ] + +-- | /O(n)/. Construct a 'Map', combining values. +-- +-- This is an asymptotically faster version of 'Data.Map.fromListWith', which exploits ordered discrimination. +-- +-- (Note: values combine in anti-stable order for compatibility with 'Data.Map.fromListWith') +-- +-- >>> toMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")] +-- fromList [(3, "ab"), (5, "cba")] +-- +-- >>> toMapWith (++) [] == empty +-- True +toMapWith :: Sorting k => (v -> v -> v) -> [(k, v)] -> Map k v +toMapWith f kvs0 = Map.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where + go ((k,v):kvs) = (k, Prelude.foldl (flip (f . snd)) v kvs) + go [] = error "bad sort" + +-- | /O(n)/. Construct a 'Map', combining values with access to the key. +-- +-- This is an asymptotically faster version of 'Data.Map.fromListWithKey', which exploits ordered discrimination. +-- +-- (Note: the values combine in anti-stable order for compatibility with 'Data.Map.fromListWithKey') +-- +-- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- >>> toMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")] +-- fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- +-- >>> toMapWithKey f [] == empty +-- True +toMapWithKey :: Sorting k => (k -> v -> v -> v) -> [(k, v)] -> Map k v +toMapWithKey f kvs0 = Map.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where + go ((k,v):kvs) = (k, Prelude.foldl (flip (f k . snd)) v kvs) + go [] = error "bad sort" + +-- | /O(n)/. Construct an 'IntMap'. +-- +-- >>> toIntMap [] == empty +-- True +-- +-- >>> toIntMap [(5,"a"), (3,"b"), (5, "c")] +-- fromList [(5,"c"), (3,"b")] +-- +-- >>> toIntMap [(5,"c"), (3,"b"), (5, "a")] +-- fromList [(5,"a"), (3,"b")] +toIntMap :: [(Int, v)] -> IntMap v +toIntMap kvs = IntMap.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ] + +-- | /O(n)/. Construct an 'IntMap', combining values. +-- +-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWith', which exploits ordered discrimination. +-- +-- (Note: values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWith') +-- +-- >>> toIntMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] +-- fromList [(3, "ab"), (5, "cba")] +-- +-- >>> toIntMapWith (++) [] == empty +-- True +toIntMapWith :: (v -> v -> v) -> [(Int, v)] -> IntMap v +toIntMapWith f kvs0 = IntMap.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where + go ((k,v):kvs) = (k, Prelude.foldl (flip (f . snd)) v kvs) + go [] = error "bad sort" + +-- | /O(n)/. Construct a 'Map', combining values with access to the key. +-- +-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWithKey', which exploits ordered discrimination. +-- +-- (Note: the values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWithKey') +-- +-- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value +-- >>> toIntMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] +-- fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- +-- >>> toIntMapWithKey f [] == empty +-- True +toIntMapWithKey :: (Int -> v -> v -> v) -> [(Int, v)] -> IntMap v +toIntMapWithKey f kvs0 = IntMap.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where + go ((k,v):kvs) = (k, Prelude.foldl (flip (f k . snd)) v kvs) + go [] = error "bad sort" + +-- | /O(n)/. Construct a 'Set' in linear time. +-- +-- This is an asymptotically faster version of 'Data.Set.fromList', which exploits ordered discrimination. +toSet :: Sorting k => [k] -> Set k +toSet kvs = Set.fromDistinctAscList $ last <$> runSort sorting [ (kv, kv) | kv <- kvs ] + +-- | /O(n)/. Construct an 'IntSet' in linear time. +-- +-- This is an asymptotically faster version of 'Data.IntSet.fromList', which exploits ordered discrimination. +toIntSet :: [Int] -> IntSet +toIntSet kvs = IntSet.fromDistinctAscList $ last <$> runSort sorting [ (kv, kv) | kv <- kvs ]