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

 Given: To get: Type: 1 2 3 3 2 1 SWAP ROT 1 2 3 1 2 3 2 OVER 1 2 3 1 2 3 3 DUP 1 2 3 1 3 3 SWAP DROP DUP 1 2 3 2 1 3 ROT SWAP 1 2 3 4 4 3 2 1 SWAP 2SWAP SWAP 1 2 3 1 2 3 1 2 3 DUP 2OVER ROT 1 2 3 4 1 2 3 4 1 2 2OVER 1 2 3 STACK EMPTY 2DROP DROP 1 2 3 1 2 3 4 4 1 2 3 1 3 SWAP DROP

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) + 10A(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`

`: 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 ACCEPT192.63.12.1IPSTRING 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`