From b8a82003cc7a71ee7def592da2448082be202644 Mon Sep 17 00:00:00 2001 From: Orion Kindel Date: Sat, 16 Dec 2023 13:09:37 -0600 Subject: [PATCH] feat: initial commit --- bun.lockb | Bin 53117 -> 53500 bytes package.json | 2 +- spago.yaml | 18 +- src/Data.Buffer.Immutable.BigInt.js | 11 + src/Data.Buffer.Immutable.BigInt.purs | 7 + src/Data.Proquint.purs | 283 ++++++++++++++++++++++++++ src/Main.purs | 7 - test/Test.Main.purs | 108 ++++++++++ 8 files changed, 423 insertions(+), 13 deletions(-) create mode 100644 src/Data.Buffer.Immutable.BigInt.js create mode 100644 src/Data.Buffer.Immutable.BigInt.purs create mode 100644 src/Data.Proquint.purs delete mode 100644 src/Main.purs create mode 100644 test/Test.Main.purs diff --git a/bun.lockb b/bun.lockb index c42d05ceb16556e06bd80e7e360bf13128ae05e8..8a06b80fc41249150f340910909608c6273e8d86 100755 GIT binary patch delta 8059 zcmeHMYg80hwysmqLV+!yMkpR4_#_GUIIoj8c3o>G>qal zC@LC21)TBDWQdb-V$7_}%EOst#$@s$iBXf48#ULg80Y0xll$$e?nLj(+w@3#53eRlbe*A^v+Yoiua z<=5RUJuew$Pg72G`0sa{M3O4kRaNtKBoHV`^-bFovu+DX3dVIsd7+Ej)>kgtjtj$ZC8XCuAaN0R!Yey*Px^_+*l2hMkOR+o=sznT7~-`lu;0QG+d=h0q) zJWBJkq1MHT!$wt*)Jg4*gNFCBzK49+n-vi<9mNxD8Gm0O1Oq2WG5u5yqmYISu*d6B!+lgk!`-nf~iw`Cc{7s`w&|?Hh1jfO&(>IM2ayzvCV|4Hi>bpA3un zt*b96MP!tMbwx#-J8qZDWuGu!8Z*QcRk^OLlG_CWb0BXnM|*B`D8^i<23XFolvvZR zs*rn0(#zmnU*;}HE>+jS81>JiK2Wkr_2m_-T=C8VcMt-yvag_!J6we2nRo}56&AS5 zSGmiJtLM{I-;w@*`DwuKK2^_r*Ar}c-8W<;LTd2AE|su%r18|GjHL65zo@2OMH7D| zH9(Vx3(5;{SQf!6f${@V#S_#Upo!;64bH4Ls@|xKM73|IRov=L9nUcJ6z|glxKA)bFldxMpH~byJ)0dt0rD0wV$T+ zv3R4$SnbM0uw?kj6w}u(s;CzpCp>i);=Z3!Zjh!7fiNBu{QB9Ig%vaDO@w;!qaj;lWMD{gr00`CvXQ zPxezNufIdgrI!Ah=%C*InsN!5J`oOmco=ec0ObvEDD#nWiKtY_8Dv+U12ac@8MnRx z#vNpG2H2I+SjyR8!cb8Q#%(?Z>jBI3GRtkS=@iv3RauUNivkL$03P1 zp3x@OlR8LKPND80)EPsxdfK3@tB+C zt+OQG#JM=azyzEjPGlqHr1|Jv4LiTnTnQz z@qECuuierFmQ49UsmeKA@q9pAV6y+f@0TgiZpi?f!cJlzsZpAIX&~pcB@CZBNt7R$ zs?5X{&jj)$%x>8RX2v|rSH_)rhW?Q{Tmnu@H28W zQKbVh4rLXd!n_}iSy0-+cut@_%&vS2#%g4qJ$Z0A9f);^O6rZ(l#X!I5eaLxi(bkd zswofRAfbPqde{^|vcC!OU^; zV`K-ZBQ@m>)Qy2Zgk!@0K`p48FvP17_ZDkN9i=J9P{&)^%+`0QWt1kXG4$amhmws) zJr9TT#%}2bL#iMrzQh%0ow4tf8L{S2kRjM@JHf_KYiz3WF0Rbn1mR#lDk}l191L;xj`+3QBB|T~Z%vO$yD$ zg@pMuYKOqe0OT3v$1JyFm_}jS2YAq=_gR^&w$M1fSAwVYUh9iG>~*8Cl_}d6ozC9K zXrr*@dnKFnKFfY709&M{QP}#@Nn7YRu1z!Q?zeo;sh)ba_!N+`nN!)=XrtF0W+?v` z>q9S&4ORJG3ynVaTbZt-l^b#Z_FCexJmCsOB}N;4SAlW4*IFn)F?1gHS#7laxW%Wo zROV@C%X3xX;cPh*Y5=Z(7?5c4gwQ&UTFVUOUd#0x0k)3-T-b8&%>dUw3UFb|_4NSP zKL&95G0T2W0QkU@c5z~Hhur`dw!Xk#fQQ=x_|V-6p~ms56^y+Pb1l#YaJUYD%e|KC zj~TW1TkhB8sb|aax;>n&FIkgxnw#Y7Z|O3tBwfSpX%g&*Al>q@aweu^#>>Q2d_B@?Y=ov4dI%AJ@){;5`a z5zI>%BY_gT!1RFr=IK`LW~Iq#x`?8Nv>ZxKx6*a6Xi7=Xp(|jm z>AHxat6=-5SSfpoE{0Oe6zI!vQVCo^<0l5T-@O@+Rxx`?Chsn9nK`ljh( zH04f%zUj~h7Ej7_=mRU8u8XmB8mwdn^v%%4IC9T`zD(!?vyqw!ePEk2buod?fo;fw zzARnXsWuDxWAILq4LbDAf<7>fQf5IPSnDiZq|;Tf z{n^l$t&0q5$%ek!&<8e+vSvdc*vZ+tm_fI|y5>ON99?8l_Z;Y(3w?8Sp;PW$=$i+9 zVA-V1gFdjbdAgWGr@>0*L*IN|%p>=F=vx4NU<*iH0DWMa7wBRUodesj5c(GCB8O@h zLf<0j1IwkjMbHPR?!=v$(T zLTXt8eYwyF=Ax`z=mR^MtBYc~1=f`ZeR;ZYQ+FQpErq_NI!?H`OQCNW^nsO;vJCpb z%9iP(f=+{#z zxRuZc*0@p^k5Dhzb|>^Xb+MTmoX}SQePDHzQUHBmtp&PxjIM(1FND5A9luYs6hhxB z=mXnIS*xHA?Bpt4JW02}x?Irb(nSMxyP&TK`igY1lX8oouNeBk8c8XJKCrT4UF@RM zU?nBcSE7q1a+eg+Gs-|ZulUmW5`Rk(p08FMu{F9>W$B4=M+f0w!j8{BibJV$U8EIDNf)VH~~|8)v-7VJm=2U@cGuVD^mD>KfQmDr*XL;`^R) zs&&Egf)oQK0H4!S0et(CcpmtC&u4u*z~2zY0{GG<8+B^}rlpE-(+^uN!=xJpdd8HUJBN z`9K@c4mf~#fWK7n37MB`F)$lg3M>Pb1H5ETpn%h_p6`q@X&?P@_lP=PM()cJWIzD? zC7~3^132CyfK!CW$CJvF%M;C07XgF={Q*uDU%&_8G~+%YKrj#lAoq>aoj+^<(3fYe zA1)Usx;!y~BJ2yjPke9U9(VIK#c1hxS@s4c(<;3q)kKKw&@ zsGDM&AEeCYl88vqKx`}T&*rjhc;H_rJ=?5`Q}hS?KTDrC7vqPQ?0v=JZ928jCcdDn z`%dBik^R}?8@j&VCT>$qi!IXo9xV5zuPlc?xjsr3%f}^*OR!^oeW-hY5G20M3l#|V=#gByZi@VX{$c= zKHA5d?M)PaNEK}~w{q0TL53$nw(k~8$iCJ{+PrL{=BMRN{ki=)(fSdH+$^orLDx7B?7$~=U?EU~sN^wwcjj+E#>4u^?t zWI1B{Uq&^^7rib}*^wU|7-Di%@4#L-;u%<&j8O$VQ;!#9JD(}WiR$JvHvA5n-llr~ zyJ%^f8sU98wR6?pXU}|i?jpv?5wV_|X%~DOsk_aFml7B7{}T#nSCI~*+tmo~3p3v( zNekcXbK({Bn}B|J%v`4x?Y0Q-i?V>$%O7s>`;6Bk30Z~qd^*{ljg#7KMDe~Vd(toN zaCXNpJK@E-hX>PY8rxxu@V+8D)Be)vX8L>*+U;hPcW85m8sUAh6#4h9Z!c5sY&7m- zEazABY=wT$RTRp&iGQ3zWv(c kvg$nT=$cAvf0JQJN~kH`*z-nLM+o`78PW6fZ>|jdFLb6#KmY&$ delta 8075 zcmeHMc~n$ant!*TkO!2qh)@E8yQNYrB^HZRfg9oj6t@x;6`_EVO}4}(1`^{IIjyc^knrKeCdnT>Pbd258GeX*F?e0mWPt45kd#@^*KI#5*{>nY) z$M=4B{eJg;_tm|;uRDDnwfpQho1UE!+S!(an_Bq;#) z5%^G8S8b)U!PV60sx7Z}Ra7>$ku0ns^}do6h|HguHO)? zj}{Mq37p3$X{=3B9r4%d?E(o$elK`1Y&$Ib(CDmr%86e0(j^hw(hhgHwF5ScYk7DM zEVoL9;^9_cY!rXnT!&hr;OQY+^LSV;zYNR6 ze}zA6b5M!f|FxTc%e}vHXJqSEXycBWOU)3{P*+pd+)$0YBNXB@u_bAQrfPj-U2VCm z+BpH7Yd4_=t161n#GHg>zOJF9)QON75vk>`g5`C89hS>$oDCJuWJxMOeeTEA7++Cc zw@x}{)au)i&#O>g(%4ilNi9-?v$@e#zDXK2Qk(wUu$Y?GDN&kkv!_9o$Dv|a9xyXn z>u3O$>rapII9}2aUk(TRzBxxIU`bMN}9HV(tTUX|cFIngM$m8uB zu-vKxmRI!5A6(%wT*u|^l3b5-wm8d7crVkX7WTxJL z43S2rK)a|RSD;~AX`BA3CgyWvAU2AizMmbGa`;Z`w=OhfJRGsv5cJYPx*x61E;X`|E|tnz)Z zRFvtcKFBI2k!hG+UaQyg^ju#YB{%XuMjp4)seJ@s%g+Xr=>a?~AXl(m93gkGUH8v^ zG!Sf)gYho#_=`dEz_L(X5DPm*?hw1~qaid9Vv~dLGT!(vOg9$5t%ZbA7+);gLyn1YL&adxPgw&2Uz7h zUTiP;sIB73 zHNq}eVf*v!sxHZ$U_77NT;Bp?b$Zn^BLePmSs|FFoP9X}rurg(fTx*i59hN@Ewz-Fqxx~bo2*WUrpQ#H-P`-rPk{08dU{~A${&IifN6mdja|Z%q33YY zF9J)Y-eDQ?i+EzOzH0ow59V2vK&#$&I6H}2VmY~D?7Gh39Lf4y$WEr-zzjJMzaBgX zh>A$7J_k(ew1uD4p?PlJrv6cO`5yApkQboNcqU$p+8m>XycLY=V=jkT#Rck*wab4- z9=qa0^)XgaO0GD&z8mkZbm|Su(ETQYCI{N&xJb=`A*%Q5!8rJ_sOa=IYIHn(y4yw?7-JJjWEyLi%SLJy1z~H72e}jmH{|S1pg_Lk~t-S?LC}?+VVKw-62&LS{o_*gJ_$H7p@JAXHMOAx=+W^z*L(& zcKo-kA^mA`#oNVO6}f znn)JI+8>;%n@qEco6n8iF1+Ia%~F}B({PK z39;FnYvnAYCoT7h?WOjOEvP28+-oMl<(NN=S(6Z<4ujZLOJ{K|5?j3Br937`Pg+42 z5@K687fY+A@3THADFk?|MQSb0GGFZBPg>Tp)RWJa>n-zew#*$KyPQvc>|P1LiLD@K zV(e&Ur2u{;rAj79Pg+53i4pW#qJIlJSgn?8mK~_|aJJk-Bf$C104KKW$WtEsw8w6Q z<@BWGdYb^Yn*mO2xxZ)l;Kl`80ZweWfTxx7TLDh3>fi5LuJ=3;1pEWQ_4fgs*zzh9 zzygi}Ec6wC6I-r-LZbJQLe)9w0Oc-E0i2$+oPS2m{jTLMyFB@9xyx=3XUi_U=HY+G z>ab{;$;uqA$xRp`KsdnZNy|h0ushXh`C)hduseB|{{QSw%CgpwK2@QIRs$8MD#C}{ zsSfH+HIN}q5qc_0bI|fM1HB72gyeJw`KKGGCS4IST>`rZ7L%cfKyqa`s4~MqH^2;J zoZ+Cz83x)qLlML18rW5^_)JBF(56fWZOk;#uff8|WOL9Yn}PP)6cJ9hz;1$N+7%H& zyX_9zWjD}0Fe9a9IVd&DKy6uyh@yV5yI}d*iin|O*$z6IZJ6p=ywV0Xdt^AwRu$MT>r5Bk9Dl$#HI`OufIh-?}Jdk9us zpx`R%E`YuQ=v$zOIaIU&`W8SRSPsbxp>HAdEmUyHxde6*ET&N5(_|s^6+$0aJ{cE5 z-y-N+q=*G{4eTmd{9;8E(x%1Gw;1}s7L#cS^eutDC5l)|x4>?KWiC~OgLW^4zNOFy zRzzvbpl=!UEmOow>Ib_EmhVtRF&%S2p9A{9)==(p=vxkb%N0>VgJ2KAii;Fn9o$9G zR|I`46ycL&v%jPApi(oOU6j4R4RnWHz`oL<)SPXr|&{wR8 zI=TjS6)b+WBI;?=YUo=HePE4bS_6G+pl^*Ln&}qUO|Z*FxV~=mXnCX(iBC z0(~Wl*h2kacfs=4DPk)fTL*pXpbxBta!aAF6#7aP@f;0;Jp?N*Q^YoMmqA|{^f?u= zor;{$=Y&46og|k-Upe%ZD`GcY0=oznQ=y1GJLmNM-W4arTYZMA3Zc)#>5EGibBSoDpI3*4d;ecpTJ18g z$H|FbPwjn!)pj8t#?2TP{??AZ?AkTLz^5Jlr_EekEJOQ3svM#(vC3DdeP#9;8eY-q ztH$Gig8?G?e%kbJQ31jG(FEzI`zgykobK*7(eMMqO}Lq;X*>S%0fC1cr{+k~4o@DR zRVGm3fv}dBJSDq4C44~g9x-=&^7yzu58(77z`f#sChF0X>+b>B`U9&0E@R)g-hGdg z)A;m-6fmRNl5C5c7T1XXlGc?|-OC{qbZ}uyE6Sb&_>@@(Yyj$k2EYZZ2daPwAQHee zRl?mrm`vbSt>mB0!Dz3vwW=ODAWNQI~-%dz%XDafSsYn6UUMa1Of(@ z9^@(DOb&zyU<5E62m?ZaaF6vq$AR;jaiDO(#CR;v`DlQ*$5>zjz-`O`2gnqFCu%al zlQxIl$i@RAMoORqhr(*CcuD~*Kr+Bf&tbqZmIZKFaP0BCbI8mBW&*Q;xj+uU@tF?r zI^+S|rvl^x+$Zn7`9Kzh91d&Y)n+UQc=b477|eN>lmY6>!SbrE0-jviHQ?)jQlJ9x z?ig-c3AlilfEr*A@FK7qcmY7bwn)41uoKt@dtR9dCNEBnRf=abiO{$u{>{oqK{ zN;D@;Gb6?@7uW!;gN88|!m~Q=>%_CkZ~()!)4dbMDDOwC2_KBRboukU&!DBnth%w6 zMz>j_yq~G|`H#BW*?9I>D4(X4=TKdnk&hm27W{O*+h$Dhe&X7A_w>uL-~7q)xG(Ql zq{RKp>VNrP8(JTi=qRu~Upz}&I*d`?FIJNteD;UNi2HA&7AD<{4MMcH-5AvYAu_al zTrjumi+y*dJ?_O#SK5vE59p`u7TuK~3O*UByBLSLy?p+iPp;kev_!nv=;x=5__p!IDGQE>v8OFj-j8WZ*Z%&0|FXa2OSP_r=X(Uz zoHj;zKdSjIPhN7vujgkdPtn%nb?QWW@5i)&wmYA^Fyyzq-W*$KKZ^cvI$xM6^Ncad z`z3AX5L0{p>9@L2i?=`;UY1mU#uDZIg7(g-%To^1?`ELfs`YY+E~CBo8&&jI+kdf2 z{(7@IN+O5$8}z3$mT2!6vVROHEFLo@;StIc%_&^|Q8djwTdw;&ntIMA>jt9fv$K(6 zI(>E4qI)lzrk+a{eYEDBC2A0FcLU;TqBt{m^99=Ynd1>h8tT^{!;yV9depWHFyC-If&Z2fORPjkYfF zQ9{(_YE*bX-Tmb2S3~U6&QzcTi@@=+kzVP}$4Rxn+k*RBjN2HH)vdm(q}Fbn;IecG vxmI`L$a{E~@g{#EHRZb4IP{x0J+*%KA-(UO-M74_6Gx_=IenIQt_}Y`ye2Al 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