| 
									
										
										
										
											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
 | 
					
						
							|  |  |  |  |     ] ;
 |