steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

add support for infinity to intervals

db4
Doug Coleman 2008-04-28 19:41:35 -05:00
parent d213150834
commit b092a4f9d5
2 changed files with 55 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
extra/db/queries/queries.factor
View File

@ -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 -- )
[

29
extra/db/tuples/tuples-tests.factor
View File

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