fstr

Description of the page content

Forth tools to manipulate text strings.

Tags:

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

Downloads

fstr.fs (26.02 KiB)