import case import math ; divmod, ilog, max, pow import stack ; to_a import util ; gt, lt, neq, range

;;; String packing and unpacking

; convert a 0-terminated string on the stack to a single base-128 integer ; [0 … c b a] => [“abc…”] ; ; [0 99 98 97] => [“abc”] ; [0 99 98 97] => [1634657] ; [0] => [0] strpack: push 0 ; accumulator _strpack_loop:

swap dup jz _strpack_done
copy 1 push 128 mul add slide 1
jump _strpack_loop

_strpack_done: pop :strrev ret

; convert a single base-128 integer to a 0-terminated string on the stack ; [“abc…”] => [0 … c b a] ; ; [“abc”] => [0 99 98 97] ; [1634657] => [0 99 98 97] ; [0] => [0] strunpack: :strrev push 0 swap ; terminator _strunpack_loop:

dup jz _strunpack_done
dup push 128 mod swap push 128 div
jump _strunpack_loop

_strunpack_done: pop ret

; returns the length of a packed string, which is just the ; value itself log-128, +1 if the integer logarithm isn't exact. ; [S] => [len(S)] ; ; [“”] => [0] ; [“abc”] => [3] ; [“foobar”] => [6] strlen: dup push 128 :ilog swap push 128 mod push 0 :neq add ret

; takes two packed strings and returns their concatenation (as a packed string) ; [S T] => [S+T] ; ; [“foo” “”] => [“foo”] ; [“” “foo”] => [“foo”] ; [“foo” “bar”] => [“foobar”] strcat: push 128 copy 2 :strlen :pow mul add ret

