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.
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
accessors math.order ;
accessors math.order locals ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
@ -27,19 +27,31 @@ IN: heaps.tests
[ 0 ] [ <max-heap> heap-size ] unit-test
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
: heap-sort ( alist -- keys )
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: heap-sort ( alist heap -- keys )
[ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
iota [
drop 32 random-bits dup number>string
] H{ } map>assoc ;
] H{ } map>assoc >alist ;
: test-heap-sort ( n -- ? )
random-alist dup sort-keys swap heap-sort = ;
:: test-heap-sort ( n heap reverse? -- ? )
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 [
[ 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
: test-entry-indices ( n -- ? )

63
basis/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
growable accessors math.order summary vectors ;
growable accessors math.order summary vectors fry combinators ;
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
@ -58,30 +58,25 @@ M: heap heap-size ( heap -- n )
[ right ] dip data-nth ; inline
: data-set-nth ( entry n heap -- )
[ [ >>index drop ] 2keep ] dip
[ [ >>index drop ] [ ] 2bi ] dip
data>> set-nth-unsafe ; inline
: data-push ( entry heap -- n )
dup heap-size [
swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
data>> pop ; inline
: data-pop* ( heap -- )
data>> pop* ; inline
] [
] bi ; inline
: data-first ( heap -- entry )
data>> first ; inline
: data-exchange ( m n heap -- )
[ [ data-nth ] curry bi@ ]
[ [ data-set-nth ] curry bi@ ] 3bi ; inline
[ '[ _ data-nth ] bi@ ]
[ '[ _ 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
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 ] dip heap-bounds-check? ; inline
: continue? ( m up[m] heap -- ? )
[ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline
: continue? ( m n heap -- ? )
[ data-nth nip ]
[ nip data-nth ]
[ 2nip ] 3tri heap-compare ;
DEFER: up-heap
: (up-heap) ( n heap -- )
[ dup up ] dip
3dup continue? [
[ data-exchange ] 2keep up-heap
[ data-exchange ] [ up-heap ] 2bi
] [
3drop
] if ; inline recursive
@ -115,10 +111,8 @@ DEFER: up-heap
over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
: (child) ( m heap -- n )
2dup right-value
[ 2dup left-value ] dip
rot heap-compare
[ right ] [ left ] if ;
{ [ drop ] [ left-value ] [ right-value ] [ nip ] } 2cleave
heap-compare [ right ] [ left ] if ;
: child ( m heap -- n )
2dup right-bounds-check?
@ -127,11 +121,11 @@ DEFER: up-heap
DEFER: down-heap
: (down-heap) ( m heap -- )
[ child ] 2keep swapd
[ drop ] [ child ] [ nip ] 2tri
3dup continue? [
3drop
] [
[ data-exchange ] 2keep down-heap
[ data-exchange ] [ down-heap ] 2bi
] if ; inline recursive
: down-heap ( m heap -- )
@ -140,14 +134,14 @@ DEFER: down-heap
PRIVATE>
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-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
M: heap heap-peek ( heap -- value key )
@ -163,29 +157,28 @@ M: bad-heap-delete summary
index>> ;
M: heap heap-delete ( entry heap -- )
[ entry>index ] keep
[ entry>index ] [ ] bi
2dup heap-size 1 - = [
nip data-pop*
nip data>> pop*
] [
[ nip data-pop ] 2keep
[ data-set-nth ] 2keep
[ nip data>> pop ]
[ data-set-nth ]
[ ] 2tri
down-heap
] if ;
M: heap heap-pop* ( heap -- )
dup data-first swap heap-delete ;
[ data-first ] keep heap-delete ;
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 )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
produce nip ;
: heap-values ( heap -- alist )
data>> [ value>> ] { } map-as ;
: slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [
[ [ 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
: 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 -- )
>link
last-element off
[ $title ] [ ($blank-line) article-content print-content ] bi ;
[ $title ] [ ($blank-line) article-content print-content nl ] bi ;
SYMBOL: help-hook
help-hook [ [ print-topic nl ] ] initialize
help-hook [ [ print-topic ] ] initialize
: help ( 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
{ $values
{ "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
{ "seq" sequence } { "quot1" quotation } { "quot2" quotation } { "exemplar" "an exemplar 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
{ $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 ;"
"\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
"\"aaabc\" [ ] [ inc-at ] H{ } sequence>assoc ."
"H{ { 97 3 } { 98 1 } { 99 1 } }"
}
} ;
HELP: sequence>assoc!
{ $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
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
"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 } }"
}
} ;
HELP: sequence>hashtable
{ $values
{ "seq" sequence } { "quot" quotation }
{ "seq" sequence } { "quot1" quotation } { "quot2" quotation }
{ "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
{ $example "! Count the number of times an element occurs in a sequence"
"USING: assocs prettyprint math.statistics ;"
"\"aaabc\" [ inc-at ] sequence>hashtable ."
"\"aaabc\" [ ] [ inc-at ] sequence>hashtable ."
"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.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel math math.functions
math.order sequences sorting locals sequences.private
assocs fry ;
USING: assocs combinators generalizations kernel locals math
math.functions math.order sequences sequences.private sorting ;
IN: math.statistics
: mean ( seq -- x )
@ -59,31 +58,34 @@ IN: math.statistics
<PRIVATE
: (sequence>assoc) ( seq quot assoc -- assoc )
[ swap curry each ] keep ; inline
: (sequence>assoc) ( seq quot1 quot2 assoc -- assoc )
[ swap curry compose each ] keep ; inline
PRIVATE>
: sequence>assoc! ( assoc seq quot: ( obj assoc -- ) -- assoc )
rot (sequence>assoc) ; inline
: sequence>assoc! ( assoc seq quot1 quot2 -- assoc )
4 nrot (sequence>assoc) ; inline
: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
: sequence>assoc ( seq quot1 quot2 exemplar -- assoc )
clone (sequence>assoc) ; inline
: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
: sequence>hashtable ( seq quot1 quot2 -- hashtable )
H{ } sequence>assoc ; inline
: histogram! ( hashtable seq -- hashtable )
[ inc-at ] sequence>assoc! ;
[ ] [ inc-at ] sequence>assoc! ;
: histogram ( seq -- hashtable )
[ inc-at ] sequence>hashtable ;
[ ] [ inc-at ] sequence>hashtable ;
: sorted-histogram ( seq -- alist )
histogram sort-values ;
: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
'[ [ dup @ ] dip push-at ] sequence>hashtable ; inline
: collect-pairs ( seq quot -- hashtable )
[ push-at ] sequence>hashtable ; inline
: collect-by ( seq quot -- hashtable )
[ dup ] prepose collect-pairs ; inline
: mode ( seq -- x )
histogram >alist

10
build-support/factor.sh
View File

@ -549,12 +549,12 @@ make_boot_image() {
}
install_build_system_apt() {
sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
install_deps_linux() {
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
}
install_build_system_port() {
install_deps_macosx() {
test_program_installed git
if [[ $? -ne 1 ]] ; then
ensure_program_installed yes
@ -588,8 +588,8 @@ set_delete
case "$1" in
install) install ;;
install-x11) install_build_system_apt; install ;;
install-macosx) install_build_system_port; install ;;
deps-linux) install_deps_linux ;;
deps-macosx) install_deps_macosx ;;
self-update) update; make_boot_image; bootstrap;;
quick-update) update; refresh_image ;;
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.streams.byte-array io.timeouts kernel make math math.bitwise
math.parser namespaces nested-comments random sequences
slots.syntax splitting system vectors vocabs.loader ;
slots.syntax splitting system vectors vocabs.loader strings ;
IN: dns
: with-input-seek ( n seek-type quot -- )
@ -286,6 +286,9 @@ M: SOA rdata>byte-array
} cleave
] B{ } append-outputs-as ;
M: TXT rdata>byte-array
drop ;
: 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-MX-query ( domain -- message ) MX 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 )
PTR IN <query> dns-query ;