: string ( -- c- u ) s" \n" ; ( two characters, \ and an n ) : string ( -- c- u ) s" John 'Maddog' Orwant" ; ( literal single quotes ---------------------------- ) : string ( -- ) cr ; ( a "newline" character, or: ) : string ( -- ) newline type ; ( a "newline" character, or: ) : string ( -- c ) 13 ; ( depending, obviously, on your platform's newline ) ( double quotes must be entered manually ) : put-quote ( c- u -- ) + 34 swap c! ; : string ( -- c- u ) s" Jon Maddog Orwant" over dup 4 put" 11 put" ( literal double quotes ) ; ( no q/ / type quoting options ---------------------------- some words to make a here document: ) : newline? ( c -- f ) dup 10 = swap 13 = or ( or whatever the newline is for your platform ) ; : get-terminator ( -- c- u ) here dup 12 chars allot 12 accept ( change 12 if you absolutely must have a larger EOF marker than 12 characters ) cr ; : get-char ( -- c ) key dup emit dup here 1 chars allot c! ; : line-in ( -- u ) 0 begin 1 + get-char 13 = until 1 - ; : <<< ( -- c- u ) \ A parsing <<< would be cute but I don't want to deal with writing one get-terminator here -rot begin line-in here over - 1 - swap 2over compare not until drop drop here over - ; <<< EOF This is a multiline here document terminated by EOF on a line by itself EOF |
: substr ( c- u u u -- c- u )
dup 0=
if
drop tuck -
else
2dup + 2swap -rot dup -rot >
if
rot drop 2dup swap - nip
else
drop swap
then
then
-rot + 0 -rot swap here swap 2dup chars allot drop 0
do
over i + c@ over i + c! rot 1+ -rot
loop
nip swap
;
: value string offset count substr ;
: value string offset 0 substr ;
: reassign ( c- u u u c- u -- c- u )
{ addr1 strlen1 offset count addr2 strlen2 }
strlen1 count - strlen2 + allocate throw
addr1 over offset cmove
addr2 over offset chars + strlen2 cmove
addr1 offset chars + count chars +
over offset chars + strlen2 chars + strlen1 count - offset - cmove
strlen1 count - strlen2 +
;
string offset count newstring reassign
( ----------------------------
get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest. )
: unpack ( c- u -- c-1 u1 c-2 u2 c-3 u3 c-4 u4 )
2>r
5 chars allocate throw 2r@ drop over 5 cmove 5
8 chars allocate throw 2r@ drop 8 chars + over 8 cmove 8
8 chars allocate throw 2r@ drop 16 chars + over 8 cmove 8
2r> 24 - dup chars allocate throw dup 2swap >r r@ swap 24 + -rot cmove
r>
;
( split at five byte boundaries )
: fivers ( c- u -- c-1 u1 c-2 u2 ... c-n un )
5 / 0
do
5 chars allocate throw 2dup swap i 5 * chars + swap 5 cmove 5 rot
loop
drop
;
( chop string into individual characters )
: chop ( c- u -- c1 c2 ... cn )
0 do dup i chars + c@ swap loop drop ;
( ---------------------------- )
: string s" This is what you have" ;
: first string drop 1 ; ( "T" )
: start string drop 5 chars + 2 ; ( "is" )
: rest string 13 swap over - -rot chars + swap; ( "you have" )
: last string 1 - chars + 1 ; ( "e" )
: end string 4 - chars + 4 ; ( "have" )
: piece string 8 - chars + 3 ; ( "you" )
( ---------------------------- )
: string s" This is what you have" ;
string type
( This is what you have )
string 5 2 s" wasn't" reassign ( change "is" to "wasn't"
This wasn't what you have )
string 13 12 s" ondrous" reassign ( replace last 12 characters
This wasn't wondrous )
string swap 1 chars + swap 1 - ( delete first character
his wasn't wondrous )
string 10 - dup -rot resize throw swap ( delete last 10 characters
his wasn' )
( ----------------------------
TODO RE's
------------------------------
exchange first and last letters in a string )
: a s" make a hat" ;
: exchange ( c- u -- )
1 - 2dup chars + c@ -rot over c@ -rot chars over + rot swap c! c!
;
a exchange type
( take a ham
------------------------------
extract column )
: a "To be or not to be" ;
: b ( c- u u u -- c- u )
dup
chars
allocate throw swap ( c- len off cou c-2 )
>r >r nip chars + 2r@ cmove r> r>
;
a 6 6 ( skip 6, grab 6 )
b type
( or not ) |
( use b if b is true, else c ) : default ( x a- -- ) dup @ not if ! else 2drop then ; c b default a ! ( set x to y unless x is already true ) : !? dup if ! else drop then ; x dup @ 0= y @ and swap !? |
: swap! ( x x -- ) 2dup @ swap @ rot ! swap ! ; var1 var2 swap! ( ---------------------------- ) variable temp a @ temp ! b @ a ! temp @ b ! ( ---------------------------- ) |
( not an issue, really; a char is just an integer and stored as a cell on the stack ) : ord ( c -- u ) ; : chr ( u -- c ) ; ( or, to see the char ) : chr ( u -- ) emit ; ( but if it's an actual variable rather than a stack element: ) : ord ( c- -- a- ) 1 cells allocate throw swap c@ swap ! ; : chr ( a- -- c- ) 1 chars allocate throw swap @ swap c! ; |
( with a literal word ) : process-string ( c- u -- variable stack effect ) 0 do dup i chars + c@ ( your-word ) swap loop drop ; ( or better yet, with an execution token ) : map-xt ( xt c- u -- variable stack effect ) 0 do 2dup i chars + c@ swap execute loop ; |
: 4dup-nip ( a b c d -- a b c d a b d )
2over 2over nip
;
: c[i]@ ( c- i -- c ) chars + c@
;
: c[i]! ( c- i c -- )
chars + c!
;
: -cmove ( c- x c- -- c- x )
over 0
u+do i 4dup-nip
1+ - c[i]@
2over nip rot c[i]!
loop
rot drop swap
;
: revbytes ( c- x -- c- x )
dup allocate throw
-cmove
;
: gnirts s" string" revbytes ;
: space?
32 =
;
: ^? ( c c- a -- c t )
c[i]@
tuck space? not swap space? and ;
: -^? ( c c- a -- c t )
c[i]@
tuck
space?
swap
space? not and
;
: count-words ( c- x -- x )
0 -rot 32 swap
0 u+do
over i ^? if
rot 1+ -rot
then
loop
drop drop
;
: last-spaces ( c- x -- x )
0 -rot
begin
1-
2dup
c[i]@
space?
over 0 >=
and
while
rot 1+ -rot
repeat
drop drop
;
: last-word ( c- x -- x )
0 -rot
begin
1-
2dup
c[i]@
space? not
over 0 >=
and
while
rot 1+ -rot
repeat
drop drop
;
: back>front ( c- x c- x -- )
2swap 2dup last-word -rot
chars + over chars - swap
rot drop rot swap
cmove ;
: sback>front ( c- x c- x -- )
2swap 2dup last-spaces -rot
chars + over chars - swap
rot drop rot swap
cmove
;
: sdrow ( c- x -- c- x ) 2dup last-spaces -
dup >r dup chars allocate throw
dup >r
over 2swap 2dup count-words 0 u+do
2dup last-word >r 2over 2over 2swap back>front r@
- rot drop dup -rot 2swap
r>
rot + swap 2swap
2dup last-spaces >r
2over 2over 2swap sback>front r@
- rot drop dup -rot 2swap
r>
rot + swap 2swap
loop
2drop 2drop
r> r>
;
: count-spaces ( c- x -- x )
0 -rot
0 u+do
dup i c[i]@ space? if
swap 1+ swap
then
loop
drop
;
: move-if-not-space ( c- c- -- f )
swap c@ dup space?
if
drop drop false
else
swap c! true
then
;
: squash-words ( c- x -- c- x )
2dup count-spaces
over swap -
dup chars allocate throw
swap >r dup >r
-rot
0 u+do
2dup
i chars +
swap
move-if-not-space if
swap 1 chars + swap
then
loop
drop drop r> r>
;
: confused ( c- x -- c- x )
squash-words
revbytes
;
80 constant biggest-word
create buff biggest-word 2 + allot
: palindrome? ( c- x -- f )
2dup revbytes
compare not
;
: chomp ( c- x -- c- x )
2dup last-spaces -
;
s" /usr/share/dict/words" r/o open-file throw value dict
: scan-dictionary ( c- x -- )
begin
buff biggest-word dict read-line throw
while
dup buff swap chomp
dup 5 > -rot
palindrome? and if
buff swap type cr
else
drop
then
repeat
;
|