fstr
Description of the page content
Forth tools to manipulate text strings.
fstr is a text string toolkit written in Forth. It was born in 2001 as part of my program eeo (not yet published), the first application I wrote to create HTML pages from contents and data stored in text files.
In order to use the tool words in other Forth programs, I extracted the code and created fstr. Since then I made some changes and improvements. Sometimes I still use some of its algorithms in other Forth programs of mine. Nevertheless, there's a Forth modern library with advanced words for manipulating text strings and do many other things: Forth Foundation Library.
Source code
\ -------------------------------------------------------
CR .( fstr )
\ -------------------------------------------------------
\ Copyright (C) 2001, 2006, 2010 Marcos Cruz (http://programandala.net)
\ Licencia/Permesilo/License: http://programandala.net/license
\ Herramientas para manipular de cadenas de texto.
\ Tekstochenaj manipuliloj.
\ Text string manipulation tools.
\ Programa escrito Forth. Probado con Gforth y Forth 5mx.
\ Programo verkita en Fortho. Provita per Gforth kaj Forth 5mx.
\ Program written in Forth. Tested with Gforth and Forth 5mx.
\ Nota: Los comentarios aún no están homogeneizados: algunos están en una lengua, otros en dos y otros en tres.
\ Noto: La komentoj ankoraw ne homogenas: ili unu-, du- aw tri-lingvas.
\ Note: The comments are not homogenized yet: some of them are in one language, some of them in two languages and some of them in three languages.
\ -------------------------------------------------------
\ Por hacer / Farenda / To do :
\ -------------------------------------------------------
\ Cambiar el orden de los parámetros en ($mid) .
\ Documentar de forma estándar las notas de la pila.
\ Documentar también en inglés y castellano las palabras.
\ Comprobar str-divide-at? .
\ -------------------------------------------------------
\ Historial / Historio / History
\ -------------------------------------------------------
\ 2010-10-22
\ New word str-slice-exchange .
\ 2006-12-31
\ New alias $count and $place .
\ New word $constant .
\ $variable fixed with align .
\ Modified the order of the max lenght and count.
\ 2006-07-09
\ New word char>char .
\ 2006-07-02
\ str-1 renamed b>str .
\ 2006-01-23
\ New word last-char-in-str .
\ New word /str-at .
\ New word /char-in-str .
\ New word /last-char-in-str .
\ 2006-01-22
\ New word char-in-str .
\ 2005-10
\ Todas las palabras ordenadas por categorías y renombradas en inglés.
\ Chiuj vortojn fake ordigitaj kaj angle nomitaj.
\ All words sorted by categories and renamed in English.
\ 2001
\ Primera versión escrita como parte del programa "eeo".
\ Unua versio verkita ere de la programo "eeo".
\ First version written as part of the "eeo" program.
\ -------------------------------------------------------
MARKER fstr
\ -------------------------------------------------------
\ Variables de texto
\ Tekstaj variabloj
\ String variables
\ -------------------------------------------------------
: 'max-$len ( $a -- a )
\ Devuelve la dirección de la longitud máxima de una variable de texto.
\ Redonu la adreson de la maksimuma longo de teksta variablo.
\ Return the address of the max lenght of a text variable.
1 CELLS -
;
: max-$len ( $a -- u )
\ Devuelve la longitud máxima de una variable de texto.
\ Redonu la maksimuman longon de teksta variablo.
\ Return the max lenght of a text variable.
'max-$len @
;
: '$len ( $a -- a )
\ Devuelve la dirección de la longitud de una variable de texto.
\ Redonu la adreson de la longo de teksta variablo.
\ Return the address of the lenght of a text variable.
\ 0 CELLS +
;
: $len ( $a -- u )
\ Devuelve la longitud de una variable de texto.
\ Redonu la longon de teksta variablo.
\ Return the lenght of a text variable.
'$len @
;
: '$txt ( $a -- a )
\ Devuelve la dirección del contenido de una variable de texto.
\ Redonu la adreson de la enhavo de teksta variablo.
\ Return the address of the content of a text variable.
CELL+
;
: $@ ( $a -- c-addr u )
\ Devuelve el contenido de una variable de texto.
\ Redonu la enhavon de teksta variablo.
\ Return the content of a text variable.
DUP '$txt SWAP $len
;
' $@ alias $count
: $constant ( c-addr u -- )
\ Crea una constante de texto.
\ Kreu tekstan konstanton.
\ Create text constant.
\ c-addr u = text
CREATE DUP , HERE OVER CHARS ALLOT ALIGN
SWAP CMOVE
DOES> $count
;
: $variable ( u -- )
\ Crea una variable de texto.
\ Kreu tekstan variablon.
\ Create text variable.
\ u = longitud máxima / maksimuma longo / max length
CREATE DUP , 0 , CHARS ALLOT ALIGN
DOES> 1 CELLS +
;
: $@max ( $a -- c-addr u )
\ Devuelve el contenido máximo de una variable de texto.
\ Redonu la maksimuman enhavon de teksta variablo.
\ Return the max content of a text variable.
DUP '$txt SWAP max-$len
;
: $erase ( $a -- )
\ Borra una variable de texto y pone su longitud a cero.
\ Forvishu kaj igu tekstan variablon longa je nulo.
\ Erase a text variable and make its lenght null.
DUP $@max ERASE
0 SWAP '$len !
;
: $blank ( $a -- )
\ Llena una variable de texto con espacios.
\ Plenigu tekstan variablon per spacoj.
\ Fill a text variable with spaces.
$@max BLANK
;
: $! ( c-addr u $a -- )
\ Guarda un texto en una variable de texto.
\ Enmetu tekston en tekstan variablon.
\ Store text into a text variable.
DUP $blank
DUP max-$len ROT MIN
2DUP SWAP '$len !
SWAP '$txt SWAP CMOVE
;
' $! alias $place
: str! ( c-addr1 u1 c-addr2 -- )
\ Guarda texto en una dirección.
\ Enmetu tekston en adreson.
\ Store text into an address.
2DUP C! 1+ SWAP CMOVE
;
: $type ( $a -- )
\ Imprime el contenido de una variable de texto.
\ Printu la enhavon de teksta variablo.
\ Print the content of a text variable.
$@ TYPE
;
\ -------------------------------------------------------
\ Búfer circular de texto
\ Cirkla teksta bufro
\ Circular text buffer
\ -------------------------------------------------------
[undefined] >sbuffer [if]
S" sbuffer.fs" INCLUDED
[then]
\ -------------------------------------------------------
\ Cadenas especiales
\ Specialaj chenoj
\ Special strings
\ -------------------------------------------------------
: b>str ( c -- c-addr 1 )
\ Devuelve un texto a partir de un caracter.
\ Redonu tekston el signo.
\ Return a text from a char.
1 +sbuffer C! sbuffer 1 sbuffer+
;
: str-space ( -- c-addr 1 )
\ Devuelve un texto con un espacio.
\ Redonu unuspacan tekston.
\ Return a one space text.
BL b>str
;
: str-tab ( -- c-addr 1 )
\ 2004 03 19
\ Devuelve un texto con un tabulador.
\ Redonu unutabulatoran tekston.
\ Return a one tab text.
9 b>str
;
: str-quotes ( -- c-addr 1 )
\ Devuelve un texto con unas comillas.
\ Redonu tekston el citiloj.
\ Return a text with quotes.
[CHAR] " b>str
;
\ -------------------------------------------------------
\ Comparación
\ Komparo
\ Comparation
\ -------------------------------------------------------
[undefined] str= [IF]
: str= ( c-addr1 u1 c-addr2 u2 -- f )
\ Comprueba si dos cadenas son idénticas.
\ Kontrolas, chu du chenoj identas.
\ Test whether two strings are identical.
COMPARE 0=
;
[THEN]
[undefined] str< [IF]
: str< \ gforth
( c-addr1 u1 c-addr2 u2 -- f )
COMPARE 0<
;
[THEN]
[undefined] str-prefix? [IF]
: str-prefix? \ gforth
( c-addr1 u1 c-addr2 u2 -- f )
\ Is c-addr2 u2 a prefix of c-addr1 u1 ?
\ Better than my own solution, str-left? .
TUCK 2>R MIN 2R> str=
;
[THEN]
\ -------------------------------------------------------
\ Unión
\ Kunigo
\ Join
\ -------------------------------------------------------
[undefined] str+ [IF]
: str+ ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Une dos textos.
\ Unuigu du tekstojn.
\ Join two texts.
\ Old version.
\ 2008-04-27 Not used any more.
DUP 3 PICK + DUP >R \ longitud total / suma longo / total lenght
+sbuffer DROP
2SWAP DUP
>R sbuffer SWAP CHARS CMOVE
R> sbuffer + SWAP CHARS CMOVE
sbuffer R> sbuffer+
\ 2008-04-27 3.4% faster version.
\ Copied and modified from:
\ Forth Dimensions, volume XVIII, number 2 (July/August 1996), page 7
\ (c) 1996 Will Baden
\ http://forth.org/FD/
\ 2 PICK OVER + >R ( R: u3 )
\ R@ +sbuffer >R ( R: u3 c-addr3 )
\ 2 PICK CHARS R@ + ( c-addr1 u1 c-addr2 u2 c-addr3+u1)
\ SWAP CHARS CMOVE ( c-addr1 u1 )
\ R@ SWAP ( c-addr1 c-addr3 u1 )
\ CHARS CMOVE
\ R> R>
;
[THEN]
[undefined] +s [IF]
' str+ alias s+
[THEN]
\ -------------------------------------------------------
\ Sustitución
\ Anstatawigo
\ Exchange
\ -------------------------------------------------------
: str-exchange? ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- c-addr4 u4 f )
\ Anstatawigu subchenon en cheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcheno serchata por anstatawigo
\ c-addr3 u3 = cheno anstatawa
\ c-addr4 u4 = nova cheno
\ c-addr5 u5 = restanta parto el la cheno ekde la trovita subcheno
\ a6 u6 = restanta parto el la cheno post la trovita subcheno
\ u1' = longo de la cheno ghis la trovita subcheno
\ f = chu anstatawo farita?
\ f' = chu subcheno trovita?
2>R DUP >R ( c-addr1 u1 c-addr2 u2 ) ( R: c-addr3 u3 u2 )
2OVER 2SWAP SEARCH ( c-addr1 u1 c-addr5 u5 f' ) ( R: c-addr3 u3 u2 )
IF
SWAP >R ( c-addr1 u1 u5 ) ( R: c-addr3 u3 u2 a5 )
DUP >R - ( c-addr1 u1' ) ( R: c-addr3 u3 u2 c-addr5 u5 )
2R> R> ( c-addr1 u1' c-addr5 u5 u2 ) ( R: c-addr3 u3 )
DUP >R - ( c-addr1 u1' a5 u6 ) ( R: c-addr3 u3 u2 )
SWAP R> + SWAP ( c-addr1 u1' a6 u6 ) ( R: c-addr3 u3 )
2R> 2SWAP 2>R str+ 2R> str+ TRUE
ELSE
2DROP R> DROP 2R> 2DROP FALSE
THEN
;
: str-exchange ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- c-addr4 u4 )
\ Anstatawigu subchenon en cheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcheno serchata por anstatawigo
\ c-addr3 u3 = cheno anstatawa
\ c-addr4 u4 = nova cheno
str-exchange? DROP
;
: str-exchange-all ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- c-addr4 u4 )
\ Anstatawigu chiujn aperon de subcheno en cheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = cheno serchata por anstatawigo
\ c-addr3 u3 = cheno anstatawa
\ c-addr4 u4 = nova cheno
5 ROLL 5 ROLL ( c-addr2 u2 c-addr3 u3 c-addr1 u1 )
BEGIN
5 PICK 5 PICK 5 PICK 5 PICK ( c-addr2 u2 c-addr3 u3 c-addr1 u1 c-addr2 u2 c-addr3 u3 )
str-exchange? 0= ( c-addr2 u2 c-addr3 u3 c-addr4 u4 f )
UNTIL
2>R 2DROP 2DROP 2R>
;
: char>char ( c-addr u c1 c2 -- )
\ 2006-07-09
\ Cambia en la cadena indicada
\ todos los caracteres c1 por c2.
SWAP 2SWAP OVER + SWAP
DO
I C@ OVER =
IF OVER I C! THEN
LOOP
2DROP
;
: str-slice-exchange ( c-addr1 u1 u3 u4 c-addr2 u2 -- c-addr5 u5 )
\ Exchange slice in a string with a substring.
\ c-addr1 u1 = string
\ u3 = first char of the slice to delete (0...n)
\ u4 = last char of the slice to delete (0...n)
\ c-addr2 u2 = substring to insert
\ c-addr5 u5 = resulting string
\ 2010-10-22
2>r >r >r
over r> \ string before the slice
2swap
swap r@ + 1+ \ address of the string after the slice
swap r> - 1- \ length of the string after the slice
2swap 2r> str+ 2swap str+ \ join both strings with the substring
;
\ -------------------------------------------------------
\ Limpieza
\ Purigo
\ Cleaning
\ -------------------------------------------------------
: str-erase ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Forvishu chenon el alia.
\ c-addr1 u1 = cheno en kiu serchi
\ c-addr2 u2 = cheno serchota kaj forvishota
\ c-addr3 u3 = cheno sen la unua apero de la forvishenda cheno
s" " str-exchange
;
: str-erase-all ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )
\ Forvishu chiujn aperojn de cheno el alia.
\ c-addr1 u1 = cheno en kiu serchi
\ c-addr2 u2 = cheno serchota kaj forvishota
\ c-addr3 u3 = cheno sen chiuj aperoj de la forvishenda cheno
2SWAP
BEGIN
2OVER s" " str-exchange? 0=
UNTIL
2SWAP 2DROP
;
: -leading ( c-addr1 u1 -- c-addr2 u2 )
\ Forigu komencajn spacojn el cheno.
DUP
IF
2DUP 0
DO
DUP I + C@ BL <>
IF I + SWAP I - ROT LEAVE THEN
LOOP
DROP
THEN
;
: -both ( c-addr1 u1 -- c-addr2 u2 )
\ Forigu komencajn kaj finajn spacojn el cheno.
-TRAILING -leading
;
\ -------------------------------------------------------
\ Búsqueda
\ Sercho
\ Search
\ -------------------------------------------------------
: str-in? ( c-addr1 u1 c-addr2 u2 -- f )
\ Respondas, chu cheno estas en alia.
\ c-addr1 u1 = cheno en kiu serchi
\ c-addr2 u2 = cheno serchata
\ f = chu jes?
SEARCH >R 2DROP R>
;
: str-in-addr? ( c-addr1 u1 c-addr2 u2 c-addr3 -- f )
\ 2002 08 21
\ Redonu, chu subcheno estas en certa adreso de cheno
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ f = sukcese?
\ a3 = adreso en kiu estu la subcheno por sukceso
>R
SEARCH ( c-addr3 u3 f )
SWAP DROP
SWAP R> = AND \ chu trovita kaj adreso estas sama ol a1
;
: str-left? ( c-addr1 u1 c-addr2 u2 -- f )
\ 2002 08 21 Modificada / Modifita / Modified
\ Redonu, chu subcheno estas la maldekstra parto de cheno
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ f = ¿éxito?/sukcese?/success?
3 PICK \ preni endan adreson de la subcheno
str-in-addr?
;
: str-right? ( c-addr1 u1 c-addr2 u2 -- f )
\ 2002 08 21
\ Redonu, chu subcheno estas la dekstra parto de cheno
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ f = sukcese?
2 PICK OVER - 4 PICK + \ kalkuli endan adreson de la subcheno
str-in-addr?
;
false [IF]
: FIRST_VERSION_OF_char-in-str ( c-addr1 u1 c -- u2 )
\ First version, with IF structures.
\ 2006-01-22
OVER >R
BEGIN
ROT DUP CHAR+ >R
C@ OVER =
IF \ char found
( u c )
DROP TRUE ( u true )
ELSE
( u c )
SWAP 1- DUP 0= ( c u f )
IF \ end found
( c u' )
SWAP DROP TRUE ( u true )
ELSE
( c u' )
R> SWAP ROT FALSE ( u c a2 false)
THEN
THEN
UNTIL
( u )
R> DROP DUP 0<> SWAP R> 1+ SWAP - AND
;
[THEN]
: end-found? ROT 1- DUP 1 = ;
: char-found? ROT ROT C@ OVER = ;
: char-in-str ( c-addr u c -- 1...u | 0 )
\ 2006-01-22
\ Return the first position of a char in a string.
SWAP DUP >R \ save the lenght
1+ SWAP \ increment it to be the counter
BEGIN
ROT DUP CHAR+ >R \ save the incremented address for the next loop
end-found? >R \ end found?
char-found? >R \ char found?
SWAP 2R@ 0= AND 0= AND \ if the end was found but the char was not, make the count zero
2R> OR 0= \ end not found and char not found?
WHILE
R> SWAP ROT \ prepare parameters again
REPEAT
NIP R> DROP \ discard char and address
DUP 0<> SWAP R> 1+ SWAP - AND \ calculate the result
;
: last-char-in-str ( c-addr u c -- 1...u | 0 )
\ 2006-01-23
\ Return the last position of a char in a string.
ROT ROT DUP 1- ROT + \ point the address after the last char
SWAP 1+ ROT \ increment the lenght to be the counter
BEGIN
ROT DUP char- >R \ save the decremented address for the next loop
end-found? >R
char-found? >R
SWAP 2R@ 0= AND 0= AND \ if the end was found but the char was not, make the count zero
2R> OR 0= \ end not found and char not found?
WHILE
R> SWAP ROT \ prepare parameters again
REPEAT
NIP R> DROP \ discard char and address
;
\ -------------------------------------------------------
\ Ajuste
\ Ghustigo
\ Fixing
\ -------------------------------------------------------
: $proper-loc ( $a u1 -- $a u2 )
\ 2004 03 28
\ Ghustigu celumitan pozicion al cheno.
\ $a = cadena / cheno / string
\ u1 = pozicio celumita
\ u2 = pozicio celumita ghustigita ghis maksimume la lasta chensigno
OVER $len 1- MIN
;
\ -------------------------------------------------------
\ Corte
\ Trancho
\ Cut
\ -------------------------------------------------------
: -left ( c-addr1 u1 n -- c-addr2 u2 )
\ Deletes n chars from the left of a string.
\ c-addr2 = c-addr1+n
\ u2 = u1-n
DUP ROT SWAP - ROT ROT + SWAP
;
: str-to-before? ( c-addr1 u1 c-addr2 u2 -- c-addr1 u4 f )
\ Redonu enhavon de cheno ghis antaw la unua apero de subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr1 u4 = nova aw sama cheno
\ f = sukcese?
\ ?!!! 2006.01.21 parece que no funciona
2 PICK >R 3 PICK >R \ konservi chenon por poste
SEARCH
IF
SWAP DROP R> SWAP ( a1 u3 )
R> SWAP - ( a1 u4 )
TRUE
ELSE
2R> 2DROP FALSE
THEN
;
: str-to-before ( c-addr1 u1 c-addr2 u2 -- c-addr1 u4 )
\ Redonu enhavon de cheno ghis antaw la unua apero de subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr1 u4 = nova aw sama cheno
str-to-before? DROP
;
: str-to-before-last ( c-addr1 u1 c-addr2 u2 -- a1 u4 )
\ Redonu enhavon de cheno ghis antaw la lasta apero de subcheno.
\ INCONCLUSO / NEFINITA / NOT FINISHED !!!
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ a1 u4 = nova aw sama cheno
2 PICK >R
FALSE
BEGIN
str-to-before?
DUP
UNTIL
\ otra manera / alia maniero / other way !!!
\ INCONCLUSO / NEFINITA / NOT FINISHED !!!
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ a1 u4 = nova aw sama cheno
0 IF
2 PICK >R 3 PICK >R \ konservi chenon por poste
SEARCH
IF
SWAP DROP R> SWAP ( a1 u3 )
R> SWAP - ( a1 u4 )
TRUE
ELSE
2R> 2DROP FALSE
THEN
THEN
\ otra manera
\ alia sistemo, bazita sur $de_post_lasta
\ other way
\ INCONCLUSO / NEFINITA / NOT FINISHED !!!
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr3 u3 = cheno en kiu eble trovighas komence la subcheno
\ c-addr4 u4 = cheno sen la komenca subcheno
\ c-addr5 u5 = fina nova cheno
2SWAP
BEGIN
2OVER ( c-addr2 u2 c-addr1 u1 c-addr2 u2 )
SEARCH ( c-addr2 u2 c-addr3 u3 f )
WHILE
\ subcheno trovita
( c-addr2 u2 c-addr3 u3 )
2OVER \ $de_post ( c-addr2 u2 c-addr4 u4 )
REPEAT
2SWAP 2DROP
;
: str-to-after? ( c-addr1 u1 c-addr2 u2 -- a1 u4 f )
\ Redonu enhavon de cheno ghis post la unua apero de subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ a1 u4 = nova aw sama cheno
\ f = sukcese?
DUP >R
str-to-before?
R> SWAP
IF
+ TRUE
ELSE
DROP FALSE
THEN
;
: str-from-after? ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 f )
\ Redonu enhavon de cheno de post la unua apero de subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr4 u4 = nova aw sama cheno
\ f = sukcese?
DUP >R SEARCH R> SWAP
IF
\ subcheno trovita en la cheno
\ necesas adapti la rezulton por forigi el ghi la subchenon
SWAP OVER - \ kalkuli longon
>R + R> TRUE \ kalkuli adreson
ELSE
DROP FALSE
THEN
;
: str-from-after ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 )
\ Redonu enhavon de cheno de post la unua apero de subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr4 u4 = nova aw sama cheno
str-from-after? DROP
;
: str-from-after-last ( c-addr1 u1 c-addr2 u2 -- c-addr5 u5 )
\ Redonu enhavon de cheno de post la lasta apero de subcheno
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr3 u3 = cheno en kiu eble trovighas komence la subcheno
\ c-addr4 u4 = cheno sen la komenca subcheno
\ c-addr5 u5 = fina nova cheno
2SWAP
BEGIN
2OVER ( c-addr2 u2 c-addr1 u1 c-addr2 u2 )
SEARCH ( c-addr2 u2 c-addr3 u3 f )
WHILE
\ subcheno trovita
( c-addr2 u2 c-addr3 u3 )
2OVER str-from-after ( c-addr2 u2 c-addr4 u4 )
REPEAT
2SWAP 2DROP
;
: str-between ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- c-addr4 u4 )
\ Redonu enhavon de cheno ekde post subcheno ghis antaw alia subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = unua subcheno, ekde post kiu preni tekston
\ c-addr3 u3 = dua subcheno, ghis antaw kiu preni tekston
\ c-addr4 u4 = rezulto, ech se nula
\ Malnova versio, kiu almenaw redonis la saman chenon:
\ 2>R str-from-after
\ 2R> str-to-before? DROP
\ Nova versio por redoni nulan chenon se nesuksece:
2>R str-from-after?
ABS * \ nuligi longon se nesukcese
2R> str-to-before?
ABS * \ nuligi longon se nesukcese
;
: str-between? ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- c-addr4 u4 TRUE | FALSE )
\ Redonu enhavon de cheno ekde post subcheno ghis antaw alia subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = unua subcheno, ekde post kiu preni tekston
\ c-addr3 u3 = dua subcheno, ghis antaw kiu preni tekston
\ c-addr4 u4 = chena rezulto, se sukcese
str-between DUP
IF TRUE
ELSE 2DROP FALSE
THEN
;
: str-without-left? ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 TRUE | FALSE )
\ Se subcheno estas la maldekstra parto de cheno,
\ redonu la chenon krom la subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr4 u4 = rezulto
DUP >R 2OVER 2>R ( R: u2 c-addr1 u1 )
str-left?
2R> ROT ( c-addr1 u1 f ) ( R: u2 )
IF
R> ROT OVER + ( u3 u2 a4 )
ROT ROT - TRUE ( c-addr4 u4 TRUE )
ELSE
2DROP R> DROP FALSE
THEN
;
: str-without-left ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 )
\ Se subcheno estas la maldekstra parto de cheno,
\ redonu la chenon krom la subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr4 u4 = rezulto, nova aw sama cheno
2OVER 2SWAP str-without-left?
IF
2SWAP 2DROP
THEN
;
: str-without-right ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 )
\ 2002 08 21
\ Se subcheno estas la dekstra parto de cheno,
\ redonu la chenon krom la subcheno.
\ c-addr1 u1 = cadena / cheno / string
\ c-addr2 u2 = subcadena / subcheno / substring
\ c-addr4 u4 = rezulto, nova aw sama cheno
2OVER 2>R \ konservi la chenon por poste
DUP >R \ konservi longon de subcheno por poste
str-right? \ kontroli, chu subcheno estas dekstre de la cheno
R> * \ repreni longon subchenan k oblige per la flago, nuligi aw minusigi
2R> ROT + \ repreni la unuan chenon kaj kalkuli la novan longon
;
: $mid-from-to ( $a u2 u1 -- c-addr u )
\ 2004 03 28
\ Redonu cheneron el cheno, inter du pozicioj
\ $a = cadena / cheno / string
\ u2 = lasta pozicio
\ u1 = unua pozicio
\ c-addr u = chenero
2DUP - 1+ >R \ (s $a u2 u1 ) (r u )
SWAP DROP
SWAP '$txt + R> \ (s c-addr u )
;
: $mid ( $a u1 u2 -- c-addr3 u3 )
\ 2004 03 28
\ Redonu cheneron el cheno.
\ $a = cadena / cheno / string
\ u1 = unua pozicio
\ u2 = longo de la chenero
\ u1' = unua pozicio, ghustigita ghis maksimume la lasta pozicio de la cheno
\ u2' = dua pozicio, ghustigita ghis maksimume la lasta pozicio de la cheno
\ c-addr3 u3 = chenero
>R $proper-loc \ (s $a u1' ) (r u2 )
R> OVER >R + 1- $proper-loc R> \ (s $a u2' u1' )
$mid-from-to
;
: $mid-tested-from-to ( $a u1 u2 -- c-addr3 u3 )
\ 2004 03 28
\ 2004 09 11 Modificada / Modifita / Modified por kontroli, chu la unua pozicio pli grandas ol la dua
\ Redonu cheneron el cheno.
\ $a = cadena / cheno / string
\ u1 = unua pozicio
\ u2 = dua pozicio
\ u1' = unua pozicio, ghustigita ghis maksimume la lasta pozicio de la cheno
\ u2' = dua pozicio, ghustigita ghis maksimume la lasta pozicio de la cheno
\ c-addr3 u3 = chenero
2DUP >
IF
2DROP '$txt 0
ELSE
>R $proper-loc \ (s $a u1' ) (r u2 )
R> SWAP >R $proper-loc R> \ (s $a u2' u1' )
$mid-from-to
ENDIF
;
: $left ( $a u -- c-addr3 u3 )
\ 2004 09 11
\ Redonu cheneron el la indikitaj signoj maldekstraj el cheno
\ $a = cadena / cheno / string
\ u = signoj
\ c-addr3 u3 = chenero
SWAP '$txt SWAP
;
: $to-right ( $a u -- c-addr3 u3 )
\ 2004 09 11
\ Redonu cheneron el cheno, de la indikita unua pozicio ghis la fino
\ $a = cadena / cheno / string
\ u = unua pozicio
\ c-addr3 u3 = chenero
OVER $len 1- $mid-tested-from-to
;
\ -------------------------------------------------------
\ División
\ Divido
\ Division
\ -------------------------------------------------------
: str-divide-at? ( c-addr1 u1 c-addr2 u2 -- c-addr4 u4 c-addr1 u3 TRUE | c-addr1 u1 FALSE )
\ Dividu chenon che forigenda subcheno, kaj redonu ambajn partojn.
\ c-addr1 u1 = cadena a dividir / dividenda cheno / substring to be divided
\ c-addr2 u2 = subcadena a borrar / forigenda subcheno / substring to be deleted
\ a1 a3 = parte derecha / dekstra parto / right parth
\ c-addr4 u4 = parte izquierda / maldekstra parto / left part
2OVER 2OVER
str-to-before? IF
2>R str-from-after 2R> TRUE
ELSE
2DROP 2DROP FALSE
THEN
;
false [IF]
\ New version to test:
2OVER 2OVER
str-to-before? DUP >R IF
2>R str-from-after 2R>
ELSE
2DROP 2DROP
THEN
R>
[THEN]
: /str-at ( c-addr1 u1 u4 -- c-addr3 u3 c-addr1 u2 | c-addr1 u1 c-addr1 0 )
\ 2006.01.23
\ Divide a string at a char position, dicarding that char.
\ c-addr1 u1 = chain
\ u4 = char position (1...u1)
>R 2DUP R>
DUP IF
DUP >R - SWAP R@ + SWAP 2SWAP R> 1-
THEN
NIP
;
: /char-in-str ( c-addr1 u1 c -- c-addr3 u3 c-addr1 u2 | c-addr1 u1 c-addr1 0 )
\ 2006.01.23
\ Divide a string at the first position of a char, that is discarded.
>R 2DUP R> char-in-str /str-at
;
: /last-char-in-str ( c-addr1 u1 c -- c-addr3 u3 c-addr1 u2 | c-addr1 u1 c-addr1 0 )
\ 2006.01.23
\ Divide a string at the last position of a char, that is dicarded.
>R 2DUP R> last-char-in-str /str-at
;
\ -------------------------------------------------------
\ Cuenta
\ Kalkulo
\ Count
\ -------------------------------------------------------
: str-char# ( c c-addr1 u1 -- u2 )
\ Kalkulas, kiom da fojoj estas signo en cheno.
\ c-addr1 u1 = cadena / cheno / string
\ c = signo
\ u2 = contador / kiomo / count
DUP IF
ROT 0 SWAP 2SWAP ( u2 c c-addr1 u1 )
OVER + SWAP
DO ( u2 c )
DUP I C@ = NEGATE ROT + SWAP
LOOP
DROP
ELSE \ malplena cheno
2DROP DROP 0
THEN
;
.( fstr ok!)