; reverses a packed string “in-place” ; [S] => [S'] ; ; [“foo”] => [“oof”] ; [“bark”] => [“krab”] ; [“ab”] => [“ba”] ['a'] => ['a'] [“”] => [“”] strrev: push 0 swap _strrev_loop:

dup jz _strrev_done
swap push 128 mul
copy 1 push 128 mod add
swap push 128 div
jump _strrev_loop

_strrev_done: pop ret

; takes a packed string S, a start index I, and a length L and returns the ; corresponding substring (simply by doing division with powers of 128; neat) ; [S I L] => [S'] ; ; [“foobar” 0 6] => [“foobar”] ; [“foobar” 1 4] => [“ooba”] ; [“foobar” 1 10] => [“oobar”] ; [“foobar” 5 1] => ['r'] ; [“foobar” 6 0] => [“”] strslice:

swap push 128 swap :pow
copy 2 swap div
swap push 128 swap :pow
mod slide 1 ret

; returns the index I of substring T in string S (or -1 if not found) ; [S T] => [I] ; ; [“foobar” 'o'] => [1] ; [“foobar” “ob”] => [2] ; [“foobar” “”] => [0] ; [“foobar” “bar”] => [3] ; [“foobar” “bark”] => [-1] strindex: swap push 0 _strindex_loop: ; [t s i]

copy 1 copy 3 :strlen push 0 swap :strslice
copy 3 sub jz _strindex_found
push 1 add swap push 128 div dup jz _strindex_no
swap jump _strindex_loop

_strindex_no: push -1 slide 3 ret _strindex_found: slide 2 ret

; returns the character C at index I in string S ; [S I] => [C] ; ; [“foobar” 1] => ['o'] ; [“foobar” 3] => ['b'] ; [“foobar” 5] => ['r'] ; [“foobar” 6] => [“”] charat: push 1 :strslice ret

; returns 1 if the character at the top of the stack is ; alphabetical (ASCII 65-90 or 97-122), 0 otherwise ; [C] => [0 | 1] ; ; ['@'] => [0] ['a'] => [1] ; ['z'] => [1] ['['] => [0] ; ['`'] => [0] ['A'] => [1] ; ['Z'] => [1] ['{'] => [0] isalpha:

dup push 123 :lt jz _isalpha_no
dup push 64 :gt jz _isalpha_no
push 32 mod $-- push 32 mod push 26 :lt ret

_isalpha_no: dup sub ret

; returns string S replicated N times ; [S N] => [S'] ; ; [“abc” 1] => [“abc”] ; [“abc” 2] => [“abcabc”] ; [“abc” 0] => [“”] strrep: push 0 swap _strrep_loop:

dup jz _strrep_done
swap copy 2 :strcat
swap push 1 sub jump _strrep_loop

_strrep_done: swap slide 2 ret

;;; String alignment

; helper function for ljustc and rjustc, since the only difference is whether ; we swap before calling strcat. _justc: swap copy 2 :strlen sub push 0 :max :strrep ret

; left-justifies string S to width W with character C ; [S W C] => [S'] ; ; [“foo” 5 'x'] => [“fooxx”] ; [“foobar” 4 'x'] => [“foobar”] ; [“” 3 'x'] => [“xxx”] ljustc: :_justc :strcat ret

; left-justifies string S to width W with spaces ; [S W] => [S'] ; ; [“foo” 5] => [“foo ”] ; [“foobar” 4] => [“foobar”] ; [“” 3] => [528416] ljust: push ' ' :ljustc ret

; right-justifies string S to width W with character C ; [S W C] => [S'] ; ; [“foo” 5 'x'] => [“xxfoo”] ; [“foobar” 4 'x'] => [“foobar”] ; [“” 3 'x'] => [“xxx”] rjustc: :_justc swap :strcat ret

; right-justifies string S to width W with spaces ; [S W C] => [S'] ; ; [“foo” 5] => [“ foo”] ; [“foobar” 4] => [“foobar”] ; [“” 3] => [528416] rjust: push ' ' :rjustc ret

; centers string S to width W with character C, favoring left alignment when ; there's a parity mismatch (even-length string to odd width or vice versa) ; ! TODO: This seems unnecessarily intricate, but perhaps just its nature. ; [S W C] => [S'] ; ; [“abc” 7 'x'] => [“xxabcxx”] ; [“abc” 6 'x'] => [“xabcxx”] ; [“abcd” 6 'o'] => [“oabcdo”] ; [“abcd” 7 'o'] => [“oabcdoo”] ; [“abcd” 3 '!'] => [“abcd”] centerc:

swap dup copy 3 :strlen sub
push 0 :max push 2 div
copy 2 swap :strrep
copy 3 :strcat
swap copy 1 :strlen sub
push 0 :max
copy 2 swap :strrep :strcat
slide 2 ret

; centers string S to width W with spaces ; [S W] => [S'] ; ; [“abc” 7] => [“ abc ”] ; [“abc” 6] => [“ abc ”] ; [“abcd” 6] => [“ abcd ”] ; [“abcd” 7] => [“ abcd ”] ; [“abcd” 3] => [“abcd”] center: push ' ' :centerc ret

;;;

; removes the last character of a string ; [S] => [S'] ; ; [“foobar”] => [“fooba”] ; [“abc”] => [“ab”] ; [“a”] => [“”] ; [“”] => [“”] strchop: dup jz _strchop_empty

dup :strlen push 1 sub push 0 swap :strslice ret

_strchop_empty: ret

; splits string S on delimiting character C, leaving the resultant substrings ; on the stack as a pseudo-array (length at top of stack) ; ! TODO: permit string delimiter ; ! clobbers heap addresses -1 (strlen), -2, and -3 ; [S C] => [A] ; ; [“fooxbar” 'x'] => [“foo” “bar” 2] ; [“foobar” 'x'] => [“foobar” 1] ; [“foo|bar|baz” '|'] => [“foo” “bar” “baz” 3] ; [“foo,,bar” ','] => [“foo” “” “bar” 3] ; [“/foo/bar/” '/'] => [“” “foo” “bar” “” 4] strsplit:

push -3,1 store ; number of found substrings
^-2 ; stash delimiter to allow some stack juggling

_strsplit_loop:

dup dup @-2
:strindex dup jn _strsplit_done ; done when index of delimiter is -1
push 0 swap :strslice
swap copy 1 @-3
swap :strlen
swap push -3 swap push 1 add store ; update number of found
push 1 add push 128 swap :pow div ; shrink haystack
jump _strsplit_loop

_strsplit_done: push 2 sub slide 1 load ret

; splits the string S on newlines lines: push 10 :strsplit ret

; joins the pseudo-array of strings A into string S with delimiter string D ; ! clobbers heap address -2 (and strlen uses -1) ; [A D] => [S] ; ; [“foo” “bar” 2 'x'] => [“fooxbar”] ; [“foo” “bar” “baz” 3 '–'] => [“foo–bar–baz”] ; [“foo” 1 “?!”] => [“foo”] strjoinc:

dup :strlen pop ^-2 ; get delimiter length into -1
map (@-2 :strcat) ; add delimiter to all elements
swap push 128 copy 1 :strlen
@-2 :strlen
sub :pow mod swap ; remove delimiter from last and flow into strjoin

; concatenates the pseudo-array of strings A into string S ; [A] => [S] ; ; [“foo” 1] => [“foo”] ; [“foo” “bar” 2] => [“foobar”] ; [“foo” 'x' “bar” 'x' “baz” 5] => [“fooxbarxbaz”] strjoin: reduce (:strcat) ret

; returns the number of ocurrences of character C in string S ; [S C] => [N] ; ; [“foobar” 'a'] => [1] ; [“foobar” 'o'] => [2] ; [“foobar” 'c'] => [0] strcountc: swap push 0 swap _strcountc_loop:

dup jz _strcountc_done
dup push 128 mod copy 3 sub jz _strcountc_yes
push 128 div jump _strcountc_loop

_strcountc_yes:

swap push 1 add swap push 128 div
jump _strcountc_loop

_strcountc_done: swap slide 2 ret

; returns the total number of ocurrences of all characters in string T in string S ; [S T] => [N] ; ! clobbers heap address -2 ; ; [“foobar” 'o'] => [2] ; [“foobar” “ob”] => [3] ; [“foxboar” “box”] => [4] ; [“eunoia” “aeiou”] => [5] ; [“why” “aeiou”] => [0] strcount:

swap ^-2 :strunpack push 0 :to_a
map (@-2 swap :strcountc)
reduce (add) ret

; translates all characters in A to the corresponding characters in B ; in string S, ; similar to the `tr` utility in Unix. A and B must be ; of the same length. TODO: make this smarter (ranges, length mismatch) ; ! clobbers heap addresses -1, -2, and -3 ; [S A B] => [S'] ; ; [“abcd” “abc” “xyz”] => [“xyzd”] ; [“foobar” “oba” “ele”] => [“feeler”] ; [“abcdcba” “abcd” “xyz|”] => [“xyz|zyx”] strtrans: ^-3 ^-2

dup :strlen ^-1 :strunpack @-1
map (:_strtrans) pop :strpack ret

_strtrans:

dup @-2 swap :strindex
dup jn _strtrans_no
@-3 swap :charat
slide 1 ret

_strtrans_no: pop ret

; expands the length-2 string S to contain the intervening ASCII characters ; ! TODO: make this smarter; multiple ranges in one string ; [S] => [S'] ; ; [“CJ”] => [“CDEFGHIJ”] ; [“DA”] => [“DCBA”] ; [“af”] => [“abcdef”] ; [“09”] => [“0123456789”] ; [“90”] => [“9876543210”] ; [“(1”] => [“()*+,-./01”] strexpand:

push 0 swap push 128 :divmod
swap :range :strpack :strrev ret

; “squeezes” runs of the same character in string S to just one occurrence ; [S] => [S'] ; ; [“abc”] => [“abc”] ; [“foobar”] => [“fobar”] ; [“bookkeeper”] => [“bokeper”] ; [“xxxxxxx”] => [“x”] strsqueeze: push 0 swap _strsqueeze_loop: ; [s]

dup jz _strsqueeze_done
push 128 :divmod dup copy 3 sub jz _strsqueeze_skip
swap jump _strsqueeze_loop

_strsqueeze_skip: pop jump _strsqueeze_loop _strsqueeze_done: pop :strpack :strrev ret

$_strdel(cmp) {

:strunpack @-1 :strlen
select (@-2 swap :strindex `cmp`)
pop :strpack ret

}

; returns the string S with all characters in string T removed, like `tr -d`. ; If the first character of T is '^', instead only those characters are kept. ; [S T] => [S'] ; ; [“abc123” “abc”] => [“123”] ; [“abc123” “123”] => [“abc”] ; [“abcba12321” “abc”] => [“12321”] ; [“abc12321cba” “^2ac”] => [“ac22ca”] ; [“facetious” “^aeiou”] => [“aeiou”] strdel: push -1 copy 2 store push -2 copy 1 store

push 0 :charat push '^' :neq jz _strdel_comp $_strdel(:neg?)

_strdel_comp: $_strdel(:pos?)

; returns the sum of the ordinal values of the characters in string S ; [S] => [N] ; ; [“ABC”] => [198] ; [“012”] => [147] ; [“a”] => [97] ; [“”] => [0] strsum: dup jz _strsum_empty

:strunpack push 0 :to_a reduce (add) ret

_strsum_empty: ret

; rotates the string S to the left N times, wrapping ; [S N] => [S'] ; ; [“abc” 0] => [“abc”] ; [“abcd” 1] => [“bcda”] ; [“abcd” 5] => [“bcda”] ; [“foodbar” 4] => [“barfood”] strrotl: push 128 swap copy 2 :strlen mod :pow :divmod :strcat ret

; rotates the string S to the right N times, wrapping ; [S N] => [S'] ; ; [“abcd” 1] => [“dabc”] ; [“abcd” 5] => [“dabc”] ; [“foodbar” 3] => [“barfood”] strrotr: push -1 mul :strrotl ret

; gets the characters of the string S onto the stack as a pseudo-array, but ; with a leading 0 on the assumption that it'll eventually be repacked ; ; [“abc”] => [0 99 98 97 3] strtoa: dup :strlen pop :strunpack @-1 $++ ret

; frobnicates the string S by XORing all its bytes with 42 ; [S] => [S'] ; ; [“foobar”] => [“LEEHKX”] ; [“LEEHKX”] => [“foobar”] memfrob: :strtoa map (push 42 :bxor) pop :strpack ret

; returns 1 if the string S begins with substring T, 0 otherwise ; [S T] => [0 | 1] ; ; [“foobar” “foo”] => [1] ; [“foobar” “boo”] => [0] ; [“abc123” “123”] => [0] ; [“ foo” “ ”] = [1] strbegins?:

dup :strlen copy 2 swap push 0 swap
:strslice :eq slide 1 ret

; returns 1 if the string S ends with substring T, 0 otherwise ; [S T] => [0 | 1] ; ; [“foobar” “bar”] => [1] ; [“foobar” “foo”] => [0] ; [“abc123” “abc”] => [0] ; [“foo ” “ ”] = [1] strends?:

:strrev dup :strlen copy 2 :strrev swap push 0 swap
:strslice :eq slide 1 ret