home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / tutor / l6p130 < prev    next >
Encoding:
Text File  |  1990-07-15  |  2.7 KB  |  93 lines
  1.        ╔════════════════════════════════════════════════════╗
  2.        ║ Lesson 6 Part 130  F-PC 3.5 Tutorial by Jack Brown ║
  3.        ╚════════════════════════════════════════════════════╝
  4.  
  5.        ┌─────────────────────────────────────────────────┐
  6.        │  Simple String Package Case Study ( continued ) │
  7.        └─────────────────────────────────────────────────┘
  8.  
  9. \ String input.  Usage:  string $IN
  10. : $IN  ( addr len  -- )
  11.     OVER SWAP MLEN EXPECT ;
  12.  
  13. \ String equality.  Usage  string1 string2 S=
  14. \ Leaves a true flag if strings are equal.
  15. : S= ( addr1 len1 addr2 len2 -- flag )
  16.      ROT OVER =
  17.      IF  TRUE SWAP 0 ?DO DROP OVER C@ OVER C@ =
  18.          IF 1 1 D+ TRUE
  19.          ELSE FALSE LEAVE
  20.          THEN LOOP
  21.      ELSE DROP FALSE
  22.      THEN NIP  NIP ;
  23.  
  24. \ String array.
  25. \ Usage:   5 20 SARRAY NAMES
  26. \         " JACK" 1 NAME  S!     1 NAME  TYPE
  27. \         " JOHN" 2 NAME  S!     2 NAME  TYPE      etc...
  28. : SARRAY  ( n len -- )  \ when compiling
  29.         CREATE  ABS 255 MIN 1 MAX SWAP
  30.                 0 ?DO DUP DUP C,
  31.                 0 ?DO BL C, LOOP 0 C,
  32.                 LOOP DROP
  33.         DOES>   SWAP 1- OVER C@
  34.                 2+ * + 1+ DUP SEARCH ;
  35.  
  36. \  Ralph Dean's FORTH implementation of SOUNDEX program that
  37. \  originally  appeared in the May 1980 Byte Magazine.
  38. \
  39. \  Executing SOUND will cause a prompt for the name.
  40. \  The name is terminated after 30 characters or <enter>.
  41. \  The soundex code is then computed and typed out.
  42. \  The string variable S$ contains the code produced.
  43. \  For more information on Soundex codes see the original
  44. \  Byte article.
  45.  
  46.  
  47. FORTH DEFINITIONS DECIMAL
  48. 30 STRING N$   \ Input string whose soundex code is to be found.
  49.  4 STRING S$   \ Output string containing soundex code.
  50.  1 STRING K$   1 STRING L$
  51.  
  52. : NAME ( --  )  \ Prompt for input of last name.
  53.         CR ." Last Name? "  N$  $IN ;
  54.  
  55. : FIRST1 ( -- ) \ Move first character to S$
  56.         1 N$ LEFT$ S$ S! ;
  57.  
  58. : ITH  ( n m  --  k )
  59.         N$  MID$ DROP C@ 64 - ;
  60.  
  61. : KTH ( k -- )
  62.         DUP " 01230120022455012623010202"
  63.         MID$ K$ S! ;
  64.  
  65. : BLS ( -- )
  66.         S$ K$ S+ S$ S! ;
  67.  
  68. : TEST ( -- flag )
  69.         K$ L$ S= K$ " 0" S= OR 0= ;
  70.  
  71. : IST  ( n   n flag )
  72.         DUP 1 < OVER 26 > OR 0= ;
  73.  
  74. \ Compute soundex code
  75. : COMP ( -- )
  76.         N$ LEN 1+ 2
  77.         DO I I ITH IST
  78.            IF   KTH TEST IF BLS THEN
  79.            ELSE DROP
  80.            THEN
  81.         K$ L$ S!
  82.         LOOP ;
  83.  
  84. \ This is the Program.   BROWN , BRUN , BRAWN  all give B650
  85. : SOUNDEX ( -- )
  86.         NAME FIRST1 N$ LEN 2 >
  87.         IF COMP THEN S$ " 0000" S+ S$ S!
  88.         CR ." Soundex Code =  " S$ TYPE CR ;
  89.  
  90. ┌─────────────────────────────────────┐
  91. │   Please Move to Lesson 6 Part 140  │
  92. └─────────────────────────────────────┘
  93.