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

Merge branch 'master' into sorting 

Conflicts:
	basis/heaps/heaps-tests.factor
db4
John Benediktsson 2011-04-12 18:09:36 -07:00
parent d58bc08aa0 9b97f22b92
commit eb6c986cd6
8 changed files with 100 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
basis/heaps/heaps-tests.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting heaps heaps.private math.parser random assocs sequences sorting
accessors math.order ; accessors math.order locals ;
IN: heaps.tests IN: heaps.tests
[ <min-heap> heap-pop ] must-fail [ <min-heap> heap-pop ] must-fail
@ -27,19 +27,31 @@ IN: heaps.tests
[ 0 ] [ <max-heap> heap-size ] unit-test [ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test [ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
: heap-sort ( alist -- keys ) : heap-sort ( alist heap -- keys )
<min-heap> [ heap-push-all ] keep heap-pop-all ; [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist ) : random-alist ( n -- alist )
iota [ iota [
drop 32 random-bits dup number>string drop 32 random-bits dup number>string
] H{ } map>assoc ; ] H{ } map>assoc >alist ;
: test-heap-sort ( n -- ? ) :: test-heap-sort ( n heap reverse? -- ? )
random-alist dup sort-keys swap heap-sort = ; n random-alist
[ sort-keys reverse? [ reverse ] when ] keep
heap heap-sort = ;
: test-minheap-sort ( n -- ? )
<min-heap> f test-heap-sort ;
: test-maxheap-sort ( n -- ? )
<max-heap> t test-heap-sort ;
14 [ 14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test [ t ] swap [ 2^ <min-heap> f test-heap-sort ] curry unit-test
] each-integer
14 [
[ t ] swap [ 2^ <max-heap> t test-heap-sort ] curry unit-test
] each-integer ] each-integer
: test-entry-indices ( n -- ? ) : test-entry-indices ( n -- ? )

63
basis/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private USING: kernel math sequences arrays assocs sequences.private
growable accessors math.order summary vectors ; growable accessors math.order summary vectors fry combinators ;
IN: heaps IN: heaps
GENERIC: heap-push* ( value key heap -- entry ) GENERIC: heap-push* ( value key heap -- entry )
@ -58,30 +58,25 @@ M: heap heap-size ( heap -- n )
[ right ] dip data-nth ; inline [ right ] dip data-nth ; inline
: data-set-nth ( entry n heap -- ) : data-set-nth ( entry n heap -- )
[ [ >>index drop ] 2keep ] dip [ [ >>index drop ] [ ] 2bi ] dip
data>> set-nth-unsafe ; inline data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n ) : data-push ( entry heap -- n )
dup heap-size [ dup heap-size [
swap 2dup data>> ensure 2drop data-set-nth swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline ] [
] bi ; inline
: data-pop ( heap -- entry )
data>> pop ; inline
: data-pop* ( heap -- )
data>> pop* ; inline
: data-first ( heap -- entry ) : data-first ( heap -- entry )
data>> first ; inline data>> first ; inline
: data-exchange ( m n heap -- ) : data-exchange ( m n heap -- )
[ [ data-nth ] curry bi@ ] [ '[ _ data-nth ] bi@ ]
[ [ data-set-nth ] curry bi@ ] 3bi ; inline [ '[ _ data-set-nth ] bi@ ] 3bi ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? ) GENERIC: heap-compare ( entry1 entry2 heap -- ? )
: (heap-compare) ( pair1 pair2 heap -- <=> ) : (heap-compare) ( entry1 entry2 heap -- <=> )
drop [ key>> ] compare ; inline drop [ key>> ] compare ; inline
M: min-heap heap-compare (heap-compare) +gt+ eq? ; M: min-heap heap-compare (heap-compare) +gt+ eq? ;
@ -97,16 +92,17 @@ M: max-heap heap-compare (heap-compare) +lt+ eq? ;
: right-bounds-check? ( m heap -- ? ) : right-bounds-check? ( m heap -- ? )
[ right ] dip heap-bounds-check? ; inline [ right ] dip heap-bounds-check? ; inline
: continue? ( m up[m] heap -- ? ) : continue? ( m n heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep [ data-nth nip ]
heap-compare ; inline [ nip data-nth ]
[ 2nip ] 3tri heap-compare ;
DEFER: up-heap DEFER: up-heap
: (up-heap) ( n heap -- ) : (up-heap) ( n heap -- )
[ dup up ] dip [ dup up ] dip
3dup continue? [ 3dup continue? [
[ data-exchange ] 2keep up-heap [ data-exchange ] [ up-heap ] 2bi
] [ ] [
3drop 3drop
] if ; inline recursive ] if ; inline recursive
@ -115,10 +111,8 @@ DEFER: up-heap
over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
: (child) ( m heap -- n ) : (child) ( m heap -- n )
2dup right-value { [ drop ] [ left-value ] [ right-value ] [ nip ] } 2cleave
[ 2dup left-value ] dip heap-compare [ right ] [ left ] if ;
rot heap-compare
[ right ] [ left ] if ;
: child ( m heap -- n ) : child ( m heap -- n )
2dup right-bounds-check? 2dup right-bounds-check?
@ -127,11 +121,11 @@ DEFER: up-heap
DEFER: down-heap DEFER: down-heap
: (down-heap) ( m heap -- ) : (down-heap) ( m heap -- )
[ child ] 2keep swapd [ drop ] [ child ] [ nip ] 2tri
3dup continue? [ 3dup continue? [
3drop 3drop
] [ ] [
[ data-exchange ] 2keep down-heap [ data-exchange ] [ down-heap ] 2bi
] if ; inline recursive ] if ; inline recursive
: down-heap ( m heap -- ) : down-heap ( m heap -- )
@ -140,14 +134,14 @@ DEFER: down-heap
PRIVATE> PRIVATE>
M: heap heap-push* ( value key heap -- entry ) M: heap heap-push* ( value key heap -- entry )
[ <entry> dup ] keep [ data-push ] keep up-heap ; [ <entry> dup ] [ data-push ] [ ] tri up-heap ;
: heap-push ( value key heap -- ) heap-push* drop ; : heap-push ( value key heap -- ) heap-push* drop ;
: heap-push-all ( assoc heap -- ) : heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ; '[ swap _ heap-push ] assoc-each ;
: >entry< ( entry -- key value ) : >entry< ( entry -- value key )
[ value>> ] [ key>> ] bi ; inline [ value>> ] [ key>> ] bi ; inline
M: heap heap-peek ( heap -- value key ) M: heap heap-peek ( heap -- value key )
@ -163,29 +157,28 @@ M: bad-heap-delete summary
index>> ; index>> ;
M: heap heap-delete ( entry heap -- ) M: heap heap-delete ( entry heap -- )
[ entry>index ] keep [ entry>index ] [ ] bi
2dup heap-size 1 - = [ 2dup heap-size 1 - = [
nip data-pop* nip data>> pop*
] [ ] [
[ nip data-pop ] 2keep [ nip data>> pop ]
[ data-set-nth ] 2keep [ data-set-nth ]
[ ] 2tri
down-heap down-heap
] if ; ] if ;
M: heap heap-pop* ( heap -- ) M: heap heap-pop* ( heap -- )
dup data-first swap heap-delete ; [ data-first ] keep heap-delete ;
M: heap heap-pop ( heap -- value key ) M: heap heap-pop ( heap -- value key )
dup data-first [ swap heap-delete ] keep >entry< ; [ data-first ] keep
[ heap-delete ] [ drop ] 2bi >entry< ;
: heap-pop-all ( heap -- alist ) : heap-pop-all ( heap -- alist )
[ dup heap-empty? not ] [ dup heap-empty? not ]
[ dup heap-pop swap 2array ] [ dup heap-pop swap 2array ]
produce nip ; produce nip ;
: heap-values ( heap -- alist )
data>> [ value>> ] { } map-as ;
: slurp-heap ( heap quot: ( elt -- ) -- ) : slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [ over heap-empty? [ 2drop ] [
[ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi

2
basis/help/apropos/apropos.factor
View File

@ -71,4 +71,4 @@ M: apropos >link ;
INSTANCE: apropos topic INSTANCE: apropos topic
: apropos ( str -- ) : apropos ( str -- )
[ blank? ] trim <apropos> print-topic nl ; [ blank? ] trim <apropos> print-topic ;

4
basis/help/help.factor
View File

@ -127,11 +127,11 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
: print-topic ( topic -- ) : print-topic ( topic -- )
>link >link
last-element off last-element off
[ $title ] [ ($blank-line) article-content print-content ] bi ; [ $title ] [ ($blank-line) article-content print-content nl ] bi ;
SYMBOL: help-hook SYMBOL: help-hook
help-hook [ [ print-topic nl ] ] initialize help-hook [ [ print-topic ] ] initialize
: help ( topic -- ) : help ( topic -- )
help-hook get call( topic -- ) ; help-hook get call( topic -- ) ;

19
basis/math/statistics/statistics-docs.factor
View File

@ -112,41 +112,42 @@ HELP: sorted-histogram
HELP: sequence>assoc HELP: sequence>assoc
{ $values { $values
{ "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" } { "seq" sequence } { "quot1" quotation } { "quot2" quotation } { "exemplar" "an exemplar assoc" }
{ "assoc" assoc } { "assoc" assoc }
} }
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } { $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } ". The first quotation gets passed an element from the sequence and should output whatever the second quotation needs, e.g. ( element -- value key ) if the second quotation is inserting into an assoc." }
{ $examples { $examples
{ $example "! Iterate over a sequence and increment the count at each element" { $example "! Iterate over a sequence and increment the count at each element"
"! The first quotation has stack effect ( key -- key ), a no-op"
"USING: assocs prettyprint math.statistics ;" "USING: assocs prettyprint math.statistics ;"
"\"aaabc\" [ inc-at ] H{ } sequence>assoc ." "\"aaabc\" [ ] [ inc-at ] H{ } sequence>assoc ."
"H{ { 97 3 } { 98 1 } { 99 1 } }" "H{ { 97 3 } { 98 1 } { 99 1 } }"
} }
} ; } ;
HELP: sequence>assoc! HELP: sequence>assoc!
{ $values { $values
{ "assoc" assoc } { "seq" sequence } { "quot" quotation } { "assoc" assoc } { "seq" sequence } { "quot1" quotation } { "quot2" quotation }
} }
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } { $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } ". The first quotation gets passed an element from the sequence and should output whatever the second quotation needs, e.g. ( element -- value key ) if the second quotation is inserting into an assoc." }
{ $examples { $examples
{ $example "! Iterate over a sequence and add the counts to an existing assoc" { $example "! Iterate over a sequence and add the counts to an existing assoc"
"USING: assocs prettyprint math.statistics kernel ;" "USING: assocs prettyprint math.statistics kernel ;"
"H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc! ." "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ ] [ inc-at ] sequence>assoc! ."
"H{ { 97 5 } { 98 2 } { 99 1 } }" "H{ { 97 5 } { 98 2 } { 99 1 } }"
} }
} ; } ;
HELP: sequence>hashtable HELP: sequence>hashtable
{ $values { $values
{ "seq" sequence } { "quot" quotation } { "seq" sequence } { "quot1" quotation } { "quot2" quotation }
{ "hashtable" hashtable } { "hashtable" hashtable }
} }
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } { $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according a combination of the first and second quotations. The quot1 is passed each element, and quot2 gets the hashtable on the top of the stack with quot1's results underneath for inserting into the hashtable." }
{ $examples { $examples
{ $example "! Count the number of times an element occurs in a sequence" { $example "! Count the number of times an element occurs in a sequence"
"USING: assocs prettyprint math.statistics ;" "USING: assocs prettyprint math.statistics ;"
"\"aaabc\" [ inc-at ] sequence>hashtable ." "\"aaabc\" [ ] [ inc-at ] sequence>hashtable ."
"H{ { 97 3 } { 98 1 } { 99 1 } }" "H{ { 97 3 } { 98 1 } { 99 1 } }"
} }
} ; } ;

28
basis/math/statistics/statistics.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Michael Judge. ! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel math math.functions USING: assocs combinators generalizations kernel locals math
math.order sequences sorting locals sequences.private math.functions math.order sequences sequences.private sorting ;
assocs fry ;
IN: math.statistics IN: math.statistics
: mean ( seq -- x ) : mean ( seq -- x )
@ -59,31 +58,34 @@ IN: math.statistics
<PRIVATE <PRIVATE
: (sequence>assoc) ( seq quot assoc -- assoc ) : (sequence>assoc) ( seq quot1 quot2 assoc -- assoc )
[ swap curry each ] keep ; inline [ swap curry compose each ] keep ; inline
PRIVATE> PRIVATE>
: sequence>assoc! ( assoc seq quot: ( obj assoc -- ) -- assoc ) : sequence>assoc! ( assoc seq quot1 quot2 -- assoc )
rot (sequence>assoc) ; inline 4 nrot (sequence>assoc) ; inline
: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc ) : sequence>assoc ( seq quot1 quot2 exemplar -- assoc )
clone (sequence>assoc) ; inline clone (sequence>assoc) ; inline
: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable ) : sequence>hashtable ( seq quot1 quot2 -- hashtable )
H{ } sequence>assoc ; inline H{ } sequence>assoc ; inline
: histogram! ( hashtable seq -- hashtable ) : histogram! ( hashtable seq -- hashtable )
[ inc-at ] sequence>assoc! ; [ ] [ inc-at ] sequence>assoc! ;
: histogram ( seq -- hashtable ) : histogram ( seq -- hashtable )
[ inc-at ] sequence>hashtable ; [ ] [ inc-at ] sequence>hashtable ;
: sorted-histogram ( seq -- alist ) : sorted-histogram ( seq -- alist )
histogram sort-values ; histogram sort-values ;
: collect-values ( seq quot: ( obj hashtable -- ) -- hash ) : collect-pairs ( seq quot -- hashtable )
'[ [ dup @ ] dip push-at ] sequence>hashtable ; inline [ push-at ] sequence>hashtable ; inline
: collect-by ( seq quot -- hashtable )
[ dup ] prepose collect-pairs ; inline
: mode ( seq -- x ) : mode ( seq -- x )
histogram >alist histogram >alist

10
build-support/factor.sh
View File

@ -549,12 +549,12 @@ make_boot_image() {
} }
install_build_system_apt() { install_deps_linux() {
sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev libgtk2.0-dev libgtkglext1-dev wget git-core git-doc rlwrap gcc make
check_ret sudo check_ret sudo
} }
install_build_system_port() { install_deps_macosx() {
test_program_installed git test_program_installed git
if [[ $? -ne 1 ]] ; then if [[ $? -ne 1 ]] ; then
ensure_program_installed yes ensure_program_installed yes
@ -588,8 +588,8 @@ set_delete
case "$1" in case "$1" in
install) install ;; install) install ;;
install-x11) install_build_system_apt; install ;; deps-linux) install_deps_linux ;;
install-macosx) install_build_system_port; install ;; deps-macosx) install_deps_macosx ;;
self-update) update; make_boot_image; bootstrap;; self-update) update; make_boot_image; bootstrap;;
quick-update) update; refresh_image ;; quick-update) update; refresh_image ;;
update) update; update_bootstrap ;; update) update; update_bootstrap ;;

