representable-tries-3.0.2/0000755000000000000000000000000012072400634013657 5ustar0000000000000000representable-tries-3.0.2/.ghci0000644000000000000000000000012512072400634014570 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h representable-tries-3.0.2/.gitignore0000644000000000000000000000010412072400634015642 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# representable-tries-3.0.2/.travis.yml0000644000000000000000000000035012072400634015766 0ustar0000000000000000language: haskell notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313representable-tries\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" representable-tries-3.0.2/.vim.custom0000644000000000000000000000137712072400634015774 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" representable-tries-3.0.2/CHANGELOG.markdown0000644000000000000000000000015612072400634016714 0ustar00000000000000003.0.2 ----- * Removed intra-package dependencies * Added `README.markdown` * Added IRC build-bot notification representable-tries-3.0.2/LICENSE0000644000000000000000000000265312072400634014672 0ustar0000000000000000Copyright 2011 Edward Kmett 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. 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. representable-tries-3.0.2/README.markdown0000644000000000000000000000211512072400634016357 0ustar0000000000000000representable-tries =================== [![Build Status](https://secure.travis-ci.org/ekmett/representable-functors.png?branch=master)](http://travis-ci.org/ekmett/representable-functors) This package provides a simple function memoization scheme based on the notion of representable functors. In category theory a representable functor (more pedantically a corepresentable functor) is one such that `f a` is isomorphic to `x -> a`. We choose the name `Representable` here because we are talking about haskell `Functor` instances, and they are all covariant, so this is the more natural notion of representability for Haskell. Given the existence of representable functors, we can choose a `Traversable` representable functor that has our data type as a representation, and use it to memoize functions by building a data structure that has one place to hold each answer for each possible argument. 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 representable-tries-3.0.2/representable-tries.cabal0000644000000000000000000000354112072400634020625 0ustar0000000000000000name: representable-tries category: Data Structures, Functors, Monads, Comonads version: 3.0.2 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/representable-tries/ bug-reports: http://github.com/ekmett/representable-tries/issues copyright: Copyright (C) 2011 Edward A. Kmett synopsis: Tries from representations of polynomial functors description: Tries from representations of polynomial functors build-type: Simple extra-source-files: .ghci .gitignore .travis.yml .vim.custom README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/representable-tries.git library hs-source-dirs: src other-extensions: CPP EmptyDataDecls FlexibleContexts FlexibleInstances GADTs MultiParamTypeClasses Rank2Types ScopedTypeVariables TypeFamilies TypeOperators UndecidableInstances build-depends: adjunctions >= 3, base >= 4 && < 5, bifunctors >= 3, comonad >= 3, comonad-transformers >= 3, containers >= 0.3 && < 0.6, distributive >= 0.2.2, keys >= 3.0.0.1, mtl >= 2.0.1 && < 2.2, transformers >= 0.2 && < 0.4, representable-functors >= 3.0.0.1, semigroups >= 0.8.3.1, semigroupoids >= 3 exposed-modules: Control.Monad.Reader.Trie Data.Functor.Representable.Trie Data.Functor.Representable.Trie.Bool Data.Functor.Representable.Trie.List Data.Functor.Representable.Trie.Either Data.Traversable.Fair Numeric.Nat.Zeroless ghc-options: -Wall representable-tries-3.0.2/Setup.lhs0000644000000000000000000000016512072400634015471 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain representable-tries-3.0.2/src/0000755000000000000000000000000012072400634014446 5ustar0000000000000000representable-tries-3.0.2/src/Control/0000755000000000000000000000000012072400634016066 5ustar0000000000000000representable-tries-3.0.2/src/Control/Monad/0000755000000000000000000000000012072400634017124 5ustar0000000000000000representable-tries-3.0.2/src/Control/Monad/Reader/0000755000000000000000000000000012072400634020326 5ustar0000000000000000representable-tries-3.0.2/src/Control/Monad/Reader/Trie.hs0000644000000000000000000001262712072400634021575 0ustar0000000000000000{-# LANGUAGE TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Control.Monad.Reader.Trie -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- ---------------------------------------------------------------------- module Control.Monad.Reader.Trie ( -- * A "Representable Trie"-based Reader monad transformer ReaderTrieT(..) , module Data.Functor.Representable.Trie ) where import Control.Applicative import Control.Comonad import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class as Writer import Data.Distributive import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Representable import Data.Functor.Representable.Trie import Data.Foldable import Data.Key import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (lookup,zipWith) type instance Key (ReaderTrieT a m) = (a, Key m) newtype ReaderTrieT a m b = ReaderTrieT { runReaderTrieT :: a :->: m b } instance (HasTrie a, Functor m) => Functor (ReaderTrieT a m) where fmap f = ReaderTrieT . fmap (fmap f) . runReaderTrieT instance (HasTrie a, Apply m) => Apply (ReaderTrieT a m) where ReaderTrieT ff <.> ReaderTrieT fa = ReaderTrieT ((<.>) <$> ff <.> fa) instance (HasTrie a, Applicative m) => Applicative (ReaderTrieT a m) where pure = ReaderTrieT . pure . pure ReaderTrieT ff <*> ReaderTrieT fa = ReaderTrieT ((<*>) <$> ff <*> fa) instance (HasTrie a, Bind m) => Bind (ReaderTrieT a m) where ReaderTrieT fm >>- f = ReaderTrieT $ tabulate (\a -> index fm a >>- flip index a . runReaderTrieT . f) instance (HasTrie a, Monad m) => Monad (ReaderTrieT a m) where return = ReaderTrieT . pure . return ReaderTrieT fm >>= f = ReaderTrieT $ tabulate (\a -> index fm a >>= flip index a . runReaderTrieT . f) instance (HasTrie a, Monad m) => MonadReader a (ReaderTrieT a m) where ask = ReaderTrieT (trie return) local f (ReaderTrieT fm) = ReaderTrieT (tabulate (index fm . f)) instance HasTrie a => MonadTrans (ReaderTrieT a) where lift = ReaderTrieT . pure instance (HasTrie a, Distributive m) => Distributive (ReaderTrieT a m) where distribute = ReaderTrieT . fmap distribute . collect runReaderTrieT instance (HasTrie a, Zip m) => Zip (ReaderTrieT a m) where zipWith f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWith (zipWith f) m n instance (HasTrie a, ZipWithKey m) => ZipWithKey (ReaderTrieT a m) where zipWithKey f (ReaderTrieT m) (ReaderTrieT n) = ReaderTrieT $ zipWithKey (\k -> zipWithKey (f . (,) k)) m n instance (HasTrie a, Keyed m) => Keyed (ReaderTrieT a m) where mapWithKey f = ReaderTrieT . mapWithKey (\k -> mapWithKey (f . (,) k)) . runReaderTrieT instance (HasTrie a, Indexable m) => Indexable (ReaderTrieT a m) where index = uncurry . fmap index . untrie . runReaderTrieT instance (HasTrie a, Adjustable m) => Adjustable (ReaderTrieT a m) where adjust f (a,k) = ReaderTrieT . adjust (adjust f k) a . runReaderTrieT instance (HasTrie a, Lookup ((:->:) a), Lookup m) => Lookup (ReaderTrieT a m) where lookup (k,k') (ReaderTrieT fm) = lookup k fm >>= lookup k' instance (HasTrie a, Representable m) => Representable (ReaderTrieT a m) where tabulate = ReaderTrieT . trie . fmap tabulate . curry instance (HasTrie a, Foldable m) => Foldable (ReaderTrieT a m) where foldMap f = foldMap (foldMap f) . runReaderTrieT instance (HasTrie a, Foldable1 m) => Foldable1 (ReaderTrieT a m) where foldMap1 f = foldMap1 (foldMap1 f) . runReaderTrieT instance (HasTrie a, FoldableWithKey m) => FoldableWithKey (ReaderTrieT a m) where foldMapWithKey f = foldMapWithKey (\k -> foldMapWithKey (f . (,) k)) . runReaderTrieT instance (HasTrie a, FoldableWithKey1 m) => FoldableWithKey1 (ReaderTrieT a m) where foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) k)) . runReaderTrieT instance (HasTrie a, Traversable m) => Traversable (ReaderTrieT a m) where traverse f = fmap ReaderTrieT . traverse (traverse f) . runReaderTrieT instance (HasTrie a, Traversable1 m) => Traversable1 (ReaderTrieT a m) where traverse1 f = fmap ReaderTrieT . traverse1 (traverse1 f) . runReaderTrieT instance (HasTrie a, TraversableWithKey m) => TraversableWithKey (ReaderTrieT a m) where traverseWithKey f = fmap ReaderTrieT . traverseWithKey (\k -> traverseWithKey (f . (,) k)) . runReaderTrieT instance (HasTrie a, TraversableWithKey1 m) => TraversableWithKey1 (ReaderTrieT a m) where traverseWithKey1 f = fmap ReaderTrieT . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) k)) . runReaderTrieT instance (HasTrie a, Representable m, Semigroup a, Semigroup (Key m)) => Extend (ReaderTrieT a m) where extended = extendedRep duplicated = duplicatedRep instance (HasTrie a, Representable m, Monoid a, Monoid (Key m)) => Comonad (ReaderTrieT a m) where extend = extendRep duplicate = duplicateRep extract = extractRep instance (HasTrie a, MonadIO m) => MonadIO (ReaderTrieT a m) where liftIO = lift . liftIO instance (HasTrie a, MonadWriter w m) => MonadWriter w (ReaderTrieT a m) where tell = lift . tell listen = ReaderTrieT . tabulate . fmap Writer.listen . index . runReaderTrieT pass = ReaderTrieT . tabulate . fmap Writer.pass . index . runReaderTrieT representable-tries-3.0.2/src/Data/0000755000000000000000000000000012072400634015317 5ustar0000000000000000representable-tries-3.0.2/src/Data/Functor/0000755000000000000000000000000012072400634016737 5ustar0000000000000000representable-tries-3.0.2/src/Data/Functor/Representable/0000755000000000000000000000000012072400634021532 5ustar0000000000000000representable-tries-3.0.2/src/Data/Functor/Representable/Trie.hs0000644000000000000000000002707412072400634023003 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, UndecidableInstances #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- | -- Module : Data.Functor.Representable.Trie -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- ---------------------------------------------------------------------- module Data.Functor.Representable.Trie ( -- * Representations of polynomial functors HasTrie(..) -- * Memoizing functions , mup, memo, memo2, memo3 , inTrie, inTrie2, inTrie3 -- * Workarounds for current GHC limitations , trie, untrie , (:->:)(..) , Entry(..) ) where import Control.Applicative import Control.Arrow import Control.Comonad import Control.Monad.Reader.Class import Control.Monad.Representable.Reader import Data.Bits import Data.Distributive import Data.Semigroup import Data.Word import Data.Int import Data.Foldable import Data.Function (on) import Data.Functor.Adjunction import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Representable.Trie.Bool import Data.Functor.Representable.Trie.Either import Data.Functor.Representable.Trie.List import Data.Key import qualified Data.Monoid as Monoid import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Sequence (Seq, (<|)) import qualified Data.Sequence as Seq import Data.Map (Map) import qualified Data.Map as Map import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Traversable import Prelude hiding (lookup, foldr) class (Adjustable (BaseTrie a), TraversableWithKey1 (BaseTrie a), Representable (BaseTrie a)) => HasTrie a where type BaseTrie a :: * -> * -- projectKey . embedKey = id embedKey :: a -> Key (BaseTrie a) projectKey :: Key (BaseTrie a) -> a {- validKey :: Key (BaseTrie a) -> Bool validKey _ = True -} newtype a :->: b = Trie { runTrie :: BaseTrie a b } type instance Key ((:->:) a) = a data Entry a b = Entry a b -- * Combinators -- Matt Hellige's notation for @argument f . result g@. -- (~>) :: (a' -> a) -> (b -> b') -> (a -> b) -> a' -> b' g ~> f = (f .) . (. g) untrie :: HasTrie t => (t :->: a) -> t -> a untrie = index trie :: HasTrie t => (t -> a) -> (t :->: a) trie = tabulate {-# RULES "trie/untrie" forall t. trie (untrie t) = t "embedKey/projectKey" forall t. projectKey (embedKey t) = t #-} memo :: HasTrie t => (t -> a) -> t -> a memo = untrie . trie -- | Lift a memoizer to work with one more argument. mup :: HasTrie t => (b -> c) -> (t -> b) -> t -> c mup mem f = memo (mem . f) -- | Memoize a binary function, on its first argument and then on its -- second. Take care to exploit any partial evaluation. memo2 :: (HasTrie s, HasTrie t) => (s -> t -> a) -> s -> t -> a memo2 = mup memo -- | Memoize a ternary function on successive arguments. Take care to -- exploit any partial evaluation. memo3 :: (HasTrie r, HasTrie s, HasTrie t) => (r -> s -> t -> a) -> r -> s -> t -> a memo3 = mup memo2 -- | Apply a unary function inside of a tabulate inTrie :: (HasTrie a, HasTrie c) => ((a -> b) -> c -> d) -> (a :->: b) -> c :->: d inTrie = untrie ~> trie -- | Apply a binary function inside of a tabulate inTrie2 :: (HasTrie a, HasTrie c, HasTrie e) => ((a -> b) -> (c -> d) -> e -> f) -> (a :->: b) -> (c :->: d) -> e :->: f inTrie2 = untrie ~> inTrie -- | Apply a ternary function inside of a tabulate inTrie3 :: (HasTrie a, HasTrie c, HasTrie e, HasTrie g) => ((a -> b) -> (c -> d) -> (e -> f) -> g -> h) -> (a :->: b) -> (c :->: d) -> (e :->: f) -> g :->: h inTrie3 = untrie ~> inTrie2 -- * Implementation details instance Functor (Entry a) where fmap f (Entry a b) = Entry a (f b) instance HasTrie e => Lookup ((:->:)e) where lookup = lookupDefault instance HasTrie e => Indexable ((:->:)e) where index (Trie f) = index f . embedKey instance HasTrie e => Distributive ((:->:) e) where distribute = distributeRep instance HasTrie e => Representable ((:->:) e) where tabulate f = Trie $ tabulate (f . projectKey) instance HasTrie e => Adjustable ((:->:) e) where adjust f k (Trie as) = Trie (adjust f (embedKey k) as) instance HasTrie e => Zip ((:->:) e) instance HasTrie e => ZipWithKey ((:->:) e) instance HasTrie e => Adjunction (Entry e) ((:->:) e) where unit = mapWithKey Entry . pure counit (Entry a t) = index t a instance HasTrie a => Functor ((:->:) a) where fmap f (Trie g) = Trie (fmap f g) instance HasTrie a => Keyed ((:->:) a) where mapWithKey f (Trie a) = Trie (mapWithKey (f . projectKey) a) instance HasTrie a => Foldable ((:->:) a) where foldMap f (Trie a) = foldMap f a instance HasTrie a => FoldableWithKey ((:->:) a) where foldMapWithKey f (Trie a) = foldMapWithKey (f . projectKey) a instance HasTrie a => Traversable ((:->:) a) where traverse f (Trie a) = Trie <$> traverse f a instance HasTrie a => TraversableWithKey ((:->:) a) where traverseWithKey f (Trie a) = Trie <$> traverseWithKey (f . projectKey) a instance HasTrie a => Foldable1 ((:->:) a) where foldMap1 f (Trie a) = foldMap1 f a instance HasTrie a => FoldableWithKey1 ((:->:) a) where foldMapWithKey1 f (Trie a) = foldMapWithKey1 (f . projectKey) a instance HasTrie a => Traversable1 ((:->:) a) where traverse1 f (Trie a) = Trie <$> traverse1 f a instance HasTrie a => TraversableWithKey1 ((:->:) a) where traverseWithKey1 f (Trie a) = Trie <$> traverseWithKey1 (f . projectKey) a instance (HasTrie a, Eq b) => Eq (a :->: b) where (==) = (==) `on` toList instance (HasTrie a, Ord b) => Ord (a :->: b) where compare = compare `on` toList instance (HasTrie a, Show a, Show b) => Show (a :->: b) where showsPrec d = showsPrec d . toKeyedList instance HasTrie a => Apply ((:->:) a) where (<.>) = apRep a <. _ = a _ .> b = b instance HasTrie a => Applicative ((:->:) a) where pure a = Trie (pureRep a) (<*>) = apRep a <* _ = a _ *> b = b instance HasTrie a => Bind ((:->:) a) where Trie m >>- f = Trie (tabulate (\a -> index (runTrie (f (index m a))) a)) instance HasTrie a => Monad ((:->:) a) where return a = Trie (pureRep a) (>>=) = (>>-) _ >> m = m instance HasTrie a => MonadReader a ((:->:) a) where ask = askRep local = localRep -- TODO: remove dependency on HasTrie in these: instance (HasTrie m, Monoid m) => Comonad ((:->:) m) where duplicate = duplicateRep extract = flip index mempty instance (HasTrie m, Semigroup m) => Extend ((:->:) m) where duplicated = duplicatedRep -- * Instances instance HasTrie () where type BaseTrie () = Identity embedKey = id projectKey = id instance HasTrie Bool where type BaseTrie Bool = BoolTrie embedKey = id projectKey = id instance HasTrie Any where type BaseTrie Any = BoolTrie embedKey = getAny projectKey = Any instance HasTrie a => HasTrie (Dual a) where type BaseTrie (Dual a) = BaseTrie a embedKey = embedKey . getDual projectKey = Dual . projectKey instance HasTrie a => HasTrie (Sum a) where type BaseTrie (Sum a) = BaseTrie a embedKey = embedKey . getSum projectKey = Sum . projectKey instance HasTrie a => HasTrie (Monoid.Product a) where type BaseTrie (Monoid.Product a) = BaseTrie a embedKey = embedKey . Monoid.getProduct projectKey = Monoid.Product . projectKey instance (HasTrie a, HasTrie b) => HasTrie (a, b) where type BaseTrie (a, b) = ReaderT (BaseTrie a) (BaseTrie b) embedKey = embedKey *** embedKey projectKey = projectKey *** projectKey instance (HasTrie a, HasTrie b) => HasTrie (Entry a b) where type BaseTrie (Entry a b) = ReaderT (BaseTrie a) (BaseTrie b) embedKey (Entry a b) = (embedKey a, embedKey b) projectKey (a, b) = Entry (projectKey a) (projectKey b) instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where type BaseTrie (Either a b) = EitherTrie (BaseTrie a) (BaseTrie b) embedKey = embedKey +++ embedKey projectKey = projectKey +++ projectKey instance HasTrie a => HasTrie (Maybe a) where type BaseTrie (Maybe a) = EitherTrie Identity (BaseTrie a) embedKey = maybe (Left ()) (Right . embedKey) projectKey = either (const Nothing) (Just . projectKey) instance HasTrie a => HasTrie [a] where type BaseTrie [a] = ListTrie (BaseTrie a) embedKey = map embedKey projectKey = map projectKey instance HasTrie a => HasTrie (Seq a) where type BaseTrie (Seq a) = ListTrie (BaseTrie a) embedKey = foldr ((:) . embedKey) [] projectKey = foldr ((<|) . projectKey) (Seq.empty) instance (HasTrie k, HasTrie v) => HasTrie (Map k v) where type BaseTrie (Map k v) = ListTrie (BaseTrie (k, v)) embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) [] projectKey = Map.fromDistinctAscList . map projectKey instance (HasTrie v) => HasTrie (IntMap v) where type BaseTrie (IntMap v) = ListTrie (BaseTrie (Int, v)) embedKey = foldrWithKey (\k v t -> embedKey (k,v) : t) [] projectKey = IntMap.fromDistinctAscList . map projectKey -- | Extract bits in little-endian order bits :: (Num t, Bits t) => t -> [Bool] bits 0 = [] bits x = testBit x 0 : bits (shiftR x 1) -- | Convert boolean to 0 (False) or 1 (True) unbit :: Num t => Bool -> t unbit False = 0 unbit True = 1 -- | Bit list to value unbits :: (Num t, Bits t) => [Bool] -> t unbits [] = 0 unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1 unbitsZ :: (Num n, Bits n) => (Bool,[Bool]) -> n unbitsZ (positive,bs) = sig (unbits bs) where sig | positive = id | otherwise = negate bitsZ :: (Ord n, Num n, Bits n) => n -> (Bool,[Bool]) bitsZ = (>= 0) &&& (bits . abs) -- TODO: fix the show instance of this instance HasTrie Int where type BaseTrie Int = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Int8 where type BaseTrie Int8 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Int16 where type BaseTrie Int16 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Int32 where type BaseTrie Int32 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Int64 where type BaseTrie Int64 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Word where type BaseTrie Word = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Word8 where type BaseTrie Word8 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Word16 where type BaseTrie Word16 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Word32 where type BaseTrie Word32 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey instance HasTrie Word64 where type BaseTrie Word64 = BaseTrie (Bool, [Bool]) embedKey = embedKey . bitsZ projectKey = unbitsZ . projectKey -- TODO: fix tree to 21 bit depth instance HasTrie Char where type BaseTrie Char = BaseTrie [Bool] embedKey = bits . fromEnum projectKey = toEnum . unbits instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where type BaseTrie (a,b,c) = BaseTrie (a,(b,c)) embedKey (a,b,c) = embedKey (a,(b,c)) projectKey p = let (a,(b,c)) = projectKey p in (a,b,c) instance (HasTrie a, HasTrie b, HasTrie c, HasTrie d) => HasTrie (a,b,c,d) where type BaseTrie (a,b,c,d) = BaseTrie ((a,b),(c,d)) embedKey (a,b,c,d) = embedKey ((a,b),(c,d)) projectKey p = let ((a,b),(c,d)) = projectKey p in (a,b,c,d) representable-tries-3.0.2/src/Data/Functor/Representable/Trie/0000755000000000000000000000000012072400634022435 5ustar0000000000000000representable-tries-3.0.2/src/Data/Functor/Representable/Trie/Bool.hs0000644000000000000000000000570512072400634023673 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------- -- | -- Module : Data.Functor.Representable.Trie.Bool -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- ---------------------------------------------------------------------- module Data.Functor.Representable.Trie.Bool ( BoolTrie (..) ) where import Control.Applicative import Data.Distributive import Data.Functor.Representable import Data.Functor.Bind import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Key import Prelude hiding (lookup) -- (Bool, -) -| BoolTrie data BoolTrie a = BoolTrie a a deriving (Eq,Ord,Show,Read) false :: BoolTrie a -> a false (BoolTrie a _) = a true :: BoolTrie a -> a true (BoolTrie _ b) = b type instance Key BoolTrie = Bool instance Functor BoolTrie where fmap f (BoolTrie a b) = BoolTrie (f a) (f b) b <$ _ = pure b instance Apply BoolTrie where BoolTrie a b <.> BoolTrie c d = BoolTrie (a c) (b d) a <. _ = a _ .> b = b instance Applicative BoolTrie where pure a = BoolTrie a a (<*>) = (<.>) a <* _ = a _ *> b = b instance Bind BoolTrie where BoolTrie a b >>- f = BoolTrie (false (f a)) (true (f b)) instance Monad BoolTrie where return = pure BoolTrie a b >>= f = BoolTrie (false (f a)) (true (f b)) _ >> a = a instance Keyed BoolTrie where mapWithKey f (BoolTrie a b) = BoolTrie (f False a) (f True b) instance Zip BoolTrie where zipWith f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f a c) (f b d) instance ZipWithKey BoolTrie where zipWithKey f (BoolTrie a b) (BoolTrie c d) = BoolTrie (f False a c) (f True b d) instance Foldable BoolTrie where foldMap f (BoolTrie a b) = f a `mappend` f b instance Foldable1 BoolTrie where foldMap1 f (BoolTrie a b) = f a <> f b instance Traversable BoolTrie where traverse f (BoolTrie a b) = BoolTrie <$> f a <*> f b instance Traversable1 BoolTrie where traverse1 f (BoolTrie a b) = BoolTrie <$> f a <.> f b instance FoldableWithKey BoolTrie where foldMapWithKey f (BoolTrie a b) = f False a `mappend` f True b instance FoldableWithKey1 BoolTrie where foldMapWithKey1 f (BoolTrie a b) = f False a <> f True b instance TraversableWithKey BoolTrie where traverseWithKey f (BoolTrie a b) = BoolTrie <$> f False a <*> f True b instance TraversableWithKey1 BoolTrie where traverseWithKey1 f (BoolTrie a b) = BoolTrie <$> f False a <.> f True b instance Distributive BoolTrie where distribute = distributeRep instance Indexable BoolTrie where index (BoolTrie a _) False = a index (BoolTrie _ b) True = b instance Adjustable BoolTrie where adjust f False (BoolTrie a b) = BoolTrie (f a) b adjust f True (BoolTrie a b) = BoolTrie a (f b) instance Lookup BoolTrie where lookup = lookupDefault instance Representable BoolTrie where tabulate f = BoolTrie (f False) (f True) representable-tries-3.0.2/src/Data/Functor/Representable/Trie/Either.hs0000644000000000000000000001177012072400634024217 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------- -- | -- Module : Data.Functor.Representable.Trie.Bool -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- ---------------------------------------------------------------------- module Data.Functor.Representable.Trie.Either ( EitherTrie (..) , left , right ) where import Control.Applicative import Data.Distributive import Data.Functor.Representable import Data.Functor.Bind import Data.Foldable import Data.Traversable import Data.Traversable.Fair import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Key import Prelude hiding (lookup,zipWith) -- the product functor would be the trie of an either, but we fair traversal data EitherTrie f g a = EitherTrie (f a) (g a) type instance Key (EitherTrie f g) = Either (Key f) (Key g) left :: EitherTrie f g a -> f a left (EitherTrie f _) = f right :: EitherTrie f g a -> g a right (EitherTrie _ g) = g instance (Apply f, Apply g, Semigroup s) => Semigroup (EitherTrie f g s) where EitherTrie a b <> EitherTrie c d = EitherTrie ((<>) <$> a <.> c) ((<>) <$> b <.> d) instance (Applicative f, Applicative g, Monoid a) => Monoid (EitherTrie f g a) where mempty = EitherTrie (pure mempty) (pure mempty) EitherTrie a b `mappend` EitherTrie c d = EitherTrie (mappend <$> a <*> c) (mappend <$> b <*> d) instance (Functor f, Functor g) => Functor (EitherTrie f g) where fmap f (EitherTrie fs gs) = EitherTrie (fmap f fs) (fmap f gs) b <$ EitherTrie fs gs = EitherTrie (b <$ fs) (b <$ gs) instance (Apply f, Apply g) => Apply (EitherTrie f g) where EitherTrie ff fg <.> EitherTrie af ag = EitherTrie (ff <.> af) (fg <.> ag) a <. _ = a _ .> b = b instance (Applicative f, Applicative g) => Applicative (EitherTrie f g) where pure a = EitherTrie (pure a) (pure a) EitherTrie ff fg <*> EitherTrie af ag = EitherTrie (ff <*> af) (fg <*> ag) a <* _ = a _ *> b = b -- the direct implementation in terms of Bind is inefficient, using bindRep instead instance (Apply f, Representable f, Apply g, Representable g) => Bind (EitherTrie f g) where (>>-) = bindRep instance (Representable f, Representable g) => Monad (EitherTrie f g) where return = pureRep (>>=) = bindRep _ >> a = a instance (Keyed f, Keyed g) => Keyed (EitherTrie f g) where mapWithKey f (EitherTrie fs gs) = EitherTrie (mapWithKey (f . Left) fs) (mapWithKey (f . Right) gs) instance (Zip f, Zip g) => Zip (EitherTrie f g) where zipWith f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWith f fs hs) (zipWith f gs is) instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (EitherTrie f g) where zipWithKey f (EitherTrie fs gs) (EitherTrie hs is) = EitherTrie (zipWithKey (f . Left) fs hs) (zipWithKey (f . Right) gs is) instance (Foldable f, Foldable g) => Foldable (EitherTrie f g) where foldMap f (EitherTrie fs gs) = foldMapBoth f fs gs instance (Foldable1 f, Foldable1 g) => Foldable1 (EitherTrie f g) where foldMap1 f (EitherTrie fs gs) = foldMapBoth1 f fs gs instance (Traversable f, Traversable g) => Traversable (EitherTrie f g) where traverse f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth f fs gs instance (Traversable1 f, Traversable1 g) => Traversable1 (EitherTrie f g) where traverse1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseBoth1 f fs gs instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (EitherTrie f g) where foldMapWithKey f (EitherTrie fs gs) = foldMapWithKeyBoth (f . Left) (f . Right) fs gs instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (EitherTrie f g) where foldMapWithKey1 f (EitherTrie fs gs) = foldMapWithKeyBoth1 (f . Left) (f . Right) fs gs instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (EitherTrie f g) where traverseWithKey f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth (f . Left) (f . Right) fs gs instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (EitherTrie f g) where traverseWithKey1 f (EitherTrie fs gs) = uncurry EitherTrie <$> traverseWithKeyBoth1 (f . Left) (f . Right) fs gs instance (Representable f, Representable g) => Distributive (EitherTrie f g) where distribute = distributeRep instance (Indexable f, Indexable g) => Indexable (EitherTrie f g) where index (EitherTrie fs _) (Left i) = index fs i index (EitherTrie _ gs) (Right j) = index gs j instance (Adjustable f, Adjustable g) => Adjustable (EitherTrie f g) where adjust f (Left i) (EitherTrie fs gs) = EitherTrie (adjust f i fs) gs adjust f (Right j) (EitherTrie fs gs) = EitherTrie fs (adjust f j gs) instance (Lookup f, Lookup g) => Lookup (EitherTrie f g) where lookup (Left i) (EitherTrie fs _) = lookup i fs lookup (Right j) (EitherTrie _ gs) = lookup j gs instance (Representable f, Representable g) => Representable (EitherTrie f g) where tabulate f = EitherTrie (tabulate (f . Left)) (tabulate (f . Right)) representable-tries-3.0.2/src/Data/Functor/Representable/Trie/List.hs0000644000000000000000000000770712072400634023717 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------- -- | -- Module : Data.Functor.Representable.Trie.List -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- ---------------------------------------------------------------------- module Data.Functor.Representable.Trie.List ( ListTrie (..) , nil , cons ) where import Control.Applicative import Data.Distributive import Data.Functor.Representable import Data.Functor.Bind import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Key import Prelude hiding (lookup,zipWith) -- the f-branching stream comonad is the trie of a list data ListTrie f a = ListTrie a (f (ListTrie f a)) -- deriving (Eq,Ord,Show,Read) type instance Key (ListTrie f) = [Key f] nil :: ListTrie f a -> a nil (ListTrie x _) = x cons :: Indexable f => Key f -> ListTrie f a -> ListTrie f a cons a (ListTrie _ xs) = index xs a instance Functor f => Functor (ListTrie f) where fmap f (ListTrie a as) = ListTrie (f a) (fmap (fmap f) as) -- b <$ _ = pure b instance Representable f => Apply (ListTrie f) where (<.>) = apRep a <. _ = a _ .> b = b instance Representable f => Applicative (ListTrie f) where pure a = as where as = ListTrie a (pureRep as) (<*>) = apRep a <* _ = a _ *> b = b instance Representable f => Bind (ListTrie f) where (>>-) = bindRep instance Representable f => Monad (ListTrie f) where return a = as where as = ListTrie a (pureRep as) (>>=) = bindRep _ >> a = a instance Zip f => Zip (ListTrie f) where zipWith f (ListTrie a as) (ListTrie b bs) = ListTrie (f a b) (zipWith (zipWith f) as bs) instance ZipWithKey f => ZipWithKey (ListTrie f) where zipWithKey f (ListTrie a as) (ListTrie b bs) = ListTrie (f [] a b) (zipWithKey (\x -> zipWithKey (f . (x:))) as bs) instance Keyed f => Keyed (ListTrie f) where mapWithKey f (ListTrie a as) = ListTrie (f [] a) (mapWithKey (\x -> mapWithKey (f . (x:))) as) instance Foldable f => Foldable (ListTrie f) where foldMap f (ListTrie a as) = f a `mappend` foldMap (foldMap f) as instance Foldable1 f => Foldable1 (ListTrie f) where foldMap1 f (ListTrie a as) = f a <> foldMap1 (foldMap1 f) as instance Traversable f => Traversable (ListTrie f) where traverse f (ListTrie a as) = ListTrie <$> f a <*> traverse (traverse f) as instance Traversable1 f => Traversable1 (ListTrie f) where traverse1 f (ListTrie a as) = ListTrie <$> f a <.> traverse1 (traverse1 f) as instance FoldableWithKey f => FoldableWithKey (ListTrie f) where foldMapWithKey f (ListTrie a as) = f [] a `mappend` foldMapWithKey (\x -> foldMapWithKey (f . (x:))) as instance FoldableWithKey1 f => FoldableWithKey1 (ListTrie f) where foldMapWithKey1 f (ListTrie a as) = f [] a <> foldMapWithKey1 (\x -> foldMapWithKey1 (f . (x:))) as instance TraversableWithKey f => TraversableWithKey (ListTrie f) where traverseWithKey f (ListTrie a as) = ListTrie <$> f [] a <*> traverseWithKey (\x -> traverseWithKey (f . (x:))) as instance TraversableWithKey1 f => TraversableWithKey1 (ListTrie f) where traverseWithKey1 f (ListTrie a as) = ListTrie <$> f [] a <.> traverseWithKey1 (\x -> traverseWithKey1 (f . (x:))) as instance Representable f => Distributive (ListTrie f) where distribute = distributeRep instance Indexable f => Indexable (ListTrie f) where index (ListTrie x _) [] = x index (ListTrie _ xs) (a:as) = index (index xs a) as instance Adjustable f => Adjustable (ListTrie f) where adjust f [] (ListTrie x xs) = ListTrie (f x) xs adjust f (a:as) (ListTrie x xs) = ListTrie x (adjust (adjust f as) a xs) instance Lookup f => Lookup (ListTrie f) where lookup [] (ListTrie x _) = Just x lookup (a:as) (ListTrie _ xs) = lookup a xs >>= lookup as instance Representable f => Representable (ListTrie f) where tabulate f = ListTrie (f []) (tabulate (\x -> tabulate (f . (x:)))) representable-tries-3.0.2/src/Data/Traversable/0000755000000000000000000000000012072400634017571 5ustar0000000000000000representable-tries-3.0.2/src/Data/Traversable/Fair.hs0000644000000000000000000001167412072400634021017 0ustar0000000000000000module Data.Traversable.Fair ( foldMapBoth , traverseBoth , foldMapWithKeyBoth , traverseWithKeyBoth , foldMapBoth1 , traverseBoth1 , foldMapWithKeyBoth1 , traverseWithKeyBoth1 ) where import Control.Applicative import Control.Arrow import Data.Key import Data.Functor.Apply import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.List.NonEmpty as NonEmpty hiding (toList) refill :: Traversable t => t a -> [b] -> t b refill t l = snd (mapAccumL (\xs _ -> (Prelude.tail xs, Prelude.head xs)) l t) toNonEmptyList :: Foldable1 f => f a -> NonEmpty a toNonEmptyList = NonEmpty.fromList . toList toKeyedNonEmptyList :: FoldableWithKey1 f => f a -> NonEmpty (Key f, a) toKeyedNonEmptyList = NonEmpty.fromList . toKeyedList foldMapBoth :: (Foldable f, Foldable g, Monoid m) => (a -> m) -> f a -> g a -> m foldMapBoth f as bs = go (toList as) (toList bs) where go [] [] = mempty go xs [] = foldMap f xs go [] ys = foldMap f ys go (x:xs) (y:ys) = f x `mappend` f y `mappend` go xs ys -- | traverse both containers, interleaving effects for fairness traverseBoth :: (Traversable f, Traversable g, Applicative m) => (a -> m b) -> f a -> g a -> m (f b, g b) traverseBoth f as bs = (refill as *** refill bs) <$> go (toList as) (toList bs) where go [] [] = pure ([],[]) go xs [] = flip (,) [] <$> traverse f xs go [] ys = (,) [] <$> traverse f ys go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f x <*> f y <*> go xs ys -- | fold both containers, interleaving results for fairness foldMapBoth1 :: (Foldable1 f, Foldable1 g, Semigroup m) => (a -> m) -> f a -> g a -> m foldMapBoth1 f as bs = go (toNonEmptyList as) (toNonEmptyList bs) where go (x:|[]) (y:|[]) = f x <> f y go (x:|z:zs) (y:|[]) = f x <> f y <> foldMap1 f (z:|zs) go (x:|[]) ys = f x <> foldMap1 f ys go (x:|z:zs) (y:|w:ws) = f x <> f y <> go (z:|zs) (w:|ws) -- | traverse both containers, interleaving effects for fairness traverseBoth1 :: (Traversable1 f, Traversable1 g, Apply m) => (a -> m b) -> f a -> g a -> m (f b, g b) traverseBoth1 f as bs = (refill as *** refill bs) <$> go (toNonEmptyList as) (toNonEmptyList bs) where go (x:|[]) (y:|[]) = (\x' y' -> ([x'], [y'] )) <$> f x <.> f y go (x:|z:zs) (y:|[]) = (\x' y' (x'':|xs') -> (x':x'':xs', [y'] )) <$> f x <.> f y <.> traverse1 f (z:|zs) go (x:|[]) ys = (\x' (y':|ys') -> ([x'], y':ys')) <$> f x <.> traverse1 f ys go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs', y':ys')) <$> f x <.> f y <.> go (z:|zs) (w:|ws) foldMapWithKeyBoth :: (FoldableWithKey f, FoldableWithKey g, Monoid m) => (Key f -> a -> m) -> (Key g -> a -> m) -> f a -> g a -> m foldMapWithKeyBoth f g as bs = go (toKeyedList as) (toKeyedList bs) where f' = uncurry f g' = uncurry g go [] [] = mempty go xs [] = foldMap f' xs go [] ys = foldMap g' ys go (x:xs) (y:ys) = f' x `mappend` g' y `mappend` go xs ys -- | traverse both containers, interleaving effects for fairness traverseWithKeyBoth :: (TraversableWithKey f, TraversableWithKey g, Applicative m) => (Key f -> a -> m b) -> (Key g -> a -> m b) -> f a -> g a -> m (f b, g b) traverseWithKeyBoth f g as bs = (refill as *** refill bs) <$> go (toKeyedList as) (toKeyedList bs) where f' = uncurry f g' = uncurry g go [] [] = pure ([],[]) go xs [] = flip (,) [] <$> traverse f' xs go [] ys = (,) [] <$> traverse g' ys go (x:xs) (y:ys) = (\x' y' (xs',ys') -> (x':xs',y':ys')) <$> f' x <*> g' y <*> go xs ys -- | fold both containers, interleaving results for fairness foldMapWithKeyBoth1 :: (FoldableWithKey1 f, FoldableWithKey1 g, Semigroup m) => (Key f -> a -> m) -> (Key g -> a -> m) -> f a -> g a -> m foldMapWithKeyBoth1 f g as bs = go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs) where f' = uncurry f g' = uncurry g go (x:|[]) (y:|[]) = f' x <> g' y go (x:|z:zs) (y:|[]) = f' x <> g' y <> foldMap1 f' (z:|zs) go (x:|[]) ys = f' x <> foldMap1 g' ys go (x:|z:zs) (y:|w:ws) = f' x <> g' y <> go (z:|zs) (w:|ws) -- | traverse both containers, interleaving effects for fairness traverseWithKeyBoth1 :: (TraversableWithKey1 f, TraversableWithKey1 g, Apply m) => (Key f -> a -> m b) -> (Key g -> a -> m b) -> f a -> g a -> m (f b, g b) traverseWithKeyBoth1 f g as bs = (refill as *** refill bs) <$> go (toKeyedNonEmptyList as) (toKeyedNonEmptyList bs) where f' = uncurry f g' = uncurry g go (x:|[]) (y:|[]) = (\x' y' -> ([x'], [y'] )) <$> f' x <.> g' y go (x:|z:zs) (y:|[]) = (\x' y' (z':|zs') -> (x':z':zs', [y'] )) <$> f' x <.> g' y <.> traverse1 f' (z:|zs) go (x:|[]) ys = (\x' (y':|ys') -> ([x'], y':ys')) <$> f' x <.> traverse1 g' ys go (x:|z:zs) (y:|w:ws) = (\x' y' (xs', ys') -> (x':xs', y':ys')) <$> f' x <.> g' y <.> go (z:|zs) (w:|ws) representable-tries-3.0.2/src/Numeric/0000755000000000000000000000000012072400634016050 5ustar0000000000000000representable-tries-3.0.2/src/Numeric/Nat/0000755000000000000000000000000012072400634016572 5ustar0000000000000000representable-tries-3.0.2/src/Numeric/Nat/Zeroless.hs0000644000000000000000000001423612072400634020742 0ustar0000000000000000{-# LANGUAGE TypeFamilies, Rank2Types, TypeOperators, GADTs, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Numeric.Nat.Zeroless -- Copyright : (c) Edward Kmett 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Zeroless numbers encoded in zeroless binary numbers ---------------------------------------------------------------------- module Numeric.Nat.Zeroless ( D0(..), D1(..), D2(..), (:+:), (:*:), Zeroless(..) , Succ, Pred , LT, GT, EQ , Compare , N1, N8, N16, N32, N64 , Nat(..), nat , Fin(..) , Reverse ) where import Data.Function (on) import Prelude hiding (lookup) infixl 7 :*: infixl 6 :+: -- * Type-level naturals using zeroless binary numbers data D0 = D0 -- ^ 0 data D1 n = D1 n -- ^ 2n + 1 data D2 n = D2 n -- ^ 2n + 2 -- * useful numbers type N1 = D1 D0 type N8 = D2 (D1 (D1 D0)) type N16 = D2 (D1 (D1 (D1 D0))) type N32 = D2 (D1 (D1 (D1 (D1 D0)))) type N64 = D2 (D1 (D1 (D1 (D1 (D1 D0))))) -- * Successor type family Succ n type instance Succ D0 = D1 D0 type instance Succ (D1 n) = D2 n type instance Succ (D2 n) = D1 (Succ n) type family Pred n type instance Pred (D1 D0) = D0 type instance Pred (D1 (D1 n)) = D2 (Pred (D1 n)) type instance Pred (D1 (D2 n)) = D2 (D1 n) type instance Pred (D2 n) = D1 n -- * Carry flags data C0 data C1 data C2 -- * Add with carry type family Add c n m type instance Add C0 D0 n = n type instance Add C1 D0 D0 = D1 D0 type instance Add C2 D0 D0 = D2 D0 type instance Add C1 D0 (D1 n) = D2 n type instance Add C1 D0 (D2 n) = D1 (Add C1 D0 n) type instance Add C2 D0 (D1 n) = D1 (Add C1 D0 n) type instance Add C2 D0 (D2 n) = D2 (Add C1 D0 n) type instance Add C0 (D1 n) D0 = D1 n type instance Add C1 (D1 n) D0 = D2 n type instance Add C2 (D1 n) D0 = D1 (Add C1 D0 n) type instance Add C0 (D1 n) (D1 m) = D2 (Add C0 n m) type instance Add C1 (D1 n) (D1 m) = D1 (Add C1 n m) type instance Add C2 (D1 n) (D1 m) = D2 (Add C1 n m) type instance Add C0 (D1 n) (D2 m) = D1 (Add C1 n m) type instance Add C1 (D1 n) (D2 m) = D2 (Add C1 n m) type instance Add C2 (D1 n) (D2 m) = D1 (Add C2 n m) type instance Add C0 (D2 n) D0 = D2 n type instance Add C1 (D2 n) D0 = D1 (Add C1 D0 n) type instance Add C2 (D2 n) D0 = D2 (Add C1 D0 n) type instance Add C0 (D2 n) (D1 m) = D1 (Add C1 n m) type instance Add C1 (D2 n) (D1 m) = D2 (Add C1 n m) type instance Add C2 (D2 n) (D1 m) = D1 (Add C2 n m) type instance Add C0 (D2 n) (D2 m) = D2 (Add C1 n m) type instance Add C1 (D2 n) (D2 m) = D1 (Add C2 n m) type instance Add C2 (D2 n) (D2 m) = D2 (Add C2 n m) -- * Adder type n :+: m = Add C0 n m data LT data EQ data GT type family Compare' a l r type instance Compare' a D0 D0 = a type instance Compare' a D0 (D1 r) = LT type instance Compare' a D0 (D2 r) = LT type instance Compare' a (D1 r) D0 = GT type instance Compare' a (D1 l) (D1 r) = Compare' a l r type instance Compare' a (D1 l) (D2 r) = Compare' LT l r type instance Compare' a (D2 l) D0 = GT type instance Compare' a (D2 l) (D1 r) = Compare' GT l r type instance Compare' a (D2 l) (D2 r) = Compare' a l r type Compare m n = Compare' EQ m n -- * Multiplier type family n :*: m type instance D0 :*: m = D0 type instance D1 n :*: m = (n :*: m) :+: (n :*: m) :+: m type instance D2 n :*: m = (n :*: m) :+: (n :*: m) :+: m :+: m -- * Digit Counter type family Digits n type instance Digits D0 = D0 type instance Digits (D1 n) = Succ (Digits n) type instance Digits (D2 n) = Succ (Digits n) type family Reverse' n m type instance Reverse' m D0 = m type instance Reverse' m (D1 n) = Reverse' (D1 m) n type instance Reverse' m (D2 n) = Reverse' (D2 m) n -- * bitwise reversal type Reverse n = Reverse' D0 n {- data Z = Z newtype S n = S n class Nat n where caseNat :: forall n. ((n ~ Z) => r) -> (forall x. (n ~ (S x), Nat x) => x -> r) -> r -} -- * Class of zeroless-binary numbers class Zeroless n where ind :: f D0 -> (forall m. Zeroless m => f m -> f (D1 m)) -> (forall m. Zeroless m => f m -> f (D2 m)) -> f n caseNat :: ((n ~ D0) => r) -> (forall x. (n ~ D1 x, Zeroless x) => x -> r) -> (forall x. (n ~ D2 x, Zeroless x) => x -> r) -> n -> r instance Zeroless D0 where ind z _ _ = z caseNat z _ _ _ = z instance Zeroless n => Zeroless (D1 n) where ind z f g = f (ind z f g) caseNat _ f _ (D1 x) = f x instance Zeroless n => Zeroless (D2 n) where ind z f g = g (ind z f g) caseNat _ _ g (D2 x) = g x class Zeroless n => Positive n instance Zeroless n => Positive (D1 n) instance Zeroless n => Positive (D2 n) newtype Nat n = Nat { fromNat :: Int } instance Zeroless n => Eq (Nat n) where _ == _ = True instance Zeroless n => Ord (Nat n) where compare _ _ = EQ instance Zeroless n => Show (Nat n) where showsPrec d (Nat n) = showsPrec d n instance Zeroless n => Bounded (Nat n) where minBound = nat maxBound = nat instance Zeroless n => Enum (Nat n) where fromEnum (Nat n) = n toEnum _ = nat nat :: Zeroless n => Nat n nat = ind (Nat 0) (Nat . (+1) . (*2) . fromNat) (Nat . (+2) . (*2) . fromNat) -- * A finite number @m < n@ newtype Fin n = Fin { fromFin :: Int } instance Show (Fin n) where showsPrec d = showsPrec d . fromFin instance Eq (Fin n) where (==) = (==) `on` fromFin instance Ord (Fin n) where compare = compare `on` fromFin instance Positive n => Num (Fin n) where fromInteger = toEnum . fromInteger a + b = toEnum (fromFin a + fromFin b) a * b = toEnum (fromFin a * fromFin b) a - b = toEnum (fromFin a - fromFin b) abs a = a signum 0 = 0 signum _ = 1 inFin :: (Int -> Int) -> Fin n -> Fin n inFin f = Fin . f . fromFin instance Positive n => Bounded (Fin n) where minBound = Fin 0 maxBound = inFin (subtract 1) $ ind (Fin 0) (Fin . ((+1) . (*2)) . fromFin) (Fin . ((+2) . (*2)) . fromFin) instance Positive n => Enum (Fin n) where fromEnum = fromFin toEnum n = r where r | n < 0 = error "Fin.toEnum: negative number" | Fin n <= b = Fin n `asTypeOf` b | otherwise = error "Fin.toEnum: index out of range" b = maxBound