diff --git a/src/arith/integer.c b/src/arith/integer.c index 5452107..01fc8fb 100644 --- a/src/arith/integer.c +++ b/src/arith/integer.c @@ -521,21 +521,3 @@ bool equal_integer_integer( struct cons_pointer a, struct cons_pointer b ) { return result; } - -/** - * true if `a` is an integer, and `b` is a real number whose value is the - * value of that integer. - */ -bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ) { - bool result = false; - - if ( integerp( a ) && realp( b ) ) { - long double bv = pointer2cell( b ).payload.real.value; - - if ( floor( bv ) == bv ) { - result = pointer2cell( a ).payload.integer.value == ( int64_t ) bv; - } - } - - return result; -} diff --git a/src/arith/peano.c b/src/arith/peano.c index ae23a00..1a43f55 100644 --- a/src/arith/peano.c +++ b/src/arith/peano.c @@ -748,3 +748,29 @@ struct cons_pointer lisp_divide( struct return result; } + +/** + * @brief Function: return a real (approcimately) equal in value to the ratio + * which is the first argument. + * + * @param frame + * @param frame_pointer + * @param env + * @return struct cons_pointer a pointer to a real + */ +// struct cons_pointer lisp_eval( struct stack_frame *frame, struct cons_pointer frame_pointer, +// struct cons_pointer env ) +struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env) { + struct cons_pointer result = NIL; + struct cons_pointer rat = frame->arg[0]; + + debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); + debug_print_object( rat, DEBUG_ARITH); + + if ( ratiop( rat)) { + result = make_real( c_ratio_to_ld( rat)); + } // TODO: else throw an exception? + + return result; +} \ No newline at end of file diff --git a/src/arith/peano.h b/src/arith/peano.h index 5e83f0c..8b2908c 100644 --- a/src/arith/peano.h +++ b/src/arith/peano.h @@ -75,4 +75,7 @@ struct cons_pointer lisp_divide( struct stack_frame *frame, struct cons_pointer frame_pointer, struct cons_pointer env ); +struct cons_pointer lisp_ratio_to_real( struct stack_frame *frame, struct cons_pointer frame_pointer, + struct cons_pointer env); + #endif /* PEANO_H */ diff --git a/src/arith/ratio.c b/src/arith/ratio.c index 5608717..9c7c524 100644 --- a/src/arith/ratio.c +++ b/src/arith/ratio.c @@ -11,15 +11,17 @@ #include #include +#include "arith/integer.h" +#include "arith/peano.h" +#include "arith/ratio.h" +#include "arith/real.h" +#include "debug.h" +#include "io/print.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" -#include "debug.h" +#include "memory/stack.h" #include "ops/equal.h" -#include "arith/integer.h" #include "ops/lispops.h" -#include "arith/peano.h" -#include "io/print.h" -#include "arith/ratio.h" /** @@ -91,11 +93,10 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { struct cons_pointer r, result; - debug_print( L"add_ratio_ratio( arg1 = ", DEBUG_ARITH ); - debug_print_object( arg1, DEBUG_ARITH ); - debug_print( L"; arg2 = ", DEBUG_ARITH ); - debug_print_object( arg2, DEBUG_ARITH ); - debug_print( L")\n", DEBUG_ARITH ); + debug_print( L"\naadd_ratio_ratio: ", DEBUG_ARITH); + debug_print_object( arg1, DEBUG_ARITH); + debug_print( L" + ", DEBUG_ARITH); + debug_print_object( arg2, DEBUG_ARITH); if ( ratiop( arg1 ) && ratiop( arg2 ) ) { struct cons_space_object cell1 = pointer2cell( arg1 ); @@ -111,7 +112,7 @@ struct cons_pointer add_ratio_ratio( struct cons_pointer arg1, lcm = least_common_multiple( dr1v, dr2v ), m1 = lcm / dr1v, m2 = lcm / dr2v; - debug_printf( DEBUG_ARITH, L"); lcm = %ld; m1 = %ld; m2 = %ld", lcm, + debug_printf( DEBUG_ARITH, L"; lcm = %ld; m1 = %ld; m2 = %ld", lcm, m1, m2 ); if ( dr1v == dr2v ) { @@ -170,6 +171,11 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; + debug_print( L"\nadd_integer_ratio: ", DEBUG_ARITH); + debug_print_object( intarg, DEBUG_ARITH); + debug_print( L" + ", DEBUG_ARITH); + debug_print_object( ratarg, DEBUG_ARITH); + if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: not longer works struct cons_pointer one = acquire_integer( 1, NIL ), @@ -188,6 +194,10 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, NIL ) ) ), NIL ); } + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + return result; } @@ -199,6 +209,10 @@ struct cons_pointer add_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { + debug_print( L"\ndivide_ratio_ratio: ", DEBUG_ARITH); + debug_print_object( arg1, DEBUG_ARITH); + debug_print( L" / ", DEBUG_ARITH); + debug_print_object( arg2, DEBUG_ARITH); // TODO: this now has to work if `arg1` is an integer struct cons_pointer i = make_ratio( pointer2cell( arg2 ).payload.ratio.divisor, @@ -207,6 +221,10 @@ struct cons_pointer divide_ratio_ratio( struct cons_pointer arg1, dec_ref( i ); + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + return result; } @@ -259,6 +277,10 @@ struct cons_pointer multiply_ratio_ratio( struct NIL ); } + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + return result; } @@ -272,6 +294,11 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, struct cons_pointer ratarg ) { struct cons_pointer result; + debug_print( L"\nmultiply_integer_ratio: ", DEBUG_ARITH); + debug_print_object( intarg, DEBUG_ARITH); + debug_print( L" * ", DEBUG_ARITH); + debug_print_object( ratarg, DEBUG_ARITH); + if ( integerp( intarg ) && ratiop( ratarg ) ) { // TODO: no longer works; fix struct cons_pointer one = acquire_integer( 1, NIL ), @@ -286,6 +313,10 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, NIL ); } + debug_print( L" => ", DEBUG_ARITH ); + debug_print_object( result, DEBUG_ARITH ); + debug_print( L"\n", DEBUG_ARITH ); + return result; } @@ -298,6 +329,11 @@ struct cons_pointer multiply_integer_ratio( struct cons_pointer intarg, */ struct cons_pointer subtract_ratio_ratio( struct cons_pointer arg1, struct cons_pointer arg2 ) { + debug_print( L"\nsubtract_ratio_ratio: ", DEBUG_ARITH); + debug_print_object( arg1, DEBUG_ARITH); + debug_print( L" * ", DEBUG_ARITH); + debug_print_object( arg2, DEBUG_ARITH); + struct cons_pointer i = negative( arg2 ), result = add_ratio_ratio( arg1, i ); @@ -361,3 +397,35 @@ bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ) { return result; } + +/** + * @brief convert a ratio to an equivalent long double. + * + * @param rat a pointer to a ratio. + * @return long double + */ +long double c_ratio_to_ld( struct cons_pointer rat) { + long double result = NAN; + + debug_print( L"\nc_ratio_to_ld: ", DEBUG_ARITH); + debug_print_object( rat, DEBUG_ARITH); + + if ( ratiop( rat)) { + struct cons_space_object * cell_a = & pointer2cell( rat); + struct cons_pointer dv = cell_a->payload.ratio.divisor; + struct cons_space_object * dv_cell = &pointer2cell( dv); + struct cons_pointer dd = cell_a->payload.ratio.dividend; + struct cons_space_object * dd_cell = &pointer2cell( dd); + + if ( nilp( dv_cell->payload.integer.more) && nilp( dd_cell->payload.integer.more)) { + result = ((long double) dd_cell->payload.integer.value) / ((long double) dv_cell->payload.integer.value);; + } else { + fwprintf( stderr, L"real conversion is not yet implemented for bignums rationals."); + } + } + + debug_printf( DEBUG_ARITH, L"\nc_ratio_to_ld returning %d\n", result ); + + return result; +} + diff --git a/src/arith/ratio.h b/src/arith/ratio.h index 9068bfb..8d93f44 100644 --- a/src/arith/ratio.h +++ b/src/arith/ratio.h @@ -36,4 +36,6 @@ struct cons_pointer make_ratio( struct cons_pointer dividend, bool equal_ratio_ratio( struct cons_pointer a, struct cons_pointer b ); +long double c_ratio_to_ld( struct cons_pointer rat); + #endif diff --git a/src/init.c b/src/init.c index 912ba45..2d3d394 100644 --- a/src/init.c +++ b/src/init.c @@ -20,6 +20,7 @@ /* libcurl, used for io */ #include +#include "arith/ratio.h" #include "version.h" #include "memory/conspage.h" #include "memory/consspaceobject.h" @@ -347,6 +348,7 @@ int main( int argc, char *argv[] ) { bind_function( L"print", &lisp_print ); bind_function( L"put!", lisp_hashmap_put ); bind_function( L"put-all!", &lisp_hashmap_put_all ); + bind_function( L"ratio->real", &lisp_ratio_to_real ); bind_function( L"read", &lisp_read ); bind_function( L"read-char", &lisp_read_char ); bind_function( L"repl", &lisp_repl ); diff --git a/src/ops/equal.c b/src/ops/equal.c index 39d80af..0b21060 100644 --- a/src/ops/equal.c +++ b/src/ops/equal.c @@ -15,6 +15,7 @@ #include "arith/integer.h" #include "arith/peano.h" #include "arith/ratio.h" +#include "debug.h" /** * Shallow, and thus cheap, equality: true if these two objects are @@ -48,11 +49,198 @@ bool end_of_string( struct cons_pointer string ) { pointer2cell( string ).payload.string.character == '\0'; } +/** + * @brief compare two long doubles and returns true if they are the same to + * within a tolerance of one part in a billion. + * + * @param a + * @param b + * @return true if `a` and `b` are equal to within one part in a billion. + * @return false otherwise. + */ +bool equal_ld_ld( long double a, long double b) { + long double fa = fabsl( a); + long double fb = fabsl( b); + /* difference of magnitudes */ + long double diff = fabsl( fa - fb); + /* average magnitude of the two */ + long double av = (fa > fb) ? ( fa - diff) : ( fb - diff); + /* amount of difference we will tolerate for equality */ + long double tolerance = av * 0.000000001; + + bool result = ( fabsl( a - b) < tolerance); + + debug_printf( DEBUG_ARITH, L"\nequal_ld_ld returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp integer -- if it isn't an integer, things will break. + * @param b a lisp real -- if it isn't a real, things will break. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_integer_real( struct cons_pointer a, struct cons_pointer b ){ + debug_print( L"\nequal_integer_real: ", DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH); + debug_print( L" = ", DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH); + bool result = false; + struct cons_space_object * cell_a = &pointer2cell( a); + struct cons_space_object * cell_b = & pointer2cell( b); + + if (nilp( cell_a->payload.integer.more)) { + result = equal_ld_ld( (long double) cell_a->payload.integer.value, cell_b->payload.real.value); + } else { + fwprintf( stderr, L"\nequality is not yet implemented for bignums compared to reals."); + } + + debug_printf( DEBUG_ARITH, L"\nequal_integer_real returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp integer -- if it isn't an integer, things will break. + * @param b a lisp number. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_integer_number( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal_integer_number: ", DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH); + debug_print( L" = ", DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH); + bool result = false; + struct cons_space_object * cell_b = & pointer2cell( b); + + switch ( cell_b->tag.value) { + case INTEGERTV: + result = equal_integer_integer( a, b); + break; + case REALTV: + result = equal_integer_real( a, b); + break; + case RATIOTV: + result = false; + break; + } + + debug_printf( DEBUG_ARITH, L"\nequal_integer_number returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a lisp real -- if it isn't an real, things will break. + * @param b a lisp number. + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_real_number( struct cons_pointer a, struct cons_pointer b) { + debug_print( L"\nequal_real_number: ", DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH); + debug_print( L" = ", DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH); + bool result = false; + struct cons_space_object * cell_b = & pointer2cell( b); + + switch ( cell_b->tag.value) { + case INTEGERTV: + result = equal_integer_real( b, a); + break; + case REALTV: { + struct cons_space_object * cell_a = & pointer2cell( a); + result = equal_ld_ld( cell_a->payload.real.value, cell_b->payload.real.value); + } + break; + case RATIOTV: + struct cons_space_object * cell_a = & pointer2cell( a); + result = equal_ld_ld( c_ratio_to_ld( b), cell_a->payload.real.value); + break; + } + + debug_printf( DEBUG_ARITH, L"\nequal_real_number returning %d\n", result ); + + return result; +} + +/** + * @brief Private function, don't use. It depends on its arguments being + * numbers and doesn't sanity check them. + * + * @param a a number + * @param b a number + * @return true if the two numbers have equal value. + * @return false if they don't. + */ +bool equal_number_number( struct cons_pointer a, struct cons_pointer b ) { + bool result = eq( a, b ); + + debug_print( L"\nequal_number_number: ", DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH); + debug_print( L" = ", DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH); + + if ( !result ) { + struct cons_space_object * cell_a = & pointer2cell( a); + struct cons_space_object * cell_b = & pointer2cell( b); + + switch ( cell_a->tag.value) { + case INTEGERTV: + result = equal_integer_number( a, b); + break; + case REALTV: + result = equal_real_number( a, b); + break; + case RATIOTV: + switch( cell_b->tag.value) { + case INTEGERTV: + /* as all ratios are simplified by make_ratio, any + * ratio that would simplify to an integer is an + * integer, */ + result = false; + break; + case REALTV: + result = equal_real_number( b, a); + break; + case RATIOTV: + result = equal_ratio_ratio( a, b); + break; + /* can't throw an exception from here, but non-numbers + * shouldn't have been passed in anyway, so no default. */ + } + break; + /* can't throw an exception from here, but non-numbers + * shouldn't have been passed in anyway, so no default. */ + } + } + + debug_printf( DEBUG_ARITH, L"\nequal_number_number returning %d\n", result ); + + return result; +} + /** * Deep, and thus expensive, equality: true if these two objects have * identical structure, else false. */ bool equal( struct cons_pointer a, struct cons_pointer b ) { + debug_print( L"\nequal: ", DEBUG_ARITH); + debug_print_object( a, DEBUG_ARITH); + debug_print( L" = ", DEBUG_ARITH); + debug_print_object( b, DEBUG_ARITH); + bool result = eq( a, b ); if ( !result && same_type( a, b ) ) { @@ -121,11 +309,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { break; } } else if ( numberp( a ) && numberp( b ) ) { - if ( integerp( a ) ) { - result = equal_integer_real( a, b ); - } else if ( integerp( b ) ) { - result = equal_integer_real( b, a ); - } + result = equal_number_number( a, b); } /* @@ -136,5 +320,7 @@ bool equal( struct cons_pointer a, struct cons_pointer b ) { * I'll ignore them, too, for now. */ + debug_printf( DEBUG_ARITH, L"\nequal returning %d\n", result ); + return result; }