From b092a4f9d5d6ad3f8cefe848d5742884f0e9b605 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 28 Apr 2008 19:41:35 -0500
Subject: [PATCH] add support for infinity to intervals
---
extra/db/queries/queries.factor | 33 +++++++++++++++++++++++------
extra/db/tuples/tuples-tests.factor | 29 +++++++++++++++++++++++++
2 files changed, 55 insertions(+), 7 deletions(-)
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 7f3eaff84c..9ee44ffeed 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -44,19 +44,38 @@ M: random-id-generator eval-generator ( singleton -- obj )
: interval-comparison ( ? str -- str )
"from" = " >" " <" ? swap [ "= " append ] when ;
+: fp-infinity? ( float -- ? )
+ dup float? [
+ double>bits -52 shift 11 2^ 1- [ bitand ] keep =
+ ] [
+ drop f
+ ] if ;
+
: where-interval ( spec obj from/to -- )
- pick column-name>> 0%
- >r first2 r> interval-comparison 0%
- bind# ;
+ over first fp-infinity? [
+ 3drop
+ ] [
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind#
+ ] if ;
: in-parens ( quot -- )
"(" 0% call ")" 0% ; inline
M: interval where ( spec obj -- )
- [
- [ from>> "from" where-interval " and " 0% ]
- [ to>> "to" where-interval ] 2bi
- ] in-parens ;
+ dup [ from>> ] [ to>> ] bi
+ [ first fp-infinity? ] bi@ and [
+ 2drop
+ " 1 = 1 " 0% ! dummy
+ ] [
+ [
+ [ from>> "from" where-interval ] [
+ nip [ from>> ] [ to>> ] bi
+ [ first fp-infinity? ] bi@ or [ " and " 0% ] unless
+ ] [ to>> "to" where-interval ] 2tri
+ ] in-parens
+ ] if ;
M: sequence where ( spec obj -- )
[
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 81a402ee5d..2b73b5c4fe 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -293,6 +293,35 @@ TUPLE: exam id name score ;
}
] [
T{ exam f T{ range f 1 3 1 } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ }
+ ] [
+ T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
] unit-test ;
TUPLE: bignum-test id m n o ;