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

db4
Slava Pestov 2009-01-08 22:44:57 -06:00
commit 730c636172
30 changed files with 346 additions and 146 deletions

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"

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

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 ;

View File

@ -0,0 +1 @@
Doug Coleman

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"

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

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

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

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

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

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 ] [

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

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

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

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 ;

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 ;

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

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

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 ;

View File

@ -192,22 +192,22 @@ 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= ( i str 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 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 ) :: walk-down ( str i -- j )
i str [ format/extended? not ] find-last-from drop 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 -- ? ) :: word-break? ( table-entry i str -- ? )
table-entry { table-entry {
@ -224,9 +224,11 @@ to: word-table
} case ; } case ;
:: 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 ;
PRIVATE> PRIVATE>

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

View File

@ -7,18 +7,18 @@ 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 ;
PRIVATE>
: ch>lower ( ch -- lower ) simple-lower at-default ; : ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ; : ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ; : ch>title ( ch -- title ) simple-title at-default ;
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 ;

View File

@ -23,7 +23,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 +128,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 +180,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

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: 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 IN: unicode.normalize
<PRIVATE <PRIVATE
@ -65,26 +66,29 @@ 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 [let | out [ string length <sbuf> ] |
! equivalent to clone on 8 and the contents of the last string [
! main quotation on 32. dup hangul? [ hangul>jamo out push-all ]
string [ 127 < ] all? [ string ] [ [ dup quot call [ out push-all ] [ out push ] ?if ] if
[ ] each out >string
string [ ] dup reorder ;
dup hangul? [ hangul>jamo % ]
[ dup quot call [ % ] [ , ] ?if ] if : with-string ( str quot -- str )
] each over aux>> [ call ] [ drop ] if ; inline
] "" make
dup reorder : (nfd) ( string -- nfd )
] if ; inline [ canonical-entry ] decompose ;
: (nfkd) ( string -- nfkd )
[ compatibility-entry ] decompose ;
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
@ -138,20 +142,26 @@ DEFER: compose-iter
: compose-iter ( last-class -- ) : compose-iter ( last-class -- )
current [ current [
dup combining-class dup combining-class {
[ try-compose to compose-iter ] { f [ 2drop ] }
[ swap [ drop ] [ try-noncombining ] if ] if* { 0 [ swap [ drop ] [ try-noncombining ] if ] }
[ try-compose to compose-iter ]
} case
] [ drop ] if* ; ] [ drop ] if* ;
: ?new-after ( -- ) : ?new-after ( -- )
after [ dup empty? [ drop SBUF" " clone ] unless ] change ; after [ dup empty? [ drop SBUF" " clone ] unless ] change ;
: compose-combining ( ch -- )
char set to ?new-after
f compose-iter
char get , after get % ;
: (compose) ( -- ) : (compose) ( -- )
current [ current [
dup jamo? [ drop compose-jamo ] [ dup jamo? [ drop compose-jamo ] [
char set to ?new-after 1 get-str combining-class
f compose-iter [ compose-combining ] [ , to ] if
char get , after get %
] if (compose) ] if (compose)
] when* ; ] when* ;
@ -166,7 +176,7 @@ DEFER: compose-iter
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 ;

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

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

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

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

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

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 )