Forth Application Techniques — Answers to Exercises

Thank you for taking the Forth Applications Techniques course. We hope you’ve found it an interesting and rewarding experience!

The solutions presented here are intended as examples; in most cases there are several valid ways of solving each problem, depending both on stylistic and functional design decisions (e.g., error checking, user prompts, etc.).

Chapter 2

Problem set 2.2.5

Problem set 2.7

1. Average of six numbers:

123. 400 M+ 1000998. D+ 3 M+ 65534 M+ 1 M+ 6 M/ . ( = 177843)

The above was generalized for both 16-bit and 32-bit implementations. For 32-bit implementations, it’s reasonable to omit the punctuation and work with all single-precision numbers.

2. Rewrite the equations using postfix notation and the proper arithmetic operators:

12 12 +
123 15 *
1.234 3.140 D+ ( scale 3.14 to consistent units of thousandths)
123.00000 1.00000 D+ ( Align decimal places)

( Alternatively: ) 123 1 + ( because there are no actual fractional digits)
16 123 4 */
10000. 15 36 M*/
15 123 * 64 - 32 + 6 /

3. 2**6:

2 2* 2* 2* 2* 2*

4. Rounding a number with one decimal place to nearest integer:

When you type 21.3, you get a double-precision number.

: ROUND ( d -- d' )   .5 D+ 10 M/ 10 M* ;

But you can do this perfectly accurately with single-precision in tenths, typing 213:

: ROUNDS ( n -- n' )   5 + 10 / 10 * ;

5. Rounding a number with one decimal place to nearest even integer :

: ROUND2 ( d -- d' )   1.0 D+ 20 M/ 20 M* ;

…and the single-precision version:

: ROUND2S ( n -- n' )   10 + 20 / 20 * ;

This is sometimes done in statistical apps to correct for the systematic upward bias caused by .5 in simple rounding.

6. To convert single to double:

a) for signed numbers, use either S>D or 1 M*
b) for unsigned numbers, just type 0 (Why does that work?)

7. How would you do the folowing operations if you had unknowns on the stack?

Given A: 3A**3 + 4A**2 – 5A + 10

First, factor it using Horner’s Method:

A(3A**2 + 4A - 5) + 10
A(A(3A + 4) - 5) + 10

: POLY ( n1 -- n2 )
   DUP DUP 3 *  \ save 3 As on stack; multiply to get 3A
   4 +          \ add 4, innermost parentheses done...
   * 5 -        \ multiply by A; then subtract 5
   10 + ;       \ consume final A on stack, multiply and add 10

Given A B: (A + B) + 1

: FORM ( a b -- n ) + 1+ ;

Given A B: 3A – 2B + 2

: FORM ( a b -- n ) -2 * SWAP 3 * + 2+ ;

Given A B: A + B(A + B)/2

: FORM ( a b -- n ) 2DUP + * 2/ + ;

Given A B: .5AB / 100
Factoring: AB / 200

: FORM ( a b -- n ) 200 */ ;

Given A B: (A + B) * (A – B)

: FORM ( a b -- n )   2DUP - ROT ROT + * ;

Given A B C: (A * (B + C) + A)

: FORM ( a b c -- )   + OVER * + ;

Given A B C: A**2 + 2AB + B**2 + C
Factoring: (A+B)**2 + C

: FORM ( a b c -- n )   ROT ROT + DUP * + ;

8. Define words to convert temperatures, using these formulae:

Fahrenheit to Centigrade: c = (f-32)/1.8 = (0 – 32)/1.8 = -17.7
Centigrade to Fahrenheit: f = (c * 1.8) + 32
Centigrade to Kelvin: c = (k – 273)

: F>C ( n1 -- n2 )   32 - 10 18 */ ;
: C>F ( n1 -- n2 )   18 10 */ 32 + ;
: C>K ( n1 -- n2 )   273 + ;
: K>C ( n1 -- n2 )   273 - ;
: F>K ( n1 -- n2 )   F>C C>K ;
: K>F ( n1 -- n2 )   K>C C>F ;

Test cases:

( a.) 0 F>C .
( b.) 212 F>C .
( c.) -32 F>C .
( d.) 16 C>F .
( e.) 233 K>C .
( f.) -40 C>F .

Chapter 3

Problem set 3.4

1. Both zero

: BOTH-ZERO ( n1 n2 -- flag )   OR 0= ;

Thinking outside the box:

: BOTH-ZERO ( n1 n2 -- flag )   D0= ;

2. Test for valid character

: ISASCII ( n -- )   32 128 WITHIN IF  ." VALID CHARACTER"  THEN ;

3. Test for non-zero

: LEAVE-IF-NONZERO ( n -- n | )  DUP 0= IF  DROP  THEN ;

Thinking outside the box:

: -ZERO ( n -- n | )  ?DUP DROP ;

4. Modulo range test

Brute-force solution:

: TEST ( n -- flag )   
   CASE
      15 OF  FALSE  ENDOF
      10 OF  FALSE  ENDOF
      5 OF  FALSE  ENDOF
      0 OF  FALSE  ENDOF
   TRUE SWAP  ENDCASE ;   

This solution takes advantage of the nature of the numbers:

: FOUR-5 ( n -- flag )   DUP 0 16 WITHIN SWAP 5 MOD 0= AND ;

Thinking outside the box:

: FOUR-5 ( n -- flag )  5 /MOD 4 / OR ;

5. Find the larger value

: MAXIMUM ( n1 n2 -- n1 | n2 )   2DUP < IF SWAP THEN DROP ;

Problem set 3.5.5

: UP ( -- )   ." UP" CR ;
: LEFT ( -- )   ." LEFT" CR ;
: HOME ( -- )   ." HOME" CR ;
: RIGHT ( -- )   ." RIGHT" CR ;
: DOWN ( -- )   ." DOWN" CR ;

: ?WAY ( -- )   BEGIN  KEY DUP  27 <> WHILE   \ Quit on ESCape key
      DUP 32 OR                  \ Set lowercase bit
      CASE
         [CHAR] i OF  UP  ENDOF
         [CHAR] j OF  LEFT  ENDOF
         [CHAR] k OF  HOME  ENDOF
         [CHAR] l OF  RIGHT  ENDOF
         [CHAR] m OF  DOWN  ENDOF
         SWAP DUP 32 127 WITHIN IF  EMIT 0  THEN
      ENDCASE 
   DROP CR   REPEAT DROP ;

There’s no need to factor the individual direction words if they are as simple as these, but we are doing it here because they will be useful in a future version of this problem.

Problem set 3.6.4

1. Avalanche

: AVALANCHE ( n -- )   BEGIN  DUP 1 AND IF ( odd ) 3 * 1+
   ELSE ( even ) 2/  THEN  DUP .   DUP 1 = UNTIL  DROP ;

2. Range

: RANGE ( n1 n2 -- )    \ n1=low, n2=high
   1+ SWAP DO  I .  I 50 = IF  LEAVE  THEN  LOOP ;

3. Star

: STAR ( -- )   [CHAR] * EMIT ;

There are two other ways to do this. What are they?

4. Stars

: STARS ( n -- )   0 ?DO  STAR  LOOP ;

Why was the ?DO necessary?

5. Box

: BOX ( y x -- ) 
   CR  SWAP 0 DO  DUP STARS CR  LOOP DROP ;

6. Slanted box

: /BOX ( y x -- ) 
   CR  OVER 0 DO  I' I - SPACES  DUP STARS CR  LOOP DROP ;

7. Diamond

Output one line of a diamond.

: ONE-LINE ( n1 n2 -- )   \ n1=size, n2=current line index
   SWAP OVER - SPACES STAR  \ Incrementally indent 1st star
   ?DUP IF                  \ Omit spaces and 2nd star for n2=0
      2* 1- SPACES STAR     \ at top and bottom of diamond
   THEN CR ;

Initial and terminal count are both zero, and just beneath them is the starting increment value. The increment value increases, and is negated when I reaches n (n remains on the stack throughout execution).

: DIAMOND ( n -- )
    CR  1- 1 0 0 DO              \ Setup increment value, initial and final count
       OVER I ONE-LINE           \ Pass I' and I to the output routine
       OVER I = IF NEGATE THEN   \ Change increment to -1 when ( I'==I)
    DUP +LOOP  2DROP ;

Problem set 3.6.8

1. Sigma

: SIGMA ( n -- n' ) 0 SWAP 1+ 0 ?DO I + LOOP ;

2. Factorial

: FACTORIAL ( n -- n' ) 1 SWAP 1+ 1 ?DO I * LOOP ;

3. Ramping

: RAMP ( tbd) ;

Chapter 4

Problem set 4.1.5

1a. Simple interest

: SIMPLE ( n1 -- n2 )
   DUP 55 1000 */     \ Get 5.5% of $24.00
   300 *              \ Multiply by 300 years
   + ;                \ and add to initial amount.

2400 SIMPLE .

1b. Compound interest

 : COMPOUND ( d -- d )   300 0 DO  1055 1000 M*/  LOOP ; 

Note: Using 1055 (105.5%) saves an add.

24.00 COMPOUND D. 

How does your result compare with that of a calculator?
How could you increase your accuracy?

2a. Version using variables

VARIABLE UPPER-LIMIT 
VARIABLE LOWER-LIMIT
VARIABLE STARTING-VALUE 
VARIABLE CURRENT-VALUE
1 CONSTANT INCREMENT

: LIMITS ( n1 n2 -- )    \ n1=upper, n2=lower
   DUP STARTING-VALUE !  DUP CURRENT-VALUE ! 
   LOWER-LIMIT !  UPPER-LIMIT ! ;

: DEFAULTS ( -- )   10 0 LIMITS ;

: STEP ( -- )   CURRENT-VALUE @  INCREMENT +
   DUP LOWER-LIMIT @  UPPER-LIMIT @ WITHIN NOT IF
   ( out of range ) DROP  STARTING-VALUE @  THEN
   CURRENT-VALUE ! ;

2b. Version using values

10 VALUE UPPER-LIMIT 
0 VALUE LOWER-LIMIT
0 VALUE STARTING-VALUE 
0 VALUE CURRENT-VALUE
1 CONSTANT INCREMENT

: LIMITS ( n1 n2 -- )    \ n1=upper, n2=lower
   DUP TO STARTING-VALUE  DUP TO CURRENT-VALUE 
   TO LOWER-LIMIT  TO UPPER-LIMIT ;

: DEFAULTS ( -- ) 10 0 LIMITS ;

: STEP ( -- ) CURRENT-VALUE INCREMENT +
   DUP LOWER-LIMIT  UPPER-LIMIT WITHIN NOT IF
   ( out of range ) DROP  STARTING-VALUE  THEN
   TO CURRENT-VALUE ;

Which do you prefer?

Problems 4.2.3

: ARRAY ( n -- )   CELLS BUFFER: ; 
: INDEX ( n addr1 -- addr2 )   SWAP CELLS + ; 

Testing

10 CONSTANT SIZE 
SIZE ARRAY NAME 

: FILL ( -- )   SIZE 0 DO  I DUP NAME  INDEX !  LOOP ;
: SHOW ( -- )   SIZE 0 DO  I NAME  INDEX @ .  LOOP ; 

4 ARRAY ITEMS
: FIRST ( -- addr )   0 ITEMS INDEX ;
: SECOND ( -- addr )   1 ITEMS INDEX ;
etc...

Chapter 5

Problem set 5.1.7

1. Insert

: INSERT ( n c -- )
    SWAP 1- DUP PAD COUNT   \ set up buffer and count relative-zero
    ROT - SWAP              \ subtract to get size
    ROT + SWAP OVER         \ calculate length to move
    DUP 1+ ROT MOVE C!
    PAD C@ 1+ PAD C! ;      \ adjust and update length of counted string

2. Delete

: DELETE ( n -- )
    DUP PAD COUNT ROT -     \ Subtract to get size of string to move
    SWAP ROT +              \ Get source address
    DUP 1- ROT MOVE         \ Move string
    PAD C@ 1- PAD C! ;       \ Update length of counted string

3. Convert case

: UPPER ( char1 -- char2 )
   DUP [CHAR] a  [CHAR] z 1+ WITHIN IF  32 -  THEN ; 

: LOWER ( char1 -- char2 )
   DUP [CHAR] A  [CHAR] Z 1+ WITHIN IF  32 +  THEN ; 

Alternative solutions without IF … THEN :

: UPPER ( char1 -- char2 )
   DUP [CHAR] a  [CHAR] z 1+ WITHIN 32 AND - ; 

: LOWER ( char1 -- char2 )
   DUP [CHAR] A  [CHAR] Z 1+ WITHIN 32 AND + ; 

Problem 5.2.1

: I'M ( -- )   BL WORD COUNT TYPE ;
: MEET ( -- )   CR ." HI " I'M ;

: NAME ( -- addr )  PAD ; 
: ADDR ( -- addr )   NAME 40 + ; 
: C/S ( -- addr )   ADDR 40 + ; 

: LINE-INPUT ( a -- )
   DUP 1+ 39 ACCEPT     \ Get input
   SWAP C! ;            \ Save actual length 

: LINE-OUTPUT ( addr -- )   CR COUNT TYPE ; 

: NAME? ( -- )   NAME LINE-INPUT ; 
: ADDR? ( -- )   ADDR LINE-INPUT ; 
: C/S? ( -- )   C/S LINE-INPUT ; 

: ?INFO ( -- )
    CR    ." NAME? "  NAME?
    CR    ." ADDR? "  ADDR?
    CR    ." C/S? "  C/S? ;

: INFO ( -- )
    NAME LINE-OUTPUT
    ADDR LINE-OUTPUT
    C/S LINE-OUTPUT ;

Problem 5.4.1

: HOME ( -- )   0 0 AT-XY ; 
: UP ( -- )   GET-XY 1- AT-XY ; 
: DOWN ( -- )   GET-XY 1+ AT-XY ; 
: LEFT ( -- )   GET-XY SWAP 1- SWAP AT-XY ; 
: RIGHT ( -- )   GET-XY SWAP 1+ SWAP AT-XY ; 
: ASCII? ( n -- flag )   32 127 WITHIN ; 
 
: ?WAY ( -- )
    BEGIN  KEY DUP  27 <> WHILE   \ Quit on ESCape key
       DUP 32 OR                  \ Set lowercase bit
       CASE
          [CHAR] i OF  UP  ENDOF
          [CHAR] j OF  LEFT  ENDOF
          [CHAR] k OF  HOME  ENDOF
          [CHAR] l OF  RIGHT  ENDOF
          [CHAR] m OF  DOWN  ENDOF
          SWAP DUP ASCII? IF  EMIT 0  THEN
       ENDCASE DROP
    REPEAT DROP ; 

Chapter 6

Problem 6.1.1

4 BUFFER: PARTS

Read ip address ‘ip-addr’ from the input stream and store as a big-endian 32-bit IP address at buffer ‘parts’

: GET-IP ( -- )
     4 0 DO  0.                   \ Set double-length accumulator
        [CHAR] . PARSE >NUMBER    \ Get a part & convert it
        2DROP DROP  parts I + C!  \ Discard address info, store part
     LOOP ; 
: TEST ( -- )   4 0 DO  parts I + C@ .  LOOP ; 

GET-IP 192.63.12.1 
TEST 

Buffered version — converts from string given addr len:

16 BUFFER: IPSTRING

: get-ip ( addr len -- )
   4 0 DO 0. 2SWAP >NUMBER      \ Convert a part
      2SWAP DROP parts I + C!   \ Store it
      1 /STRING                 \ Increment addr over 
   LOOP 2DROP ;

CR IPSTRING 16 ACCEPT
192.63.12.1
IPSTRING SWAP get-ip TEST

Also, here’s a simple one-line test:

S" 122.236.17.55" GET-IP TEST

Problem set 6.2.6

1.
: '-' ( -- )   [CHAR] - HOLD ;
: .SSN ( ud -- )  <# # # # # '-' # # '-' #S #> TYPE ;

2.
: '(' ( -- )   [CHAR] ( HOLD ;
: ')' ( -- )   [CHAR] ) HOLD ;

: .PH ( n ud -- )
   <# # # # # '-' #S BL HOLD 2DROP 0 ')' #S '(' #> TYPE ;

3.
: '.' ( -- )   [CHAR] . HOLD ;
: N.2 ( n -- )   DUP ABS 0 <# # # '.' #S ROT SIGN #> TYPE ;

4.
: DF. ( d n -- )
   -ROT DUP >R DABS ROT
   <# ?DUP IF  0 DO # LOOP '.' THEN
   #S  R> SIGN  #> TYPE ;

5.
: ?BASE ( -- )   BASE @ DUP DECIMAL . BASE ! ;

Chapter 7

Problem set 7.2.1

: UP ( -- ) GET-XY 1- AT-XY ;
: LEFT ( -- ) GET-XY SWAP 1- SWAP AT-XY ;
: HOME ( -- ) 0 0 AT-XY ;
: RIGHT ( -- ) GET-XY SWAP 1+ SWAP AT-XY ;
: DOWN ( -- ) GET-XY 1+ AT-XY ;

Construct the table of execution vectors:

CREATE KEYS   ' UP , ' LEFT , ' HOME , ' RIGHT , ' DOWN ,

: ?WAY ( -- )
   BEGIN KEY DUP
      27 = NOT WHILE
      DUP 32 OR                 \ make lowercase for comparison
      [CHAR] i -                \ adjust for offset into vector table
      DUP 0 5 WITHIN IF
         SWAP DROP CELLS        \ calculate table offset
         KEYS + @EXECUTE        \ do a vector
      ELSE DROP EMIT THEN       \ or emit the original ASCII character
   REPEAT DROP ;                \ loop until Esc key pressed

Chapter 8

Problem set 8.6.1

Defining behavior: ny nx 2ARRAY
Create 2-dimensional array of ny * nx elements, where nx is innermost and contiguous dimension, and the first two cells hold ny and nx respectively.

Instance behavior: ( iy ix — a )
Return the address a of array element [ny][nx] where nx is the innermost and contiguous dimension.

: 2ARRAY ( ny nx -- )
   CREATE 2DUP , , * CELLS ALLOT
   DOES> ( iy ix -- a )  DUP >R 2@      \ iy ix ny nx, addr saved
   2OVER ROT 0 SWAP WITHIN              \ Check x range
   -ROT 0 ROT WITHIN                    \ Check y range
   AND 0= ABORT" Out of range"          \ Abort if illegal
   SWAP R@ @ ( nx) * +                  \ Multiply iy by nx
   2+ CELLS R> + ;                      \ Add offset, add to addr