home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
tutor
/
l6p130
< prev
next >
Wrap
Text File
|
1990-07-15
|
3KB
|
93 lines
╔════════════════════════════════════════════════════╗
║ Lesson 6 Part 130 F-PC 3.5 Tutorial by Jack Brown ║
╚════════════════════════════════════════════════════╝
┌─────────────────────────────────────────────────┐
│ Simple String Package Case Study ( continued ) │
└─────────────────────────────────────────────────┘
\ String input. Usage: string $IN
: $IN ( addr len -- )
OVER SWAP MLEN EXPECT ;
\ String equality. Usage string1 string2 S=
\ Leaves a true flag if strings are equal.
: S= ( addr1 len1 addr2 len2 -- flag )
ROT OVER =
IF TRUE SWAP 0 ?DO DROP OVER C@ OVER C@ =
IF 1 1 D+ TRUE
ELSE FALSE LEAVE
THEN LOOP
ELSE DROP FALSE
THEN NIP NIP ;
\ String array.
\ Usage: 5 20 SARRAY NAMES
\ " JACK" 1 NAME S! 1 NAME TYPE
\ " JOHN" 2 NAME S! 2 NAME TYPE etc...
: SARRAY ( n len -- ) \ when compiling
CREATE ABS 255 MIN 1 MAX SWAP
0 ?DO DUP DUP C,
0 ?DO BL C, LOOP 0 C,
LOOP DROP
DOES> SWAP 1- OVER C@
2+ * + 1+ DUP SEARCH ;
\ Ralph Dean's FORTH implementation of SOUNDEX program that
\ originally appeared in the May 1980 Byte Magazine.
\
\ Executing SOUND will cause a prompt for the name.
\ The name is terminated after 30 characters or <enter>.
\ The soundex code is then computed and typed out.
\ The string variable S$ contains the code produced.
\ For more information on Soundex codes see the original
\ Byte article.
FORTH DEFINITIONS DECIMAL
30 STRING N$ \ Input string whose soundex code is to be found.
4 STRING S$ \ Output string containing soundex code.
1 STRING K$ 1 STRING L$
: NAME ( -- ) \ Prompt for input of last name.
CR ." Last Name? " N$ $IN ;
: FIRST1 ( -- ) \ Move first character to S$
1 N$ LEFT$ S$ S! ;
: ITH ( n m -- k )
N$ MID$ DROP C@ 64 - ;
: KTH ( k -- )
DUP " 01230120022455012623010202"
MID$ K$ S! ;
: BLS ( -- )
S$ K$ S+ S$ S! ;
: TEST ( -- flag )
K$ L$ S= K$ " 0" S= OR 0= ;
: IST ( n n flag )
DUP 1 < OVER 26 > OR 0= ;
\ Compute soundex code
: COMP ( -- )
N$ LEN 1+ 2
DO I I ITH IST
IF KTH TEST IF BLS THEN
ELSE DROP
THEN
K$ L$ S!
LOOP ;
\ This is the Program. BROWN , BRUN , BRAWN all give B650
: SOUNDEX ( -- )
NAME FIRST1 N$ LEN 2 >
IF COMP THEN S$ " 0000" S+ S$ S!
CR ." Soundex Code = " S$ TYPE CR ;
┌─────────────────────────────────────┐
│ Please Move to Lesson 6 Part 140 │
└─────────────────────────────────────┘