math: adding a fast-gcd that speeds up all ratio operations by up to 10 times for bignum ratios.
							parent
							
								
									22c26ff3f5
								
							
						
					
					
						commit
						b2ffda32ca
					
				| 
						 | 
					@ -111,8 +111,20 @@ PRIVATE>
 | 
				
			||||||
: gcd ( x y -- a d )
 | 
					: gcd ( x y -- a d )
 | 
				
			||||||
    [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; inline
 | 
					    [ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					MATH: fast-gcd ( x y -- d ) foldable
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					<PRIVATE
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: simple-gcd ( x y -- d ) gcd nip ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					PRIVATE>
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					M: real fast-gcd simple-gcd ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					M: bignum fast-gcd bignum-gcd ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: lcm ( a b -- c )
 | 
					: lcm ( a b -- c )
 | 
				
			||||||
    [ * ] 2keep gcd nip /i ; foldable
 | 
					    [ * ] 2keep fast-gcd /i ; foldable
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: divisor? ( m n -- ? )
 | 
					: divisor? ( m n -- ? )
 | 
				
			||||||
    mod 0 = ; inline
 | 
					    mod 0 = ; inline
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -1,9 +1,10 @@
 | 
				
			||||||
! Copyright (C) 2008 Slava Pestov.
 | 
					! Copyright (C) 2008 Slava Pestov.
 | 
				
			||||||
! See http://factorcode.org/license.txt for BSD license.
 | 
					! See http://factorcode.org/license.txt for BSD license.
 | 
				
			||||||
USING: accessors kernel kernel.private math math.private words
 | 
					USING: accessors kernel kernel.private math math.private
 | 
				
			||||||
sequences parser namespaces make assocs quotations arrays
 | 
					math.functions math.functions.private sequences parser
 | 
				
			||||||
generic generic.math hashtables effects compiler.units
 | 
					namespaces make assocs quotations arrays generic generic.math
 | 
				
			||||||
classes.algebra fry combinators ;
 | 
					hashtables effects compiler.units classes.algebra fry
 | 
				
			||||||
 | 
					combinators words ;
 | 
				
			||||||
IN: math.partial-dispatch
 | 
					IN: math.partial-dispatch
 | 
				
			||||||
 | 
					
 | 
				
			||||||
PREDICATE: math-partial < word
 | 
					PREDICATE: math-partial < word
 | 
				
			||||||
| 
						 | 
					@ -215,6 +216,8 @@ SYMBOL: fast-math-ops
 | 
				
			||||||
        \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 | 
					        \ mod \ fixnum-mod \ bignum-mod define-integer-ops
 | 
				
			||||||
        \ /i \ fixnum/i \ bignum/i define-integer-ops
 | 
					        \ /i \ fixnum/i \ bignum/i define-integer-ops
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					        \ fast-gcd \ simple-gcd \ bignum-gcd define-integer-ops
 | 
				
			||||||
 | 
					
 | 
				
			||||||
        \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 | 
					        \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
 | 
				
			||||||
        \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 | 
					        \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
 | 
				
			||||||
        \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 | 
					        \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -30,7 +30,7 @@ M: integer /
 | 
				
			||||||
        division-by-zero
 | 
					        division-by-zero
 | 
				
			||||||
    ] [
 | 
					    ] [
 | 
				
			||||||
        dup 0 < [ [ neg ] bi@ ] when
 | 
					        dup 0 < [ [ neg ] bi@ ] when
 | 
				
			||||||
        2dup gcd nip [ /i ] curry bi@ fraction>
 | 
					        2dup fast-gcd [ /i ] curry bi@ fraction>
 | 
				
			||||||
    ] if-zero ;
 | 
					    ] if-zero ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: ratio hashcode*
 | 
					M: ratio hashcode*
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue