]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge branch 'master' of git://factorcode.org/git/factor
authorJohn Benediktsson <mrjbq7@gmail.com>
Mon, 18 May 2009 18:10:36 +0000 (11:10 -0700)
committerJohn Benediktsson <mrjbq7@gmail.com>
Mon, 18 May 2009 18:10:36 +0000 (11:10 -0700)
14 files changed:
basis/checksums/md5/md5.factor
basis/checksums/openssl/openssl-tests.factor
basis/cpu/x86/64/64.factor
basis/io/backend/windows/windows.factor
basis/lists/lazy/lazy-tests.factor
basis/lists/lazy/lazy.factor
basis/math/statistics/statistics-docs.factor
basis/math/statistics/statistics-tests.factor
basis/math/statistics/statistics.factor
basis/promises/promises.factor
basis/tools/disassembler/gdb/gdb.factor
core/checksums/checksums.factor
core/classes/predicate/predicate-docs.factor
core/sequences/sequences.factor

index 026df340125fb31bafc6cfa2422c362a34ac5e25..89ff5d46a264f3eb94b3e105a9d6f302655f9e1f 100644 (file)
@@ -4,7 +4,8 @@ USING: kernel io io.binary io.files io.streams.byte-array math
 math.functions math.parser namespaces splitting grouping strings
 sequences byte-arrays locals sequences.private macros fry
 io.encodings.binary math.bitwise checksums accessors
-checksums.common checksums.stream combinators combinators.smart ;
+checksums.common checksums.stream combinators combinators.smart
+specialized-arrays.uint literals ;
 IN: checksums.md5
 
 SINGLETON: md5
@@ -16,7 +17,7 @@ TUPLE: md5-state < checksum-state state old-state ;
 : <md5-state> ( -- md5 )
     md5-state new-checksum-state
         64 >>block-size
-        { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+        uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
         [ clone >>state ] [ >>old-state ] bi ;
 
 M: md5 initialize-checksum-state drop <md5-state> ;
@@ -29,8 +30,10 @@ M: md5 initialize-checksum-state drop <md5-state> ;
     [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
     [ (>>old-state) ] [ (>>state) ] bi ; inline
 
-: T ( N -- Y )
-    sin abs 32 2^ * >integer ; inline
+CONSTANT: T
+    $[
+        80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
+    ]
 
 :: F ( X Y Z -- FXYZ )
     #! F(X,Y,Z) = XY v not(X) Z
@@ -70,22 +73,22 @@ CONSTANT: b 1
 CONSTANT: c 2
 CONSTANT: d 3
 
-:: (ABCD) ( x V a b c d k s i quot -- )
+:: (ABCD) ( x state a b c d k s i quot -- )
     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
-    a V [
-        b V nth
-        c V nth
-        d V nth quot call w+
-        k x nth w+
-        i T w+
+    a state [
+        b state nth-unsafe
+        c state nth-unsafe
+        d state nth-unsafe quot call w+
+        k x nth-unsafe w+
+        i T nth-unsafe w+
         s bitroll-32
-        b V nth w+
-    ] change-nth ; inline
+        b state nth-unsafe w+ 32 bits
+    ] change-nth-unsafe ; inline
 
 MACRO: with-md5-round ( ops quot -- )
     '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
 
-: (process-md5-block-F) ( block v -- )
+: (process-md5-block-F) ( block state -- )
     {
         [ a b c d 0  S11 1  ]
         [ d a b c 1  S12 2  ]
@@ -105,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ b c d a 15 S14 16 ]
     } [ F ] with-md5-round ; inline
 
-: (process-md5-block-G) ( block v -- )
+: (process-md5-block-G) ( block state -- )
     {
         [ a b c d 1  S21 17 ]
         [ d a b c 6  S22 18 ]
@@ -125,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ b c d a 12 S24 32 ]
     } [ G ] with-md5-round ; inline
 
-: (process-md5-block-H) ( block v -- )
+: (process-md5-block-H) ( block state -- )
     {
         [ a b c d 5  S31 33 ]
         [ d a b c 8  S32 34 ]
@@ -145,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ b c d a 2  S34 48 ]
     } [ H ] with-md5-round ; inline
 
-: (process-md5-block-I) ( block v -- )
+: (process-md5-block-I) ( block state -- )
     {
         [ a b c d 0  S41 49 ]
         [ d a b c 7  S42 50 ]
@@ -167,7 +170,7 @@ MACRO: with-md5-round ( ops quot -- )
 
 M: md5-state checksum-block ( block state -- )
     [
-        [ 4 <groups> [ le> ] map ] [ state>> ] bi* {
+        [ byte-array>uint-array ] [ state>> ] bi* {
             [ (process-md5-block-F) ]
             [ (process-md5-block-G) ]
             [ (process-md5-block-H) ]
@@ -177,8 +180,7 @@ M: md5-state checksum-block ( block state -- )
         nip update-md5
     ] 2bi ;
 
-: md5>checksum ( md5 -- bytes )
-    state>> [ 4 >le ] map B{ } concat-as ;
+: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
 
 M: md5-state clone ( md5 -- new-md5 )
     call-next-method
index 253069c95280b102370d5e104d18dca36022a333..2a160e1486e0b3a96e649a44fb4675760b0d45d5 100644 (file)
@@ -1,6 +1,6 @@
+USING: accessors byte-arrays checksums checksums.openssl
+combinators.short-circuit kernel system tools.test ;
 IN: checksums.openssl.tests
-USING: byte-arrays checksums.openssl checksums tools.test
-accessors kernel system ;
 
 [
     B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
@@ -22,7 +22,7 @@ accessors kernel system ;
     "Bad checksum test" >byte-array
     "no such checksum" <openssl-checksum>
     checksum-bytes
-] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
+] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ]
 must-fail-with
 
 [ ] [ image openssl-sha1 checksum-file drop ] unit-test
index ad1b487e448100ae628f01a9901ae25416e46005..b77539b7e76d17bce7968b2ad5e50725a9e4f71d 100644 (file)
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.structs
-slots splitting assocs combinators make locals cpu.x86.assembler
+slots splitting assocs combinators locals cpu.x86.assembler
 cpu.x86 cpu.architecture compiler.constants
 compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
index 9f5c00cc5f4ace2b91d31555b10747a8a7b633e9..2e9aac2ac9deb30de09baf4aa30f9aa312d51eae 100755 (executable)
@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.ports io.binary io.timeouts system
-windows.errors strings kernel math namespaces sequences
-windows.errors windows.kernel32 windows.shell32 windows.types
-windows.winsock splitting continuations math.bitwise accessors ;
+strings kernel math namespaces sequences windows.errors
+windows.kernel32 windows.shell32 windows.types windows.winsock
+splitting continuations math.bitwise accessors ;
 IN: io.backend.windows
 
 : set-inherit ( handle ? -- )
index f4e55cba1922b1f2b9fa1ead9e179c39312fa8a0..8fb638b8566992c52016260beeec9aa137d8b153 100644 (file)
@@ -1,6 +1,7 @@
 ! Copyright (C) 2006 Matthew Willis and Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lists lists.lazy tools.test kernel math io sequences ;
+USING: io io.encodings.utf8 io.files kernel lists lists.lazy
+math sequences tools.test ;
 IN: lists.lazy.tests
 
 [ { 1 2 3 4 } ] [
@@ -33,3 +34,6 @@ IN: lists.lazy.tests
 [ [ drop ] foldl ] must-infer
 [ [ drop ] leach ] must-infer
 [ lnth ] must-infer
+
+[ ] [ "resource:license.txt" utf8 <file-reader> llines list>array drop ] unit-test
+[ ] [ "resource:license.txt" utf8 <file-reader> lcontents list>array drop ] unit-test
index 49aee471bf8f407feabc8f6cc6757d3f0c12515f..bde26e2fb9cff2fa06cf4b09f5a371bdb2b0d46d 100644 (file)
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math vectors arrays namespaces make
-quotations promises combinators io lists accessors ;
+USING: accessors arrays combinators io kernel lists math
+promises quotations sequences summary vectors ;
 IN: lists.lazy
 
 M: promise car ( promise -- car )
@@ -10,16 +10,16 @@ M: promise car ( promise -- car )
 M: promise cdr ( promise -- cdr )
     force cdr ;
 
-M: promise nil? ( cons -- bool )
+M: promise nil? ( cons -- ? )
     force nil? ;
-    
 ! Both 'car' and 'cdr' are promises
 TUPLE: lazy-cons car cdr ;
 
 : lazy-cons ( car cdr -- promise )
-    [ promise ] bi@ \ lazy-cons boa
-    T{ promise f f t f } clone
-        swap >>value ;
+    [ T{ promise f f t f } clone ] 2dip
+        [ promise ] bi@ \ lazy-cons boa
+        >>value ;
 
 M: lazy-cons car ( lazy-cons -- car )
     car>> force ;
@@ -27,7 +27,7 @@ M: lazy-cons car ( lazy-cons -- car )
 M: lazy-cons cdr ( lazy-cons -- cdr )
     cdr>> force ;
 
-M: lazy-cons nil? ( lazy-cons -- bool )
+M: lazy-cons nil? ( lazy-cons -- ? )
     nil eq? ;
 
 : 1lazy-list ( a -- lazy-cons )
@@ -41,11 +41,9 @@ M: lazy-cons nil? ( lazy-cons -- bool )
 
 TUPLE: memoized-cons original car cdr nil? ;
 
-: not-memoized ( -- obj )
-    { } ;
+: not-memoized ( -- obj ) { } ;
 
-: not-memoized? ( obj -- bool )
-    not-memoized eq? ;
+: not-memoized? ( obj -- ? ) not-memoized eq? ;
 
 : <memoized-cons> ( cons -- memoized-cons )
     not-memoized not-memoized not-memoized
@@ -65,7 +63,7 @@ M: memoized-cons cdr ( memoized-cons -- cdr )
         cdr>>
     ] if ;
 
-M: memoized-cons nil? ( memoized-cons -- bool )
+M: memoized-cons nil? ( memoized-cons -- ? )
     dup nil?>> not-memoized? [
         dup original>> nil?  [ >>nil? drop ] keep
     ] [
@@ -80,14 +78,12 @@ C: <lazy-map> lazy-map
     over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
 
 M: lazy-map car ( lazy-map -- car )
-    [ cons>> car ] keep
-    quot>> call( old -- new ) ;
+    [ cons>> car ] [ quot>> call( old -- new ) ] bi ;
 
 M: lazy-map cdr ( lazy-map -- cdr )
-    [ cons>> cdr ] keep
-    quot>> lazy-map ;
+    [ cons>> cdr ] [ quot>> lazy-map ] bi ;
 
-M: lazy-map nil? ( lazy-map -- bool )
+M: lazy-map nil? ( lazy-map -- ? )
     cons>> nil? ;
 
 TUPLE: lazy-take n cons ;
@@ -95,7 +91,7 @@ TUPLE: lazy-take n cons ;
 C: <lazy-take> lazy-take
 
 : ltake ( n list -- result )
-        over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+    over zero? [ 2drop nil ] [ <lazy-take> ] if ;
 
 M: lazy-take car ( lazy-take -- car )
     cons>> car ;
@@ -104,12 +100,8 @@ M: lazy-take cdr ( lazy-take -- cdr )
     [ n>> 1- ] keep
     cons>> cdr ltake ;
 
-M: lazy-take nil? ( lazy-take -- bool )
-    dup n>> zero? [
-        drop t
-    ] [
-        cons>> nil?
-    ] if ;
+M: lazy-take nil? ( lazy-take -- ? )
+    dup n>> zero? [ drop t ] [ cons>> nil? ] if ;
 
 TUPLE: lazy-until cons quot ;
 
@@ -125,7 +117,7 @@ M: lazy-until cdr ( lazy-until -- cdr )
      [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
      [ 2drop nil ] [ luntil ] if ;
 
-M: lazy-until nil? ( lazy-until -- bool )
+M: lazy-until nil? ( lazy-until -- ? )
      drop f ;
 
 TUPLE: lazy-while cons quot ;
@@ -141,7 +133,7 @@ M: lazy-while car ( lazy-while -- car )
 M: lazy-while cdr ( lazy-while -- cdr )
      [ cons>> cdr ] keep quot>> lwhile ;
 
-M: lazy-while nil? ( lazy-while -- bool )
+M: lazy-while nil? ( lazy-while -- ? )
      [ car ] keep quot>> call( elt -- ? ) not ;
 
 TUPLE: lazy-filter cons quot ;
@@ -167,7 +159,7 @@ M: lazy-filter cdr ( lazy-filter -- cdr )
         dup skip cdr
     ] if ;
 
-M: lazy-filter nil? ( lazy-filter -- bool )
+M: lazy-filter nil? ( lazy-filter -- ? )
     dup cons>> nil? [
         drop t
     ] [
@@ -189,10 +181,9 @@ M: lazy-append car ( lazy-append -- car )
     list1>> car ;
 
 M: lazy-append cdr ( lazy-append -- cdr )
-    [ list1>> cdr    ] keep
-    list2>> lappend ;
+    [ list1>> cdr ] [ list2>> ] bi lappend ;
 
-M: lazy-append nil? ( lazy-append -- bool )
+M: lazy-append nil? ( lazy-append -- ? )
      drop f ;
 
 TUPLE: lazy-from-by n quot ;
@@ -209,7 +200,7 @@ M: lazy-from-by cdr ( lazy-from-by -- cdr )
     [ n>> ] keep
     quot>> [ call( old -- new ) ] keep lfrom-by ;
 
-M: lazy-from-by nil? ( lazy-from-by -- bool )
+M: lazy-from-by nil? ( lazy-from-by -- ? )
     drop f ;
 
 TUPLE: lazy-zip list1 list2 ;
@@ -226,14 +217,14 @@ M: lazy-zip car ( lazy-zip -- car )
 M: lazy-zip cdr ( lazy-zip -- cdr )
         [ list1>> cdr ] keep list2>> cdr lzip ;
 
-M: lazy-zip nil? ( lazy-zip -- bool )
+M: lazy-zip nil? ( lazy-zip -- ? )
         drop f ;
 
 TUPLE: sequence-cons index seq ;
 
 C: <sequence-cons> sequence-cons
 
-: seq>list ( index seq -- list )
+: sequence-tail>list ( index seq -- list )
     2dup length >= [
         2drop nil
     ] [
@@ -241,21 +232,24 @@ C: <sequence-cons> sequence-cons
     ] if ;
 
 M: sequence-cons car ( sequence-cons -- car )
-    [ index>> ] keep
-    seq>> nth ;
+    [ index>> ] [ seq>> nth ] bi ;
 
 M: sequence-cons cdr ( sequence-cons -- cdr )
-    [ index>> 1+ ] keep
-    seq>> seq>list ;
+    [ index>> 1+ ] [ seq>> sequence-tail>list ] bi ;
 
-M: sequence-cons nil? ( sequence-cons -- bool )
+M: sequence-cons nil? ( sequence-cons -- ? )
     drop f ;
 
+ERROR: list-conversion-error object ;
+
+M: list-conversion-error summary
+    drop "Could not convert object to list" ;
+
 : >list ( object -- list )
     {
-        { [ dup sequence? ] [ 0 swap seq>list ] }
-        { [ dup list?         ] [ ] }
-        [ "Could not convert object to a list" throw ]
+        { [ dup sequence? ] [ 0 swap sequence-tail>list ] }
+        { [ dup list? ] [ ] }
+        [ list-conversion-error ]
     } cond ;
 
 TUPLE: lazy-concat car cdr ;
@@ -265,18 +259,10 @@ C: <lazy-concat> lazy-concat
 DEFER: lconcat
 
 : (lconcat) ( car cdr -- list )
-    over nil? [
-        nip lconcat
-    ] [
-        <lazy-concat>
-    ] if ;
+    over nil? [ nip lconcat ] [ <lazy-concat> ] if ;
 
 : lconcat ( list -- result )
-    dup nil? [
-        drop nil
-    ] [
-        uncons (lconcat)
-    ] if ;
+    dup nil? [ drop nil ] [ uncons (lconcat) ] if ; 
 
 M: lazy-concat car ( lazy-concat -- car )
     car>> car ;
@@ -284,12 +270,8 @@ M: lazy-concat car ( lazy-concat -- car )
 M: lazy-concat cdr ( lazy-concat -- cdr )
     [ car>> cdr ] keep cdr>> (lconcat) ;
 
-M: lazy-concat nil? ( lazy-concat -- bool )
-    dup car>> nil? [
-        cdr>> nil?
-    ] [
-        drop f
-    ] if ;
+M: lazy-concat nil? ( lazy-concat -- ? )
+    dup car>> nil? [ cdr>> nil?  ] [ drop f ] if ;
 
 : lcartesian-product ( list1 list2 -- result )
     swap [ swap [ 2array ] with lazy-map  ] with lazy-map  lconcat ;
@@ -298,7 +280,9 @@ M: lazy-concat nil? ( lazy-concat -- bool )
     dup nil? [
         drop nil
     ] [
-        [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
+        [ car ] [ cdr ] bi
+        [ car lcartesian-product ] [ cdr ] bi
+        list>array swap [
             swap [ swap [ suffix ] with lazy-map  ] with lazy-map  lconcat
         ] reduce
     ] if ;
@@ -322,9 +306,9 @@ DEFER: lmerge
 
 : lmerge ( list1 list2 -- result )
     {
-        { [ over nil? ] [ nip     ] }
-        { [ dup nil?    ]    [ drop ] }
-        { [ t                 ]    [ (lmerge) ] }
+        { [ over nil? ] [ nip ] }
+        { [ dup nil? ] [ drop ] }
+        { [ t ] [ (lmerge) ] }
     } cond ;
 
 TUPLE: lazy-io stream car cdr quot ;
@@ -338,30 +322,29 @@ C: <lazy-io> lazy-io
     f f [ stream-readln ] <lazy-io> ;
 
 M: lazy-io car ( lazy-io -- car )
-    dup car>> dup [
+    dup car>> [
         nip
     ] [
-        drop dup stream>> over quot>>
-        call( stream -- value )
-        >>car
-    ] if ;
+        [ ] [ stream>> ] [ quot>> ] tri
+        call( stream -- value ) [ >>car ] [ drop nil ] if*
+    ] if* ;
 
 M: lazy-io cdr ( lazy-io -- cdr )
     dup cdr>> dup [
         nip
     ] [
         drop dup
-        [ stream>> ] keep
-        [ quot>> ] keep
-        car [
+        [ stream>> ]
+        [ quot>> ]
+        [ car ] tri [
             [ f f ] dip <lazy-io> [ >>cdr drop ] keep
         ] [
             3drop nil
         ] if
     ] if ;
 
-M: lazy-io nil? ( lazy-io -- bool )
-    car not ;
+M: lazy-io nil? ( lazy-io -- ? )
+    car nil? ;
 
 INSTANCE: sequence-cons list
 INSTANCE: memoized-cons list
index 7a7eb70dd27d2e03a7b9371ad08e4a9d4954be4a..1a29d611f916d8500573fbe7283bcb7d4feff612 100644 (file)
@@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ;
 IN: math.statistics
 
 HELP: geometric-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
 { $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
 { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
 { $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
 
 HELP: harmonic-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
 { $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
 { $notes "Positive reals only." }
 { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
 { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
 
 HELP: mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
 { $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
 { $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
 { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
 
 HELP: median
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
 { $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
 { $examples
   { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
@@ -29,7 +29,7 @@ HELP: median
 { $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
 
 HELP: range
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
 { $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
 { $examples
   { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
index b6ff421956a616da7317533c497bb0af798fae5f..c160d57db7f315beee92463e4096f4054b34db36 100644 (file)
@@ -13,6 +13,24 @@ IN: math.statistics.tests
 [ 2 ] [ { 1 2 3 } median ] unit-test
 [ 5/2 ] [ { 1 2 3 4 } median ] unit-test
 
+[ { } median ] must-fail
+[ { } upper-median ] must-fail
+[ { } lower-median ] must-fail
+
+[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test
+[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test
+[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test
+[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test
+
+
+[ 1 ] [ { 1 } lower-median ] unit-test
+[ 1 ] [ { 1 } upper-median ] unit-test
+[ 1 ] [ { 1 } median ] unit-test
+
+[ 1 ] [ { 1 2 } lower-median ] unit-test
+[ 2 ] [ { 1 2 } upper-median ] unit-test
+[ 3/2 ] [ { 1 2 } median ] unit-test
+
 [ 1 ] [ { 1 2 3 } var ] unit-test
 [ 1.0 ] [ { 1 2 3 } std ] unit-test
 [ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
index 4cd8c5b88865be31cde80f18a159f3943fe14ab3..3812e79ec595fe56035513b5a93c5dd7fb307815 100644 (file)
@@ -1,30 +1,66 @@
 ! Copyright (C) 2008 Doug Coleman, Michael Judge.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators kernel math math.analysis
-math.functions math.order sequences sorting ;
+math.functions math.order sequences sorting locals
+sequences.private ;
 IN: math.statistics
 
-: mean ( seq -- n )
+: mean ( seq -- x )
     [ sum ] [ length ] bi / ;
 
-: geometric-mean ( seq -- n )
+: geometric-mean ( seq -- x )
     [ length ] [ product ] bi nth-root ;
 
-: harmonic-mean ( seq -- n )
+: harmonic-mean ( seq -- x )
     [ recip ] sigma recip ;
 
-: median ( seq -- n )
-    natural-sort dup length even? [
-        [ midpoint@ dup 1 - 2array ] keep nths mean
-    ] [
-        [ midpoint@ ] keep nth
-    ] if ;
+:: kth-smallest ( seq k -- elt )
+    #! Wirth's method, Algorithm's + Data structues = Programs p. 84
+    #! The algorithm modifiers seq, so we clone it
+    seq clone :> seq
+    0 :> i!
+    0 :> j!
+    0 :> l!
+    0 :> x!
+    seq length 1 - :> m!
+    [ l m < ]
+    [
+        k seq nth x!
+        l i!
+        m j!
+        [ i j <= ]
+        [
+            [ i seq nth-unsafe x < ] [ i 1 + i! ] while
+            [ x j seq nth-unsafe < ] [ j 1 - j! ] while
+            i j <= [
+                i j seq exchange
+                i 1 + i!
+                j 1 - j!
+            ] when
+        ] do while
+
+        j k < [ i l! ] when
+        k i < [ j m! ] when
+    ] while
+    k seq nth ; inline
+
+: lower-median ( seq -- elt )
+    dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ;
+
+: upper-median ( seq -- elt )
+    dup midpoint@ kth-smallest ;
+
+: medians ( seq -- lower upper )
+    [ lower-median ] [ upper-median ] bi ;
+
+: median ( seq -- x )
+    dup length odd? [ lower-median ] [ medians + 2 / ] if ;
 
 : minmax ( seq -- min max )
     #! find the min and max of a seq in one pass
     [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
 
-: range ( seq -- n )
+: range ( seq -- x )
     minmax swap - ;
 
 : var ( seq -- x )
@@ -32,15 +68,13 @@ IN: math.statistics
     dup length 1 <= [
         drop 0
     ] [
-        [ [ mean ] keep [ - sq ] with sigma ] keep
-        length 1 - /
+        [ [ mean ] keep [ - sq ] with sigma ]
+        [ length 1 - ] bi /
     ] if ;
 
-: std ( seq -- x )
-    var sqrt ;
+: std ( seq -- x ) var sqrt ;
 
-: ste ( seq -- x )
-    [ std ] [ length ] bi sqrt / ;
+: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ;
 
 : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
     ! finds sigma((xi-mean(x))(yi-mean(y))
@@ -64,4 +98,3 @@ IN: math.statistics
     [ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
     swap / * ! stack is mean(x) mean(y) beta
     [ swapd * - ] keep ;
-
index c3951f46ba60d927a0e9556684d53f4e41ecf9d6..cd9882720685a6ef6daa4ecfd798560845a71863 100755 (executable)
@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math arrays namespaces
-parser effects generalizations fry words accessors ;
+USING: accessors arrays effects fry generalizations kernel math
+namespaces parser sequences words ;
 IN: promises
 
 TUPLE: promise quot forced? value ;
index 9076b67606399d0e6a4939268d364ff128f36f81..c4c724b69607c77755b911e72195d01a8aeba157 100755 (executable)
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io.files.temp io words alien kernel math.parser
-alien.syntax io.launcher system assocs arrays sequences
+alien.syntax io.launcher assocs arrays sequences
 namespaces make system math io.encodings.ascii
 accessors tools.disassembler ;
 IN: tools.disassembler.gdb
index 9d40521fc8269d881a6b5d01b415b186b9ab1a84..0dd808c7227faf0d88c066b014ff58431b896f9b 100644 (file)
@@ -1,17 +1,17 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors io io.backend io.files kernel math math.parser
-sequences vectors quotations ;
+sequences byte-arrays byte-vectors quotations ;
 IN: checksums
 
 MIXIN: checksum
 
-TUPLE: checksum-state bytes-read block-size bytes ;
+TUPLE: checksum-state
+    { bytes-read integer } { block-size integer } { bytes byte-vector } ;
 
 : new-checksum-state ( class -- checksum-state )
     new
-        0 >>bytes-read
-        V{ } clone >>bytes ; inline
+        BV{ } clone >>bytes ; inline
 
 M: checksum-state clone
     call-next-method
@@ -27,11 +27,13 @@ GENERIC: get-checksum ( checksum -- value )
     over bytes>> [ push-all ] keep
     [ dup length pick block-size>> >= ]
     [
-        64 cut-slice [
+        64 cut-slice [ >byte-array ] dip [
             over [ checksum-block ]
             [ [ 64 + ] change-bytes-read drop ] bi
         ] dip
-    ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
+    ] while
+    >byte-vector
+    [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
 
 : add-checksum-stream ( checksum-state stream -- checksum-state )
     [
index 3ea0a24674b457af0822642ed986dbff1be34c6a..552ff209b8ac92b92d41c74c83bf5bcdd70c5968 100644 (file)
@@ -1,6 +1,6 @@
 USING: generic help.markup help.syntax kernel kernel.private
 namespaces sequences words arrays layouts help effects math
-layouts classes.private classes compiler.units ;
+classes.private classes compiler.units ;
 IN: classes.predicate
 
 ARTICLE: "predicates" "Predicate classes"
index 99dddb8aedf744a9943b7c0af6ed5c6749236e5f..9b0f4c1530a6b90eb10fa851cf3eab328a32a03d 100755 (executable)
@@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ;
 M: sequence nth-unsafe nth ;
 M: sequence set-nth-unsafe set-nth ;
 
+: change-nth-unsafe ( i seq quot -- )
+    [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
+
 ! The f object supports the sequence protocol trivially
 M: f length drop 0 ;
 M: f nth-unsafe nip ;