From 80782f699a73bd5a07175aa229a7b4dc26d116b6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 7 Jan 2009 13:38:34 -0600
Subject: [PATCH 01/12] fix a couple more typos in grouping
---
basis/grouping/grouping-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor
index 1eff4820dd..b9af98d1f8 100644
--- a/basis/grouping/grouping-docs.factor
+++ b/basis/grouping/grouping-docs.factor
@@ -49,7 +49,7 @@ HELP: <groups>
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
- "{ 1 2 3 4 5 6 } 3 <groups> 0 swap nth ."
+ "{ 1 2 3 4 5 6 } 3 <groups> first ."
"{ 1 2 3 }"
}
} ;
@@ -66,7 +66,7 @@ HELP: <sliced-groups>
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
- "{ 1 2 3 4 5 6 } 3 <sliced-groups> 1 swap nth ."
+ "{ 1 2 3 4 5 6 } 3 <sliced-groups> second ."
"T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
}
} ;
From 638f1f4cebdd9fb53b684e5586004c75a4919aa3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 7 Jan 2009 14:53:43 -0600
Subject: [PATCH 02/12] fix group-name word, rename username -> user-name
because of symmetry with group-name, use cleave>array in a couple places to
eliminate counting items in an array manually
---
basis/tools/files/files.factor | 2 ++
basis/tools/files/unix/unix.factor | 13 ++++++-----
basis/unix/groups/groups.factor | 2 +-
basis/unix/users/users-docs.factor | 34 ++++++++++++++---------------
basis/unix/users/users-tests.factor | 10 ++++-----
basis/unix/users/users.factor | 16 +++++++-------
6 files changed, 41 insertions(+), 36 deletions(-)
diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor
index 3670891e41..e6ca02d5f9 100755
--- a/basis/tools/files/files.factor
+++ b/basis/tools/files/files.factor
@@ -5,6 +5,8 @@ io.directories kernel math.parser sequences system vocabs.loader
calendar math fry prettyprint ;
IN: tools.files
+SYMBOLS: permissions file-name nlinks file-size date ;
+
<PRIVATE
: ls-time ( timestamp -- string )
diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor
index 3b32f7b52d..507c689a55 100755
--- a/basis/tools/files/unix/unix.factor
+++ b/basis/tools/files/unix/unix.factor
@@ -3,9 +3,12 @@
USING: accessors combinators kernel system unicode.case io.files
io.files.info io.files.info.unix tools.files generalizations
strings arrays sequences math.parser unix.groups unix.users
-tools.files.private unix.stat math ;
+tools.files.private unix.stat math fry macros ;
IN: tools.files.unix
+MACRO: cleave>array ( array -- quot )
+ dup length '[ _ cleave _ narray ] ;
+
<PRIVATE
: unix-execute>string ( str bools -- str' )
@@ -28,7 +31,7 @@ IN: tools.files.unix
[ other-read? read>string ]
[ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
- } cleave 10 narray concat ;
+ } cleave>array concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
@@ -49,11 +52,11 @@ M: unix (directory.) ( path -- lines )
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
- ! [ uid>> ]
- ! [ gid>> ]
+ [ uid>> user-name ]
+ [ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
- } cleave 4 narray swap suffix " " join
+ } cleave>array swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor
index 60785a5b17..41cd80f456 100644
--- a/basis/unix/groups/groups.factor
+++ b/basis/unix/groups/groups.factor
@@ -43,7 +43,7 @@ PRIVATE>
: group-name ( id -- string )
dup group-cache get [
- at
+ dupd at* [ name>> nip ] [ drop number>string ] if
] [
group-struct group-gr_name
] if*
diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor
index 0740561cc1..2d46ab2d81 100644
--- a/basis/unix/users/users-docs.factor
+++ b/basis/unix/users/users-docs.factor
@@ -7,13 +7,13 @@ HELP: all-users
{ $values { "seq" sequence } }
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
-HELP: effective-username
+HELP: effective-user-name
{ $values { "string" string } }
-{ $description "Returns the effective username for the current user." } ;
+{ $description "Returns the effective user-name for the current user." } ;
HELP: effective-user-id
{ $values { "id" integer } }
-{ $description "Returns the effective username id for the current user." } ;
+{ $description "Returns the effective user-name id for the current user." } ;
HELP: new-passwd
{ $values { "passwd" passwd } }
@@ -31,9 +31,9 @@ HELP: passwd>new-passwd
{ "new-passwd" "a passwd tuple" } }
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
-HELP: real-username
+HELP: real-user-name
{ $values { "string" string } }
-{ $description "The real username of the current user." } ;
+{ $description "The real user-name of the current user." } ;
HELP: real-user-id
{ $values { "id" integer } }
@@ -41,34 +41,34 @@ HELP: real-user-id
HELP: set-effective-user
{ $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current effective user given a username or a user id." } ;
+{ $description "Sets the current effective user given a user-name or a user id." } ;
HELP: set-real-user
{ $values { "string/id" "a string or a user id" } }
-{ $description "Sets the current real user given a username or a user id." } ;
+{ $description "Sets the current real user given a user-name or a user id." } ;
HELP: user-passwd
{ $values
{ "obj" object }
{ "passwd/f" "passwd or f" } }
-{ $description "Returns the passwd tuple given a username string or user id." } ;
+{ $description "Returns the passwd tuple given a user-name string or user id." } ;
-HELP: username
+HELP: user-name
{ $values
{ "id" integer }
{ "string" string } }
-{ $description "Returns the username associated with the user id." } ;
+{ $description "Returns the user-name associated with the user id." } ;
HELP: user-id
{ $values
{ "string" string }
{ "id" integer } }
-{ $description "Returns the user id associated with the username." } ;
+{ $description "Returns the user id associated with the user-name." } ;
HELP: with-effective-user
{ $values
{ "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
HELP: with-user-cache
{ $values
@@ -78,11 +78,11 @@ HELP: with-user-cache
HELP: with-real-user
{ $values
{ "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
{
- real-username real-user-id set-real-user
- effective-username effective-user-id
+ real-user-name real-user-id set-real-user
+ effective-user-name effective-user-id
set-effective-user
} related-words
@@ -93,11 +93,11 @@ $nl
{ $subsection all-users }
"Returning a passwd tuple:"
"Real user:"
-{ $subsection real-username }
+{ $subsection real-user-name }
{ $subsection real-user-id }
{ $subsection set-real-user }
"Effective user:"
-{ $subsection effective-username }
+{ $subsection effective-user-name }
{ $subsection effective-user-id }
{ $subsection set-effective-user }
"Combinators to change users:"
diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor
index 5a4639c856..f2a4b7bc27 100644
--- a/basis/unix/users/users-tests.factor
+++ b/basis/unix/users/users-tests.factor
@@ -8,8 +8,8 @@ IN: unix.users.tests
\ all-users must-infer
-[ t ] [ real-username string? ] unit-test
-[ t ] [ effective-username string? ] unit-test
+[ t ] [ real-user-name string? ] unit-test
+[ t ] [ effective-user-name string? ] unit-test
[ t ] [ real-user-id integer? ] unit-test
[ t ] [ effective-user-id integer? ] unit-test
@@ -17,14 +17,14 @@ IN: unix.users.tests
[ ] [ real-user-id set-real-user ] unit-test
[ ] [ effective-user-id set-effective-user ] unit-test
-[ ] [ real-username [ ] with-real-user ] unit-test
+[ ] [ real-user-name [ ] with-real-user ] unit-test
[ ] [ real-user-id [ ] with-real-user ] unit-test
-[ ] [ effective-username [ ] with-effective-user ] unit-test
+[ ] [ effective-user-name [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
[ ] [ [ ] with-user-cache ] unit-test
-[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
+[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor
index 21538080c9..da38972955 100644
--- a/basis/unix/users/users.factor
+++ b/basis/unix/users/users.factor
@@ -7,7 +7,7 @@ accessors math.parser fry assocs namespaces continuations
vocabs.loader system ;
IN: unix.users
-TUPLE: passwd username password uid gid gecos dir shell ;
+TUPLE: passwd user-name password uid gid gecos dir shell ;
HOOK: new-passwd os ( -- passwd )
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
@@ -20,7 +20,7 @@ M: unix new-passwd ( -- passwd )
M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip
{
- [ passwd-pw_name >>username ]
+ [ passwd-pw_name >>user-name ]
[ passwd-pw_passwd >>password ]
[ passwd-pw_uid >>uid ]
[ passwd-pw_gid >>gid ]
@@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f )
M: string user-passwd ( string -- passwd/f )
getpwnam dup [ passwd>new-passwd ] when ;
-: username ( id -- string )
+: user-name ( id -- string )
dup user-passwd
- [ nip username>> ] [ number>string ] if* ;
+ [ nip user-name>> ] [ number>string ] if* ;
: user-id ( string -- id )
user-passwd uid>> ;
@@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f )
: real-user-id ( -- id )
getuid ; inline
-: real-username ( -- string )
- real-user-id username ; inline
+: real-user-name ( -- string )
+ real-user-id user-name ; inline
: effective-user-id ( -- id )
geteuid ; inline
-: effective-username ( -- string )
- effective-user-id username ; inline
+: effective-user-name ( -- string )
+ effective-user-id user-name ; inline
GENERIC: set-real-user ( string/id -- )
From 6d6e6910838a8a9e1a61d257a180ad2f353228d2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 7 Jan 2009 15:58:33 -0600
Subject: [PATCH 03/12] Make human-sort behave like sort
---
basis/sorting/human/human.factor | 16 +++++++++++++---
1 file changed, 13 insertions(+), 3 deletions(-)
diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index 1c2ba419c7..f338e21887 100644
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -1,10 +1,20 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting ;
+USING: peg.ebnf math.parser kernel assocs sorting fry
+math.order sequences ascii splitting.monotonic ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-: human-sort ( seq -- seq' )
- [ dup find-numbers ] { } map>assoc sort-values keys ;
+: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
+
+: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
+
+: human-sort-keys ( seq -- sortedseq )
+ [ [ first ] human-compare ] sort ;
+
+: human-sort-values ( seq -- sortedseq )
+ [ [ second ] human-compare ] sort ;
From d3220a607f53b2507177c3f6d0b6493476a111c7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 7 Jan 2009 16:04:42 -0600
Subject: [PATCH 04/12] add unit test for group-name
---
basis/unix/groups/groups-tests.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor
index 7e7ebd902a..a1b5e6973f 100644
--- a/basis/unix/groups/groups-tests.factor
+++ b/basis/unix/groups/groups-tests.factor
@@ -3,7 +3,6 @@
USING: tools.test unix.groups kernel strings math ;
IN: unix.groups.tests
-
[ ] [ all-groups drop ] unit-test
\ all-groups must-infer
@@ -24,3 +23,5 @@ IN: unix.groups.tests
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
[ ] [ [ ] with-group-cache ] unit-test
+
+[ ] [ real-group-id group-name drop ] unit-test
From 3026f1c8e3f91979ba659f92dfa69e4cdb635684 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 7 Jan 2009 16:05:48 -0600
Subject: [PATCH 05/12] add another test for group-name
---
basis/unix/groups/groups-tests.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor
index a1b5e6973f..75f5d64b5f 100644
--- a/basis/unix/groups/groups-tests.factor
+++ b/basis/unix/groups/groups-tests.factor
@@ -25,3 +25,5 @@ IN: unix.groups.tests
[ ] [ [ ] with-group-cache ] unit-test
[ ] [ real-group-id group-name drop ] unit-test
+
+[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
From 4f4198d85040ae4c16002489074aaa49d4c52478 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.(none)>
Date: Thu, 8 Jan 2009 15:00:59 -0600
Subject: [PATCH 06/12] Cleaning up case conversion (still need Lithuanian
tests)
---
basis/unicode/case/case-tests.factor | 4 +-
basis/unicode/case/case.factor | 105 ++++++++++++++-------------
2 files changed, 55 insertions(+), 54 deletions(-)
diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor
index f9d304e05c..6e26a36a19 100644
--- a/basis/unicode/case/case-tests.factor
+++ b/basis/unicode/case/case-tests.factor
@@ -6,12 +6,12 @@ USING: unicode.case tools.test namespaces ;
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
-[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
+[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test
[
"tr" locale set
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
-! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
+ [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set
! Lithuanian casing tests
diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index 5d103e2dd0..b0472cd9cb 100644
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make
-unicode.normalize math unicode.categories combinators
-assocs strings splitting kernel accessors unicode.breaks ;
+unicode.normalize math unicode.categories combinators unicode.syntax
+assocs strings splitting kernel accessors unicode.breaks fry ;
IN: unicode.case
<PRIVATE
@@ -16,6 +16,13 @@ PRIVATE>
SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE
+
+: split-subseq ( string sep -- strings )
+ [ dup ] swap '[ _ split1 swap ] [ ] produce nip ;
+
+: replace ( old new str -- newstr )
+ [ split-subseq ] dip join ;
+
: i-dot? ( -- ? )
locale get { "tr" "az" } member? ;
@@ -23,57 +30,51 @@ SYMBOL: locale ! Just casing locale, or overall?
: dot-over ( -- ch ) HEX: 307 ;
-: lithuanian-ch>upper ( ? next ch -- ? )
- rot [ 2drop f ]
- [ swap dot-over = over "ij" member? and swap , ] if ;
-
: lithuanian>upper ( string -- lower )
- [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
+ "i\u000307" "i" replace
+ "j\u000307" "j" replace ;
: mark-above? ( ch -- ? )
combining-class 230 = ;
-: lithuanian-ch>lower ( next ch -- )
- ! This fails to add a dot above in certain edge cases
- ! where there is a non-above combining mark before an above one
- ! in Lithuanian
- dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
+: with-rest ( seq quot: ( seq -- seq ) -- seq )
+ [ unclip ] dip swap slip prefix ; inline
+
+: add-dots ( seq -- seq )
+ [ [ "" ] [
+ dup first mark-above?
+ [ CHAR: combining-dot-above prefix ] when
+ ] if-empty ] with-rest ;
: lithuanian>lower ( string -- lower )
- [ [ lithuanian-ch>lower ] each-next ] "" make ;
-
-: turk-ch>upper ( ch -- )
- dup CHAR: i =
- [ drop CHAR: I , dot-over , ] [ , ] if ;
+ "i" split add-dots "i" join
+ "j" split add-dots "i" join ;
: turk>upper ( string -- upper-i )
- [ [ turk-ch>upper ] each ] "" make ;
-
-: turk-ch>lower ( ? next ch -- ? )
- {
- { [ rot ] [ 2drop f ] }
- { [ dup CHAR: I = ] [
- drop dot-over =
- dup CHAR: i HEX: 131 ? ,
- ] }
- [ , drop f ]
- } cond ;
+ "i" "I\u000307" replace ;
: turk>lower ( string -- lower-i )
- [ f swap [ turk-ch>lower ] each-next drop ] "" make ;
+ "I\u000307" "i" replace
+ "I" "\u000131" replace ;
-: word-boundary ( prev char -- new ? )
- dup non-starter? [ drop dup ] when
- swap uncased? ;
+: fix-sigma-end ( string -- string )
+ [ "" ] [
+ dup peek CHAR: greek-small-letter-sigma =
+ [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
+ ] if-empty ;
: sigma-map ( string -- string )
- [
- swap [ uncased? ] keep not or
- [ drop HEX: 3C2 ] when
- ] map-next ;
+ { CHAR: greek-capital-letter-sigma } split [ [
+ [ { CHAR: greek-small-letter-sigma } ] [
+ dup first uncased?
+ CHAR: greek-small-letter-final-sigma
+ CHAR: greek-small-letter-sigma ? prefix
+ ] if-empty
+ ] map ] with-rest concat fix-sigma-end ;
: final-sigma ( string -- string )
- HEX: 3A3 over member? [ sigma-map ] when ;
+ CHAR: greek-capital-letter-sigma
+ over member? [ sigma-map ] when ;
: map-case ( string string-quot char-quot -- case )
[
@@ -83,26 +84,26 @@ SYMBOL: locale ! Just casing locale, or overall?
] 2curry each
] "" make ; inline
-: (>lower) ( string -- lower )
- [ lower>> ] [ ch>lower ] map-case ;
-
-: (>title) ( string -- title )
- [ title>> ] [ ch>title ] map-case ;
-
-: (>upper) ( string -- upper )
- [ upper>> ] [ ch>upper ] map-case ;
-
-: title-word ( string -- title )
- unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ;
-
PRIVATE>
: >lower ( string -- lower )
- i-dot? [ turk>lower ] when
- final-sigma (>lower) ;
+ i-dot? [ turk>lower ] when final-sigma
+ [ lower>> ] [ ch>lower ] map-case ;
: >upper ( string -- upper )
- i-dot? [ turk>upper ] when (>upper) ;
+ i-dot? [ turk>upper ] when
+ [ upper>> ] [ ch>upper ] map-case ;
+
+<PRIVATE
+
+: (>title) ( string -- title )
+ i-dot? [ turk>upper ] when
+ [ title>> ] [ ch>title ] map-case ;
+
+: title-word ( string -- title )
+ unclip 1string [ >lower ] [ (>title) ] bi* prepend ;
+
+PRIVATE>
: >title ( string -- title )
final-sigma >words [ title-word ] map concat ;
From e927d844045e00d34f48aa5dbd279c403da8c7e1 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 8 Jan 2009 15:38:03 -0600
Subject: [PATCH 07/12] Fixing doc errors
---
basis/unicode/case/case-docs.factor | 2 +-
.../unicode/categories/categories-docs.factor | 72 ++++++++-----------
basis/unicode/data/data-docs.factor | 18 ++---
basis/unicode/data/data.factor | 4 +-
basis/unicode/normalize/normalize-docs.factor | 2 +-
5 files changed, 44 insertions(+), 54 deletions(-)
diff --git a/basis/unicode/case/case-docs.factor b/basis/unicode/case/case-docs.factor
index 86b791ed81..da582c659a 100644
--- a/basis/unicode/case/case-docs.factor
+++ b/basis/unicode/case/case-docs.factor
@@ -35,7 +35,7 @@ HELP: >title
{ $description "Converts a string to title case." } ;
HELP: >case-fold
-{ $values { "string" string } { "case-fold" string } }
+{ $values { "string" string } { "fold" string } }
{ $description "Converts a string to case-folded form." } ;
HELP: upper?
diff --git a/basis/unicode/categories/categories-docs.factor b/basis/unicode/categories/categories-docs.factor
index 421fa90dd2..a7fe8d1e02 100644
--- a/basis/unicode/categories/categories-docs.factor
+++ b/basis/unicode/categories/categories-docs.factor
@@ -3,57 +3,47 @@
USING: help.markup help.syntax kernel ;
IN: unicode.categories
-HELP: LETTER?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is an upper-cased letter" } ;
+HELP: LETTER
+{ $class-description "The class of upper cased letters" } ;
-HELP: Letter?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is a letter of any case" } ;
+HELP: Letter
+{ $class-description "The class of letters" } ;
-HELP: alpha?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is alphanumeric" } ;
+HELP: alpha
+{ $class-description "The class of code points which are alphanumeric" } ;
-HELP: blank?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether the code point is whitespace" } ;
+HELP: blank
+{ $class-description "The class of code points which are whitespace" } ;
-HELP: character?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a number is a code point which has been assigned" } ;
+HELP: character
+{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
-HELP: control?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a control character" } ;
+HELP: control
+{ $class-description "The class of control characters" } ;
-HELP: digit?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a digit" } ;
+HELP: digit
+{ $class-description "The class of code coints which are digits" } ;
-HELP: letter?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is a lower-cased letter" } ;
+HELP: letter
+{ $class-description "The class of code points which are lower-cased letters" } ;
-HELP: printable?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a code point is printable, as opposed to being a control character or formatting character" } ;
+HELP: printable
+{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
-HELP: uncased?
-{ $values { "ch" "a character" } { "?" "a boolean" } }
-{ $description "Determines whether a character has a case" } ;
+HELP: uncased
+{ $class-description "The class of letters which don't have a case" } ;
ARTICLE: "unicode.categories" "Character classes"
-{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ASCII" "ascii" } " equivalents in most cases. Below are links to the useful predicates, but note that each of these is defined to be a predicate class."
-{ $subsection blank? }
-{ $subsection letter? }
-{ $subsection LETTER? }
-{ $subsection Letter? }
-{ $subsection digit? }
-{ $subsection printable? }
-{ $subsection alpha? }
-{ $subsection control? }
-{ $subsection uncased? }
-{ $subsection character? } ;
+{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
+{ $subsection blank }
+{ $subsection letter }
+{ $subsection LETTER }
+{ $subsection Letter }
+{ $subsection digit }
+{ $subsection printable }
+{ $subsection alpha }
+{ $subsection control }
+{ $subsection uncased }
+{ $subsection character } ;
ABOUT: "unicode.categories"
diff --git a/basis/unicode/data/data-docs.factor b/basis/unicode/data/data-docs.factor
index a918728285..55fed31386 100644
--- a/basis/unicode/data/data-docs.factor
+++ b/basis/unicode/data/data-docs.factor
@@ -15,37 +15,37 @@ ARTICLE: "unicode.data" "Unicode data tables"
{ $subsection property? } ;
HELP: load-script
-{ $value { "filename" string } { "table" "an interval map" } }
+{ $values { "filename" string } { "table" "an interval map" } }
{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
HELP: canonical-entry
-{ $value { "char" "a code point" } { "seq" string } }
+{ $values { "char" "a code point" } { "seq" string } }
{ $description "Finds the canonical decomposition (NFD) for a code point" } ;
HELP: combine-chars
-{ $value { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
+{ $values { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
{ $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ;
HELP: compatibility-entry
-{ $value { "char" "a code point" } { "seq" string } }
+{ $values { "char" "a code point" } { "seq" string } }
{ $description "This returns the compatibility decomposition (NFKD) for a code point" } ;
HELP: combining-class
-{ $value { "char" "a code point" } { "n" "an integer" } }
+{ $values { "char" "a code point" } { "n" "an integer" } }
{ $description "Finds the combining class of a code point." } ;
HELP: non-starter?
-{ $value { "char" "a code point" } { "?" "a boolean" } }
+{ $values { "char" "a code point" } { "?" "a boolean" } }
{ $description "Returns true if the code point has a combining class." } ;
HELP: char>name
-{ $value { "char" "a code point" } { "name" string } }
+{ $values { "char" "a code point" } { "name" string } }
{ $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ;
HELP: name>char
-{ $value { "name" string } { "char" "a code point" } }
+{ $values { "name" string } { "char" "a code point" } }
{ $description "Looks up the code point corresponding to a given name." } ;
HELP: property?
-{ $value { "char" "a code point" } { "property" string } { "?" "a boolean" } }
+{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor
index 8f99b6c160..cf4130ca4d 100644
--- a/basis/unicode/data/data.factor
+++ b/basis/unicode/data/data.factor
@@ -24,8 +24,8 @@ VALUE: properties
: compatibility-entry ( char -- seq ) compatibility-map at ;
: combining-class ( char -- n ) class-map at ;
: non-starter? ( char -- ? ) class-map key? ;
-: name>char ( string -- char ) name-map at ;
-: char>name ( char -- string ) name-map value-at ;
+: name>char ( name -- char ) name-map at ;
+: char>name ( char -- name ) name-map value-at ;
: property? ( char property -- ? ) properties at interval-key? ;
! Loading data from UnicodeData.txt
diff --git a/basis/unicode/normalize/normalize-docs.factor b/basis/unicode/normalize/normalize-docs.factor
index 65f50ab0ae..4b1e3485ef 100644
--- a/basis/unicode/normalize/normalize-docs.factor
+++ b/basis/unicode/normalize/normalize-docs.factor
@@ -23,5 +23,5 @@ HELP: nfkc
{ $description "Converts a string to Normalization Form KC" } ;
HELP: nfkd
-{ $values { "string" string } { "nfc" "a string in NFKD" } }
+{ $values { "string" string } { "nfkd" "a string in NFKD" } }
{ $description "Converts a string to Normalization Form KD" } ;
From 076b2d0893d60e5b019f6989743afa685796cf16 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Jan 2009 16:06:01 -0600
Subject: [PATCH 08/12] add >=< word to math.order
---
core/math/order/order-docs.factor | 7 +++++++
core/math/order/order.factor | 2 ++
2 files changed, 9 insertions(+)
diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor
index ef006bbc21..1bdd1009e9 100644
--- a/core/math/order/order-docs.factor
+++ b/core/math/order/order-docs.factor
@@ -15,6 +15,12 @@ HELP: <=>
}
} ;
+HELP: >=<
+{ $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } }
+{ $description "Compares two objects using the " { $link <=> } " comparator and inverts the output." } ;
+
+{ <=> >=< } related-words
+
HELP: +lt+
{ $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ;
@@ -85,6 +91,7 @@ ARTICLE: "order-specifiers" "Ordering specifiers"
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
{ $subsection <=> }
+{ $subsection >=< }
{ $subsection compare }
{ $subsection invert-comparison }
"The above words output order specifiers."
diff --git a/core/math/order/order.factor b/core/math/order/order.factor
index aae5841185..a06209bf63 100644
--- a/core/math/order/order.factor
+++ b/core/math/order/order.factor
@@ -13,6 +13,8 @@ SYMBOL: +gt+
GENERIC: <=> ( obj1 obj2 -- <=> )
+: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
+
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
GENERIC: before? ( obj1 obj2 -- ? )
From 6414426373bd82f6daa1d91e8dd8ad584e3371df Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Jan 2009 16:32:26 -0600
Subject: [PATCH 09/12] Add docs for sorting.human, add human>=<
---
basis/sorting/human/human-docs.factor | 71 +++++++++++++++++++++++++++
basis/sorting/human/human.factor | 2 +
2 files changed, 73 insertions(+)
create mode 100644 basis/sorting/human/human-docs.factor
diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor
new file mode 100644
index 0000000000..5342b28317
--- /dev/null
+++ b/basis/sorting/human/human-docs.factor
@@ -0,0 +1,71 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel math.order quotations
+sequences strings ;
+IN: sorting.human
+
+HELP: find-numbers
+{ $values
+ { "string" string }
+ { "seq" sequence }
+}
+{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ;
+
+HELP: human-<=>
+{ $values
+ { "obj1" object } { "obj2" object }
+ { "<=>" "an ordering specifier" }
+}
+{ $description "Compares two objects after converting numbers in the string into integers." } ;
+
+HELP: human->=<
+{ $values
+ { "obj1" object } { "obj2" object }
+ { ">=<" "an ordering specifier" }
+}
+{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ;
+
+HELP: human-compare
+{ $values
+ { "obj1" object } { "obj2" object } { "quot" quotation }
+ { "<=>" "an ordering specifier" }
+}
+{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
+
+HELP: human-sort
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
+
+HELP: human-sort-keys
+{ $values
+ { "seq" "an alist" }
+ { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ;
+
+HELP: human-sort-values
+{ $values
+ { "seq" "an alist" }
+ { "sortedseq" "a new sorted sequence" }
+}
+{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ;
+
+{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
+
+ARTICLE: "sorting.human" "sorting.human"
+"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
+"Comparing two objects:"
+{ $subsection human-<=> }
+{ $subsection human->=< }
+{ $subsection human-compare }
+"Sort a sequence:"
+{ $subsection human-sort }
+{ $subsection human-sort-keys }
+{ $subsection human-sort-values }
+"Splitting a string into substrings and integers:"
+{ $subsection find-numbers } ;
+
+ABOUT: "sorting.human"
diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index f338e21887..2c4d391a60 100644
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -9,6 +9,8 @@ IN: sorting.human
: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
+: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
+
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ;
: human-sort ( seq -- seq' ) [ human-<=> ] sort ;
From d9d349993a78a66ceef9b31596687cffd2563e9f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Jan 2009 16:38:44 -0600
Subject: [PATCH 10/12] Sorting by sequences of accessor/comparator pairs
---
basis/sorting/slots/authors.txt | 2 ++
basis/sorting/slots/slots-docs.factor | 42 ++++++++++++++++++++++
basis/sorting/slots/slots-tests.factor | 50 ++++++++++++++++++++++++++
basis/sorting/slots/slots.factor | 19 ++++++++++
4 files changed, 113 insertions(+)
create mode 100644 basis/sorting/slots/authors.txt
create mode 100644 basis/sorting/slots/slots-docs.factor
create mode 100644 basis/sorting/slots/slots-tests.factor
create mode 100644 basis/sorting/slots/slots.factor
diff --git a/basis/sorting/slots/authors.txt b/basis/sorting/slots/authors.txt
new file mode 100644
index 0000000000..5674120196
--- /dev/null
+++ b/basis/sorting/slots/authors.txt
@@ -0,0 +1,2 @@
+Doug Coleman
+Slava Pestov
diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor
new file mode 100644
index 0000000000..64d0a1efdf
--- /dev/null
+++ b/basis/sorting/slots/slots-docs.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math.order
+sequences ;
+IN: sorting.slots
+
+HELP: compare-slots
+{ $values
+ { "sort-specs" "a sequence of accessor/comparator pairs" }
+ { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+}
+{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
+
+HELP: sort-by-slots
+{ $values
+ { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
+ { "seq'" sequence }
+}
+{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
+{ $examples
+ "Sort by slot c, then b descending:"
+ { $example
+ "USING: accessors math.order prettyprint sorting.slots ;"
+ "IN: scratchpad"
+ "TUPLE: sort-me a b ;"
+ "{"
+ " T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
+ " T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
+ "}"
+ "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+ "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
+ }
+} ;
+
+ARTICLE: "sorting.slots" "Sorting by slots"
+"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
+"Comparing two objects by a sequence of slots:"
+{ $subsection compare-slots }
+"Sorting a sequence by a sequence of slots:"
+{ $subsection sort-by-slots } ;
+
+ABOUT: "sorting.slots"
diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor
new file mode 100644
index 0000000000..ab130d1eed
--- /dev/null
+++ b/basis/sorting/slots/slots-tests.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.order sorting.slots tools.test
+sorting.human ;
+IN: sorting.literals.tests
+
+TUPLE: sort-test a b c ;
+
+[
+ {
+ T{ sort-test { a 1 } { b 3 } { c 9 } }
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ }
+] [
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+ {
+ T{ sort-test { a 1 } { b 3 } { c 9 } }
+ T{ sort-test { a 1 } { b 1 } { c 10 } }
+ T{ sort-test { a 1 } { b 1 } { c 11 } }
+ T{ sort-test { a 2 } { b 5 } { c 2 } }
+ T{ sort-test { a 2 } { b 5 } { c 3 } }
+ }
+] [
+ {
+ T{ sort-test f 1 3 9 }
+ T{ sort-test f 1 1 10 }
+ T{ sort-test f 1 1 11 }
+ T{ sort-test f 2 5 3 }
+ T{ sort-test f 2 5 2 }
+ } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots
+] unit-test
+
+[
+ { }
+] [
+ { }
+ { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
new file mode 100644
index 0000000000..02a11428f9
--- /dev/null
+++ b/basis/sorting/slots/slots.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit fry kernel macros math.order
+sequences words sorting ;
+IN: sorting.slots
+
+<PRIVATE
+
+: slot-comparator ( accessor comparator -- quot )
+ '[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
+
+PRIVATE>
+
+MACRO: compare-slots ( sort-specs -- <=> )
+ #! sort-spec: { accessor comparator }
+ [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by-slots ( seq sort-specs -- seq' )
+ '[ _ compare-slots ] sort ;
From 0a9677c0af560b283334b7bdc77134a113a72131 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Jan 2009 16:41:38 -0600
Subject: [PATCH 11/12] Test the database with parallel combinators
---
basis/db/tester/authors.txt | 2 +
basis/db/tester/tester-tests.factor | 7 ++++
basis/db/tester/tester.factor | 57 +++++++++++++++++++++++++++++
3 files changed, 66 insertions(+)
create mode 100644 basis/db/tester/authors.txt
create mode 100644 basis/db/tester/tester-tests.factor
create mode 100644 basis/db/tester/tester.factor
diff --git a/basis/db/tester/authors.txt b/basis/db/tester/authors.txt
new file mode 100644
index 0000000000..f372b574ae
--- /dev/null
+++ b/basis/db/tester/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman
diff --git a/basis/db/tester/tester-tests.factor b/basis/db/tester/tester-tests.factor
new file mode 100644
index 0000000000..6b39a7e218
--- /dev/null
+++ b/basis/db/tester/tester-tests.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db.tester ;
+IN: db.tester.tests
+
+[ ] [ sqlite-test-db db-tester ] unit-test
+[ ] [ sqlite-test-db db-tester2 ] unit-test
diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor
new file mode 100644
index 0000000000..4e53ad3df7
--- /dev/null
+++ b/basis/db/tester/tester.factor
@@ -0,0 +1,57 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db.pools db.sqlite db.tuples
+db.types kernel math random threads tools.test db sequences
+io prettyprint ;
+IN: db.tester
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
+: test-db ( -- db ) "test.db" <sqlite-db> ;
+
+: db-tester ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ 10 [
+ drop
+ 10 [
+ dup [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] with-db
+ ] times
+ ] with parallel-each
+ ] bi ;
+
+: db-tester2 ( test-db -- )
+ [
+ [ test-1 recreate-table ] with-db
+ ] [
+ [
+ 2 [
+ 10 random 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] parallel-each
+ ] with-db
+ ] bi ;
From b9f0d16026e005de682fe100898149ef33ccef3d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 8 Jan 2009 17:01:27 -0600
Subject: [PATCH 12/12] add upward/stable/downward slices, monotonic-slice,
trends and docs
---
.../splitting/monotonic/monotonic-docs.factor | 109 ++++++++++++++++++
.../monotonic/monotonic-tests.factor | 45 ++++++++
basis/splitting/monotonic/monotonic.factor | 54 ++++++++-
3 files changed, 206 insertions(+), 2 deletions(-)
create mode 100644 basis/splitting/monotonic/monotonic-docs.factor
diff --git a/basis/splitting/monotonic/monotonic-docs.factor b/basis/splitting/monotonic/monotonic-docs.factor
new file mode 100644
index 0000000000..983c5b0dea
--- /dev/null
+++ b/basis/splitting/monotonic/monotonic-docs.factor
@@ -0,0 +1,109 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations classes sequences
+multiline ;
+IN: splitting.monotonic
+
+HELP: monotonic-slice
+{ $values
+ { "seq" sequence } { "quot" quotation } { "class" class }
+ { "slices" "a sequence of slices" }
+}
+{ $description "Monotonically splits a sequence into slices of the type " { $snippet "class" } "." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ."
+ <" {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 2 3 4 } }
+ }
+ T{ upward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 2 3 4 } }
+ }
+}">
+ }
+} ;
+
+HELP: monotonic-split
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" "a sequence of sequences" }
+}
+{ $description "Compares pairs of elements in a sequence and collects elements into sequences while they satisfy the predicate. Once the predicate fails, a new sequence is started, and all sequences are returned in a single sequence." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 2 3 4 } [ < ] monotonic-split ."
+ "{ V{ 1 2 3 } V{ 2 3 4 } }"
+ }
+} ;
+
+HELP: downward-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of downward-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: stable-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of stable-slices" }
+}
+{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: upward-slices
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of upward-slices" }
+}
+{ $description "Returns an array of monotonically increasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ;
+
+HELP: trends
+{ $values
+ { "seq" sequence }
+ { "slices" "a sequence of downward, stable, and upward slices" }
+}
+{ $description "Returns a sorted sequence of downward, stable, or upward slices. The endpoints of some slices may overlap with each other." }
+{ $examples
+ { $example
+ "USING: splitting.monotonic math prettyprint ;"
+ "{ 1 2 3 3 2 1 } trends ."
+ <" {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ stable-slice
+ { from 2 }
+ { to 4 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ downward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+}">
+ }
+} ;
+
+ARTICLE: "splitting.monotonic" "Splitting trending sequences"
+"The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl
+"Splitting into sequences:"
+{ $subsection monotonic-split }
+"Splitting into slices:"
+{ $subsection monotonic-slice }
+"Trending:"
+{ $subsection downward-slices }
+{ $subsection stable-slices }
+{ $subsection upward-slices }
+{ $subsection trends } ;
+
+ABOUT: "splitting.monotonic"
diff --git a/basis/splitting/monotonic/monotonic-tests.factor b/basis/splitting/monotonic/monotonic-tests.factor
index ab4c48b292..7bf9a38e8a 100644
--- a/basis/splitting/monotonic/monotonic-tests.factor
+++ b/basis/splitting/monotonic/monotonic-tests.factor
@@ -6,3 +6,48 @@ USING: tools.test math arrays kernel sequences ;
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
+[ { } ]
+[ { } [ = ] slice monotonic-slice ] unit-test
+
+[ t ]
+[ { 1 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 } } ]
+[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ t ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test
+
+[ { { 1 1 1 } { 2 2 } { 3 3 } { 4 } } ]
+[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[ { { 3 3 } } ]
+[ { 3 3 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
+
+[
+ {
+ T{ upward-slice { from 0 } { to 3 } { seq { 1 2 3 2 1 } } }
+ T{ downward-slice { from 2 } { to 5 } { seq { 1 2 3 2 1 } } }
+ }
+]
+[ { 1 2 3 2 1 } trends ] unit-test
+
+[
+ {
+ T{ upward-slice
+ { from 0 }
+ { to 3 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ stable-slice
+ { from 2 }
+ { to 4 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ T{ downward-slice
+ { from 3 }
+ { to 6 }
+ { seq { 1 2 3 3 2 1 } }
+ }
+ }
+] [ { 1 2 3 3 2 1 } trends ] unit-test
diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor
index 5bc7a51522..e39bba25ab 100644
--- a/basis/splitting/monotonic/monotonic.factor
+++ b/basis/splitting/monotonic/monotonic.factor
@@ -1,8 +1,11 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: make namespaces sequences kernel fry ;
+USING: make namespaces sequences kernel fry arrays compiler.utilities
+math accessors circular grouping combinators sorting math.order ;
IN: splitting.monotonic
+<PRIVATE
+
: ,, ( obj -- ) building get peek push ;
: v, ( -- ) V{ } clone , ;
: ,v ( -- ) building get dup peek empty? [ dup pop* ] when drop ;
@@ -13,5 +16,52 @@ IN: splitting.monotonic
v, '[ over ,, @ [ v, ] unless ] 2each ,v
] { } make ; inline
+PRIVATE>
+
: monotonic-split ( seq quot -- newseq )
over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline
+
+<PRIVATE
+
+: (monotonic-slice) ( seq quot class -- slices )
+ -rot
+ dupd '[
+ [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+ [ @ not [ , ] [ drop ] if ] 3each
+ ] { } make
+ dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
+ [ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline
+
+PRIVATE>
+
+: monotonic-slice ( seq quot class -- slices )
+ pick length {
+ { 0 [ 2drop ] }
+ { 1 [ nip [ 0 1 rot ] dip boa 1array ] }
+ [ drop (monotonic-slice) ]
+ } case ;
+
+TUPLE: downward-slice < slice ;
+TUPLE: stable-slice < slice ;
+TUPLE: upward-slice < slice ;
+
+: downward-slices ( seq -- slices )
+ [ > ] downward-slice monotonic-slice [ length 1 > ] filter ;
+
+: stable-slices ( seq -- slices )
+ [ = ] stable-slice monotonic-slice [ length 1 > ] filter ;
+
+: upward-slices ( seq -- slices )
+ [ < ] upward-slice monotonic-slice [ length 1 > ] filter ;
+
+: trends ( seq -- slices )
+ dup length {
+ { 0 [ ] }
+ { 1 [ [ 0 1 ] dip stable-slice boa ] }
+ [
+ drop
+ [ downward-slices ]
+ [ stable-slices ]
+ [ upward-slices ] tri 3append [ [ from>> ] compare ] sort
+ ]
+ } case ;