fstr

Descripción del contenido de la página

Herramientas en Forth para manipular cadenas de texto.

Etiquetas:

fstr es un conjunto de herramientas, escritas en Forth, para manipular cadenas de texto en este lenguaje. Empecé a escribirlas en 2001, como parte de mi programa eeo (aún inédito), la primera aplicación que escribí para crear páginas HTML a partir de contenidos y datos guardados en ficheros de texto.

Independicé el código para utilizarlo como librería en otras aplicaciones, y con el tiempo le hice algunos retoques y mejoras. Años después aún recurro alguna vez a fstr para copiar algún algoritmo de manipulación de textos y aplicarlo en alguno de mis programas en Forth. No obstante, hay una librería moderna que contiene palabras avanzadas para manipulación de cadenas de texto en Forth y hacer otras muchas cosas: Forth Foundation Library.

Código fuente

\ -------------------------------------------------------
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!)

Descargas

fstr.fs (26.02 KiB)