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.).
On This Page
- Chapter 2
- Problem set 2.2.5
- Problem set 2.7
- 1. Average of six numbers:
- 2. Rewrite the equations using postfix notation and the proper arithmetic operators:
- 3. 2**6:
- 4. Rounding a number with one decimal place to nearest integer:
- 5. Rounding a number with one decimal place to nearest even integer :
- 6. To convert single to double:
- 7. How would you do the folowing operations if you had unknowns on the stack?
- 8. Define words to convert temperatures, using these formulae:
- Chapter 3
- Chapter 4
- Chapter 5
- Chapter 6
- Chapter 7
- Chapter 8
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) + 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