diff --git a/bun.lockb b/bun.lockb index c42d05c..8a06b80 100755 Binary files a/bun.lockb and b/bun.lockb differ diff --git a/package.json b/package.json index e446309..8c2b8e1 100644 --- a/package.json +++ b/package.json @@ -14,5 +14,5 @@ "peerDependencies": { "typescript": "^5.0.0" }, - "dependencies": {} + "dependencies": { "big-integer": "^1.6.52" } } diff --git a/spago.yaml b/spago.yaml index a8c16f6..92dc080 100644 --- a/spago.yaml +++ b/spago.yaml @@ -1,21 +1,29 @@ package: dependencies: - - prelude - aff + - console - effect - either - - maybe - foldable-traversable - - console + - js-bigints + - maybe - newtype + - node-buffer + - prelude + - quickcheck + - spec-quickcheck - strings - stringutils - transformers - tuples - typelevel-prelude - name: project + name: proquint + test: + main: Test.Main + dependencies: + - spec workspace: extra_packages: {} package_set: url: https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.10-20230930/packages.json - hash: sha256-nTsd44o7/hrTdk0c6dh0wyBqhFFDJJIeKdQU6L1zv/A= + hash: sha256-hp58GPoH+qX3eUsk2ecoHBZpQ50rFeZCCMTdKkYTr/Y= diff --git a/src/Data.Buffer.Immutable.BigInt.js b/src/Data.Buffer.Immutable.BigInt.js new file mode 100644 index 0000000..930f3db --- /dev/null +++ b/src/Data.Buffer.Immutable.BigInt.js @@ -0,0 +1,11 @@ +import { Buffer } from 'node:buffer' + +/** @type {(offset: number) => (b: Buffer) => bigint} */ +export const readBigUInt64BE = off => b => b.readBigUInt64BE(off) + +/** @type {(b: bigint) => Buffer} */ +export const fromBigUInt64BE = b => { + const buf = Buffer.alloc(8) + buf.writeBigUInt64BE(b) + return buf +} diff --git a/src/Data.Buffer.Immutable.BigInt.purs b/src/Data.Buffer.Immutable.BigInt.purs new file mode 100644 index 0000000..e3d381f --- /dev/null +++ b/src/Data.Buffer.Immutable.BigInt.purs @@ -0,0 +1,7 @@ +module Data.Buffer.Immutable.BigInt where + +import JS.BigInt (BigInt) +import Node.Buffer.Immutable (ImmutableBuffer) + +foreign import readBigUInt64BE :: Int -> ImmutableBuffer -> BigInt +foreign import fromBigUInt64BE :: BigInt -> ImmutableBuffer diff --git a/src/Data.Proquint.purs b/src/Data.Proquint.purs new file mode 100644 index 0000000..03bada2 --- /dev/null +++ b/src/Data.Proquint.purs @@ -0,0 +1,283 @@ +module Data.Proquint where + +import Prelude + +import Control.Monad.Error.Class (liftMaybe, throwError) +import Data.Array as Array +import JS.BigInt (BigInt) +import Data.Bounded.Generic (genericBottom, genericTop) +import Data.Buffer.Immutable.BigInt as Buffer.Immutable.BigInt +import Data.Either (Either(..)) +import Data.Enum (class BoundedEnum, class Enum, upFromIncluding) +import Data.Enum.Generic (genericCardinality, genericFromEnum, genericPred, genericSucc, genericToEnum) +import Data.Foldable (intercalate) +import Data.FunctorWithIndex (mapWithIndex) +import Data.Generic.Rep (class Generic) +import Data.Int as Int +import Data.Int.Bits (shl, shr, (.&.), (.|.)) +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Newtype (wrap) +import Data.Show.Generic (genericShow) +import Data.String as String +import Data.Traversable (for, traverse) +import Data.Tuple.Nested ((/\)) +import Effect (Effect) +import Effect.Unsafe (unsafePerformEffect) +import Node.Buffer (Buffer, BufferValueType(..)) +import Node.Buffer as Buffer +import Node.Buffer.Immutable (ImmutableBuffer) +import Node.Buffer.Immutable as Buffer.Immutable + +segmentMask :: Int +segmentMask = 65535 -- 0b1111111111111111 + +conMask :: Int +conMask = 15 -- 0b1111 + +voMask :: Int +voMask = 3 -- 0b11 + +data Con + = ConB + | ConD + | ConF + | ConG + | ConH + | ConJ + | ConK + | ConL + | ConM + | ConN + | ConP + | ConR + | ConS + | ConT + | ConV + | ConZ + +derive instance Generic Con _ +derive instance Ord Con +derive instance Eq Con +instance Show Con where + show = genericShow + +instance Enum Con where + pred = genericPred + succ = genericSucc + +instance Bounded Con where + bottom = genericBottom + top = genericTop + +instance BoundedEnum Con where + cardinality = genericCardinality + toEnum = genericToEnum + fromEnum = genericFromEnum + +conBits :: Con -> Int +conBits ConB = 0x0 +conBits ConD = 0x1 +conBits ConF = 0x2 +conBits ConG = 0x3 +conBits ConH = 0x4 +conBits ConJ = 0x5 +conBits ConK = 0x6 +conBits ConL = 0x7 +conBits ConM = 0x8 +conBits ConN = 0x9 +conBits ConP = 0xA +conBits ConR = 0xB +conBits ConS = 0xC +conBits ConT = 0xD +conBits ConV = 0xE +conBits ConZ = 0xF + +conBitsMap :: Map Int Con +conBitsMap = Map.fromFoldable $ map (\c -> conBits c /\ c) (upFromIncluding bottom :: Array _) + +conFromBits :: Int -> Con +conFromBits = fromMaybe ConB <<< flip Map.lookup conBitsMap + +conToString :: Con -> String +conToString ConB = "b" +conToString ConD = "d" +conToString ConF = "f" +conToString ConG = "g" +conToString ConH = "h" +conToString ConJ = "j" +conToString ConK = "k" +conToString ConL = "l" +conToString ConM = "m" +conToString ConN = "n" +conToString ConP = "p" +conToString ConR = "r" +conToString ConS = "s" +conToString ConT = "t" +conToString ConV = "v" +conToString ConZ = "z" + +conStringMap :: Map String Con +conStringMap = Map.fromFoldable $ map (\c -> conToString c /\ c) (upFromIncluding bottom :: Array _) + +conFromString :: String -> Maybe Con +conFromString = flip Map.lookup conStringMap + +data Vo + = VoA + | VoI + | VoO + | VoU + +derive instance Generic Vo _ +derive instance Ord Vo +derive instance Eq Vo +instance Show Vo where + show = genericShow + +instance Enum Vo where + pred = genericPred + succ = genericSucc + +instance Bounded Vo where + bottom = genericBottom + top = genericTop + +instance BoundedEnum Vo where + cardinality = genericCardinality + toEnum = genericToEnum + fromEnum = genericFromEnum + +voBits :: Vo -> Int +voBits VoA = 0x0 +voBits VoI = 0x1 +voBits VoO = 0x2 +voBits VoU = 0x3 + +voBitsMap :: Map Int Vo +voBitsMap = Map.fromFoldable $ map (\c -> voBits c /\ c) (upFromIncluding bottom :: Array _) + +voFromBits :: Int -> Vo +voFromBits = fromMaybe VoA <<< flip Map.lookup voBitsMap + +voToString :: Vo -> String +voToString VoA = "a" +voToString VoI = "i" +voToString VoO = "o" +voToString VoU = "u" + +voStringMap :: Map String Vo +voStringMap = Map.fromFoldable $ map (\c -> voToString c /\ c) (upFromIncluding bottom :: Array _) + +voFromString :: String -> Maybe Vo +voFromString = flip Map.lookup voStringMap + +data Segment = Segment Con Vo Con Vo Con + +derive instance Generic Segment _ +derive instance Ord Segment +derive instance Eq Segment +instance Show Segment where + show = genericShow + +segmentBits :: Segment -> Int +segmentBits (Segment a b c d e) = + let + con g = conBits g .&. conMask + vo g = voBits g .&. voMask + + bits = shl (con a) 12 .|. shl (vo b) 10 .|. shl (con c) 6 .|. shl (vo d) 4 .|. con e + in + bits .&. segmentMask + +segmentFromBits :: Int -> Segment +segmentFromBits n = + let + con = conFromBits + vo = voFromBits + in + Segment + (con $ (shr n 12) .&. conMask) + (vo $ (shr n 10) .&. voMask) + (con $ (shr n 6) .&. conMask) + (vo $ (shr n 4) .&. voMask) + (con $ n .&. conMask) + +segmentToString :: Segment -> String +segmentToString (Segment a b c d e) = + let + con = conToString + vo = voToString + in + con a <> vo b <> con c <> vo d <> con e + +segmentFromString :: String -> Either String Segment +segmentFromString s = + let + chars = map (String.fromCodePointArray <<< pure) $ String.toCodePointArray s + con s' = liftMaybe ("Expected consonant, found " <> s) $ conFromString s' + vo s' = liftMaybe ("Expected vowel, found " <> s) $ voFromString s' + in + case chars of + [ a, b, c, d, e ] -> pure Segment <*> con a <*> vo b <*> con c <*> vo d <*> con e + _ -> throwError $ "Expected 5-char segment, got " <> s + +data Proquint = Proquint (Array Segment) + +derive instance Generic Proquint _ +derive instance Ord Proquint +derive instance Eq Proquint +instance Show Proquint where + show = genericShow + +toString :: Proquint -> String +toString (Proquint segments) = intercalate "-" $ map segmentToString segments + +fromString :: String -> Either String Proquint +fromString "" = Right $ Proquint [] +fromString s = map Proquint $ traverse segmentFromString $ String.split (wrap "-") s + +fromInt :: Int -> Proquint +fromInt n = fromBits $ unsafePerformEffect do + buf <- Buffer.alloc 4 + Buffer.write Buffer.UInt32BE (Int.toNumber n) 0 buf + Buffer.freeze buf + +toInt :: Proquint -> Maybe Int +toInt pq@(Proquint segs) + | Array.length segs <= 2 = Int.fromNumber $ Buffer.Immutable.read UInt32BE 0 $ toBits pq + | otherwise = Nothing + +toBigInt :: Proquint -> Maybe BigInt +toBigInt pq@(Proquint segs) + | Array.length segs <= 4 = Just $ Buffer.Immutable.BigInt.readBigUInt64BE 0 $ toBits pq + | otherwise = Nothing + +fromBigInt :: BigInt -> Proquint +fromBigInt b = fromBits $ Buffer.Immutable.BigInt.fromBigUInt64BE b + +toBits :: Proquint -> ImmutableBuffer +toBits (Proquint segments) = unsafePerformEffect do + buf <- Buffer.alloc (2 * Array.length segments) + let + segmentsIndexed = mapWithIndex (\x s -> x /\ s) segments + void $ for segmentsIndexed \(x /\ s) -> + Buffer.write + Buffer.UInt16BE + (Int.toNumber $ segmentBits s) + (x * 2) + buf + Buffer.freeze buf + +fromBits :: ImmutableBuffer -> Proquint +fromBits buf = + let + len = Buffer.Immutable.size buf + octet x = fromMaybe 0 $ Buffer.Immutable.getAtOffset x buf + octets x = (shl (octet x) 8) .|. octet (x + 1) + go segs x + | x >= len = segs + | otherwise = go (segs <> [ segmentFromBits $ octets x ]) (x + 2) + in + Proquint $ go [] 0 diff --git a/src/Main.purs b/src/Main.purs deleted file mode 100644 index ee561ac..0000000 --- a/src/Main.purs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Prelude -import Effect (Effect) - -main :: Effect Unit -main = pure unit diff --git a/test/Test.Main.purs b/test/Test.Main.purs new file mode 100644 index 0000000..649ef75 --- /dev/null +++ b/test/Test.Main.purs @@ -0,0 +1,108 @@ +module Test.Main where + +import Prelude + +import Control.Monad.Gen (suchThat) +import Data.Array as Array +import JS.BigInt (BigInt) +import JS.BigInt as BigInt +import Data.Buffer.Immutable.BigInt as Buffer.Immutable.BigInt +import Data.Char as Char +import Data.Char.Gen (genDigitChar) +import Data.Either (Either(..)) +import Data.Foldable (intercalate) +import Data.Generic.Rep (class Generic) +import Data.Maybe (Maybe(..), fromJust) +import Data.Newtype (class Newtype, wrap) +import Data.Proquint (Con, Proquint(..), Segment(..), Vo) +import Data.Proquint as PQ +import Data.String as String +import Data.String.CodePoints as String.CodePoint +import Data.Traversable (sequence) +import Data.Tuple.Nested ((/\)) +import Effect (Effect) +import Effect.Aff (launchAff_) +import Effect.Unsafe (unsafePerformEffect) +import Node.Buffer as Buffer +import Node.Buffer.Immutable as Buffer.Immutable +import Node.Encoding (Encoding(..)) +import Partial.Unsafe (unsafePartial) +import Test.QuickCheck (class Arbitrary, arbitrary, (===)) +import Test.QuickCheck.Arbitrary (genericArbitrary) +import Test.QuickCheck.Gen (Gen, arrayOf, enum, resize) +import Test.QuickCheck.Gen as Gen +import Test.Spec (describe, it) +import Test.Spec.QuickCheck (quickCheck) +import Test.Spec.Reporter (consoleReporter) +import Test.Spec.Runner (runSpec) + +genCon :: Gen Con +genCon = enum + +genVo :: Gen Vo +genVo = enum + +genSegment :: Gen Segment +genSegment = pure Segment <*> genCon <*> genVo <*> genCon <*> genVo <*> genCon + +genProquint :: Gen Proquint +genProquint = pure Proquint <*> arrayOf genSegment + +genProquint64 :: Gen Proquint +genProquint64 = pure Proquint <*> (sequence $ Array.replicate 4 genSegment) + +genBigInt :: Gen BigInt +genBigInt = + let + bigintFromString = unsafePartial fromJust <<< BigInt.fromString + boolArrayToBinary = append "0b" <<< intercalate "" <<< map bit + bit true = "1" + bit false = "0" + in + map (bigintFromString <<< boolArrayToBinary) $ sequence $ Array.replicate 64 (arbitrary @Boolean) + +newtype TestCon = TestCon Con + +derive instance Newtype TestCon _ +derive instance Generic TestCon _ +instance Arbitrary TestCon where + arbitrary = wrap <$> enum + +newtype TestVo = TestVo Vo + +derive instance Newtype TestVo _ +derive instance Generic TestVo _ +instance Arbitrary TestVo where + arbitrary = wrap <$> enum + +newtype TestSegment = TestSegment Segment + +derive instance Newtype TestSegment _ +derive instance Generic TestSegment _ +instance Arbitrary TestSegment where + arbitrary = wrap <$> genSegment + +newtype TestProquint = TestProquint Proquint + +derive instance Newtype TestProquint _ +derive instance Generic TestProquint _ +instance Arbitrary TestProquint where + arbitrary = wrap <$> genProquint + +newtype TestBigInt = TestBigInt BigInt + +derive instance Newtype TestBigInt _ +derive instance Generic TestBigInt _ +instance Arbitrary TestBigInt where + arbitrary = wrap <$> genBigInt + +main :: Effect Unit +main = + launchAff_ $ runSpec [ consoleReporter ] do + describe "Data.Proquint" do + it "(toString >>> fromString) === Right" + $ quickCheck \(TestProquint pq) -> PQ.fromString (PQ.toString pq) === Right pq + it "(toBits >>> fromBits) === identity" + $ quickCheck \(TestProquint pq) -> PQ.fromBits (PQ.toBits pq) === pq + it "(fromBigInt >>> toBigInt) === Just" + $ quickCheck \(TestBigInt bi) -> PQ.toBigInt (PQ.fromBigInt bi) === Just bi