extra/punycode/punycode.factor

   1 ! Copyright (C) 2020 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors ascii byte-arrays combinators kernel literals
   5 math math.order sbufs sequences sequences.extras sets sorting
   6 splitting urls ;
   7
   8 IN: punycode
   9
  10 <PRIVATE
  11
  12 <<
  13 CONSTANT: BASE   36
  14 CONSTANT: TMIN   1
  15 CONSTANT: TMAX   26
  16 CONSTANT: SKEW   38
  17 CONSTANT: DAMP   700
  18 CONSTANT: BIAS   72
  19 CONSTANT: N      128
  20 CONSTANT: DIGITS $[ "abcdefghijklmnopqrstuvwxyz0123456789" >byte-array ]
  21 >>
  22
  23 : threshold ( j bias -- T )
  24     [ BASE * ] [ - ] bi* TMIN TMAX clamp ;
  25
  26 :: adapt ( delta! #chars first? -- bias )
  27     delta first? DAMP 2 ? /i delta!
  28     delta dup #chars /i + delta!
  29     0 [ delta $[ BASE TMIN - TMAX * 2 /i ] > ] [
  30         delta $[ BASE TMIN - ] /i delta!
  31         BASE +
  32     ] while BASE delta * delta SKEW + /i + ;
  33
  34 : segregate ( str -- base extended )
  35     [ N < ] partition members natural-sort ;
  36
  37 :: find-pos ( str ch i pos -- i' pos' )
  38     i pos 1 + str [
  39         ch <=> {
  40             { +eq+ [ 1 + t ] }
  41             { +lt+ [ 1 + f ] }
  42             [ drop f ]
  43         } case
  44     ] find-from drop [ drop -1 -1 ] unless* ;
  45
  46 :: insertion-unsort ( str extended -- deltas )
  47     V{ } clone :> accum
  48     N :> oldch!
  49     -1 :> oldi!
  50     extended [| ch |
  51         -1 :> i!
  52         -1 :> pos!
  53         str [ ch < ] count :> curlen
  54         curlen 1 + ch oldch - * :> delta!
  55         [
  56             str ch i pos find-pos pos! i!
  57             i -1 = [
  58                 f
  59             ] [
  60                 i oldi - delta + delta!
  61                 delta 1 - accum push
  62                 i oldi!
  63                 0 delta!
  64                 t
  65             ] if
  66         ] loop
  67         ch oldch!
  68     ] each accum ;
  69
  70 :: encode-delta ( delta! bias -- seq )
  71     SBUF" " clone :> accum
  72     0 :> j!
  73     [
  74         j 1 + j!
  75         j bias threshold :> T
  76         delta T < [
  77             f
  78             delta
  79         ] [
  80             t
  81             delta T - BASE T - /mod T + swap delta!
  82         ] if DIGITS nth accum push
  83     ] loop accum ;
  84
  85 :: encode-deltas ( baselen deltas -- seq )
  86     SBUF" " clone :> accum
  87     BIAS :> bias!
  88     deltas [| delta i |
  89         delta bias encode-delta accum push-all
  90         delta baselen i + 1 + i 0 = adapt bias!
  91     ] each-index accum ;
  92
  93 PRIVATE>
  94
  95 :: >punycode ( str -- punicode )
  96     str segregate :> ( base extended )
  97     str extended insertion-unsort :> deltas
  98     base length deltas encode-deltas
  99     base [ "-" rot 3append ] unless-empty "" like ;
 100
 101 <PRIVATE
 102
 103 ERROR: invalid-digit char ;
 104
 105 : decode-digit ( ch -- digit )
 106     {
 107         { [ dup LETTER? ] [ CHAR: A - ] }
 108         { [ dup digit? ] [ CHAR: 0 26 - - ] }
 109         [ invalid-digit ]
 110     } cond ;
 111
 112 :: decode-delta ( extended extpos! bias -- extpos' delta )
 113     0 :> delta!
 114     1 :> w!
 115     0 :> j!
 116     [
 117         j 1 + j!
 118         j bias threshold :> T
 119         extpos extended nth decode-digit :> digit
 120         extpos 1 + extpos!
 121         digit w * delta + delta!
 122         BASE T - w * w!
 123         digit T >=
 124     ] loop extpos delta ;
 125
 126 ERROR: invalid-character char ;
 127
 128 :: insertion-sort ( base extended -- base )
 129     N :> ch!
 130     -1 :> pos!
 131     BIAS :> bias!
 132     0 :> extpos!
 133     extended length :> extlen
 134     [ extpos extlen < ] [
 135         extended extpos bias decode-delta :> ( newpos delta )
 136         delta 1 + pos + pos!
 137         pos base length 1 + /mod pos! ch + ch!
 138         ch 0x10FFFF > [ ch invalid-character ] when
 139         ch pos base insert-nth!
 140         delta base length extpos 0 = adapt bias!
 141         newpos extpos!
 142     ] while base ;
 143
 144 PRIVATE>
 145
 146 : punycode> ( punycode -- str )
 147     CHAR: - over last-index [
 148         ! FIXME: assert all non-basic code-points
 149         [ head >sbuf ] [ 1 + tail ] 2bi >upper
 150     ] [
 151         SBUF" " clone swap >upper
 152     ] if* insertion-sort "" like ;
 153
 154 GENERIC: idna> ( punycode -- obj )
 155
 156 M: object idna>
 157     "." split [
 158         "xn--" ?head [ punycode> ] when
 159     ] map "." join ;
 160
 161 M: url idna> [ idna> ] change-host ;
 162
 163 GENERIC: >idna ( obj -- punycode )
 164
 165 M: object >idna
 166     "." split [
 167         dup [ N < ] all? [
 168             >punycode "xn--" prepend
 169         ] unless
 170     ] map "." join ;
 171
 172 M: url >idna [ >idna ] change-host ;