feat: initial commit

package.json

@@ -14,5 +14,5 @@
   "peerDependencies": {
     "typescript": "^5.0.0"
   },
-  "dependencies": {}
+  "dependencies": { "big-integer": "^1.6.52" }
 }

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=

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
+}

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

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

src/Main.purs

@@ -1,7 +0,0 @@
-module Main where
-
-import Prelude
-import Effect (Effect)
-
-main :: Effect Unit
-main = pure unit

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