home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p3_31dc.seq < prev    next >
Encoding:
Text File  |  1990-04-06  |  3.4 KB  |  130 lines
  1. \ Problem 3.31 by Dickson Cheng  04/06/90 17:07:32.43
  2.  
  3.  
  4. 07 CONSTANT CONTROL_G   \ Bell character
  5. 08 CONSTANT CONTROL_H   \ Back space character
  6. 48 CONSTANT ASCII_0     \ Digit " 0 "
  7. 57 CONSTANT ASCII_9     \ Digit " 9 "
  8. 45 CONSTANT ASCII_-     \ Minus sign character
  9. 13 CONSTANT CONTROL_M   \ /Carriage return character
  10.  
  11. : (IN)          ( x a b -- flag )
  12.         2DUP < NOT ABORT" Invalid interval."
  13.         -ROT OVER < -ROT > AND ;
  14.  
  15. : [IN]          ( x a b -- flag )
  16.         1+ SWAP 1- SWAP (IN) ;
  17.  
  18. : BELL          ( -- )
  19.         CONTROL_G EMIT -1 #OUT +! ;
  20.  
  21. : RUBOUT        ( -- )
  22.         CONTROL_H EMIT SPACE
  23.         CONTROL_H EMIT
  24.         -4 #OUT +! ;
  25.  
  26. : -DIGIT        ( count n -- count-1 n/10 )
  27.         RUBOUT
  28.         SWAP 1- SWAP 10 / ;
  29.  
  30. : +DIGIT        ( count n key -- count+1 n'  If valid key )
  31.                 (             -- count   n   If invalid key )
  32.         SWAP 10 UM*
  33.         2 PICK ASCII_0 -
  34.         0 D+
  35.         32767. 2OVER DU<
  36.         IF 10 UM/MOD
  37.            NIP NIP BELL
  38.         ELSE DROP
  39.              SWAP EMIT
  40.              SWAP 1+ SWAP
  41.         THEN ;
  42.  
  43. : DIGIT?        ( n -- flag )
  44.         ASCII_0 ASCII_9 [IN] ;
  45.  
  46. : CLEAR_SIGN?   ( flag count n -- ff count n )
  47.         OVER 0= IF ROT DROP FALSE -ROT THEN ;
  48.  
  49. : CORRECT_IT    ( flag count num key -- flag count num )
  50.         DROP OVER 0<>
  51.         IF -DIGIT
  52.         ELSE BELL
  53.         THEN
  54.         CLEAR_SIGN? ;
  55.  
  56. : PROCESS_IT    ( flag count num key -- flag count num )
  57.         DUP DIGIT?
  58.         IF +DIGIT
  59.         ELSE DROP BELL
  60.         THEN ;
  61.  
  62. : APPLY_SIGN    ( flag count num key -- num )
  63.         DROP NIP SWAP
  64.         IF NEGATE THEN ;
  65.  
  66. : NEGATIVE?     ( count num key -- count num key flag )
  67.         DUP ASCII_- = 3 PICK 0= AND ;
  68.  
  69. : SET_FLAG      ( flag count num key -- flag count num )
  70.         EMIT ROT DROP TRUE -ROT
  71.         SWAP 1+ SWAP ;
  72.  
  73. : #IN           ( -- number )
  74.         FALSE 0 0
  75.         BEGIN KEY
  76.           NEGATIVE?
  77.           IF   SET_FLAG
  78.           ELSE DUP CONTROL M =
  79.                IF APPLY_SIGN EXIT
  80.                THEN
  81.                DUP CONTROL H =
  82.                IF CORRECT_IT
  83.                ELSE PROCESS_IT
  84.                THEN
  85.           THEN
  86.         AGAIN ;
  87.  
  88. : CONTROL?      ( n -- flag )
  89.         0 31 [IN] ;
  90.  
  91. : SPACE?        ( n -- flag )
  92.         32 = ;
  93.  
  94. : PUNCTUATION?  ( n -- flag )
  95.         DUP 33 47 [IN] SWAP
  96.         DUP 58 64 [IN] SWAP
  97.         DUP 91 96 [IN] SWAP
  98.           123 126 [IN]
  99.         OR OR OR ;
  100. : LOWER?        ( n -- flag )
  101.         97 122 [IN] ;
  102.  
  103. : UPPER?        ( n -- flag )
  104.         65 90 [IN] ;
  105.  
  106. : EXTENDED?     ( n -- flag )
  107.         127 225 [IN] ;
  108.  
  109. : INVALID_KEY?  ( n -- flag )
  110.         0 225 [IN]  NOT ;
  111.  
  112. : IDENTIFY      ( -- )
  113.         BEGIN CR ." Input your ASCII code> " #IN SPACE
  114.         DUP INVALID_KEY?  IF DROP ABORT" Invalid key code!"   ELSE
  115.         DUP CONTROL?      IF ." Control character: "     EMIT ELSE
  116.         DUP SPACE?        IF  ." A space."               DROP ELSE
  117.         DUP PUNCTUATION?  IF ." Punctuation character: " EMIT ELSE
  118.         DUP DIGIT?        IF ." Numeric Digit: "         EMIT ELSE
  119.         DUP UPPER?        IF ." Upper case letter: "     EMIT ELSE
  120.         DUP LOWER?        IF ." Lower case letter: "     EMIT ELSE
  121.         DUP EXTENDED?     IF ." Extended character: "    EMIT ELSE
  122.         THEN THEN THEN THEN THEN THEN THEN THEN DROP
  123.         AGAIN ;
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.