1 ! Copyright (C) 2018, 2019 Alexander Ilin.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: ascii binary-search calendar endian kernel make math
4 math.bitwise math.order namespaces random sequences splitting
10 M: ulid-overflow summary drop "Too many ULIDs generated per msec" ;
14 CONSTANT: encoding "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
16 CONSTANT: 80-bits 0xFFFFFFFFFFFFFFFFFFFF
18 SYMBOL: last-time-string
19 SYMBOL: last-random-bits
21 : encode-bits ( n chars -- string )
22 [ base /mod encoding nth ] "" replicate-as nip reverse! ;
24 : encode-random-bits ( n -- string )
27 : encode-time ( timestamp -- string )
28 timestamp>millis 10 encode-bits ;
30 : same-millisecond? ( -- ? )
31 nano-count 1,000,000 /i dup \ same-millisecond? get =
32 [ drop t ] [ \ same-millisecond? set f ] if ;
34 : pack-bits ( seq -- seq' )
35 5 swap [ first ] [ rest ] bi [
36 [ ! can-take-bits overflow-byte elt
38 swap 5 shift bitor swap 5 - [ , 0 8 ] when-zero swap
40 3dup rot [ shift ] [ 5 - shift ] bi-curry bi* bitor ,
41 nip 5 rot - [ bits 8 ] keep - swap
46 TR: (normalize-ulid) "ILO" "110" ; inline
48 : (ulid) ( same-millisecond? -- ulid )
50 last-time-string get last-random-bits get 1 +
51 dup 80-bits > [ ulid-overflow ] when
53 now encode-time dup last-time-string set
55 ] if dup last-random-bits set encode-random-bits append ;
60 same-millisecond? (ulid) ;
62 ERROR: ulid>bytes-bad-length n ;
63 M: ulid>bytes-bad-length summary drop "Invalid ULID length" ;
65 ERROR: ulid>bytes-bad-character ch ;
66 M: ulid>bytes-bad-character summary drop "Invalid character in ULID" ;
68 ERROR: ulid>bytes-overflow ;
69 M: ulid>bytes-overflow summary drop "Overflow error in ULID" ;
71 : ulid>bytes ( ulid -- byte-array )
72 dup length dup 26 = [ drop ] [ ulid>bytes-bad-length ] if
74 dup [ >=< ] curry encoding swap search pick =
75 [ nip ] [ drop ulid>bytes-bad-character ] if
76 ] B{ } map-as dup first 7 > [ ulid>bytes-overflow ] when pack-bits ;
78 : normalize-ulid ( str -- str' )
79 >upper (normalize-ulid) ;
81 ERROR: bytes>ulid-bad-length n ;
82 M: bytes>ulid-bad-length summary drop "Invalid ULID byte-array length" ;
84 : bytes>ulid ( byte-array -- ulid )
85 dup length dup 16 = [ drop ] [ bytes>ulid-bad-length ] if