diff --git a/Data/Word/General.hs b/Data/Word/General.hs new file mode 100644 --- /dev/null +++ b/Data/Word/General.hs @@ -0,0 +1,69 @@ +module Data.Word.General (Word) where + +import Prelude hiding (Word, reverse, (!!)) +import Control.Applicative +import Control.Monad.Trans.State +import Data.Bits (Bits (..)) +import Data.Bool (bool) +import Data.Fin +import Data.Fin.List hiding (swap) +import Data.Function (on) +import Data.Functor.Const (Const (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Reverse (Reverse (..)) +import Data.Maybe (fromMaybe, fromJust) +import Data.Natural.Class +import Data.Semigroup (Endo (..), Semigroup (..)) +import Data.Tuple (swap) +import qualified Numeric.Natural as N + +newtype Word n = Word { bits :: List n Bool } + deriving (Eq) + +instance Ord (Word n) where + compare = compare `on` reverse . bits + +instance Natural n => Num (Word n) where + Word as + Word bs = Word (go False as bs) + where + go :: ∀ n . Natural n => Bool -> List n Bool -> List n Bool -> List n Bool + go c = unOp₂ $ natural (Op₂ $ \ Nil Nil -> Nil) $ Op₂ $ \ (a:.as) (b:.bs) -> + let (z, c') = ((a /= b) /= c, a && b && c) in z:.go c' as bs + + a * b = fromInteger . fromIntegral $ toNatural a * toNatural b + + negate = (+1) . complement + + abs = id + + signum = fromInteger . fromIntegral . signum . toNatural + + fromInteger n = case compare n 0 of + LT -> negate $ fromInteger (abs n) + EQ -> zeroBits + GT -> fromInteger (n-1) + bit 0 + +toNatural :: Word n -> N.Natural +toNatural = foldl (\ n b -> bool id (+1) b $ n `shiftL` 1) 0 . bits + +instance Natural n => Bits (Word n) where + Word as .&. Word bs = Word (liftA2 (&&) as bs) + Word as .|. Word bs = Word (liftA2 (&&) as bs) + Word as `xor` Word bs = Word (liftA2 (/=) as bs) + complement (Word as) = Word (not <$> as) + shiftL (Word as) k = Word $ stimes k (Endo go) `appEndo` as + where go as = flip evalState False $ traverse (state . curry swap) as + shiftR (Word as) k = Word $ stimes k (Endo go) `appEndo` as + where go as = getReverse . flip evalState False $ traverse (state . curry swap) (Reverse as) + rotateL (Word as) k = Word $ stimes k (Endo go) `appEndo` as + where go as = let (bs, c) = flip runState c $ traverse (state . curry swap) as in bs + rotateR (Word as) k = Word $ stimes k (Endo go) `appEndo` as + where go as = let (Reverse bs, c) = flip runState c $ traverse (state . curry swap) (Reverse as) in bs + bitSize = fromJust . bitSizeMaybe + bitSizeMaybe _ = Just . fromIntegral . getConst $ (reify :: Const Peano n) + isSigned _ = False + testBit (Word as) = fromMaybe False . fmap (as !!) . toFinMay + bit n = Word $ maybe id (\ n -> runIdentity . at n ((pure . pure) True)) (toFinMay n) $ pure False + popCount = foldr (bool id (+1)) 0 . bits + +newtype Op₂ a b n = Op₂ { unOp₂ :: List n a -> List n a -> List n b } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright M Farkas-Dyck © 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of M Farkas-Dyck nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 COPYRIGHT +OWNER 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.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# word 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/word.cabal b/word.cabal new file mode 100644 --- /dev/null +++ b/word.cabal @@ -0,0 +1,47 @@ +name: word +version: 0.1.0.0 +synopsis: Words of arbitrary size +-- description: +license: BSD3 +license-file: LICENSE +author: M Farkas-Dyck +maintainer: strake888@gmail.com +copyright: 2018 M Farkas-Dyck +-- category: +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: . + exposed-modules: Data.Word.General + build-depends: Fin >=0.2.2 && <0.3 + , base >= 4.7 && < 5 + , natural-induction >=0.2 && <0.3 + , peano >=0.1 && <0.2 + , transformers + default-language: Haskell2010 + default-extensions: UnicodeSyntax + , LambdaCase + , EmptyCase + , InstanceSigs + , PartialTypeSignatures + , ScopedTypeVariables + , PolyKinds + , ConstraintKinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , StandaloneDeriving + , DeriveFunctor, DeriveFoldable, DeriveTraversable + ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Werror=incomplete-patterns + -Werror=incomplete-uni-patterns + -Werror=incomplete-record-updates + -Werror=missing-fields + -Werror=missing-methods + +source-repository head + type: git + location: https://github.com/strake/word.hs