21
extra/dns/dns.factor
View File

@ -6,7 +6,7 @@ io io.binary io.encodings.binary io.encodings.string
io.encodings.utf8 io.sockets io.sockets.private io.encodings.utf8 io.sockets io.sockets.private
io.streams.byte-array io.timeouts kernel make math math.bitwise io.streams.byte-array io.timeouts kernel make math math.bitwise
math.parser namespaces nested-comments random sequences math.parser namespaces nested-comments random sequences
slots.syntax splitting system vectors vocabs.loader ; slots.syntax splitting system vectors vocabs.loader strings ;
IN: dns IN: dns
: with-input-seek ( n seek-type quot -- ) : with-input-seek ( n seek-type quot -- )
@ -286,6 +286,9 @@ M: SOA rdata>byte-array
} cleave } cleave
] B{ } append-outputs-as ; ] B{ } append-outputs-as ;
M: TXT rdata>byte-array
drop ;
: rr>byte-array ( rr -- byte-array ) : rr>byte-array ( rr -- byte-array )
[ [
{ {
@ -333,6 +336,22 @@ M: SOA rdata>byte-array
: dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ; : dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
: dns-MX-query ( domain -- message ) MX IN <query> dns-query ; : dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
: dns-NS-query ( domain -- message ) NS IN <query> dns-query ; : dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
: dns-TXT-query ( domain -- message ) TXT IN <query> dns-query ;
: TXT-message>strings ( message -- strings )
answer-section>>
[ rdata>>
[
binary <byte-reader> [
[
read1 [ read , t ] [ f ] if*
] loop
] with-input-stream
] { } make [ utf8 decode ] map
] map ;
: TXT. ( domain -- )
dns-TXT-query TXT-message>strings [ [ write ] each nl ] each ;
: reverse-lookup ( reversed-ip -- message ) : reverse-lookup ( reversed-ip -- message )
PTR IN <query> dns-query ; PTR IN <query> dns-query ;