Better support for prolog numbers

parent 8979910a
......@@ -10,6 +10,7 @@
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog char)
#:use-module (logic guile-log prolog char-conversion)
#:use-module (logic guile-log prolog conversion)
#:re-export (;; Scheme functions
compile-string compile-file save-operator-table prolog-run
load-prolog clear-directives
......
......@@ -247,6 +247,12 @@
(else
(<code> (error "Bug in prolog flag 'unknown' implementation"))))))))
(<define> (<iss> x y)
(<let> ((x (<lookup> x)))
(if (<var?> x)
(<=> x y)
(when (my-equal? x y)))))
(define-syntax-rule (mk-prolog-abstract tp op fk-name tr-name)
(begin
(define-goal-functor fk-name (fk-error op))
......@@ -272,7 +278,8 @@
(mk-prolog-biop 'xfx "@<" tr-olt olt term< a a)
(mk-prolog-biop-not 'xfx "@>=" tr-0ge oge term< a a)
(mk-prolog-biop-not 'xfx "@=<" tr-0le ole term> a a)
(mk-prolog-is 'xfx "is" tr-is is <r=> v s)
;(mk-prolog-is 'xfx "is" tr-is is <r=> v s)
(mk-prolog-biop 'xfx "is" tr-is is <iss> v s)
(define-syntax-rule (shr x y) (ash x (- y)))
......@@ -293,11 +300,38 @@
(mk-prolog-biop-when 'xfx "<" tr-< lt < s s)
(mk-prolog-biop-when 'xfx ">" tr-> gt > s s)
(mk-prolog-biop-when 'xfx ">=" tr->= ge >= s s)
(mk-prolog-biop-when 'xfx "=<" tr-=< le <= s s)
(mk-prolog-biop-when 'xfx "=:=" tr-equal equal = s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equal notEqual = s s)
(mk-prolog-biop-when 'xfx ">=" tr->= ge my->= s s)
(mk-prolog-biop-when 'xfx "=<" tr-=< le my-<= s s)
(mk-prolog-biop-when 'xfx "=:=" tr-equal equal my-equal? s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equal notEqual my-equal? s s)
(define e1 1.000000000001)
(define e2 0.999999999999)
(define (my-equal? x y)
(if (< x 0) (set! x (- x)))
(if (< y 0) (set! y (- y)))
(if (and (number? x) (number? y))
(if (inexact? x)
(and (< y (* e1 x)) (> y (* e2 x)))
(if (inexact? y)
(and (< x (* e1 y)) (> x (* e2 y)))
(= x y)))
(= x y)))
(define (my-<= x y)
(if (inexact? x)
(> y (* e2 x))
(if (inexact? y)
(< x (* e1 y))
(= x y))))
(define (my->= x y)
(if (inexact? x)
(< y (* e1 x))
(if (inexact? y)
(> x (* e2 y))
(= x y))))
#| Further supported operators scm functions are
abs(x) (abs x)
......
......@@ -1247,13 +1247,79 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
gp_debug2("unify> (equal/= ~x ~x)\n", scm1, scm2);
if(SCM_NUMBERP(scm1))
{
{
if(SCM_NUMBERP(scm2))
{
if(scm_is_true(scm_num_eq_p(scm1, scm2)))
{U_NEXT;}
if(SCM_INEXACTP(scm1))
if(SCM_INEXACTP(scm2))
{
num_retry:
if(SCM_REALP(scm1) && SCM_REALP(scm2))
{
double r1 = scm_to_double (scm1);
double r2 = scm_to_double (scm2);
if(r1 < 0 && r2 < 0)
{
r1 = -r1;
r2 = -r2;
}
if (r1 < 1.000000000001 * r2 && r2 < 1.000000000001 * r1)
{U_NEXT;}
else
return
(SCM) 0;
}
else
{
if(SCM_REALP(scm1) || SCM_REALP(scm2))
return (SCM) 0;
double r1 = scm_c_real_part(scm1);
double r2 = scm_c_real_part(scm2);
double c1 = scm_c_imag_part(scm1);
double c2 = scm_c_imag_part(scm2);
if(r1 < 0 && r2 < 0)
{
r1 = -r1;
r2 = -r2;
}
if(c1 < 0 && c2 < 0)
{
c1 = -c1;
c2 = -c2;
}
if (r1 < 1.000000000001 * r2 && r2 < 1.000000000001 * r1 &&
c1 < 1.000000000001 * c2 && c2 < 1.000000000001 * c1)
{U_NEXT;}
else
return (SCM) 0;
}
}
else
if(SCM_FRACTIONP(scm2))
{
scm2 = scm_exact_to_inexact (scm2);
goto num_retry;
}
else
return (SCM) 0;
else
return (SCM) 0;
if(SCM_INEXACTP(scm2))
if(SCM_FRACTIONP(scm1))
{
scm1 = scm_exact_to_inexact (scm1);
goto num_retry;
}
else
return (SCM) 0;
else
if(scm_is_true(scm_num_eq_p(scm1, scm2)))
{U_NEXT;}
else
return (SCM) 0;
}
else
return (SCM) 0;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment