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

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2009-01-10 20:58:00 +01:00
parent 65e6a6ca84 f4cffe8a1b
commit 982e14a7fd
51 changed files with 617 additions and 336 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" } } { $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; { $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" ARTICLE: "ascii" "ASCII character classes"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:" "The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
{ $subsection blank? } { $subsection blank? }
@ -46,6 +66,12 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection printable? } { $subsection printable? }
{ $subsection control? } { $subsection control? }
{ $subsection quotable? } { $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" ABOUT: "ascii"

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

@ -12,3 +12,8 @@ IN: ascii.tests
0 "There are Four Upper Case characters" 0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each [ LETTER? [ 1+ ] when ] each
] unit-test ] 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 ; combinators.short-circuit ;
IN: ascii IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline : blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
@ -25,3 +27,15 @@ IN: ascii
: alpha? ( ch -- ? ) : alpha? ( ch -- ? )
[ [ Letter? ] [ digit? ] ] 1|| ; [ [ 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 ;

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-outputs
{ $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-outputs ."
"-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-outputs }
"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-outputs ] unit-test
[ [ 1 2 3 ] [ + ] reduce-outputs ] 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-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline

24
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry words namespaces continuations classes fry combinators.smart
compiler.tree compiler.tree
compiler.tree.builder compiler.tree.builder
compiler.tree.recursive compiler.tree.recursive
@ -134,17 +134,19 @@ DEFER: (flat-length)
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ; over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n ) : inlining-rank ( #call word -- n )
[ classes-known? 2 0 ? ]
[ [
{ [ classes-known? 2 0 ? ]
[ body-length-bias ] [
[ "default" word-prop -4 0 ? ] {
[ "specializer" word-prop 1 0 ? ] [ body-length-bias ]
[ method-body? 1 0 ? ] [ "default" word-prop -4 0 ? ]
} cleave [ "specializer" word-prop 1 0 ? ]
node-count-bias [ method-body? 1 0 ? ]
loop-nesting get 0 or 2 * } cleave
] bi* + + + + + + ; node-count-bias
loop-nesting get 0 or 2 *
] bi*
] sum-outputs ;
: should-inline? ( #call word -- ? ) : should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;

2
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -3,7 +3,7 @@
USING: accessors alien.c-types alien.syntax combinators USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.files.info io.files.unix kernel math system unix io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 sequences grouping alien.strings io.encodings.utf8 unix.types
specialized-arrays.direct.uint arrays io.files.info.unix ; specialized-arrays.direct.uint arrays io.files.info.unix ;
IN: io.files.info.unix.freebsd IN: io.files.info.unix.freebsd

2
basis/io/files/info/unix/linux/linux.factor
View File

@ -5,7 +5,7 @@ io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ; io.pathnames unix.types ;
IN: io.files.info.unix.linux IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info TUPLE: linux-file-system-info < unix-file-system-info

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

@ -22,11 +22,11 @@ HELP: file-permissions
{ "n" integer } } { "n" integer } }
{ $description "Returns the Unix file permissions for a given file." } ; { $description "Returns the Unix file permissions for a given file." } ;
HELP: file-username HELP: file-user-name
{ $values { $values
{ "path" "a pathname string" } { "path" "a pathname string" }
{ "string" string } } { "string" string } }
{ $description "Returns the username for a given file." } ; { $description "Returns the user-name for a given file." } ;
HELP: file-user-id HELP: file-user-id
{ $values { $values
@ -110,7 +110,7 @@ HELP: set-file-times
HELP: set-file-user HELP: set-file-user
{ $values { $values
{ "path" "a pathname string" } { "string/id" "a string or a user id" } } { "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 HELP: set-file-modified-time
{ $values { $values
@ -258,7 +258,7 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps"
ARTICLE: "unix-file-ids" "Unix file user and group ids" ARTICLE: "unix-file-ids" "Unix file user and group ids"
"Reading file user data:" "Reading file user data:"
{ $subsection file-user-id } { $subsection file-user-id }
{ $subsection file-username } { $subsection file-user-name }
"Setting file user data:" "Setting file user data:"
{ $subsection set-file-user } { $subsection set-file-user }
"Reading file group data:" "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 ) : file-user-id ( path -- uid )
normalize-path file-info uid>> ; normalize-path file-info uid>> ;
: file-username ( path -- string ) : file-user-name ( path -- string )
file-user-id username ; file-user-id user-name ;
: file-group-id ( path -- gid ) : file-group-id ( path -- gid )
normalize-path file-info gid>> ; normalize-path file-info gid>> ;

4
basis/io/files/unix/unix-tests.factor
View File

@ -117,12 +117,12 @@ prepare-test-file
[ ] [ test-file f f 2array set-file-times ] unit-test [ ] [ test-file f f 2array set-file-times ] unit-test
[ ] [ test-file real-username set-file-user ] unit-test [ ] [ test-file real-user-name set-file-user ] unit-test
[ ] [ test-file real-user-id set-file-user ] unit-test [ ] [ test-file real-user-id set-file-user ] unit-test
[ ] [ test-file real-group-name set-file-group ] unit-test [ ] [ test-file real-group-name set-file-group ] unit-test
[ ] [ test-file real-group-id set-file-group ] unit-test [ ] [ test-file real-group-id set-file-group ] unit-test
[ t ] [ test-file file-username real-username = ] unit-test [ t ] [ test-file file-user-name real-user-name = ] unit-test
[ t ] [ test-file file-group-name real-group-name = ] unit-test [ t ] [ test-file file-group-name real-group-name = ] unit-test
[ ] [ ]

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

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

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

@ -3,7 +3,10 @@
USING: accessors arrays assocs grouping kernel regexp.backend USING: accessors arrays assocs grouping kernel regexp.backend
locals math namespaces regexp.parser sequences fry quotations locals math namespaces regexp.parser sequences fry quotations
math.order math.ranges vectors unicode.categories regexp.utils 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 IN: regexp.nfa
SYMBOL: negation-mode SYMBOL: negation-mode
@ -160,6 +163,8 @@ M: LETTER-class nfa-node ( node -- )
M: character-class-range nfa-node ( node -- ) M: character-class-range nfa-node ( node -- )
case-insensitive option? [ case-insensitive option? [
! This should be implemented for Unicode by case-folding
! the input and all strings in the regexp.
dup [ from>> ] [ to>> ] bi dup [ from>> ] [ to>> ] bi
2dup [ Letter? ] bi@ and [ 2dup [ Letter? ] bi@ and [
rot drop rot drop

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

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

2
basis/soundex/soundex.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: soundex
TR: soundex-tr TR: soundex-tr

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

@ -15,6 +15,8 @@ USING: tools.test math arrays kernel sequences ;
[ { { 1 } } ] [ { { 1 } } ]
[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test [ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test
[ { 1 } [ = ] slice monotonic-slice ] must-infer
[ t ] [ t ]
[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test [ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test

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

@ -24,13 +24,15 @@ PRIVATE>
<PRIVATE <PRIVATE
: (monotonic-slice) ( seq quot class -- slices ) : (monotonic-slice) ( seq quot class -- slices )
-rot [
dupd '[ dupd '[
[ length ] [ ] [ <circular> 1 over change-circular-start ] tri [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each [ @ not [ , ] [ drop ] if ] 3each
] { } make ] { } make
dup empty? [ over length 1- prefix ] when -1 prefix 2 clump dup empty? [ over length 1- prefix ] when -1 prefix 2 clump
[ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline swap
] dip
'[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline
PRIVATE> PRIVATE>
@ -39,7 +41,7 @@ PRIVATE>
{ 0 [ 2drop ] } { 0 [ 2drop ] }
{ 1 [ nip [ 0 1 rot ] dip boa 1array ] } { 1 [ nip [ 0 1 rot ] dip boa 1array ] }
[ drop (monotonic-slice) ] [ drop (monotonic-slice) ]
} case ; } case ; inline
TUPLE: downward-slice < slice ; TUPLE: downward-slice < slice ;
TUPLE: stable-slice < slice ; TUPLE: stable-slice < slice ;

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

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

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

@ -65,7 +65,7 @@ percent-used percent-free ;
[ [ unparse ] map ] bi prefix simple-table. ; [ [ unparse ] map ] bi prefix simple-table. ;
: file-systems. ( -- ) : file-systems. ( -- )
{ device-name free-space used-space total-space percent-used mount-point } { device-name available-space free-space used-space total-space percent-used mount-point }
print-file-systems ; print-file-systems ;
{ {

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

@ -3,12 +3,9 @@
USING: accessors combinators kernel system unicode.case io.files USING: accessors combinators kernel system unicode.case io.files
io.files.info io.files.info.unix tools.files generalizations io.files.info io.files.info.unix tools.files generalizations
strings arrays sequences math.parser unix.groups unix.users strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math fry macros ; tools.files.private unix.stat math fry macros combinators.smart ;
IN: tools.files.unix IN: tools.files.unix
MACRO: cleave>array ( array -- quot )
dup length '[ _ cleave _ narray ] ;
<PRIVATE <PRIVATE
: unix-execute>string ( str bools -- str' ) : unix-execute>string ( str bools -- str' )
@ -20,18 +17,20 @@ MACRO: cleave>array ( array -- quot )
} case ; } case ;
: permissions-string ( permissions -- str ) : permissions-string ( permissions -- str )
{ [
[ type>> file-type>ch 1string ] {
[ user-read? read>string ] [ type>> file-type>ch 1string ]
[ user-write? write>string ] [ user-read? read>string ]
[ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ] [ user-write? write>string ]
[ group-read? read>string ] [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
[ group-write? write>string ] [ group-read? read>string ]
[ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ] [ group-write? write>string ]
[ other-read? read>string ] [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
[ other-write? write>string ] [ other-read? read>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] [ other-write? write>string ]
} cleave>array concat ; [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave
] output>array concat ;
: mode>symbol ( mode -- ch ) : mode>symbol ( mode -- ch )
S_IFMT bitand S_IFMT bitand
@ -48,15 +47,16 @@ MACRO: cleave>array ( array -- quot )
M: unix (directory.) ( path -- lines ) M: unix (directory.) ( path -- lines )
[ [ [ [
[ [
dup file-info dup file-info [
{ {
[ permissions-string ] [ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ] [ nlink>> number>string 3 CHAR: \s pad-left ]
[ uid>> user-name ] [ uid>> user-name ]
[ gid>> group-name ] [ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ] [ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ] [ modified>> ls-timestamp ]
} cleave>array swap suffix " " join } cleave
] output>array swap suffix " " join
] map ] map
] with-group-cache ] with-user-cache ; ] with-group-cache ] with-user-cache ;

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

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

4
basis/tr/tr.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; fry kernel words parser lexer assocs math math.order summary ;
IN: tr IN: tr
@ -11,8 +11,6 @@ M: bad-tr summary
<PRIVATE <PRIVATE
: ascii? ( ch -- ? ) 0 127 between? ; inline
: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline : tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
: check-tr ( from to -- ) : 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.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types ui.render math.geometry.rect locals alien.c-types
specialized-arrays.float fry ; specialized-arrays.float fry combinators.smart ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;
@ -111,12 +111,14 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
<PRIVATE <PRIVATE
: checkmark-points ( dim -- points ) : checkmark-points ( dim -- points )
{ [
[ { 0 0 } v* { 0.5 0.5 } v+ ] {
[ { 1 1 } v* { 0.5 0.5 } v+ ] [ { 0 0 } v* { 0.5 0.5 } v+ ]
[ { 1 0 } v* { -0.3 0.5 } v+ ] [ { 1 1 } v* { 0.5 0.5 } v+ ]
[ { 0 1 } v* { -0.3 0.5 } v+ ] [ { 1 0 } v* { -0.3 0.5 } v+ ]
} cleave 4array ; [ { 0 1 } v* { -0.3 0.5 } v+ ]
} cleave
] output>array ;
: checkmark-vertices ( dim -- vertices ) : checkmark-vertices ( dim -- vertices )
checkmark-points concat >float-array ; checkmark-points concat >float-array ;

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

@ -4,7 +4,8 @@ USING: combinators.short-circuit unicode.categories kernel math
combinators splitting sequences math.parser io.files io assocs combinators splitting sequences math.parser io.files io assocs
arrays namespaces make math.ranges unicode.normalize.private values arrays namespaces make math.ranges unicode.normalize.private values
io.encodings.ascii unicode.syntax unicode.data compiler.units fry io.encodings.ascii unicode.syntax unicode.data compiler.units fry
alien.syntax sets accessors interval-maps memoize locals words ; alien.syntax sets accessors interval-maps memoize locals words
strings hints ;
IN: unicode.breaks IN: unicode.breaks
<PRIVATE <PRIVATE
@ -58,38 +59,31 @@ SYMBOL: table
: finish-table ( -- table ) : finish-table ( -- table )
table get [ [ 1 = ] map ] map ; table get [ [ 1 = ] map ] map ;
: set-table ( class1 class2 val -- ) : eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
: (set-table) ( class1 class2 val -- )
-rot table get nth [ swap or ] change-nth ; -rot table get nth [ swap or ] change-nth ;
: set-table ( classes1 classes2 val -- )
[ [ eval-seq ] bi@ ] dip
[ [ (set-table) ] curry with each ] 2curry each ;
: connect ( class1 class2 -- ) 1 set-table ; : connect ( class1 class2 -- ) 1 set-table ;
: disconnect ( class1 class2 -- ) 0 set-table ; : disconnect ( class1 class2 -- ) 0 set-table ;
: check-before ( class classes value -- )
[ set-table ] curry with each ;
: check-after ( classes class value -- )
[ set-table ] 2curry each ;
: connect-before ( class classes -- )
1 check-before ;
: connect-after ( classes class -- )
1 check-after ;
: break-around ( classes1 classes2 -- ) : break-around ( classes1 classes2 -- )
[ [ 2dup disconnect swap disconnect ] with each ] curry each ; [ disconnect ] [ swap disconnect ] 2bi ;
: make-grapheme-table ( -- ) : make-grapheme-table ( -- )
CR LF connect { CR } { LF } connect
Control CR LF 3array graphemes break-around { Control CR LF } graphemes disconnect
L L V LV LVT 4array connect-before graphemes { Control CR LF } disconnect
V V T 2array connect-before { L } { L V LV LVT } connect
LV V T 2array connect-before { LV V } { V T } connect
T T connect { LVT T } { T } connect
LVT T connect graphemes { Extend } connect
graphemes Extend connect-after graphemes { SpacingMark } connect
graphemes SpacingMark connect-after { Prepend } graphemes connect ;
Prepend graphemes connect-before ;
VALUE: grapheme-table VALUE: grapheme-table
@ -99,14 +93,11 @@ VALUE: grapheme-table
: chars ( i str n -- str[i] str[i+n] ) : chars ( i str n -- str[i] str[i+n] )
swap [ dupd + ] dip [ ?nth ] curry bi@ ; swap [ dupd + ] dip [ ?nth ] curry bi@ ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline
PRIVATE> PRIVATE>
: first-grapheme ( str -- i ) : first-grapheme ( str -- i )
unclip-slice grapheme-class over unclip-slice grapheme-class over
[ grapheme-class tuck grapheme-break? ] find-index [ grapheme-class tuck grapheme-break? ] find drop
nip swap length or 1+ ; nip swap length or 1+ ;
<PRIVATE <PRIVATE
@ -125,7 +116,7 @@ PRIVATE>
: last-grapheme ( str -- i ) : last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ; [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
<PRIVATE <PRIVATE
@ -156,27 +147,23 @@ wMidNum wMidNumLet wNumeric wExtendNumLet words ;
word-break-table interval-at word-break-table interval-at
word-break-classes at [ wOther ] unless* ; word-break-classes at [ wOther ] unless* ;
: e ( seq -- seq ) [ execute ] map ;
SYMBOL: check-letter-before SYMBOL: check-letter-before
SYMBOL: check-letter-after SYMBOL: check-letter-after
SYMBOL: check-number-before SYMBOL: check-number-before
SYMBOL: check-number-after SYMBOL: check-number-after
: make-word-table ( -- ) : make-word-table ( -- )
wCR wLF connect { wCR } { wLF } connect
{ wNewline wCR wLF } e words break-around { wNewline wCR wLF } words disconnect
wALetter dup connect words { wNewline wCR wLF } disconnect
wALetter { wMidLetter wMidNumLet } e check-letter-after check-before { wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
{ wMidLetter wMidNumLet } e wALetter check-letter-before check-after { wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
wNumeric dup connect { wNumeric wALetter } { wNumeric wALetter } connect
wALetter wNumeric connect { wNumeric } { wMidNum wMidNumLet } check-number-after set-table
wNumeric wALetter connect { wMidNum wMidNumLet } { wNumeric } check-number-before set-table
wNumeric { wMidNum wMidNumLet } e check-number-after check-before { wKatakana } { wKatakana } connect
{ wMidNum wMidNumLet } e wNumeric check-number-before check-after { wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
wKatakana dup connect [ connect ] [ swap connect ] 2bi ;
{ wALetter wNumeric wKatakana wExtendNumLet } e wExtendNumLet
[ connect-after ] [ swap connect-before ] 2bi ;
VALUE: word-table VALUE: word-table
@ -192,48 +179,58 @@ to: word-table
: word-table-nth ( class1 class2 -- ? ) : word-table-nth ( class1 class2 -- ? )
word-table nth nth ; word-table nth nth ;
: property-not= ( i str property -- ? ) :: property-not= ( str i property -- ? )
pick [ i [
[ ?nth ] dip swap i str ?nth [ word-break-prop property = not ]
[ word-break-prop = not ] [ drop f ] if* [ f ] if*
] [ 3drop t ] if ; ] [ t ] if ;
: format/extended? ( ch -- ? ) : format/extended? ( ch -- ? )
word-break-prop { 4 5 } member? ; word-break-prop { 4 5 } member? ;
:: walk-up ( str i -- j ) : (walk-up) ( str i -- j )
i 1 + str [ format/extended? not ] find-from drop swap [ format/extended? not ] find-from drop ;
1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
:: walk-down ( str i -- j ) : walk-up ( str i -- j )
i str [ format/extended? not ] find-last-from drop dupd 1+ (walk-up) [ 1+ (walk-up) ] [ drop f ] if* ;
1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
:: word-break? ( table-entry i str -- ? ) : (walk-down) ( str i -- j )
table-entry { swap [ format/extended? not ] find-last-from drop ;
{ t [ f ] }
{ f [ t ] } : walk-down ( str i -- j )
dupd (walk-down) [ 1- (walk-down) ] [ drop f ] if* ;
: word-break? ( table-entry i str -- ? )
spin {
{ t [ 2drop f ] }
{ f [ 2drop t ] }
{ check-letter-after { check-letter-after
[ str i walk-up str wALetter property-not= ] } [ dupd walk-up wALetter property-not= ] }
{ check-letter-before { check-letter-before
[ str i walk-down str wALetter property-not= ] } [ dupd walk-down wALetter property-not= ] }
{ check-number-after { check-number-after
[ str i walk-up str wNumeric property-not= ] } [ dupd walk-up wNumeric property-not= ] }
{ check-number-before { check-number-before
[ str i walk-down str wNumeric property-not= ] } [ dupd walk-down wNumeric property-not= ] }
} case ; } case ; inline
:: word-break-next ( old-class new-char i str -- next-class ? ) :: word-break-next ( old-class new-char i str -- next-class ? )
new-char word-break-prop dup { 4 5 } member? new-char dup format/extended?
[ drop old-class dup { 1 2 3 } member? ] [ drop old-class dup { 1 2 3 } member? ] [
[ old-class over word-table-nth i str word-break? ] if ; word-break-prop old-class over word-table-nth
i str word-break?
] if ; inline
PRIVATE> PRIVATE>
:: first-word ( str -- i ) : first-word ( str -- i )
str unclip-slice word-break-prop over <enum> [ unclip-slice word-break-prop over <enum> ] keep
[ swap str word-break-next ] assoc-find 2drop '[ swap _ word-break-next ] assoc-find 2drop
nip swap length or 1+ ; nip swap length or 1+ ; inline
HINTS: first-word string ;
: >words ( str -- words ) : >words ( str -- words )
[ first-word ] >pieces ; [ first-word ] >pieces ;
HINTS: >words string ;

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

@ -9,10 +9,6 @@ ARTICLE: "unicode.case" "Case mapping"
{ $subsection >lower } { $subsection >lower }
{ $subsection >title } { $subsection >title }
{ $subsection >case-fold } { $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:" "To test if a string is in a given case:"
{ $subsection upper? } { $subsection upper? }
{ $subsection lower? } { $subsection lower? }
@ -53,18 +49,3 @@ HELP: title?
HELP: case-fold? HELP: case-fold?
{ $values { "string" string } { "?" "a boolean" } } { $values { "string" string } { "?" "a boolean" } }
{ $description "Tests if a string is in case-folded form." } ; { $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" } "." } ;

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

@ -1,27 +1,29 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences sequences.next namespaces make USING: unicode.data sequences sequences.next namespaces
unicode.normalize math unicode.categories combinators unicode.syntax sbufs make unicode.syntax unicode.normalize math hints
assocs strings splitting kernel accessors unicode.breaks fry ; unicode.categories combinators unicode.syntax assocs
strings splitting kernel accessors unicode.breaks fry locals ;
QUALIFIED: ascii
IN: unicode.case IN: unicode.case
<PRIVATE <PRIVATE
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
PRIVATE>
: ch>lower ( ch -- lower ) simple-lower at-default ; : ch>lower ( ch -- lower ) simple-lower at-default ; inline
: ch>upper ( ch -- upper ) simple-upper at-default ; : ch>upper ( ch -- upper ) simple-upper at-default ; inline
: ch>title ( ch -- title ) simple-title at-default ; : ch>title ( ch -- title ) simple-title at-default ; inline
PRIVATE>
SYMBOL: locale ! Just casing locale, or overall? SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE <PRIVATE
: split-subseq ( string sep -- strings ) : split-subseq ( string sep -- strings )
[ dup ] swap '[ _ split1 swap ] [ ] produce nip ; [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
: replace ( old new str -- newstr ) : replace ( old new str -- newstr )
[ split-subseq ] dip join ; [ split-subseq ] dip join ; inline
: i-dot? ( -- ? ) : i-dot? ( -- ? )
locale get { "tr" "az" } member? ; locale get { "tr" "az" } member? ;
@ -44,24 +46,24 @@ SYMBOL: locale ! Just casing locale, or overall?
[ [ "" ] [ [ [ "" ] [
dup first mark-above? dup first mark-above?
[ CHAR: combining-dot-above prefix ] when [ CHAR: combining-dot-above prefix ] when
] if-empty ] with-rest ; ] if-empty ] with-rest ; inline
: lithuanian>lower ( string -- lower ) : lithuanian>lower ( string -- lower )
"i" split add-dots "i" join "i" split add-dots "i" join
"j" split add-dots "i" join ; "j" split add-dots "i" join ; inline
: turk>upper ( string -- upper-i ) : turk>upper ( string -- upper-i )
"i" "I\u000307" replace ; "i" "I\u000307" replace ; inline
: turk>lower ( string -- lower-i ) : turk>lower ( string -- lower-i )
"I\u000307" "i" replace "I\u000307" "i" replace
"I" "\u000131" replace ; "I" "\u000131" replace ; inline
: fix-sigma-end ( string -- string ) : fix-sigma-end ( string -- string )
[ "" ] [ [ "" ] [
dup peek CHAR: greek-small-letter-sigma = dup peek CHAR: greek-small-letter-sigma =
[ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
] if-empty ; ] if-empty ; inline
: sigma-map ( string -- string ) : sigma-map ( string -- string )
{ CHAR: greek-capital-letter-sigma } split [ [ { CHAR: greek-capital-letter-sigma } split [ [
@ -70,19 +72,20 @@ SYMBOL: locale ! Just casing locale, or overall?
CHAR: greek-small-letter-final-sigma CHAR: greek-small-letter-final-sigma
CHAR: greek-small-letter-sigma ? prefix CHAR: greek-small-letter-sigma ? prefix
] if-empty ] if-empty
] map ] with-rest concat fix-sigma-end ; ] map ] with-rest concat fix-sigma-end ; inline
: final-sigma ( string -- string ) : final-sigma ( string -- string )
CHAR: greek-capital-letter-sigma CHAR: greek-capital-letter-sigma
over member? [ sigma-map ] when ; over member? [ sigma-map ] when
"" like ; inline
: map-case ( string string-quot char-quot -- case ) :: map-case ( string string-quot char-quot -- case )
[ string length <sbuf> :> out
[ string [
[ dup special-casing at ] 2dip dup special-casing at
[ [ % ] compose ] [ [ , ] compose ] bi* ?if [ string-quot call out push-all ]
] 2curry each [ char-quot call out push ] ?if
] "" make ; inline ] each out "" like ; inline
PRIVATE> PRIVATE>
@ -90,24 +93,30 @@ PRIVATE>
i-dot? [ turk>lower ] when final-sigma i-dot? [ turk>lower ] when final-sigma
[ lower>> ] [ ch>lower ] map-case ; [ lower>> ] [ ch>lower ] map-case ;
HINTS: >lower string ;
: >upper ( string -- upper ) : >upper ( string -- upper )
i-dot? [ turk>upper ] when i-dot? [ turk>upper ] when
[ upper>> ] [ ch>upper ] map-case ; [ upper>> ] [ ch>upper ] map-case ;
HINTS: >upper string ;
<PRIVATE <PRIVATE
: (>title) ( string -- title ) : (>title) ( string -- title )
i-dot? [ turk>upper ] when i-dot? [ turk>upper ] when
[ title>> ] [ ch>title ] map-case ; [ title>> ] [ ch>title ] map-case ; inline
: title-word ( string -- title ) : title-word ( string -- title )
unclip 1string [ >lower ] [ (>title) ] bi* prepend ; unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
PRIVATE> PRIVATE>
: >title ( string -- title ) : >title ( string -- title )
final-sigma >words [ title-word ] map concat ; final-sigma >words [ title-word ] map concat ;
HINTS: >title string ;
: >case-fold ( string -- fold ) : >case-fold ( string -- fold )
>upper >lower ; >upper >lower ;

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

2
basis/unicode/normalize/normalize-tests.factor
View File

@ -3,6 +3,8 @@ unicode.data io.encodings.utf8 io.files splitting math.parser
locals math quotations assocs combinators unicode.normalize.private ; locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests IN: unicode.normalize.tests
{ nfc nfkc nfd nfkd } [ must-infer ] each
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces make unicode.data kernel math arrays USING: ascii 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 hints combinators.short-circuit vectors ;
IN: unicode.normalize IN: unicode.normalize
<PRIVATE <PRIVATE
@ -18,16 +19,16 @@ CONSTANT: medial-count 21
CONSTANT: final-count 28 CONSTANT: final-count 28
: ?between? ( n/f from to -- ? ) : ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ; pick [ between? ] [ 3drop f ] if ; inline
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; : hangul? ( ch -- ? ) hangul-base hangul-end ?between? ; inline
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; : jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ; inline
! These numbers come from UAX 29 ! These numbers come from UAX 29
: initial? ( ch -- ? ) : initial? ( ch -- ? )
dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ; inline
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; : medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ; inline
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; : final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ; inline
: hangul>jamo ( hangul -- jamo-string ) : hangul>jamo ( hangul -- jamo-string )
hangul-base - final-count /mod final-base + hangul-base - final-count /mod final-base +
@ -47,16 +48,16 @@ CONSTANT: final-count 28
: reorder-slice ( string start -- slice done? ) : reorder-slice ( string start -- slice done? )
2dup swap [ non-starter? not ] find-from drop 2dup swap [ non-starter? not ] find-from drop
[ [ over length ] unless* rot <slice> ] keep not ; [ [ over length ] unless* rot <slice> ] keep not ; inline
: reorder-next ( string i -- new-i done? ) : reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [ over [ non-starter? ] find-from drop [
reorder-slice reorder-slice
[ dup [ combining-class ] insertion-sort to>> ] dip [ dup [ combining-class ] insertion-sort to>> ] dip
] [ length t ] if* ; ] [ length t ] if* ; inline
: reorder-loop ( string start -- ) : reorder-loop ( string start -- )
dupd reorder-next [ 2drop ] [ reorder-loop ] if ; dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive
: reorder ( string -- ) : reorder ( string -- )
0 reorder-loop ; 0 reorder-loop ;
@ -65,108 +66,131 @@ CONSTANT: final-count 28
over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ; over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ;
:: decompose ( string quot -- decomposed ) :: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be string length <sbuf> :> out
! equivalent to clone on 8 and the contents of the last string [
! main quotation on 32. >fixnum dup ascii? [ out push ] [
string [ 127 < ] all? [ string ] [ dup hangul? [ hangul>jamo out push-all ]
[ [ dup quot call [ out push-all ] [ out push ] ?if ] if
string [ ] if
dup hangul? [ hangul>jamo % ] ] each
[ dup quot call [ % ] [ , ] ?if ] if out "" like dup reorder ; inline
] each
] "" make : with-string ( str quot -- str )
dup reorder over aux>> [ call ] [ drop ] if ; inline
] if ; inline
: (nfd) ( string -- nfd )
[ canonical-entry ] decompose ;
HINTS: (nfd) string ;
: (nfkd) ( string -- nfkd )
[ compatibility-entry ] decompose ;
HINTS: (nfkd) string ;
PRIVATE> PRIVATE>
: nfd ( string -- nfd ) : nfd ( string -- nfd )
[ canonical-entry ] decompose ; [ (nfd) ] with-string ;
: nfkd ( string -- nfkd ) : nfkd ( string -- nfkd )
[ compatibility-entry ] decompose ; [ (nfkd) ] with-string ;
: string-append ( s1 s2 -- string ) : string-append ( s1 s2 -- string )
[ append ] keep [ append ] keep
0 over ?nth non-starter? 0 over ?nth non-starter?
[ length dupd reorder-back ] [ drop ] if ; [ length dupd reorder-back ] [ drop ] if ;
HINTS: string-append string string ;
<PRIVATE <PRIVATE
! Normalization -- Composition ! Normalization -- Composition
SYMBOL: main-str
SYMBOL: ind
SYMBOL: after
SYMBOL: char
: get-str ( i -- ch ) ind get + main-str get ?nth ; : initial-medial? ( str i -- ? )
: current ( -- ch ) 0 get-str ; { [ swap nth initial? ] [ 1+ swap ?nth medial? ] } 2&& ;
: to ( -- ) ind inc ;
: initial-medial? ( -- ? ) : --final? ( str i -- ? )
current initial? [ 1 get-str medial? ] [ f ] if ; 2 + swap ?nth final? ;
: --final? ( -- ? ) : imf, ( str i -- str i )
2 get-str final? ; [ tail-slice first3 jamo>hangul , ]
[ 3 + ] 2bi ;
: imf, ( -- ) : im, ( str i -- str i )
current to current to current jamo>hangul , ; [ tail-slice first2 final-base jamo>hangul , ]
[ 2 + ] 2bi ;
: im, ( -- ) : compose-jamo ( str i -- str i )
current to current final-base jamo>hangul , ; 2dup initial-medial? [
2dup --final? [ imf, ] [ im, ] if
] [ 2dup swap nth , 1+ ] if ;
: compose-jamo ( -- ) : pass-combining ( str -- str i )
initial-medial? [ dup [ non-starter? not ] find drop
--final? [ imf, ] [ im, ] if [ dup length ] unless*
] [ current , ] if to ; 2dup head-slice % ;
: pass-combining ( -- ) TUPLE: compose-state i str char after last-class ;
current non-starter? [ current , to pass-combining ] when ;
:: try-compose ( last-class new-char current-class -- new-class ) : get-str ( state i -- ch )
last-class current-class = [ new-char after get push last-class ] [ swap [ i>> + ] [ str>> ] bi ?nth ; inline
char get new-char combine-chars : current ( state -- ch ) 0 get-str ; inline
[ char set last-class ] : to ( state -- state ) [ 1+ ] change-i ; inline
[ new-char after get push current-class ] if* : push-after ( ch state -- state ) [ ?push ] change-after ; inline
] if ;
:: try-compose ( state new-char current-class -- state )
state last-class>> current-class =
[ new-char state push-after ] [
state char>> new-char combine-chars
[ state swap >>char ] [
new-char state push-after
current-class >>last-class
] if*
] if ; inline
DEFER: compose-iter DEFER: compose-iter
: try-noncombining ( char -- ) : try-noncombining ( char state -- state )
char get swap combine-chars tuck char>> swap combine-chars
[ char set to f compose-iter ] when* ; [ >>char to f >>last-class compose-iter ] when* ; inline
: compose-iter ( last-class -- ) : compose-iter ( state -- state )
current [ dup current [
dup combining-class dup combining-class {
[ try-compose to compose-iter ] { f [ drop ] }
[ swap [ drop ] [ try-noncombining ] if ] if* { 0 [
] [ drop ] if* ; over last-class>>
[ drop ] [ swap try-noncombining ] if ] }
[ try-compose to compose-iter ]
} case
] when* ; inline recursive
: ?new-after ( -- ) : compose-combining ( ch str i -- str i )
after [ dup empty? [ drop SBUF" " clone ] unless ] change ; compose-state new
swap >>i
swap >>str
swap >>char
compose-iter
{ [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline
: (compose) ( -- ) :: (compose) ( str i -- )
current [ i str ?nth [
dup jamo? [ drop compose-jamo ] [ dup jamo? [ drop str i compose-jamo ] [
char set to ?new-after i 1+ str ?nth combining-class
f compose-iter [ str i 1+ compose-combining ] [ , str i 1+ ] if
char get , after get %
] if (compose) ] if (compose)
] when* ; ] when* ; inline recursive
: combine ( str -- comp ) : combine ( str -- comp )
[ [ pass-combining (compose) ] "" make ;
main-str set
0 ind set HINTS: combine string ;
SBUF" " clone after set
pass-combining (compose)
] "" make ;
PRIVATE> PRIVATE>
: nfc ( string -- nfc ) : nfc ( string -- nfc )
nfd combine ; [ (nfd) combine ] with-string ;
: nfkc ( string -- nfkc ) : nfkc ( string -- nfkc )
nfkd combine ; [ (nfkd) combine ] with-string ;

6
basis/unix/groups/groups-docs.factor
View File

@ -24,8 +24,8 @@ HELP: group-cache
HELP: group-id HELP: group-id
{ $values { $values
{ "string" string } { "string" string }
{ "id" integer } } { "id/f" "an integer or f" } }
{ $description "Returns the group id given a group name." } ; { $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ;
HELP: group-name HELP: group-name
{ $values { $values
@ -36,7 +36,7 @@ HELP: group-name
HELP: group-struct HELP: group-struct
{ $values { $values
{ "obj" object } { "obj" object }
{ "group" "a group struct" } } { "group/f" "a group struct or f" } }
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ; { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
HELP: real-group-id HELP: real-group-id

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

@ -27,3 +27,5 @@ IN: unix.groups.tests
[ ] [ real-group-id group-name drop ] unit-test [ ] [ real-group-id group-name drop ] unit-test
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test [ "888888888888888" ] [ 888888888888888 group-name ] unit-test
[ f ]
[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test

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

@ -13,7 +13,7 @@ TUPLE: group id name passwd members ;
SYMBOL: group-cache SYMBOL: group-cache
GENERIC: group-struct ( obj -- group ) GENERIC: group-struct ( obj -- group/f )
<PRIVATE <PRIVATE
@ -24,11 +24,14 @@ GENERIC: group-struct ( obj -- group )
"group" <c-object> tuck 4096 "group" <c-object> tuck 4096
[ <byte-array> ] keep f <void*> ; [ <byte-array> ] keep f <void*> ;
M: integer group-struct ( id -- group ) : check-group-struct ( group-struct ptr -- group-struct/f )
(group-struct) getgrgid_r io-error ; *void* [ drop f ] unless ;
M: string group-struct ( string -- group ) M: integer group-struct ( id -- group/f )
(group-struct) getgrnam_r 0 = [ (io-error) ] unless ; (group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
M: string group-struct ( string -- group/f )
(group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
: group-struct>group ( group-struct -- group ) : group-struct>group ( group-struct -- group )
[ \ group new ] dip [ \ group new ] dip
@ -45,12 +48,12 @@ PRIVATE>
dup group-cache get [ dup group-cache get [
dupd at* [ name>> nip ] [ drop number>string ] if dupd at* [ name>> nip ] [ drop number>string ] if
] [ ] [
group-struct group-gr_name group-struct [ group-gr_name ] [ f ] if*
] if* ] if*
[ nip ] [ number>string ] if* ; [ nip ] [ number>string ] if* ;
: group-id ( string -- id ) : group-id ( string -- id/f )
group-struct group-gr_gid ; group-struct [ group-gr_gid ] [ f ] if* ;
<PRIVATE <PRIVATE

2
basis/unix/statfs/freebsd/freebsd.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.freebsd IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */ CONSTANT: MFSNAMELEN 16 ! length of type name including null */

2
basis/unix/statfs/linux/linux.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.linux IN: unix.statfs.linux
C-STRUCT: statfs64 C-STRUCT: statfs64

3
basis/unix/statfs/macosx/macosx.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings.utf8 io.encodings.string USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax ; grouping system alien.strings math.bitwise alien.syntax
unix.types ;
IN: unix.statfs.macosx IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001 CONSTANT: MNT_RDONLY HEX: 00000001

2
basis/unix/statfs/openbsd/openbsd.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax unix.types unix.stat ;
IN: unix.statfs.openbsd IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16 CONSTANT: MFSNAMELEN 16

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

@ -19,6 +19,7 @@ HELP: VALUE:
{ $examples { $examples
{ $example { $example
"USING: values math prettyprint ;" "USING: values math prettyprint ;"
"IN: scratchpad"
"VALUE: x" "VALUE: x"
"2 2 + to: x" "2 2 + to: x"
"x ." "x ."

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.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings xmode.catalog sequences math assocs combinators strings
parser-combinators.regexp splitting parser-combinators ascii 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 ! Based on org.gjt.sp.jedit.syntax.TokenMarker

34
core/sequences/sequences-docs.factor
View File

@ -338,6 +338,10 @@ HELP: 2each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; { $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 3each
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
HELP: 2reduce HELP: 2reduce
{ $values { "seq1" sequence } { $values { "seq1" sequence }
{ "seq2" sequence } { "seq2" sequence }
@ -350,10 +354,18 @@ HELP: 2map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 3map
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 2map-as HELP: 2map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 3map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all? HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; { $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
@ -1262,6 +1274,17 @@ HELP: shorten
"V{ 1 2 3 }" "V{ 1 2 3 }"
} } ; } } ;
HELP: iota
{ $values { "n" integer } { "iota" iota } }
{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." }
{ $examples
{ $example
"USING: math sequences prettyprint ;"
"3 iota [ sq ] map ."
"{ 0 1 4 }"
}
} ;
ARTICLE: "sequences-unsafe" "Unsafe sequence operations" ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance." "The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl $nl
@ -1422,16 +1445,23 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection all? } { $subsection all? }
"Testing how elements are related:" "Testing how elements are related:"
{ $subsection monotonic? } { $subsection monotonic? }
{ $subsection "sequence-2combinators" } ; { $subsection "sequence-2combinators" }
{ $subsection "sequence-3combinators" } ;
ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators" ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." "There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined."
{ $subsection 2each } { $subsection 2each }
{ $subsection 2reduce } { $subsection 2reduce }
{ $subsection 2map } { $subsection 2map }
{ $subsection 2map-as } { $subsection 2map-as }
{ $subsection 2all? } ; { $subsection 2all? } ;
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined."
{ $subsection 3each }
{ $subsection 3map }
{ $subsection 3map-as } ;
ARTICLE: "sequences-tests" "Testing sequences" ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:" "Testing for an empty sequence:"
{ $subsection empty? } { $subsection empty? }

6
core/sequences/sequences-tests.factor
View File

@ -276,4 +276,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
{ 3 0 } [ [ 3drop ] 3each ] must-infer-as { 3 0 } [ [ 3drop ] 3each ] must-infer-as
[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test [ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test
[ "asdf" iota ] must-fail
[ T{ iota { n 10 } } ] [ 10 iota ] unit-test
[ 0 ] [ 10 iota first ] unit-test

14
core/sequences/sequences.factor
View File

@ -101,6 +101,20 @@ M: integer nth-unsafe drop ;
INSTANCE: integer immutable-sequence INSTANCE: integer immutable-sequence
PRIVATE>
! In the future, this will replace integer sequences
TUPLE: iota { n integer read-only } ;
: iota ( n -- iota ) \ iota boa ; inline
<PRIVATE
M: iota length n>> ;
M: iota nth-unsafe drop ;
INSTANCE: iota immutable-sequence
: first-unsafe ( seq -- first ) : first-unsafe ( seq -- first )
0 swap nth-unsafe ; inline 0 swap nth-unsafe ; inline

3
core/sorting/sorting-docs.factor
View File

@ -20,7 +20,8 @@ ABOUT: "sequences-sorting"
HELP: sort HELP: sort
{ $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } }
{ $description "Sorts the elements into a new array." } ; { $description "Sorts the elements into a new array using a stable sort." }
{ $notes "The algorithm used is the merge sort." } ;
HELP: sort-keys HELP: sort-keys
{ $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } }

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 USING: io io.files io.files.temp io.streams.duplex kernel
sequences sequences.private strings vectors words memoize sequences sequences.private strings vectors words memoize
splitting grouping hints tr continuations io.encodings.ascii splitting grouping hints tr continuations io.encodings.ascii
unicode.case ; ascii ;
IN: benchmark.reverse-complement IN: benchmark.reverse-complement
TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ; 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 io.pathnames io.encodings.ascii io.streams.string http.client
generalizations combinators math.parser math.vectors generalizations combinators math.parser math.vectors
math.intervals interval-maps memoize csv accessors assocs math.intervals interval-maps memoize csv accessors assocs
strings math splitting grouping arrays ; strings math splitting grouping arrays combinators.smart ;
IN: geo-ip IN: geo-ip
: db-path ( -- path ) "IpToCountry.csv" temp-file ; : db-path ( -- path ) "IpToCountry.csv" temp-file ;
@ -20,15 +20,17 @@ IN: geo-ip
TUPLE: ip-entry from to registry assigned city cntry country ; TUPLE: ip-entry from to registry assigned city cntry country ;
: parse-ip-entry ( row -- ip-entry ) : parse-ip-entry ( row -- ip-entry )
7 firstn { [
[ string>number ] {
[ string>number ] [ string>number ]
[ ] [ string>number ]
[ ] [ ]
[ ] [ ]
[ ] [ ]
[ ] [ ]
} spread ip-entry boa ; [ ]
} spread
] input<sequence ip-entry boa ;
MEMO: ip-db ( -- seq ) MEMO: ip-db ( -- seq )
download-db ascii file-lines 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 namespaces parser lexer parser-combinators
parser-combinators.simple promises quotations sequences strings parser-combinators.simple promises quotations sequences strings
math.order assocs prettyprint.backend prettyprint.custom memoize math.order assocs prettyprint.backend prettyprint.custom memoize
unicode.case unicode.categories combinators.short-circuit ascii unicode.categories combinators.short-circuit
accessors make io ; accessors make io ;
IN: parser-combinators.regexp 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. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences generalizations USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv summary math.parser combinators kernel memoize csv summary
words accessors math.order binary-search ; words accessors math.order binary-search combinators.smart ;
IN: usa-cities IN: usa-cities
SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN 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 ) MEMO: cities ( -- seq )
"resource:extra/usa-cities/zipcode.csv" ascii <file-reader> "resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
csv rest-slice [ csv rest-slice [
7 firstn { [
[ string>number ] {
[ ] [ string>number ]
[ string>state ] [ ]
[ string>number ] [ string>state ]
[ string>number ] [ string>number ]
[ string>number ] [ string>number ]
[ string>number ] [ string>number ]
} spread city boa [ string>number ]
} spread
] input<sequence city boa
] map ; ] map ;
MEMO: cities-named ( name -- cities ) MEMO: cities-named ( name -- cities )