home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
p3_31dc.seq
< prev
next >
Wrap
Text File
|
1990-04-06
|
3KB
|
130 lines
\ Problem 3.31 by Dickson Cheng 04/06/90 17:07:32.43
07 CONSTANT CONTROL_G \ Bell character
08 CONSTANT CONTROL_H \ Back space character
48 CONSTANT ASCII_0 \ Digit " 0 "
57 CONSTANT ASCII_9 \ Digit " 9 "
45 CONSTANT ASCII_- \ Minus sign character
13 CONSTANT CONTROL_M \ /Carriage return character
: (IN) ( x a b -- flag )
2DUP < NOT ABORT" Invalid interval."
-ROT OVER < -ROT > AND ;
: [IN] ( x a b -- flag )
1+ SWAP 1- SWAP (IN) ;
: BELL ( -- )
CONTROL_G EMIT -1 #OUT +! ;
: RUBOUT ( -- )
CONTROL_H EMIT SPACE
CONTROL_H EMIT
-4 #OUT +! ;
: -DIGIT ( count n -- count-1 n/10 )
RUBOUT
SWAP 1- SWAP 10 / ;
: +DIGIT ( count n key -- count+1 n' If valid key )
( -- count n If invalid key )
SWAP 10 UM*
2 PICK ASCII_0 -
0 D+
32767. 2OVER DU<
IF 10 UM/MOD
NIP NIP BELL
ELSE DROP
SWAP EMIT
SWAP 1+ SWAP
THEN ;
: DIGIT? ( n -- flag )
ASCII_0 ASCII_9 [IN] ;
: CLEAR_SIGN? ( flag count n -- ff count n )
OVER 0= IF ROT DROP FALSE -ROT THEN ;
: CORRECT_IT ( flag count num key -- flag count num )
DROP OVER 0<>
IF -DIGIT
ELSE BELL
THEN
CLEAR_SIGN? ;
: PROCESS_IT ( flag count num key -- flag count num )
DUP DIGIT?
IF +DIGIT
ELSE DROP BELL
THEN ;
: APPLY_SIGN ( flag count num key -- num )
DROP NIP SWAP
IF NEGATE THEN ;
: NEGATIVE? ( count num key -- count num key flag )
DUP ASCII_- = 3 PICK 0= AND ;
: SET_FLAG ( flag count num key -- flag count num )
EMIT ROT DROP TRUE -ROT
SWAP 1+ SWAP ;
: #IN ( -- number )
FALSE 0 0
BEGIN KEY
NEGATIVE?
IF SET_FLAG
ELSE DUP CONTROL M =
IF APPLY_SIGN EXIT
THEN
DUP CONTROL H =
IF CORRECT_IT
ELSE PROCESS_IT
THEN
THEN
AGAIN ;
: CONTROL? ( n -- flag )
0 31 [IN] ;
: SPACE? ( n -- flag )
32 = ;
: PUNCTUATION? ( n -- flag )
DUP 33 47 [IN] SWAP
DUP 58 64 [IN] SWAP
DUP 91 96 [IN] SWAP
123 126 [IN]
OR OR OR ;
: LOWER? ( n -- flag )
97 122 [IN] ;
: UPPER? ( n -- flag )
65 90 [IN] ;
: EXTENDED? ( n -- flag )
127 225 [IN] ;
: INVALID_KEY? ( n -- flag )
0 225 [IN] NOT ;
: IDENTIFY ( -- )
BEGIN CR ." Input your ASCII code> " #IN SPACE
DUP INVALID_KEY? IF DROP ABORT" Invalid key code!" ELSE
DUP CONTROL? IF ." Control character: " EMIT ELSE
DUP SPACE? IF ." A space." DROP ELSE
DUP PUNCTUATION? IF ." Punctuation character: " EMIT ELSE
DUP DIGIT? IF ." Numeric Digit: " EMIT ELSE
DUP UPPER? IF ." Upper case letter: " EMIT ELSE
DUP LOWER? IF ." Lower case letter: " EMIT ELSE
DUP EXTENDED? IF ." Extended character: " EMIT ELSE
THEN THEN THEN THEN THEN THEN THEN THEN DROP
AGAIN ;