1hw.fs

   1 \ http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/Tutorial.html
   2 \ all `ass*' words are `( -- )' if not stated otherwise.
   3
   4 : rr ( -- ) s" 1hw.fs" included ;
   5 : :r rr ; \ ghci style
   6
   7 \ ============================== 3.4 =========================================
   8 : ass34 5 6 7 .s 2drop drop ;
   9
  10 \ ============================== 3.5 =========================================
  11 \ postfix       |   infix
  12 \ 3 4 + 5 *     =       (3 + 4) * 5
  13 \ 3 4 5 * +     =       (4 * 5) + 3
  14
  15
  16 \ Assignment: What are the infix expressions corresponding to the Forth code
  17 \ above? Write 6-7*8+9 in Forth notation1.
  18 : ass35.1 6 7 8 * - 9 + .s drop ;
  19
  20 \ Assignment: Convert -(-3)*4-5 to Forth.
  21 : ass35.2 3 negate 4 * negate 5 - .s drop ;
  22
  23 \ ============================== 3.6 =========================================
  24
  25 \ Assignment: Replace nip and tuck with combinations of other stack
  26 \ manipulation words.
  27 : ass36nip ( a b -- a )
  28         swap drop ;
  29 : ass36tuck ( a b -- b a b )
  30         swap over ;
  31
  32 \          Given:          How do you get:
  33 \          1 2 3           3 2 1
  34 : ass36.1.1 1 2 3 rot rot swap .s 2drop drop ;
  35
  36 \          1 2 3           1 2 3 2
  37 : ass36.1.2 1 2 3 over .s 2drop 2drop ;
  38
  39 \          1 2 3           1 2 3 3
  40 : ass36.1.3 1 2 3 dup .s 2drop 2drop ;
  41
  42 \          1 2 3           1 3 3
  43 : ass36.1.4 1 2 3 swap drop dup .s 2drop drop ;
  44
  45 \          1 2 3           2 1 3
  46 : ass36.1.5 1 2 3 rot swap .s 2drop drop ;
  47
  48 \          1 2 3 4         4 3 2 1
  49 : ass36.1.6 1 2 3 4 swap 2swap swap ;
  50
  51 \          1 2 3           1 2 3 1 2 3
  52 : ass36.1.7 1 2 3 dup 2over rot .s 2drop 2drop 2drop ;
  53
  54 \          1 2 3 4         1 2 3 4 1 2
  55 : ass36.1.8 1 2 3 4 2over .s 2drop 2drop 2drop ;
  56
  57 \          1 2 3
  58 : ass36.1.9 1 2 3 2drop drop .s ;
  59
  60 \          1 2 3           1 2 3 4
  61 \ WTF??
  62 : ass36.1.10 1 2 3 4 .s 2drop 2drop ;
  63
  64 \          1 2 3           1 3
  65 : ass36.1.11 1 2 3 nip .s 2drop ;
  66
  67
  68 \ Assignment: Write 17^3 and 17^4 in Forth, without writing 17 more than once.
  69 \ Write a piece of Forth code that expects two numbers on the stack (a and b,
  70 \ with b on top) and computes (a-b)(a+1).
  71
  72 : ass36.2 17 dup dup * * ;
  73 : ass36.3 17 dup 2dup * * * ;
  74 : ass36.4 ( a b -- erg)
  75         over swap - swap 1 + * ;
  76
  77 \ ============================== 3.9 =========================================
  78 \ Assignment: Write colon definitions for nip, tuck, negate, and /mod in terms
  79 \ of other Forth words, and check if they work (hint: test your tests on the
  80 \ originals first). Don't let the `redefined'-Messages spook you, they are
  81 \ just warnings.
  82
  83 : nip ( a b -- b ) swap drop ;
  84 : tuck ( a b -- b a b ) swap over ;
  85 : negate ( a -- -a ) -1 * ;
  86 : /mod 2dup mod rot rot / ;
  87
  88 \ ============================== 3.15 ========================================
  89 \ Assignment: Rewrite your definitions until now with locals
  90 : nip { a b } b ;
  91 : tuck { a b } b a b ;
  92 : /mod { a b } a b mod a b / ;
  93
  94 \ ============================== 3.16 ========================================
  95 \ Assignment: Write min without else-part (hint: what's the definition of nip?).
  96 : min ( n1 n2 -- n )
  97         2dup < if swap then nip ;
  98
  99 \ ============================== 3.17 ========================================
 100 \ Assignment: Write min without if.
 101 : min ( n1 n2 -- n ) 2dup < dup
 102         2swap ( v v n1 n2)
 103         rot ( v n1 n2 v )
 104         invert and ( v n1 n2v )
 105         rot rot and ( n2v n1v )
 106         or ( n ) ;
 107
 108 \ ============================== 3.18 ========================================
 109 \ Assignment: Write a definition for computing the greatest common divisor.
 110 : gcd ( a b -- x )
 111         begin
 112                 2dup mod ( a b r )
 113                 rot drop ( b r -> a b in next step )
 114                 dup 0=
 115         until drop ;
 116
 117
 118 \ ============================== 3.19 ========================================
 119 \ Assignment: Write a definition for computing the nth Fibonacci number.
 120
 121 : fibit ( n -- fib (n)
 122         0 1 ( u v -- initial values )
 123         rot 0 u+do
 124                 2dup + ( u_old u_new v_new )
 125                 rot drop ( u_new v_new )
 126         loop nip ;
 127
 128 \ ============================== 3.20 ========================================
 129 \ Assignment: Write a recursive definition for computing the nth Fibonacci
 130 \ number.
 131 : fibrec ( n -- fib (n)
 132         dup 1 > if dup 1- recurse swap 2 - recurse +
 133         else dup 0= if drop 1 then then ;
 134
 135 : show20fib cr 20 0 u+do i dup dup . ." : " fibit . ." , " fibrec . cr loop ;
 136
 137 \ ============================== 3.22 ========================================
 138 \ Assignment: Can you rewrite any of the definitions you wrote until now in a
 139 \ better way using the return stack?
 140 : min ( n1 n2 -- n)
 141         2dup < >r r@ ( n1 n2 v )
 142         invert and swap r> and or ;
 143
 144 \ ============================== 3.23 ========================================
 145 \ Assignment: Write a definition sum ( addr u -- n ) that computes the sum of u
 146 \ cells, with the first of these calls at addr, the next one at addr cell+ etc.
 147 : sum ( addr u -- n )
 148         >r
 149         1 cells - 0 ( addr-4 0)
 150         r> 0 ( addr-4 0 u 0 )
 151         u+do
 152                 swap cell+ dup ( 0 addr addr )
 153                 @ ( 0 addr val )
 154                 rot ( addr val 0 )
 155                 + ( addr sum )
 156         loop swap drop ;
 157
 158 create v3
 159  5 , 4 , 3 , 2 , 1 ,
 160 : sumexample v3 5 sum ;