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

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2009-01-08 20:54:22 -08:00
parent 9b704d640d 8d8efb6dce
commit 70732d4176
55 changed files with 936 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
basis/ascii/ascii-docs.factor
View File

@ -37,6 +37,26 @@ HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
HELP: ascii?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for whether a number is an ASCII character." } ;
HELP: ch>lower
{ $values { "ch" "a character" } { "lower" "a character" } }
{ $description "Converts an ASCII character to lower case." } ;
HELP: ch>upper
{ $values { "ch" "a character" } { "upper" "a character" } }
{ $description "Converts an ASCII character to upper case." } ;
HELP: >lower
{ $values { "str" "a string" } { "lower" "a string" } }
{ $description "Converts an ASCII string to lower case." } ;
HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } }
{ $description "Converts an ASCII string to upper case." } ;
ARTICLE: "ascii" "ASCII character classes"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
{ $subsection blank? }
@ -46,6 +66,12 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection printable? }
{ $subsection control? }
{ $subsection quotable? }
"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
{ $subsection ascii? }
"ASCII case conversion is also implemented:"
{ $subsection ch>lower }
{ $subsection ch>upper }
{ $subsection >lower }
{ $subsection >upper }
"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;
ABOUT: "ascii"

5
basis/ascii/ascii-tests.factor
View File

@ -12,3 +12,8 @@ IN: ascii.tests
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
] unit-test
[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test

14
basis/ascii/ascii.factor
View File

@ -4,6 +4,8 @@ USING: kernel math math.order sequences
combinators.short-circuit ;
IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
@ -25,3 +27,15 @@ IN: ascii
: alpha? ( ch -- ? )
[ [ Letter? ] [ digit? ] ] 1|| ;
: ch>lower ( ch -- lower )
dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ;
: >lower ( str -- lower )
[ ch>lower ] map ;
: ch>upper ( ch -- upper )
dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ;
: >upper ( str -- upper )
[ ch>upper ] map ;

1
basis/bootstrap/help/help.factor
View File

@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ;
IN: bootstrap.help
: load-help ( -- )
"help.lint" require
"alien.syntax" require
"compiler" require

5
basis/bootstrap/unicode/unicode.factor
View File

@ -1,5 +0,0 @@
USING: strings.parser kernel namespaces unicode unicode.data ;
IN: bootstrap.unicode
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

1
basis/combinators/smart/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

91
basis/combinators/smart/smart-docs.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations math sequences
multiline ;
IN: combinators.smart
HELP: input<sequence
{ $values
{ "quot" quotation }
{ "newquot" quotation }
}
{ $description "Infers the number of inputs, " { $snippet "n" } ", to " { $snippet "quot" } " and calls the " { $snippet "quot" } " with the first " { $snippet "n" } " values from a sequence." }
{ $examples
{ $example
"USING: combinators.smart math prettyprint ;"
"{ 1 2 3 } [ + + ] input<sequence ."
"6"
}
} ;
HELP: output>array
{ $values
{ "quot" quotation }
{ "newquot" quotation }
}
{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
{ $examples
{ $example
<" USING: combinators combinators.smart math prettyprint ;
9 [
{ [ 1- ] [ 1+ ] [ sq ] } cleave
] output>array .">
"{ 8 10 81 }"
}
} ;
HELP: output>sequence
{ $values
{ "quot" quotation } { "exemplar" "an exemplar" }
{ "newquot" quotation }
}
{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." }
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
"4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ."
"V{ 5 6 7 }"
}
} ;
HELP: reduce-output
{ $values
{ "quot" quotation } { "operation" quotation }
{ "newquot" quotation }
}
{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." }
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
"3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-output ."
"-9"
}
} ;
HELP: sum-outputs
{ $values
{ "quot" quotation }
{ "n" integer }
}
{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." }
{ $examples
{ $example
"USING: combinators.smart kernel math prettyprint ;"
"10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
"20"
}
} ;
ARTICLE: "combinators.smart" "Smart combinators"
"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
"Smart inputs from a sequence:"
{ $subsection input<sequence }
"Smart outputs to a sequence:"
{ $subsection output>sequence }
{ $subsection output>array }
"Reducing the output of a quotation:"
{ $subsection reduce-output }
"Summing the output of a quotation:"
{ $subsection sum-outputs } ;
ABOUT: "combinators.smart"

21
basis/combinators/smart/smart-tests.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test combinators.smart math kernel ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
10 [ 1- ] [ 1+ ] bi ;
[ [ test-bi ] output>array ] must-infer
[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
[ { 9 11 } [ + ] input<sequence ] must-infer
[ 20 ] [ { 9 11 } [ + ] input<sequence ] unit-test
[ 6 ] [ [ 1 2 3 ] [ + ] reduce-output ] unit-test
[ [ 1 2 3 ] [ + ] reduce-output ] must-infer
[ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test

22
basis/combinators/smart/smart.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry generalizations kernel macros math.order
stack-checker math ;
IN: combinators.smart
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
: output>array ( quot -- newquot )
{ } output>sequence ; inline
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn @ ] ;
MACRO: reduce-output ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
: sum-outputs ( quot -- n )
[ + ] reduce-output ; inline

2
basis/db/tester/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Doug Coleman

7
basis/db/tester/tester-tests.factor Normal file
View File

@ -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

57
basis/db/tester/tester.factor Normal file
View File

@ -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 ;

4
basis/grouping/grouping-docs.factor
View File

@ -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 } } }"
}
} ;

