diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello" diff --git a/basen.cabal b/basen.cabal new file mode 100644 --- /dev/null +++ b/basen.cabal @@ -0,0 +1,73 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.32.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 772b5ccd7340e4cef1a9359bf9d2277864b33bfa7ee361078619966a6badc415 + +name: basen +version: 0.1.0.0 +description: Please see the README +homepage: https://github.com/LibreCybernetics/basen-hs#readme +bug-reports: https://github.com/LibreCybernetics/basen-hs/issues +author: LibreCybernetics +maintainer: LibreCybernetics +license: OtherLicense +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/LibreCybernetics/basen-hs + +library + exposed-modules: + Data.BaseN + Data.BaseN.Internal + other-modules: + Paths_basen + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.12.0.0 && <5 + , bytestring >=0.10.8.2 && <1 + , text >=1.2.3.1 && <2 + default-language: Haskell2010 + +executable basen-app + main-is: Main.hs + other-modules: + Paths_basen + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12.0.0 && <5 + , basen + , bytestring >=0.10.8.2 && <1 + , text >=1.2.3.1 && <2 + default-language: Haskell2010 + +test-suite basen-test + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + other-modules: + Data.BaseNTest + Paths_basen + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12.0.0 && <5 + , basen + , bytestring >=0.10.8.2 && <1 + , quickcheck-instances + , tasty + , tasty-discover + , tasty-hspec + , tasty-quickcheck + , text >=1.2.3.1 && <2 + default-language: Haskell2010 diff --git a/src/Data/BaseN.hs b/src/Data/BaseN.hs new file mode 100644 --- /dev/null +++ b/src/Data/BaseN.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Data.BaseN ( + Base(..), DecodeError(..), + encodeBaseN, decodeBaseN, + encodeBase2, decodeBase2 +) where + +import Data.BaseN.Internal + +import Prelude hiding (concat, length, seq, tail, take) + +import Data.Bits +import Data.Word + +import qualified Data.List as L +import qualified Data.String as S + +-- +-- Type Classes / Data Types +-- + +data Base = Base2 deriving (Eq, Show) +data DecodeError = UnkownAlphabet | WrongLength Int deriving (Eq, Show) + +-- +-- Constants +-- + +base2Alphabet = ['0', '1'] +base8Alphabet = ['0'..'7'] +base16Alphabet = ['0'..'9'] <> ['a'..'f'] + +-- +-- Functions +-- + +encodeBase2 :: (ByteStringLike b, StringLike s) => b -> s +encodeBase2 = (`encodeBaseN` Base2) + +decodeBase2 :: (StringLike s, ByteStringLike b) => s -> Either DecodeError b +decodeBase2 = (`decodeBaseN` Base2) + +encodeBaseN :: (ByteStringLike b, StringLike s) => b -> Base -> s +encodeBaseN seq base = case base of + Base2 -> seq `encodeBase2N` 2 + +decodeBaseN :: (StringLike s, ByteStringLike b) => s -> Base -> Either DecodeError b +decodeBaseN seq base = case base of + Base2 -> seq `decodeBase2N` 2 + +-- +-- Helper function +-- + +encodeBase2N :: (ByteStringLike b, StringLike s) => b -> Int -> s +encodeBase2N seq base = concat + [S.fromString [base2Alphabet L.!! val | val <- chunk] | chunk <- encodeBase2N' seq base] + +encodeBase2N' :: (ByteStringLike b) => b -> Int -> [[Int]] +encodeBase2N' seq base = case uncons seq of + Just (h, seq') -> case base of + 2 -> [if h `testBit` i then 1 else 0 | i <- [7,6..0] :: [Int]] : encodeBase2N' seq' base + _ -> undefined + Nothing -> [] + +decodeBase2N :: (StringLike s, ByteStringLike b) => s -> Int -> Either DecodeError b +decodeBase2N seq base = case base of + 2 | lenDivBy 8 -> decodeBase2N' (seq `inChunksOf` 8) 2 + | otherwise -> Left . WrongLength $ 8 - (length seq `mod` 8) + _ -> undefined + where lenDivBy d = length seq `rem` d == 0 + +decodeBase2N' :: (StringLike s, ByteStringLike b) => [s] -> Int -> Either DecodeError b +decodeBase2N' [] _ = Right empty +decodeBase2N' (cnk:t) base = case base of + 2 -> do + val <- attemptSum [positionValue base base2Alphabet vals | vals <- zip (toString cnk) [7,6..0]] UnkownAlphabet + tail <- decodeBase2N' t base + Right $ cons val tail + _ -> undefined + +attemptSum :: [Maybe Int] -> Maybe Word8 +attemptSum l = fromIntegral . sum <$> sequence l +positionValue base baseAlphabet (v, e) = (* base^e) <$> L.elemIndex v baseAlphabet diff --git a/src/Data/BaseN/Internal.hs b/src/Data/BaseN/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/BaseN/Internal.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Data.BaseN.Internal where + +import Data.Word + +import Prelude hiding (drop, length, take) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as L +import qualified Data.String as S +import qualified Data.Text as T + +-- +-- Type Classes +-- + +-- ByteStringLike + +class ByteStringLike b where + cons :: Word8 -> b -> b + empty :: b + null :: b -> Bool + uncons :: b -> Maybe (Word8, b) + (!!) :: Integral i => b -> i -> Maybe Word8 + +instance ByteStringLike [Word8] where + cons = (:) + empty = [] + null = L.null + uncons = L.uncons + l !! i | i `boundedBy` L.length l = Just (l L.!! fromIntegral i) + | otherwise = Nothing + +instance ByteStringLike BS.ByteString where + cons = BS.cons + empty = BS.empty + null = BS.null + uncons = BS.uncons + bs !! i | i `boundedBy` BS.length bs = Just (bs `BS.index` fromIntegral i) + | otherwise = Nothing + +instance ByteStringLike LBS.ByteString where + cons = LBS.cons + empty = LBS.empty + null = LBS.null + uncons = LBS.uncons + bs !! i | i `boundedBy` LBS.length bs = Just(bs `LBS.index` fromIntegral i) + | otherwise = Nothing + +-- StringLike + +class S.IsString s => StringLike s where + concat :: [s] -> s + drop :: Int -> s -> s + length :: s -> Int + take :: Int -> s -> s + toString :: s -> String + +instance StringLike String where + concat = L.concat + drop = L.drop + length = L.length + take = L.take + toString = id + +instance StringLike T.Text where + concat = T.concat + drop = T.drop + length = T.length + take = T.take + toString = T.unpack + +-- +-- Helper Functions +-- + +-- | Bounded between 0 and a given i. [0, i) +boundedBy :: (Integral idx, Integral len) => idx -> len -> Bool +idx `boundedBy` len = 0 <= idx' && idx' < len + where idx' = fromIntegral idx + +inChunksOf :: StringLike s => s -> Int -> [s] +s `inChunksOf` n | length s > n = take n s : (drop n s `inChunksOf` n) + | length s > 0 = [s] + | otherwise = [] + + +-- Taken from: https://github.com/pmlodawski/error-util +-- License: MIT +infixl 4 +() :: Maybe b -> a -> Either a b +val m = maybe (Left m) Right val diff --git a/test/Data/BaseNTest.hs b/test/Data/BaseNTest.hs new file mode 100644 --- /dev/null +++ b/test/Data/BaseNTest.hs @@ -0,0 +1,45 @@ +module Data.BaseNTest where + +import Test.Tasty.Hspec +import Test.Tasty.QuickCheck +import Test.QuickCheck.Instances.ByteString () + +import Data.BaseN + +import Data.ByteString +import Data.Word + +-- +-- Specs +-- + +spec_examples :: Spec +spec_examples = do + describe "Edge Cases" $ do + it "Empty Base2" $ do + encodeBase2 ([] :: [Word8]) `shouldBe` "" + decodeBase2 "" `shouldBe` Right ([] :: [Word8]) + it "Malformed Base2" $ do + decodeBase2 "0" `shouldBe` (Left (WrongLength 7) :: Either DecodeError [Word8]) + decodeBase2 "000011110000" `shouldBe`(Left (WrongLength 4) :: Either DecodeError [Word8]) + decodeBase2 "01234567" `shouldBe` (Left UnkownAlphabet :: Either DecodeError [Word8]) + describe "Base2 Spec" $ do + testEnc2 [0] "00000000" + testEnc2 [1] "00000001" + testEnc2 [10] "00001010" + testEnc2 [123] "01111011" + testEnc2 [0,0] "0000000000000000" + testEnc2 [213,231] "1101010111100111" + where + testEnc2 i s = it (show i) $ encodeBase2 (i :: [Word8]) `shouldBe` s + +-- +-- Properties +-- + +prop_decodeBase2IsLeftInverseOfencodeBase2 :: ByteString -> Bool +prop_decodeBase2IsLeftInverseOfencodeBase2 input = + decodeBase2 encoded == Right input + where + encoded :: String + encoded = encodeBase2 input diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-}