fstr
Priskribo de la ĉi-paĝa enhavo
Forth-ilaro por teksto-ĉena manipulado.
fstr estas ilaro, verkita en Fortho, por manipuli teksto-ĉenojn en tiu lingvo. Mi ekverkis ĝin en 2001, kiel eron de mia programo eeo (ankore nepublikigita), la unua laborprogramo mia por krei HTML -paĝojn el datenoj kaj informo konservitaj en tekstaj dosieroj.
Mi sendependigis la kodon por ĝin utiligi kun aliaj programoj. De tiam mi foje iomete plibonigis aŭ kompletigis ĝin. Jarojn poste, mi foje ankore el ĝi prenas algoritmon por aliaj Forth-programoj miaj. Tamen estas moderna Forth-ilaro enhavanta utilajn vortojn por manipuli teksto-ĉenojn kaj fari multon alian: Forth Foundation Library.
Fontkodo
\ -------------------------------------------------------
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!)