8
basis/io/files/info/unix/unix-docs.factor
View File

@ -22,11 +22,11 @@ HELP: file-permissions
{ "n" integer } }
{ $description "Returns the Unix file permissions for a given file." } ;
HELP: file-username
HELP: file-user-name
{ $values
{ "path" "a pathname string" }
{ "string" string } }
{ $description "Returns the username for a given file." } ;
{ $description "Returns the user-name for a given file." } ;
HELP: file-user-id
{ $values
@ -110,7 +110,7 @@ HELP: set-file-times
HELP: set-file-user
{ $values
{ "path" "a pathname string" } { "string/id" "a string or a user id" } }
{ $description "Sets a file's user id from the given user id or username." } ;
{ $description "Sets a file's user id from the given user id or user-name." } ;
HELP: set-file-modified-time
{ $values
@ -258,7 +258,7 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps"
ARTICLE: "unix-file-ids" "Unix file user and group ids"
"Reading file user data:"
{ $subsection file-user-id }
{ $subsection file-username }
{ $subsection file-user-name }
"Setting file user data:"
{ $subsection set-file-user }
"Reading file group data:"

4
basis/io/files/info/unix/unix.factor
View File

@ -243,8 +243,8 @@ M: string set-file-group ( path string -- )
: file-user-id ( path -- uid )
normalize-path file-info uid>> ;
: file-username ( path -- string )
file-user-id username ;
: file-user-name ( path -- string )
file-user-id user-name ;
: file-group-id ( path -- gid )
normalize-path file-info gid>> ;

4
basis/math/bitwise/bitwise-tests.factor
View File

@ -32,3 +32,7 @@ IN: math.bitwise.tests
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test
[ 4 ] [ BIN: 1010101 bit-count ] unit-test
[ 0 ] [ BIN: 0 bit-count ] unit-test
[ 1 ] [ BIN: 1 bit-count ] unit-test

16
basis/math/bitwise/bitwise.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
combinators fry io.binary ;
combinators fry io.binary combinators.smart ;
IN: math.bitwise
! utilities
@ -76,12 +76,14 @@ DEFER: byte-bit-count
GENERIC: (bit-count) ( x -- n )
M: fixnum (bit-count)
{
[ byte-bit-count ]
[ -8 shift byte-bit-count ]
[ -16 shift byte-bit-count ]
[ -24 shift byte-bit-count ]
} cleave + + + ;
[
{
[ byte-bit-count ]
[ -8 shift byte-bit-count ]
[ -16 shift byte-bit-count ]
[ -24 shift byte-bit-count ]
} cleave
] sum-outputs ;
M: bignum (bit-count)
dup 0 = [ drop 0 ] [

7
basis/regexp/nfa/nfa.factor
View File

@ -3,7 +3,10 @@
USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences fry quotations
math.order math.ranges vectors unicode.categories regexp.utils
regexp.transition-tables words sets regexp.classes unicode.case ;
regexp.transition-tables words sets regexp.classes unicode.case.private ;
! This uses unicode.case.private for ch>upper and ch>lower
! but case-insensitive matching should be done by case-folding everything
! before processing starts
IN: regexp.nfa
SYMBOL: negation-mode
@ -160,6 +163,8 @@ M: LETTER-class nfa-node ( node -- )
M: character-class-range nfa-node ( node -- )
case-insensitive option? [
! This should be implemented for Unicode by case-folding
! the input and all strings in the regexp.
dup [ from>> ] [ to>> ] bi
2dup [ Letter? ] bi@ and [
rot drop

10
basis/regexp/parser/parser.factor
View File

@ -3,8 +3,8 @@
USING: accessors arrays assocs combinators io io.streams.string
kernel math math.parser namespaces sets
quotations sequences splitting vectors math.order
unicode.categories strings regexp.backend regexp.utils
unicode.case words locals regexp.classes ;
strings regexp.backend regexp.utils
unicode.case unicode.categories words locals regexp.classes ;
IN: regexp.parser
FROM: math.ranges => [a,b] ;
@ -261,7 +261,7 @@ ERROR: bad-escaped-literals seq ;
parse-til-E
drop1
[ epsilon ] [
[ quot call <constant> ] V{ } map-as
quot call [ <constant> ] V{ } map-as
first|concatenation
] if-empty ; inline
@ -269,10 +269,10 @@ ERROR: bad-escaped-literals seq ;
[ ] (parse-escaped-literals) ;
: lower-case-literals ( -- obj )
[ ch>lower ] (parse-escaped-literals) ;
[ >lower ] (parse-escaped-literals) ;
: upper-case-literals ( -- obj )
[ ch>upper ] (parse-escaped-literals) ;
[ >upper ] (parse-escaped-literals) ;
: parse-escaped ( -- obj )
read1

71
basis/sorting/human/human-docs.factor Normal file
View File

@ -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"

18
basis/sorting/human/human.factor
View File

@ -1,10 +1,22 @@
! 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->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline
: 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 ;

2
basis/sorting/slots/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Doug Coleman
Slava Pestov

42
basis/sorting/slots/slots-docs.factor Normal file
View File

@ -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"

50
basis/sorting/slots/slots-tests.factor Normal file
View File

@ -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

19
basis/sorting/slots/slots.factor Normal file
View File

@ -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 ;

2
basis/soundex/soundex.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences grouping assocs kernel ascii unicode.case tr ;
USING: sequences grouping assocs kernel ascii ascii tr ;
IN: soundex
TR: soundex-tr

109
basis/splitting/monotonic/monotonic-docs.factor Normal file
View File

@ -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"

45
basis/splitting/monotonic/monotonic-tests.factor
View File

@ -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

54
basis/splitting/monotonic/monotonic.factor
View File

@ -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 ;

16
basis/tools/cocoa/cocoa.factor
View File

@ -1,16 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays cocoa.messages cocoa.runtime combinators
prettyprint ;
prettyprint combinators.smart ;
IN: tools.cocoa
: method. ( method -- )
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave 4array . ;
[
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave
] output>array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;

2
basis/tools/files/files.factor
View File

@ -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 )

47
basis/tools/files/unix/unix.factor
View File

@ -3,7 +3,7 @@
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 combinators.smart ;
IN: tools.files.unix
<PRIVATE
@ -17,18 +17,20 @@ IN: tools.files.unix
} case ;
: permissions-string ( permissions -- str )
{
[ type>> file-type>ch 1string ]
[ user-read? read>string ]
[ user-write? write>string ]
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
[ group-read? read>string ]
[ group-write? write>string ]
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
[ other-read? read>string ]
[ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
[
{
[ type>> file-type>ch 1string ]
[ user-read? read>string ]
[ user-write? write>string ]
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
[ group-read? read>string ]
[ group-write? write>string ]
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
[ other-read? read>string ]
[ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave
] output>array concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
@ -45,15 +47,16 @@ IN: tools.files.unix
M: unix (directory.) ( path -- lines )
[ [
[
dup file-info
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
! [ uid>> ]
! [ gid>> ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave 4 narray swap suffix " " join
dup file-info [
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
[ uid>> user-name ]
[ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave
] output>array swap suffix " " join
] map
] with-group-cache ] with-user-cache ;

2
basis/tr/tr-tests.factor
View File

@ -1,5 +1,5 @@
IN: tr.tests
USING: tr tools.test unicode.case ;
USING: tr tools.test ascii ;
TR: tr-test ch>upper "ABC" "XYZ" ;

4
basis/tr/tr.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays strings sequences sequences.private
USING: byte-arrays strings sequences sequences.private ascii
fry kernel words parser lexer assocs math math.order summary ;
IN: tr
@ -11,8 +11,6 @@ M: bad-tr summary
<PRIVATE
: ascii? ( ch -- ? ) 0 127 between? ; inline
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
: check-tr ( from to -- )

16
basis/ui/gadgets/buttons/buttons.factor
View File

@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types
specialized-arrays.float fry ;
specialized-arrays.float fry combinators.smart ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@ -111,12 +111,14 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
<PRIVATE
: checkmark-points ( dim -- points )
{
[ { 0 0 } v* { 0.5 0.5 } v+ ]
[ { 1 1 } v* { 0.5 0.5 } v+ ]
[ { 1 0 } v* { -0.3 0.5 } v+ ]
[ { 0 1 } v* { -0.3 0.5 } v+ ]
} cleave 4array ;
[
{
[ { 0 0 } v* { 0.5 0.5 } v+ ]
[ { 1 1 } v* { 0.5 0.5 } v+ ]
[ { 1 0 } v* { -0.3 0.5 } v+ ]
[ { 0 1 } v* { -0.3 0.5 } v+ ]
} cleave
] output>array ;
: checkmark-vertices ( dim -- vertices )
checkmark-points concat >float-array ;

22
basis/unicode/breaks/breaks.factor
View File

@ -192,22 +192,22 @@ to: word-table
: word-table-nth ( class1 class2 -- ? )
word-table nth nth ;
: property-not= ( i str property -- ? )
pick [
[ ?nth ] dip swap
[ word-break-prop = not ] [ drop f ] if*
] [ 3drop t ] if ;
:: property-not= ( i str property -- ? )
i [
i str ?nth [ word-break-prop property = not ]
[ f ] if*
] [ t ] if ;
: format/extended? ( ch -- ? )
word-break-prop { 4 5 } member? ;
:: walk-up ( str i -- j )
i 1 + str [ format/extended? not ] find-from drop
1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
[ 1+ str [ format/extended? not ] find-from drop ] [ f ] if* ;
:: walk-down ( str i -- j )
i str [ format/extended? not ] find-last-from drop
1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
[ 1- str [ format/extended? not ] find-last-from drop ] [ f ] if* ;
:: word-break? ( table-entry i str -- ? )
table-entry {
@ -224,9 +224,11 @@ to: word-table
} case ;
:: word-break-next ( old-class new-char i str -- next-class ? )
new-char word-break-prop dup { 4 5 } member?
[ drop old-class dup { 1 2 3 } member? ]
[ old-class over word-table-nth i str word-break? ] if ;
new-char dup format/extended?
[ drop old-class dup { 1 2 3 } member? ] [
word-break-prop old-class over word-table-nth
i str word-break?
] if ;
PRIVATE>

19
basis/unicode/case/case-docs.factor
View File

@ -9,10 +9,6 @@ ARTICLE: "unicode.case" "Case mapping"
{ $subsection >lower }
{ $subsection >title }
{ $subsection >case-fold }
"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one."
{ $subsection ch>upper }
{ $subsection ch>lower }
{ $subsection ch>title }
"To test if a string is in a given case:"
{ $subsection upper? }
{ $subsection lower? }
@ -53,18 +49,3 @@ HELP: title?
HELP: case-fold?
{ $values { "string" string } { "?" "a boolean" } }
{ $description "Tests if a string is in case-folded form." } ;
HELP: ch>lower
{ $values { "ch" "a code point" } { "lower" "a code point" } }
{ $description "Converts a code point to lower case." }
{ $warning "Don't use this unless you know what you're doing! " { $code ">lower" } " is not the same as " { $code "[ ch>lower ] map" } "." } ;
HELP: ch>upper
{ $values { "ch" "a code point" } { "upper" "a code point" } }
{ $description "Converts a code point to upper case." }
{ $warning "Don't use this unless you know what you're doing! " { $code ">upper" } " is not the same as " { $code "[ ch>upper ] map" } "." } ;
HELP: ch>title
{ $values { "ch" "a code point" } { "title" "a code point" } }
{ $description "Converts a code point to title case." }
{ $warning "Don't use this unless you know what you're doing! " { $code ">title" } " is not the same as " { $code "[ ch>title ] map" } "." } ;

6
basis/unicode/case/case.factor
View File

@ -1,24 +1,24 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make
USING: unicode.data sequences sequences.next namespaces make unicode.syntax
unicode.normalize math unicode.categories combinators unicode.syntax
assocs strings splitting kernel accessors unicode.breaks fry ;
IN: unicode.case
<PRIVATE
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
PRIVATE>
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
PRIVATE>
SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE
: split-subseq ( string sep -- strings )
[ dup ] swap '[ _ split1 swap ] [ ] produce nip ;
[ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
: replace ( old new str -- newstr )
[ split-subseq ] dip join ;

20
basis/unicode/data/data.factor
View File

@ -4,7 +4,8 @@ USING: combinators.short-circuit assocs math kernel sequences
io.files hashtables quotations splitting grouping arrays io
math.parser hash2 math.order byte-arrays words namespaces words
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make io.encodings.utf8 ;
ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 ;
IN: unicode.data
VALUE: simple-lower
@ -23,7 +24,7 @@ VALUE: properties
: combine-chars ( a b -- char/f ) combine-map hash2 ;
: compatibility-entry ( char -- seq ) compatibility-map at ;
: combining-class ( char -- n ) class-map at ;
: non-starter? ( char -- ? ) class-map key? ;
: non-starter? ( char -- ? ) combining-class { 0 f } member? not ;
: name>char ( name -- char ) name-map at ;
: char>name ( char -- name ) name-map value-at ;
: property? ( char property -- ? ) properties at interval-key? ;
@ -128,12 +129,9 @@ VALUE: properties
cat categories index char table ?set-nth
] assoc-each table fill-ranges ] ;
: ascii-lower ( string -- lower )
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
: process-names ( data -- names-hash )
1 swap (process-data) [
ascii-lower { { CHAR: \s CHAR: - } } substitute swap
>lower { { CHAR: \s CHAR: - } } substitute swap
] H{ } assoc-map-as ;
: multihex ( hexstring -- string )
@ -183,6 +181,13 @@ load-data {
[ process-category to: category-map ]
} cleave
: postprocess-class ( -- )
combine-map [ [ second ] map ] map concat
[ combining-class not ] filter
[ 0 swap class-map set-at ] each ;
postprocess-class
load-special-casing to: special-casing
load-properties to: properties
@ -214,3 +219,6 @@ SYMBOL: interned
: load-script ( filename -- table )
ascii <file-reader> parse-script process-script ;
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

56
basis/unicode/normalize/normalize.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces make unicode.data kernel math arrays
locals sorting.insertion accessors assocs math.order ;
locals sorting.insertion accessors assocs math.order combinators
unicode.syntax strings sbufs ;
IN: unicode.normalize
<PRIVATE
@ -65,26 +66,29 @@ CONSTANT: final-count 28
over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
:: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be
! equivalent to clone on 8 and the contents of the last
! main quotation on 32.
string [ 127 < ] all? [ string ] [
[
string [
dup hangul? [ hangul>jamo % ]
[ dup quot call [ % ] [ , ] ?if ] if
] each
] "" make
dup reorder
] if ; inline
[let | out [ string length <sbuf> ] |
string [
dup hangul? [ hangul>jamo out push-all ]
[ dup quot call [ out push-all ] [ out push ] ?if ] if
] each out >string
] dup reorder ;
: with-string ( str quot -- str )
over aux>> [ call ] [ drop ] if ; inline
: (nfd) ( string -- nfd )
[ canonical-entry ] decompose ;
: (nfkd) ( string -- nfkd )
[ compatibility-entry ] decompose ;
PRIVATE>
: nfd ( string -- nfd )
[ canonical-entry ] decompose ;
[ (nfd) ] with-string ;
: nfkd ( string -- nfkd )
[ compatibility-entry ] decompose ;
[ (nfkd) ] with-string ;
: string-append ( s1 s2 -- string )
[ append ] keep
@ -138,20 +142,26 @@ DEFER: compose-iter
: compose-iter ( last-class -- )
current [
dup combining-class
[ try-compose to compose-iter ]
[ swap [ drop ] [ try-noncombining ] if ] if*
dup combining-class {
{ f [ 2drop ] }
{ 0 [ swap [ drop ] [ try-noncombining ] if ] }
[ try-compose to compose-iter ]
} case
] [ drop ] if* ;
: ?new-after ( -- )
after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
: compose-combining ( ch -- )
char set to ?new-after
f compose-iter
char get , after get % ;
: (compose) ( -- )
current [
dup jamo? [ drop compose-jamo ] [
char set to ?new-after
f compose-iter
char get , after get %
1 get-str combining-class
[ compose-combining ] [ , to ] if
] if (compose)
] when* ;
@ -166,7 +176,7 @@ DEFER: compose-iter
PRIVATE>
: nfc ( string -- nfc )
nfd combine ;
[ (nfd) combine ] with-string ;
: nfkc ( string -- nfkc )
nfkd combine ;
[ (nfkd) combine ] with-string ;

5
basis/unix/groups/groups-tests.factor
View File

@ -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,7 @@ 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
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test

4
basis/unix/groups/groups.factor
View File

@ -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*
@ -71,7 +71,7 @@ M: string user-groups ( string -- seq )
(user-groups) ;
M: integer user-groups ( id -- seq )
username (user-groups) ;
user-name (user-groups) ;
: all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;

34
basis/unix/users/users-docs.factor
View File

@ -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:"

10
basis/unix/users/users-tests.factor
View File

@ -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

16
basis/unix/users/users.factor
View File

@ -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 -- )

11
basis/values/values-docs.factor
View File

@ -15,7 +15,16 @@ ABOUT: "values"
HELP: VALUE:
{ $syntax "VALUE: word" }
{ $values { "word" "a word to be created" } }
{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ;
{ $description "Creates a value on the given word, initializing it to hold " { $snippet "f" } ". To get the value, just run the word. To set it, use " { $link POSTPONE: to: } "." }
{ $examples
{ $example
"USING: values math prettyprint ;"
"VALUE: x"
"2 2 + to: x"
"x ."
"4"
}
} ;
HELP: get-value
{ $values { "word" "a value word" } { "value" "the contents" } }

2
basis/xmode/marker/marker.factor
View File

@ -5,7 +5,7 @@ USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
parser-combinators.regexp splitting parser-combinators ascii
unicode.case combinators.short-circuit accessors ;
ascii combinators.short-circuit accessors ;
! Based on org.gjt.sp.jedit.syntax.TokenMarker

7
core/math/order/order-docs.factor
View File

@ -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."

2
core/math/order/order.factor
View File

@ -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 -- ? )

2
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -3,7 +3,7 @@
USING: io io.files io.files.temp io.streams.duplex kernel
sequences sequences.private strings vectors words memoize
splitting grouping hints tr continuations io.encodings.ascii
unicode.case ;
ascii ;
IN: benchmark.reverse-complement
TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ;

22
extra/geo-ip/geo-ip.factor
View File

@ -4,7 +4,7 @@ USING: kernel sequences io.files io.files.temp io.launcher
io.pathnames io.encodings.ascii io.streams.string http.client
generalizations combinators math.parser math.vectors
math.intervals interval-maps memoize csv accessors assocs
strings math splitting grouping arrays ;
strings math splitting grouping arrays combinators.smart ;
IN: geo-ip
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
@ -20,15 +20,17 @@ IN: geo-ip
TUPLE: ip-entry from to registry assigned city cntry country ;
: parse-ip-entry ( row -- ip-entry )
7 firstn {
[ string>number ]
[ string>number ]
[ ]
[ ]
[ ]
[ ]
[ ]
} spread ip-entry boa ;
[
{
[ string>number ]
[ string>number ]
[ ]
[ ]
[ ]
[ ]
[ ]
} spread
] input<sequence ip-entry boa ;
MEMO: ip-db ( -- seq )
download-db ascii file-lines

2
extra/parser-combinators/regexp/regexp.factor
View File

@ -2,7 +2,7 @@ USING: arrays combinators kernel lists math math.parser
namespaces parser lexer parser-combinators
parser-combinators.simple promises quotations sequences strings
math.order assocs prettyprint.backend prettyprint.custom memoize
unicode.case unicode.categories combinators.short-circuit
ascii unicode.categories combinators.short-circuit
accessors make io ;
IN: parser-combinators.regexp

6
extra/usa-cities/usa-cities-tests.factor Normal file
View File

@ -0,0 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel tools.test usa-cities ;
IN: usa-cities.tests
[ t ] [ 55406 find-zip-code name>> "Minneapolis" = ] unit-test

22
extra/usa-cities/usa-cities.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv summary
words accessors math.order binary-search ;
words accessors math.order binary-search combinators.smart ;
IN: usa-cities
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
@ -30,15 +30,17 @@ first-zip name state latitude longitude gmt-offset dst-offset ;
MEMO: cities ( -- seq )
"resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
csv rest-slice [
7 firstn {
[ string>number ]
[ ]
[ string>state ]
[ string>number ]
[ string>number ]
[ string>number ]
[ string>number ]
} spread city boa
[
{
[ string>number ]
[ ]
[ string>state ]
[ string>number ]
[ string>number ]
[ string>number ]
[ string>number ]
} spread
] input<sequence city boa
] map ;
MEMO: cities-named ( name -- cities )

72
misc/fuel/factor-mode.el
View File

@ -1,6 +1,6 @@
;;; factor-mode.el -- mode for editing Factor source
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
;; See http://factorcode.org/license.txt for BSD license.
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@ -28,6 +28,14 @@
:group 'fuel
:group 'languages)
(defcustom factor-mode-cycle-always-ask-p t
"Whether to always ask for file creation when cycling to a
source/docs/tests file.
When set to false, you'll be asked only once."
:type 'boolean
:group 'factor-mode)
(defcustom factor-mode-use-fuel t
"Whether to use the full FUEL facilities in factor mode.
@ -174,33 +182,58 @@ code in the buffer."
(defconst factor-mode--cycle-endings
'(".factor" "-tests.factor" "-docs.factor"))
(defconst factor-mode--regex-cycle-endings
(format "\\(.*?\\)\\(%s\\)$"
(regexp-opt factor-mode--cycle-endings)))
(make-local-variable
(defvar factor-mode--cycling-no-ask nil))
(defconst factor-mode--cycle-endings-ring
(defvar factor-mode--cycle-ring
(let ((ring (make-ring (length factor-mode--cycle-endings))))
(dolist (e factor-mode--cycle-endings ring)
(ring-insert ring e))))
(ring-insert ring e))
ring))
(defconst factor-mode--cycle-basename-regex
(format "\\(.+?\\)\\(%s\\)$" (regexp-opt factor-mode--cycle-endings)))
(defun factor-mode--cycle-split (basename)
(when (string-match factor-mode--cycle-basename-regex basename)
(cons (match-string 1 basename) (match-string 2 basename))))
(defun factor-mode--cycle-next (file)
(let* ((match (string-match factor-mode--regex-cycle-endings file))
(base (and match (match-string-no-properties 1 file)))
(ending (and match (match-string-no-properties 2 file)))
(idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
(gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
(if (not idx) file
(let ((l (length factor-mode--cycle-endings)) (i 1) next)
(while (and (not next) (< i l))
(when (file-exists-p (funcall gfl (+ idx i)))
(setq next (+ idx i)))
(setq i (1+ i)))
(funcall gfl (or next idx))))))
(let* ((dir (file-name-directory file))
(basename (file-name-nondirectory file))
(p/s (factor-mode--cycle-split basename))
(prefix (car p/s))
(ring factor-mode--cycle-ring)
(idx (or (ring-member ring (cdr p/s)) 0))
(len (ring-size ring))
(i 1)
(result nil))
(while (and (< i len) (not result))
(let* ((suffix (ring-ref ring (+ i idx)))
(path (expand-file-name (concat prefix suffix) dir)))
(when (or (file-exists-p path)
(and (not (member suffix factor-mode--cycling-no-ask))
(y-or-n-p (format "Create %s? " path))))
(setq result path))
(when (and (not factor-mode-cycle-always-ask-p)
(not (member suffix factor-mode--cycling-no-ask)))
(setq factor-mode--cycling-no-ask
(cons name factor-mode--cycling-no-ask))))
(setq i (1+ i)))
result))
(defsubst factor-mode--cycling-setup ()
(setq factor-mode--cycling-no-ask nil))
(defun factor-mode-visit-other-file (&optional file)
"Cycle between code, tests and docs factor files."
(interactive)
(find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
(let ((file (factor-mode--cycle-next (or file (buffer-file-name)))))
(unless file (error "No other file found"))
(find-file file)
(unless (file-exists-p file)
(set-buffer-modified-p t)
(save-buffer))))
;;; Keymap:
@ -237,6 +270,7 @@ code in the buffer."
(factor-mode--keymap-setup)
(factor-mode--indentation-setup)
(factor-mode--syntax-setup)
(factor-mode--cycling-setup)
(when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
(run-hooks 'factor-mode-hook))