remove 1-, 1+, use iota somewhere
parent
ffbd19faba
commit
d168f76ab0
|
|
@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
|
||||||
C: <bits> bits
|
C: <bits> bits
|
||||||
|
|
||||||
: make-bits ( number -- bits )
|
: make-bits ( number -- bits )
|
||||||
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
|
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
|
||||||
|
|
||||||
M: bits length length>> ;
|
M: bits length length>> ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -13,10 +13,10 @@ IN: math.bitwise
|
||||||
: unmask? ( x n -- ? ) unmask 0 > ; inline
|
: unmask? ( x n -- ? ) unmask 0 > ; inline
|
||||||
: mask ( x n -- ? ) bitand ; inline
|
: mask ( x n -- ? ) bitand ; inline
|
||||||
: mask? ( x n -- ? ) mask 0 > ; inline
|
: mask? ( x n -- ? ) mask 0 > ; inline
|
||||||
: wrap ( m n -- m' ) 1- bitand ; inline
|
: wrap ( m n -- m' ) 1 - bitand ; inline
|
||||||
: bits ( m n -- m' ) 2^ wrap ; inline
|
: bits ( m n -- m' ) 2^ wrap ; inline
|
||||||
: mask-bit ( m n -- m' ) 2^ mask ; inline
|
: mask-bit ( m n -- m' ) 2^ mask ; inline
|
||||||
: on-bits ( n -- m ) 2^ 1- ; inline
|
: on-bits ( n -- m ) 2^ 1 - ; inline
|
||||||
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
|
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
|
||||||
|
|
||||||
: shift-mod ( n s w -- n )
|
: shift-mod ( n s w -- n )
|
||||||
|
|
@ -64,8 +64,8 @@ DEFER: byte-bit-count
|
||||||
<<
|
<<
|
||||||
|
|
||||||
\ byte-bit-count
|
\ byte-bit-count
|
||||||
256 [
|
256 iota [
|
||||||
8 <bits> 0 [ [ 1+ ] when ] reduce
|
8 <bits> 0 [ [ 1 + ] when ] reduce
|
||||||
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
|
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
|
||||||
(( byte -- table )) define-declared
|
(( byte -- table )) define-declared
|
||||||
|
|
||||||
|
|
@ -97,12 +97,12 @@ PRIVATE>
|
||||||
|
|
||||||
! Signed byte array to integer conversion
|
! Signed byte array to integer conversion
|
||||||
: signed-le> ( bytes -- x )
|
: signed-le> ( bytes -- x )
|
||||||
[ le> ] [ length 8 * 1- on-bits ] bi
|
[ le> ] [ length 8 * 1 - on-bits ] bi
|
||||||
2dup > [ bitnot bitor ] [ drop ] if ;
|
2dup > [ bitnot bitor ] [ drop ] if ;
|
||||||
|
|
||||||
: signed-be> ( bytes -- x )
|
: signed-be> ( bytes -- x )
|
||||||
<reversed> signed-le> ;
|
<reversed> signed-le> ;
|
||||||
|
|
||||||
: >signed ( x n -- y )
|
: >signed ( x n -- y )
|
||||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -164,7 +164,7 @@ M: VECTOR element-type
|
||||||
M: VECTOR Vswap
|
M: VECTOR Vswap
|
||||||
(prepare-swap) [ XSWAP ] 2dip ;
|
(prepare-swap) [ XSWAP ] 2dip ;
|
||||||
M: VECTOR Viamax
|
M: VECTOR Viamax
|
||||||
(prepare-nrm2) IXAMAX 1- ;
|
(prepare-nrm2) IXAMAX 1 - ;
|
||||||
|
|
||||||
M: VECTOR (blas-vector-like)
|
M: VECTOR (blas-vector-like)
|
||||||
drop <VECTOR> ;
|
drop <VECTOR> ;
|
||||||
|
|
|
||||||
|
|
@ -18,7 +18,7 @@ M: real sqrt
|
||||||
: factor-2s ( n -- r s )
|
: factor-2s ( n -- r s )
|
||||||
#! factor an integer into 2^r * s
|
#! factor an integer into 2^r * s
|
||||||
dup 0 = [ 1 ] [
|
dup 0 = [ 1 ] [
|
||||||
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
|
0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
@ -216,17 +216,17 @@ M: real tanh ftanh ;
|
||||||
: coth ( x -- y ) tanh recip ; inline
|
: coth ( x -- y ) tanh recip ; inline
|
||||||
|
|
||||||
: acosh ( x -- y )
|
: acosh ( x -- y )
|
||||||
dup sq 1- sqrt + log ; inline
|
dup sq 1 - sqrt + log ; inline
|
||||||
|
|
||||||
: asech ( x -- y ) recip acosh ; inline
|
: asech ( x -- y ) recip acosh ; inline
|
||||||
|
|
||||||
: asinh ( x -- y )
|
: asinh ( x -- y )
|
||||||
dup sq 1+ sqrt + log ; inline
|
dup sq 1 + sqrt + log ; inline
|
||||||
|
|
||||||
: acosech ( x -- y ) recip asinh ; inline
|
: acosech ( x -- y ) recip asinh ; inline
|
||||||
|
|
||||||
: atanh ( x -- y )
|
: atanh ( x -- y )
|
||||||
[ 1+ ] [ 1- neg ] bi / log 2 / ; inline
|
[ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
|
||||||
|
|
||||||
: acoth ( x -- y ) recip atanh ; inline
|
: acoth ( x -- y ) recip atanh ; inline
|
||||||
|
|
||||||
|
|
@ -259,7 +259,7 @@ M: real atan fatan ;
|
||||||
|
|
||||||
: floor ( x -- y )
|
: floor ( x -- y )
|
||||||
dup 1 mod dup zero?
|
dup 1 mod dup zero?
|
||||||
[ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
|
[ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
|
||||||
|
|
||||||
: ceiling ( x -- y ) neg floor neg ; foldable
|
: ceiling ( x -- y ) neg floor neg ; foldable
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -380,7 +380,7 @@ SYMBOL: incomparable
|
||||||
[
|
[
|
||||||
to>> first 1 max dup most-positive-fixnum >
|
to>> first 1 max dup most-positive-fixnum >
|
||||||
[ drop full-interval interval-log2 ]
|
[ drop full-interval interval-log2 ]
|
||||||
[ 1+ >integer log2 0 swap [a,b] ]
|
[ 1 + >integer log2 0 swap [a,b] ]
|
||||||
if
|
if
|
||||||
]
|
]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
@ -407,7 +407,7 @@ SYMBOL: incomparable
|
||||||
|
|
||||||
: integral-closure ( i1 -- i2 )
|
: integral-closure ( i1 -- i2 )
|
||||||
dup special-interval? [
|
dup special-interval? [
|
||||||
[ from>> first2 [ 1+ ] unless ]
|
[ from>> first2 [ 1 + ] unless ]
|
||||||
[ to>> first2 [ 1- ] unless ]
|
[ to>> first2 [ 1 - ] unless ]
|
||||||
bi [a,b]
|
bi [a,b]
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,7 @@ PRIVATE>
|
||||||
: n*p ( n p -- n*p ) n*v ;
|
: n*p ( n p -- n*p ) n*v ;
|
||||||
|
|
||||||
: pextend-conv ( p q -- p q )
|
: pextend-conv ( p q -- p q )
|
||||||
2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
|
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
|
||||||
|
|
||||||
: p* ( p q -- r )
|
: p* ( p q -- r )
|
||||||
2unempty pextend-conv <reversed> dup length
|
2unempty pextend-conv <reversed> dup length
|
||||||
|
|
@ -44,7 +44,7 @@ PRIVATE>
|
||||||
2ptrim
|
2ptrim
|
||||||
2dup [ length ] bi@ -
|
2dup [ length ] bi@ -
|
||||||
dup 1 < [ drop 1 ] when
|
dup 1 < [ drop 1 ] when
|
||||||
[ over length + 0 pad-head pextend ] keep 1+ ;
|
[ over length + 0 pad-head pextend ] keep 1 + ;
|
||||||
|
|
||||||
: /-last ( seq seq -- a )
|
: /-last ( seq seq -- a )
|
||||||
#! divide the last two numbers in the sequences
|
#! divide the last two numbers in the sequences
|
||||||
|
|
|
||||||
|
|
@ -10,7 +10,7 @@ TUPLE: range
|
||||||
{ step read-only } ;
|
{ step read-only } ;
|
||||||
|
|
||||||
: <range> ( a b step -- range )
|
: <range> ( a b step -- range )
|
||||||
[ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
|
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
|
||||||
|
|
||||||
M: range length ( seq -- n )
|
M: range length ( seq -- n )
|
||||||
length>> ;
|
length>> ;
|
||||||
|
|
|
||||||
|
|
@ -15,7 +15,7 @@ IN: math.statistics
|
||||||
|
|
||||||
: median ( seq -- n )
|
: median ( seq -- n )
|
||||||
natural-sort dup length even? [
|
natural-sort dup length even? [
|
||||||
[ midpoint@ dup 1- 2array ] keep nths mean
|
[ midpoint@ dup 1 - 2array ] keep nths mean
|
||||||
] [
|
] [
|
||||||
[ midpoint@ ] keep nth
|
[ midpoint@ ] keep nth
|
||||||
] if ;
|
] if ;
|
||||||
|
|
@ -33,7 +33,7 @@ IN: math.statistics
|
||||||
drop 0
|
drop 0
|
||||||
] [
|
] [
|
||||||
[ [ mean ] keep [ - sq ] with sigma ] keep
|
[ [ mean ] keep [ - sq ] with sigma ] keep
|
||||||
length 1- /
|
length 1 - /
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: std ( seq -- x )
|
: std ( seq -- x )
|
||||||
|
|
@ -47,7 +47,7 @@ IN: math.statistics
|
||||||
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
|
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
|
||||||
|
|
||||||
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
|
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
|
||||||
* recip [ [ ((r)) ] keep length 1- / ] dip * ;
|
* recip [ [ ((r)) ] keep length 1 - / ] dip * ;
|
||||||
|
|
||||||
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
|
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
|
||||||
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
|
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue