\ http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/Tutorial.html
\ all `ass*' words are `( -- )' if not stated otherwise.

: rr ( -- ) s" 1hw.fs" included ;
: :r rr ; \ ghci style

\ ============================== 3.4 =========================================
: ass34 5 6 7 .s 2drop drop ;

\ ============================== 3.5 =========================================
\ postfix       |   infix
\ 3 4 + 5 * 	= 	(3 + 4) * 5
\ 3 4 5 * +     = 	(4 * 5) + 3


\ Assignment: What are the infix expressions corresponding to the Forth code
\ above? Write 6-7*8+9 in Forth notation1.
: ass35.1 6 7 8 * - 9 + .s drop ;

\ Assignment: Convert -(-3)*4-5 to Forth.
: ass35.2 3 negate 4 * negate 5 - .s drop ;

\ ============================== 3.6 =========================================

\ Assignment: Replace nip and tuck with combinations of other stack
\ manipulation words.
: ass36nip ( a b -- a )
	swap drop ;
: ass36tuck ( a b -- b a b )
	swap over ;

\          Given:          How do you get:
\          1 2 3           3 2 1
: ass36.1.1 1 2 3 rot rot swap .s 2drop drop ;

\          1 2 3           1 2 3 2
: ass36.1.2 1 2 3 over .s 2drop 2drop ;

\          1 2 3           1 2 3 3
: ass36.1.3 1 2 3 dup .s 2drop 2drop ;

\          1 2 3           1 3 3
: ass36.1.4 1 2 3 swap drop dup .s 2drop drop ;

\          1 2 3           2 1 3
: ass36.1.5 1 2 3 rot swap .s 2drop drop ;

\          1 2 3 4         4 3 2 1
: ass36.1.6 1 2 3 4 swap 2swap swap ;

\          1 2 3           1 2 3 1 2 3
: ass36.1.7 1 2 3 dup 2over rot .s 2drop 2drop 2drop ;

\          1 2 3 4         1 2 3 4 1 2
: ass36.1.8 1 2 3 4 2over .s 2drop 2drop 2drop ;

\          1 2 3
: ass36.1.9 1 2 3 2drop drop .s ;

\          1 2 3           1 2 3 4
\ WTF??
: ass36.1.10 1 2 3 4 .s 2drop 2drop ;

\          1 2 3           1 3
: ass36.1.11 1 2 3 nip .s 2drop ;


\ Assignment: Write 17^3 and 17^4 in Forth, without writing 17 more than once.
\ Write a piece of Forth code that expects two numbers on the stack (a and b,
\ with b on top) and computes (a-b)(a+1). 

: ass36.2 17 dup dup * * ;
: ass36.3 17 dup 2dup * * * ;
: ass36.4 ( a b -- erg)
	over swap - swap 1 + * ;

\ ============================== 3.9 =========================================
\ Assignment: Write colon definitions for nip, tuck, negate, and /mod in terms
\ of other Forth words, and check if they work (hint: test your tests on the
\ originals first). Don't let the `redefined'-Messages spook you, they are
\ just warnings.

: nip ( a b -- b ) swap drop ;
: tuck ( a b -- b a b ) swap over ;
: negate ( a -- -a ) -1 * ;
: /mod 2dup mod rot rot / ;

\ ============================== 3.15 ========================================
\ Assignment: Rewrite your definitions until now with locals
: nip { a b } b ;
: tuck { a b } b a b ;
: /mod { a b } a b mod a b / ;

\ ============================== 3.16 ========================================
\ Assignment: Write min without else-part (hint: what's the definition of nip?).
: min ( n1 n2 -- n )
	2dup < if swap then nip ;

\ ============================== 3.17 ========================================
\ Assignment: Write min without if.
: min ( n1 n2 -- n ) 2dup < dup
	2swap ( v v n1 n2)
	rot ( v n1 n2 v )
	invert and ( v n1 n2v )
	rot rot and ( n2v n1v )
	or ( n ) ;

\ ============================== 3.18 ========================================
\ Assignment: Write a definition for computing the greatest common divisor.
: gcd ( a b -- x )
	begin
		2dup mod ( a b r )
		rot drop ( b r -> a b in next step )
		dup 0=
	until drop ;


\ ============================== 3.19 ========================================
\ Assignment: Write a definition for computing the nth Fibonacci number.

: fibit ( n -- fib (n)
	0 1 ( u v -- initial values )
	rot 0 u+do
		2dup + ( u_old u_new v_new )
		rot drop ( u_new v_new )
	loop nip ;

\ ============================== 3.20 ========================================
\ Assignment: Write a recursive definition for computing the nth Fibonacci
\ number.
: fibrec ( n -- fib (n)
	dup 1 > if dup 1- recurse swap 2 - recurse +
	else dup 0= if drop 1 then then ;

: show20fib cr 20 0 u+do i dup dup . ." : " fibit . ." , " fibrec . cr loop ;

\ ============================== 3.22 ========================================
\ Assignment: Can you rewrite any of the definitions you wrote until now in a
\ better way using the return stack?
: min ( n1 n2 -- n)
	2dup < >r r@ ( n1 n2 v )
	invert and swap r> and or ;

\ ============================== 3.23 ========================================
\ Assignment: Write a definition sum ( addr u -- n ) that computes the sum of u
\ cells, with the first of these calls at addr, the next one at addr cell+ etc.
: sum ( addr u -- n )
	>r
	1 cells - 0 ( addr-4 0)
	r> 0 ( addr-4 0 u 0 )
	u+do
		swap cell+ dup ( 0 addr addr )
		@ ( 0 addr val )
		rot ( addr val 0 )
		+ ( addr sum )
	loop swap drop ;

create v3
 5 , 4 , 3 , 2 , 1 ,
: sumexample v3 5 sum ;