2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! Copyright (c) 2012 Anonymous
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:31:10 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								USING: combinators fry kernel locals math ;
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 12:44:44 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								IN: rosetta-code.y-combinator
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! http://rosettacode.org/wiki/Y_combinator
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! In strict functional programming and the lambda calculus,
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! functions (lambda expressions) don't have state and are only
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! allowed to refer to arguments of enclosing functions. This rules
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! out the usual definition of a recursive function wherein a
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! function is associated with the state of a variable and this
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! variable's state is used in the body of the function.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! The Y combinator is itself a stateless function that, when
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! applied to another stateless function, returns a recursive
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! version of the function. The Y combinator is the simplest of the
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! class of such functions, called fixed-point combinators.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! The task is to define the stateless Y combinator and use it to
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! compute factorials and Fibonacci numbers from other stateless
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! functions or lambda expressions.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								: Y ( quot -- quot )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:21:55 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								    '[ [ dup call call ] curry @ ] dup call ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:25:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! factorial sequence
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								: almost-fac ( quot -- quot )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:25:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								    '[ dup zero? [ drop 1 ] [ dup 1 - @ * ] if ] ;
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:25:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								! fibonacci sequence
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-03 18:17:50 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								: almost-fib ( quot -- quot )
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:25:03 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								    '[ dup 2 >= [ 1 2 [ - @ ] bi-curry@ bi + ] when ] ;
							 | 
						
					
						
							
								
									
										
										
										
											2012-08-04 16:31:10 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
										
									
								 | 
							
							
								! Ackermann–Péter function
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								:: almost-ack ( quot -- quot )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								    [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								        {
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								          { [ over zero? ] [ nip 1 + ] }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								          { [ dup zero? ] [ [ 1 - ] [ drop 1 ] bi* quot call ] }
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								          [ [ drop 1 - ] [ 1 - quot call ] 2bi quot call ]
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								        } cond
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
								
									
								 | 
							
							
								    ] ;
							 |