base92: adding Base92 encoding/decoding

factor · Dec 7, 2024 · a5c9ae6 · a5c9ae6
1 parent a75eced
commit a5c9ae6
Show file tree

Hide file tree

Showing 6 changed files with 134 additions and 0 deletions.
diff --git a/basis/base92/authors.txt b/basis/base92/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/basis/base92/base92-docs.factor b/basis/base92/base92-docs.factor
@@ -0,0 +1,20 @@
+USING: help.markup help.syntax sequences ;
+IN: base92
+
+HELP: >base92
+{ $values { "seq" sequence } { "base92" sequence } }
+{ $description "Encode into Base92 encoding." } ;
+
+HELP: base92>
+{ $values { "base92" sequence } { "seq" sequence } }
+{ $description "Decode from Base92 encoding." } ;
+
+ARTICLE: "base92" "Base92 conversions"
+"The " { $vocab-link "base92" } " vocabulary supports encoding and decoding of the Base92 format:"
+$nl
+{ $subsections
+    >base92
+    base92>
+} ;
+
+ABOUT: "base92"
diff --git a/basis/base92/base92-tests.factor b/basis/base92/base92-tests.factor
@@ -0,0 +1,26 @@
+USING: base92 byte-arrays kernel sequences tools.test ;
+
+{ t } [ 256 <iota> >byte-array dup >base92 base92> = ] unit-test
+
+{ "Fc_$aOTdKnsM*k" } [ "hello world" >base92 "" like ] unit-test
+{ "hello world" } [ "Fc_$aOTdKnsM*k" base92> "" like ] unit-test
+
+{ "~" } [ f >base92 "" like ] unit-test
+{ "!!" } [ B{ 0 } >base92 "" like ] unit-test
+{ "D," } [ "a" >base92 "" like ] unit-test
+{ "D82" } [ "ab" >base92 "" like ] unit-test
+{ "D8<q" } [ "abc" >base92 "" like ] unit-test
+{ "D8<rF" } [ "abcd" >base92 "" like ] unit-test
+{ "D8<rU3B" } [ "abcde" >base92 "" like ] unit-test
+{ "D8<rU3ay" } [ "abcdef" >base92 "" like ] unit-test
+{ "D8<rU3b#>" } [ "abcdefg" >base92 "" like ] unit-test
+
+{ B{ } } [ f base92> ] unit-test
+{ "\0" } [ "!!" base92> "" like ] unit-test
+{ "a" } [ "D," base92> "" like ] unit-test
+{ "ab" } [ "D82" base92> "" like ] unit-test
+{ "abc" } [ "D8<q" base92> "" like ] unit-test
+{ "abcd" } [ "D8<rF" base92> "" like ] unit-test
+{ "abcde" } [ "D8<rU3B" base92> "" like ] unit-test
+{ "abcdef" } [ "D8<rU3ay" base92> "" like ] unit-test
+{ "abcdefg" } [ "D8<rU3b#>" base92> "" like ] unit-test
diff --git a/basis/base92/base92.factor b/basis/base92/base92.factor
@@ -0,0 +1,85 @@
+! Copyright (C) 2019 John Benediktsson.
+! See https://factorcode.org/license.txt for BSD license.
+USING: base64.private byte-arrays combinators kernel
+kernel.private literals math sequences sequences.private ;
+IN: base92
+
+ERROR: malformed-base92 ;
+
+<PRIVATE
+
+<<
+CONSTANT: alphabet $[
+    "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_abcdefghijklmnopqrstuvwxyz{|}"
+    >byte-array
+]
+>>
+
+: ch>base92 ( ch -- ch )
+    alphabet nth ; inline
+
+: base92>ch ( ch -- ch )
+    $[ alphabet alphabet-inverse ] nth
+    [ malformed-base92 ] unless* { fixnum } declare ; inline
+
+PRIVATE>
+
+:: >base92 ( seq -- base92 )
+    0 :> b!
+    0 :> n!
+    BV{ } clone :> accum
+
+    seq [
+        b 8 shift bitor b!
+        n 8 + n!
+        n 13 >= [
+            b n 13 - neg shift 0x1fff bitand
+            91 /mod [ ch>base92 accum push ] bi@
+            n 13 - n!
+        ] when
+    ] each
+
+    n 0 > [
+        n 7 < [
+            b 6 n - shift 0x3f bitand ch>base92 accum push
+        ] [
+            b 13 n - shift 0x1fff bitand
+            91 /mod [ ch>base92 accum push ] bi@
+        ] if
+    ] when
+
+    accum [ CHAR: ~ 1byte-array ] [ B{ } like ] if-empty ;
+
+:: base92> ( base92 -- seq )
+    base92 length :> len
+    {
+        { [ len 0 = ] [ B{ } clone ] }
+        { [ len 1 = base92 first CHAR: ~ = and ] [ B{ } clone ] }
+        { [ len 2 < ] [ f ] }
+        [
+            0 :> b!
+            0 :> n!
+            BV{ } clone :> accum
+
+            len 2/ <iota> [
+                2 * dup 1 + [ base92 nth-unsafe base92>ch ] bi@
+                [ 91 * ] dip + b 13 shift bitor b!
+                n 13 + n!
+                [ n 8 >= ] [
+                    b n 8 - neg shift 0xff bitand accum push
+                    n 8 - n!
+                ] while
+            ] each
+
+            len odd? [
+                len 1 - base92 nth-unsafe base92>ch b 6 shift bitor b!
+                n 6 + n!
+                [ n 8 >= ] [
+                    b n 8 - neg shift 0xff bitand accum push
+                    n 8 - n!
+                ] while
+            ] when
+
+            accum B{ } like
+        ]
+    } cond ;
diff --git a/basis/base92/summary.txt b/basis/base92/summary.txt
@@ -0,0 +1 @@
+Base92 encoding/decoding
diff --git a/basis/base92/tags.txt b/basis/base92/tags.txt
@@ -0,0 +1 @@
+parsing