extra/base91/base91.factor

   1 ! Copyright (C) 2019 John Benediktsson.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: base64.private byte-arrays kernel kernel.private
   4 literals math sequences ;
   5 IN: base91
   6
   7 ERROR: malformed-base91 ;
   8
   9 <PRIVATE
  10
  11 <<
  12 CONSTANT: alphabet $[
  13     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$%&()*+,./:;<=>?@[]^_`{|}~\""
  14     >byte-array
  15 ]
  16 >>
  17
  18 : ch>base91 ( ch -- ch )
  19     alphabet nth ; inline
  20
  21 : base91>ch ( ch -- ch )
  22     $[ alphabet alphabet-inverse ] nth
  23     [ malformed-base91 ] unless* { fixnum } declare ; inline
  24
  25 PRIVATE>
  26
  27 :: >base91 ( seq -- base91 )
  28     0 :> b!
  29     0 :> n!
  30     BV{ } clone :> accum
  31
  32     seq [
  33         n shift b bitor b!
  34         n 8 + n!
  35         n 13 > [
  36             b 0x1fff bitand dup 88 > [
  37                 b -13 shift b!
  38                 n 13 - n!
  39             ] [
  40                 drop b 0x3fff bitand
  41                 b -14 shift b!
  42                 n 14 - n!
  43             ] if 91 /mod swap [ ch>base91 accum push ] bi@
  44         ] when
  45     ] each
  46
  47     n 0 > [
  48         b 91 mod ch>base91 accum push
  49         n 7 > b 90 > or [
  50             b 91 /i ch>base91 accum push
  51         ] when
  52     ] when
  53
  54     accum B{ } like ;
  55
  56 :: base91> ( base91 -- seq )
  57     f :> v!
  58     0 :> b!
  59     0 :> n!
  60     BV{ } clone :> accum
  61
  62     base91 [
  63         base91>ch
  64         v [
  65             91 * v + v!
  66             v n shift b bitor b!
  67             v 0x1fff bitand 88 > 13 14 ? n + n!
  68             [ n 7 > ] [
  69                 b 0xff bitand accum push
  70                 b -8 shift b!
  71                 n 8 - n!
  72             ] do while
  73             f v!
  74         ] [
  75             v!
  76         ] if
  77     ] each
  78
  79     v [
  80         b v n shift bitor 0xff bitand accum push
  81     ] when
  82
  83     accum B{ } like ;