Merge branch 'faster_string_to_number'
commit
8da4f59931
|
@ -411,7 +411,7 @@ TUPLE: exam id name score ;
|
||||||
T{ exam f 4 "Cartman" 41 }
|
T{ exam f 4 "Cartman" 41 }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
|
T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -419,7 +419,7 @@ TUPLE: exam id name score ;
|
||||||
T{ exam f 1 "Kyle" 100 }
|
T{ exam f 1 "Kyle" 100 }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
|
T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -430,7 +430,7 @@ TUPLE: exam id name score ;
|
||||||
T{ exam f 4 "Cartman" 41 }
|
T{ exam f 4 "Cartman" 41 }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
|
T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -22,7 +22,7 @@ server-state f
|
||||||
|
|
||||||
: expire-state ( class -- )
|
: expire-state ( class -- )
|
||||||
new
|
new
|
||||||
-1.0/0.0 millis [a,b] >>expires
|
-1/0. millis [a,b] >>expires
|
||||||
delete-tuples ;
|
delete-tuples ;
|
||||||
|
|
||||||
TUPLE: server-state-manager < filter-responder timeout ;
|
TUPLE: server-state-manager < filter-responder timeout ;
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: parser words definitions kernel sequences assocs arrays
|
USING: parser words definitions kernel sequences assocs arrays
|
||||||
kernel.private fry combinators accessors vectors strings sbufs
|
kernel.private fry combinators accessors vectors strings sbufs
|
||||||
byte-arrays byte-vectors io.binary io.streams.string splitting
|
byte-arrays byte-vectors io.binary io.streams.string splitting
|
||||||
math generic generic.standard generic.standard.engines classes
|
math math.parser generic generic.standard generic.standard.engines classes
|
||||||
hashtables ;
|
hashtables ;
|
||||||
IN: hints
|
IN: hints
|
||||||
|
|
||||||
|
@ -118,6 +118,8 @@ SYNTAX: HINTS:
|
||||||
|
|
||||||
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
|
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
|
||||||
|
|
||||||
|
\ base> { string fixnum } "specializer" set-word-prop
|
||||||
|
|
||||||
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
|
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
|
||||||
|
|
||||||
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
|
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
|
||||||
|
|
|
@ -22,9 +22,9 @@ IN: math.functions.tests
|
||||||
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
|
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
|
||||||
|
|
||||||
[ t ] [ 0 0 ^ fp-nan? ] unit-test
|
[ t ] [ 0 0 ^ fp-nan? ] unit-test
|
||||||
[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
|
[ 1/0. ] [ 0 -2 ^ ] unit-test
|
||||||
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
|
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
|
||||||
[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test
|
[ 1/0. ] [ 0 -2.0 ^ ] unit-test
|
||||||
[ 0 ] [ 0 3.0 ^ ] unit-test
|
[ 0 ] [ 0 3.0 ^ ] unit-test
|
||||||
[ 0 ] [ 0 3 ^ ] unit-test
|
[ 0 ] [ 0 3 ^ ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
|
||||||
$nl
|
$nl
|
||||||
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
|
||||||
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
|
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
|
||||||
{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
|
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
|
||||||
"Trigonometric functions:"
|
"Trigonometric functions:"
|
||||||
{ $subsection fcos }
|
{ $subsection fcos }
|
||||||
{ $subsection fsin }
|
{ $subsection fsin }
|
||||||
|
|
|
@ -1,13 +1,13 @@
|
||||||
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: fry accessors arrays kernel kernel.private combinators.private
|
USING: fry accessors arrays kernel kernel.private combinators.private
|
||||||
words sequences generic math math.order namespaces make quotations assocs
|
words sequences generic math math.order namespaces make quotations
|
||||||
combinators combinators.short-circuit classes.tuple
|
assocs combinators combinators.short-circuit classes.tuple
|
||||||
classes.tuple.private effects summary hashtables classes generic sets
|
classes.tuple.private effects summary hashtables classes generic sets
|
||||||
definitions generic.standard slots.private continuations locals
|
definitions generic.standard slots.private continuations locals
|
||||||
generalizations stack-checker.backend stack-checker.state
|
sequences.private generalizations stack-checker.backend
|
||||||
stack-checker.visitor stack-checker.errors stack-checker.values
|
stack-checker.state stack-checker.visitor stack-checker.errors
|
||||||
stack-checker.recursive-state ;
|
stack-checker.values stack-checker.recursive-state ;
|
||||||
IN: stack-checker.transforms
|
IN: stack-checker.transforms
|
||||||
|
|
||||||
: give-up-transform ( word -- )
|
: give-up-transform ( word -- )
|
||||||
|
@ -106,40 +106,68 @@ IN: stack-checker.transforms
|
||||||
] [ drop f ] if
|
] [ drop f ] if
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
! Membership testing
|
! Fast at for integer maps
|
||||||
CONSTANT: bit-member-max 256
|
CONSTANT: lookup-table-at-max 256
|
||||||
|
|
||||||
: bit-member? ( seq -- ? )
|
: lookup-table-at? ( assoc -- ? )
|
||||||
#! Can we use a fast byte array test here?
|
#! Can we use a fast byte array test here?
|
||||||
{
|
{
|
||||||
[ length 4 > ]
|
[ assoc-size 4 > ]
|
||||||
[ [ integer? ] all? ]
|
[ values [ ] all? ]
|
||||||
[ [ 0 bit-member-max between? ] any? ]
|
[ keys [ integer? ] all? ]
|
||||||
|
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
||||||
} 1&& ;
|
} 1&& ;
|
||||||
|
|
||||||
: bit-member-seq ( seq -- flags )
|
: lookup-table-seq ( assoc -- table )
|
||||||
[ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
|
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
||||||
|
|
||||||
: bit-member-quot ( seq -- newquot )
|
: lookup-table-quot ( seq -- newquot )
|
||||||
bit-member-seq
|
lookup-table-seq
|
||||||
'[
|
'[
|
||||||
_ {
|
_ over integer? [
|
||||||
{ [ over fixnum? ] [ ?nth 1 eq? ] }
|
2dup bounds-check? [
|
||||||
{ [ over bignum? ] [ ?nth 1 eq? ] }
|
nth-unsafe dup >boolean
|
||||||
[ 2drop f ]
|
] [ 2drop f f ] if
|
||||||
} cond
|
] [ 2drop f f ] if
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: member-quot ( seq -- newquot )
|
: fast-lookup-table-at? ( assoc -- ? )
|
||||||
dup bit-member? [
|
values {
|
||||||
bit-member-quot
|
[ [ integer? ] all? ]
|
||||||
] [
|
[ [ 0 254 between? ] all? ]
|
||||||
dup length 4 <= [
|
} 1&& ;
|
||||||
[ drop f ] swap
|
|
||||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
: fast-lookup-table-seq ( assoc -- table )
|
||||||
|
lookup-table-seq [ 255 or ] B{ } map-as ;
|
||||||
|
|
||||||
|
: fast-lookup-table-quot ( seq -- newquot )
|
||||||
|
fast-lookup-table-seq
|
||||||
|
'[
|
||||||
|
_ over integer? [
|
||||||
|
2dup bounds-check? [
|
||||||
|
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: at-quot ( assoc -- quot )
|
||||||
|
dup lookup-table-at? [
|
||||||
|
dup fast-lookup-table-at? [
|
||||||
|
fast-lookup-table-quot
|
||||||
] [
|
] [
|
||||||
unique [ key? ] curry
|
lookup-table-quot
|
||||||
] if
|
] if
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
\ at* [ at-quot ] 1 define-transform
|
||||||
|
|
||||||
|
! Membership testing
|
||||||
|
: member-quot ( seq -- newquot )
|
||||||
|
dup length 4 <= [
|
||||||
|
[ drop f ] swap
|
||||||
|
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||||
|
] [
|
||||||
|
unique [ key? ] curry
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
\ member? [
|
\ member? [
|
||||||
|
@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256
|
||||||
|
|
||||||
\ shuffle [
|
\ shuffle [
|
||||||
shuffle-mapping nths-quot
|
shuffle-mapping nths-quot
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
|
@ -30,7 +30,7 @@ SYMBOL: line-ideal
|
||||||
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
|
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
|
||||||
|
|
||||||
:: min-by ( seq quot -- elt )
|
:: min-by ( seq quot -- elt )
|
||||||
f 1.0/0.0 seq [| key value new |
|
f 1/0. seq [| key value new |
|
||||||
new quot call :> newvalue
|
new quot call :> newvalue
|
||||||
newvalue value < [ new newvalue ] [ key value ] if
|
newvalue value < [ new newvalue ] [ key value ] if
|
||||||
] each drop ; inline
|
] each drop ; inline
|
||||||
|
|
|
@ -56,8 +56,6 @@ unit-test
|
||||||
[ t ] [ 0.0 zero? ] unit-test
|
[ t ] [ 0.0 zero? ] unit-test
|
||||||
[ t ] [ -0.0 zero? ] unit-test
|
[ t ] [ -0.0 zero? ] unit-test
|
||||||
|
|
||||||
! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
|
|
||||||
|
|
||||||
[ 0 ] [ 1/0. >bignum ] unit-test
|
[ 0 ] [ 1/0. >bignum ] unit-test
|
||||||
|
|
||||||
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
|
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
|
||||||
|
|
|
@ -122,7 +122,7 @@ M: bignum (log2) bignum-log2 ;
|
||||||
2drop 0.0
|
2drop 0.0
|
||||||
] [
|
] [
|
||||||
dup zero? [
|
dup zero? [
|
||||||
2drop 1.0/0.0
|
2drop 1/0.
|
||||||
] [
|
] [
|
||||||
pre-scale
|
pre-scale
|
||||||
/f-loop over odd?
|
/f-loop over odd?
|
||||||
|
|
|
@ -95,17 +95,17 @@ unit-test
|
||||||
[ 1 0 >base ] must-fail
|
[ 1 0 >base ] must-fail
|
||||||
[ 1 -1 >base ] must-fail
|
[ 1 -1 >base ] must-fail
|
||||||
|
|
||||||
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
|
[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
|
||||||
|
|
||||||
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
|
[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
|
||||||
|
|
||||||
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
|
[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
|
||||||
|
|
||||||
[ t ] [ "0/0." string>number fp-nan? ] unit-test
|
[ t ] [ "0/0." string>number fp-nan? ] unit-test
|
||||||
|
|
||||||
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
|
[ 1/0. ] [ "1/0." string>number ] unit-test
|
||||||
|
|
||||||
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
|
[ -1/0. ] [ "-1/0." string>number ] unit-test
|
||||||
|
|
||||||
[ "-0.0" ] [ -0.0 number>string ] unit-test
|
[ "-0.0" ] [ -0.0 number>string ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel math.private namespaces sequences strings
|
USING: kernel math.private namespaces sequences sequences.private
|
||||||
arrays combinators splitting math assocs make ;
|
strings arrays combinators splitting math assocs make ;
|
||||||
IN: math.parser
|
IN: math.parser
|
||||||
|
|
||||||
: digit> ( ch -- n )
|
: digit> ( ch -- n )
|
||||||
|
@ -28,13 +28,19 @@ IN: math.parser
|
||||||
{ CHAR: d 13 }
|
{ CHAR: d 13 }
|
||||||
{ CHAR: e 14 }
|
{ CHAR: e 14 }
|
||||||
{ CHAR: f 15 }
|
{ CHAR: f 15 }
|
||||||
} at ;
|
} at 255 or ; inline
|
||||||
|
|
||||||
: string>digits ( str -- digits )
|
: string>digits ( str -- digits )
|
||||||
[ digit> ] { } map-as ;
|
[ digit> ] B{ } map-as ; inline
|
||||||
|
|
||||||
: digits>integer ( seq radix -- n )
|
: (digits>integer) ( valid? accum digit radix -- valid? accum )
|
||||||
0 swap [ swapd * + ] curry reduce ;
|
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
|
||||||
|
|
||||||
|
: each-digit ( seq radix quot -- n/f )
|
||||||
|
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
|
||||||
|
|
||||||
|
: digits>integer ( seq radix -- n/f )
|
||||||
|
[ (digits>integer) ] each-digit ; inline
|
||||||
|
|
||||||
DEFER: base>
|
DEFER: base>
|
||||||
|
|
||||||
|
@ -43,6 +49,9 @@ DEFER: base>
|
||||||
SYMBOL: radix
|
SYMBOL: radix
|
||||||
SYMBOL: negative?
|
SYMBOL: negative?
|
||||||
|
|
||||||
|
: string>natural ( seq radix -- n/f )
|
||||||
|
[ [ digit> ] dip (digits>integer) ] each-digit ; inline
|
||||||
|
|
||||||
: sign ( -- str ) negative? get "-" "+" ? ;
|
: sign ( -- str ) negative? get "-" "+" ? ;
|
||||||
|
|
||||||
: with-radix ( radix quot -- )
|
: with-radix ( radix quot -- )
|
||||||
|
@ -54,37 +63,30 @@ SYMBOL: negative?
|
||||||
sign split1 [ (base>) ] dip
|
sign split1 [ (base>) ] dip
|
||||||
dup [ (base>) ] [ drop 0 swap ] if ;
|
dup [ (base>) ] [ drop 0 swap ] if ;
|
||||||
|
|
||||||
: string>ratio ( str -- a/b )
|
: string>ratio ( str radix -- a/b )
|
||||||
"-" ?head dup negative? set swap
|
[
|
||||||
"/" split1 (base>) [ whole-part ] dip
|
"-" ?head dup negative? set swap
|
||||||
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
|
"/" split1 (base>) [ whole-part ] dip
|
||||||
|
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
|
||||||
|
] with-radix ;
|
||||||
|
|
||||||
: valid-digits? ( seq -- ? )
|
: string>integer ( str radix -- n/f )
|
||||||
{
|
over first-unsafe CHAR: - = [
|
||||||
{ [ dup empty? ] [ drop f ] }
|
[ rest-slice ] dip string>natural dup [ neg ] when
|
||||||
{ [ f over memq? ] [ drop f ] }
|
] [
|
||||||
[ radix get [ < ] curry all? ]
|
string>natural
|
||||||
} cond ;
|
] if ; inline
|
||||||
|
|
||||||
: string>integer ( str -- n/f )
|
|
||||||
"-" ?head swap
|
|
||||||
string>digits dup valid-digits?
|
|
||||||
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: base> ( str radix -- n/f )
|
: base> ( str radix -- n/f )
|
||||||
[
|
over empty? [ 2drop f ] [
|
||||||
CHAR: / over member? [
|
over [ "/." member? ] find nip {
|
||||||
string>ratio
|
{ CHAR: / [ string>ratio ] }
|
||||||
] [
|
{ CHAR: . [ drop string>float ] }
|
||||||
CHAR: . over member? [
|
[ drop string>integer ]
|
||||||
string>float
|
} case
|
||||||
] [
|
] if ;
|
||||||
string>integer
|
|
||||||
] if
|
|
||||||
] if
|
|
||||||
] with-radix ;
|
|
||||||
|
|
||||||
: string>number ( str -- n/f ) 10 base> ;
|
: string>number ( str -- n/f ) 10 base> ;
|
||||||
: bin> ( str -- n/f ) 2 base> ;
|
: bin> ( str -- n/f ) 2 base> ;
|
||||||
|
@ -147,9 +149,9 @@ M: ratio >base
|
||||||
|
|
||||||
M: float >base
|
M: float >base
|
||||||
drop {
|
drop {
|
||||||
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
|
{ [ dup fp-nan? ] [ drop "0/0." ] }
|
||||||
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
|
{ [ dup 1/0. = ] [ drop "1/0." ] }
|
||||||
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
|
{ [ dup -1/0. = ] [ drop "-1/0." ] }
|
||||||
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
|
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
|
||||||
[ float>string fix-float ]
|
[ float>string fix-float ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
@ -53,7 +53,7 @@ C: <sphere> sphere
|
||||||
|
|
||||||
: sphere-t ( b d -- t )
|
: sphere-t ( b d -- t )
|
||||||
-+ dup 0.0 <
|
-+ dup 0.0 <
|
||||||
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
|
[ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
|
||||||
|
|
||||||
: sphere-b&v ( sphere ray -- b v )
|
: sphere-b&v ( sphere ray -- b v )
|
||||||
[ sphere-v ] [ nip ] 2bi
|
[ sphere-v ] [ nip ] 2bi
|
||||||
|
|
Loading…
Reference in New Issue