Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
e20145dbad
|
|
@ -78,3 +78,5 @@ IN: bit-arrays.tests
|
|||
} bit-array>integer ] unit-test
|
||||
|
||||
[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
|
||||
|
||||
[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
0 swap underlying>> dup length [
|
||||
0 swap underlying>> dup length <reversed> [
|
||||
alien-unsigned-1 swap 8 shift bitor
|
||||
] with each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: strings.parser kernel namespaces unicode.data ;
|
||||
USING: strings.parser kernel namespaces unicode unicode.data ;
|
||||
IN: bootstrap.unicode
|
||||
|
||||
[ name>char [ "Invalid character" throw ] unless* ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel make math math.primes sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: count-factor ( n d -- n' c )
|
||||
[ 1 ] 2dip [ /i ] keep
|
||||
[ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] [ drop ] while
|
||||
swap ;
|
||||
|
||||
: write-factor ( n d -- n' d )
|
||||
2dup mod zero? [ [ [ count-factor ] keep swap 2array , ] keep ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: group-factors ( n -- seq )
|
||||
[ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ;
|
||||
|
||||
: unique-factors ( n -- seq ) group-factors [ first ] map ;
|
||||
|
||||
: factors ( n -- seq ) group-factors [ first2 swap <array> ] map concat ;
|
||||
|
||||
: totient ( n -- t )
|
||||
{
|
||||
{ [ dup 2 < ] [ drop 0 ] }
|
||||
[ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
|
||||
} cond ; foldable
|
||||
|
|
@ -11,15 +11,7 @@ HELP: prime?
|
|||
{ $values { "n" "an integer" } { "?" "a boolean" } }
|
||||
{ $description "Test if an integer is a prime number." } ;
|
||||
|
||||
{ lprimes lprimes-from primes-upto primes-between } related-words
|
||||
|
||||
HELP: lprimes
|
||||
{ $values { "list" "a lazy list" } }
|
||||
{ $description "Return a sorted list containing all the prime numbers." } ;
|
||||
|
||||
HELP: lprimes-from
|
||||
{ $values { "n" "an integer" } { "list" "a lazy list" } }
|
||||
{ $description "Return a sorted list containing all the prime numbers greater or equal to " { $snippet "n" } "." } ;
|
||||
{ primes-upto primes-between } related-words
|
||||
|
||||
HELP: primes-upto
|
||||
{ $values { "n" "an integer" } { "seq" "a sequence" } }
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
USING: arrays math.primes tools.test ;
|
||||
|
||||
{ 1237 } [ 1234 next-prime ] unit-test
|
||||
{ f t } [ 1234 prime? 1237 prime? ] unit-test
|
||||
{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
|
||||
{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test
|
||||
|
||||
{ { 4999963 4999999 5000011 5000077 5000081 } }
|
||||
[ 4999962 5000082 primes-between >array ] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Samuel Tardieu.
|
||||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel lists.lazy math math.functions
|
||||
math.miller-rabin math.order math.primes.erato math.ranges sequences ;
|
||||
USING: combinators kernel math math.functions math.miller-rabin
|
||||
math.order math.primes.erato math.ranges sequences ;
|
||||
IN: math.primes
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -23,11 +23,6 @@ PRIVATE>
|
|||
: next-prime ( n -- p )
|
||||
next-odd [ dup really-prime? ] [ 2 + ] [ ] until ; foldable
|
||||
|
||||
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
|
||||
|
||||
: lprimes-from ( n -- list )
|
||||
dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
|
||||
|
||||
: primes-between ( low high -- seq )
|
||||
[ dup 3 max dup even? [ 1 + ] when ] dip
|
||||
2 <range> [ prime? ] filter
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.breaks
|
||||
|
||||
ABOUT: "unicode.breaks"
|
||||
|
||||
ARTICLE: "unicode.breaks" "Word and grapheme breaks"
|
||||
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
|
||||
$nl "Operations for graphemes:"
|
||||
{ $subsection first-grapheme }
|
||||
{ $subsection last-grapheme }
|
||||
{ $subsection >graphemes }
|
||||
{ $subsection string-reverse }
|
||||
"Operations on words:"
|
||||
{ $subsection first-word }
|
||||
{ $subsection >words } ;
|
||||
|
||||
HELP: first-grapheme
|
||||
{ $values { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the length of the first grapheme of the string. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
|
||||
|
||||
HELP: last-grapheme
|
||||
{ $values { "str" string } { "i" "an index" } }
|
||||
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
|
||||
|
||||
HELP: >graphemes
|
||||
{ $values { "str" string } { "graphemes" "an array of strings" } }
|
||||
{ $description "Divides a string into a sequence of individual graphemes." } ;
|
||||
|
||||
HELP: string-reverse
|
||||
{ $values { "str" string } { "rts" string } }
|
||||
{ $description "Reverses a string, leaving graphemes in-tact." } ;
|
||||
|
||||
HELP: first-word
|
||||
{ $values { "str" string } { "i" "index" } }
|
||||
{ $description "Finds the length of the first word in the string." } ;
|
||||
|
||||
HELP: >words
|
||||
{ $values { "str" string } { "words" "an array of strings" } }
|
||||
{ $description "Divides the string up into words." } ;
|
||||
|
|
@ -36,4 +36,4 @@ IN: unicode.breaks.tests
|
|||
] each ;
|
||||
|
||||
grapheme-break-test parse-test-file [ >graphemes ] test
|
||||
! word-break-test parse-test-file [ >words ] test
|
||||
word-break-test parse-test-file [ >words ] test
|
||||
|
|
|
|||
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit unicode.categories kernel math
|
||||
combinators splitting sequences math.parser io.files io assocs
|
||||
arrays namespaces make math.ranges unicode.normalize values
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units
|
||||
arrays namespaces make math.ranges unicode.normalize.private values
|
||||
io.encodings.ascii unicode.syntax unicode.data compiler.units fry
|
||||
alien.syntax sets accessors interval-maps memoize locals words ;
|
||||
IN: unicode.breaks
|
||||
|
||||
<PRIVATE
|
||||
! Grapheme breaks
|
||||
|
||||
C-ENUM: Any L V T LV LVT Extend Control CR LF
|
||||
|
|
@ -101,19 +102,20 @@ VALUE: grapheme-table
|
|||
: find-index ( seq quot -- i ) find drop ; inline
|
||||
: find-last-index ( seq quot -- i ) find-last drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: first-grapheme ( str -- i )
|
||||
unclip-slice grapheme-class over
|
||||
[ grapheme-class tuck grapheme-break? ] find-index
|
||||
nip swap length or 1+ ;
|
||||
|
||||
:: (>pieces) ( str quot -- )
|
||||
str [
|
||||
dup quot call cut-slice
|
||||
swap , quot (>pieces)
|
||||
] unless-empty ;
|
||||
<PRIVATE
|
||||
|
||||
: >pieces ( str quot -- graphemes )
|
||||
[ (>pieces) ] { } make ;
|
||||
: >pieces ( str quot: ( str -- i ) -- graphemes )
|
||||
[ dup empty? not ] swap '[ dup @ cut-slice swap ]
|
||||
[ ] produce nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >graphemes ( str -- graphemes )
|
||||
[ first-grapheme ] >pieces ;
|
||||
|
|
@ -125,6 +127,8 @@ VALUE: grapheme-table
|
|||
unclip-last-slice grapheme-class swap
|
||||
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
graphemes init-table table
|
||||
[ make-grapheme-table finish-table ] with-variable
|
||||
to: grapheme-table
|
||||
|
|
@ -139,14 +143,14 @@ to: word-break-table
|
|||
C-ENUM: wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
|
||||
wMidNum wMidNumLet wNumeric wExtendNumLet words ;
|
||||
|
||||
MEMO: word-break-classes ( -- table )
|
||||
: word-break-classes ( -- table ) ! Is there a way to avoid this?
|
||||
H{
|
||||
{ "Other" wOther } { "CR" wCR } { "LF" wLF } { "Newline" wNewline }
|
||||
{ "Extend" wExtend } { "Format" wFormat } { "Katakana" wKatakana }
|
||||
{ "ALetter" wALetter } { "MidLetter" wMidLetter }
|
||||
{ "MidNum" wMidNum } { "MidNumLet" wMidNumLet } { "Numeric" wNumeric }
|
||||
{ "ExtendNumLet" wExtendNumLet }
|
||||
} [ execute ] assoc-map ;
|
||||
{ "Other" 0 } { "CR" 1 } { "LF" 2 } { "Newline" 3 }
|
||||
{ "Extend" 4 } { "Format" 5 } { "Katakana" 6 }
|
||||
{ "ALetter" 7 } { "MidLetter" 8 }
|
||||
{ "MidNum" 9 } { "MidNumLet" 10 } { "Numeric" 11 }
|
||||
{ "ExtendNumLet" 12 }
|
||||
} ;
|
||||
|
||||
: word-break-prop ( char -- word-break-prop )
|
||||
word-break-table interval-at
|
||||
|
|
@ -185,22 +189,51 @@ words init-table table
|
|||
[ make-word-table finish-word-table ] with-variable
|
||||
to: word-table
|
||||
|
||||
: word-break? ( class1 class2 -- ? )
|
||||
word-table nth nth not ;
|
||||
: word-table-nth ( class1 class2 -- ? )
|
||||
word-table nth nth ;
|
||||
|
||||
: skip? ( char -- ? )
|
||||
word-break-prop { 4 5 } member? ; ! wExtend or wFormat
|
||||
: property-not= ( i str property -- ? )
|
||||
pick [
|
||||
[ ?nth ] dip swap
|
||||
[ word-break-prop = not ] [ drop f ] if*
|
||||
] [ 3drop t ] if ;
|
||||
|
||||
: word-break-next ( old-class new-char -- next-class ? )
|
||||
word-break-prop dup { 4 5 } member?
|
||||
[ drop f ] [ tuck word-break? ] if ;
|
||||
: format/extended? ( ch -- ? )
|
||||
word-break-prop { 4 5 } member? ;
|
||||
|
||||
: first-word ( str -- i )
|
||||
unclip-slice word-break-prop over
|
||||
[ word-break-next ] find-index
|
||||
:: walk-up ( str i -- j )
|
||||
i 1 + str [ format/extended? not ] find-from drop
|
||||
1+ str [ format/extended? not ] find-from drop ; ! possible bounds error?
|
||||
|
||||
:: walk-down ( str i -- j )
|
||||
i str [ format/extended? not ] find-last-from drop
|
||||
1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error?
|
||||
|
||||
:: word-break? ( table-entry i str -- ? )
|
||||
table-entry {
|
||||
{ t [ f ] }
|
||||
{ f [ t ] }
|
||||
{ check-letter-after
|
||||
[ str i walk-up str wALetter property-not= ] }
|
||||
{ check-letter-before
|
||||
[ str i walk-down str wALetter property-not= ] }
|
||||
{ check-number-after
|
||||
[ str i walk-up str wNumeric property-not= ] }
|
||||
{ check-number-before
|
||||
[ str i walk-down str wNumeric property-not= ] }
|
||||
} case ;
|
||||
|
||||
:: word-break-next ( old-class new-char i str -- next-class ? )
|
||||
new-char word-break-prop dup { 4 5 } member?
|
||||
[ drop old-class dup { 1 2 3 } member? ]
|
||||
[ old-class over word-table-nth i str word-break? ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: first-word ( str -- i )
|
||||
str unclip-slice word-break-prop over <enum>
|
||||
[ swap str word-break-next ] assoc-find 2drop
|
||||
nip swap length or 1+ ;
|
||||
! This must be changed to ignore format/extended chars and
|
||||
! handle symbols in the table specially
|
||||
|
||||
: >words ( str -- words )
|
||||
[ first-word ] >pieces ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,70 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.case
|
||||
|
||||
ABOUT: "unicode.case"
|
||||
|
||||
ARTICLE: "unicode.case" "Case mapping"
|
||||
"When considering Unicode in general and not just ASCII or a smaller character set, putting a string in upper case, title case or lower case is slightly more complicated. In most contexts it's best to use the general Unicode routines for case conversion. There is an additional type of casing, case-fold, which is defined as bringing a string into upper case and then lower. This exists because in some cases it is different from simple lower case."
|
||||
{ $subsection >upper }
|
||||
{ $subsection >lower }
|
||||
{ $subsection >title }
|
||||
{ $subsection >case-fold }
|
||||
"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one."
|
||||
{ $subsection ch>upper }
|
||||
{ $subsection ch>lower }
|
||||
{ $subsection ch>title }
|
||||
"To test if a string is in a given case:"
|
||||
{ $subsection upper? }
|
||||
{ $subsection lower? }
|
||||
{ $subsection title? }
|
||||
{ $subsection case-fold? }
|
||||
"For certain languages (Turkish, Azeri, Lithuanian), case mapping is dependent on locale; To change this, set the following variable to the ISO-639-1 code for your language:"
|
||||
{ $subsection locale }
|
||||
"This is unnecessary for most locales." ;
|
||||
|
||||
HELP: >upper
|
||||
{ $values { "string" string } { "upper" string } }
|
||||
{ $description "Converts a string to upper case." } ;
|
||||
|
||||
HELP: >lower
|
||||
{ $values { "string" string } { "lower" string } }
|
||||
{ $description "Converts a string to lower case." } ;
|
||||
|
||||
HELP: >title
|
||||
{ $values { "string" string } { "title" string } }
|
||||
{ $description "Converts a string to title case." } ;
|
||||
|
||||
HELP: >case-fold
|
||||
{ $values { "string" string } { "fold" string } }
|
||||
{ $description "Converts a string to case-folded form." } ;
|
||||
|
||||
HELP: upper?
|
||||
{ $values { "string" string } { "?" "a boolean" } }
|
||||
{ $description "Tests if a string is in upper case." } ;
|
||||
|
||||
HELP: lower?
|
||||
{ $values { "string" string } { "?" "a boolean" } }
|
||||
{ $description "Tests if a string is in lower case." } ;
|
||||
|
||||
HELP: title?
|
||||
{ $values { "string" string } { "?" "a boolean" } }
|
||||
{ $description "Tests if a string is in title case." } ;
|
||||
|
||||
HELP: case-fold?
|
||||
{ $values { "string" string } { "?" "a boolean" } }
|
||||
{ $description "Tests if a string is in case-folded form." } ;
|
||||
|
||||
HELP: ch>lower
|
||||
{ $values { "ch" "a code point" } { "lower" "a code point" } }
|
||||
{ $description "Converts a code point to lower case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">lower" } " is not the same as " { $code "[ ch>lower ] map" } "." } ;
|
||||
|
||||
HELP: ch>upper
|
||||
{ $values { "ch" "a code point" } { "upper" "a code point" } }
|
||||
{ $description "Converts a code point to upper case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">upper" } " is not the same as " { $code "[ ch>upper ] map" } "." } ;
|
||||
|
||||
HELP: ch>title
|
||||
{ $values { "ch" "a code point" } { "title" "a code point" } }
|
||||
{ $description "Converts a code point to title case." }
|
||||
{ $warning "Don't use this unless you know what you're doing! " { $code ">title" } " is not the same as " { $code "[ ch>title ] map" } "." } ;
|
||||
|
|
@ -4,14 +4,14 @@ USING: unicode.case tools.test namespaces ;
|
|||
\ >lower must-infer
|
||||
\ >title must-infer
|
||||
|
||||
[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
|
||||
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
|
||||
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
|
||||
[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test
|
||||
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
|
||||
[ t ] [ "hello how are you?" lower? ] unit-test
|
||||
[
|
||||
"tr" locale set
|
||||
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
|
||||
! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
|
||||
[ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
|
||||
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
|
||||
"lt" locale set
|
||||
! Lithuanian casing tests
|
||||
|
|
|
|||
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: unicode.data sequences sequences.next namespaces make
|
||||
unicode.normalize math unicode.categories combinators
|
||||
assocs strings splitting kernel accessors ;
|
||||
unicode.normalize math unicode.categories combinators unicode.syntax
|
||||
assocs strings splitting kernel accessors unicode.breaks fry ;
|
||||
IN: unicode.case
|
||||
|
||||
<PRIVATE
|
||||
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
|
||||
PRIVATE>
|
||||
|
||||
: ch>lower ( ch -- lower ) simple-lower at-default ;
|
||||
: ch>upper ( ch -- upper ) simple-upper at-default ;
|
||||
|
|
@ -13,6 +15,14 @@ IN: unicode.case
|
|||
|
||||
SYMBOL: locale ! Just casing locale, or overall?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: split-subseq ( string sep -- strings )
|
||||
[ dup ] swap '[ _ split1 swap ] [ ] produce nip ;
|
||||
|
||||
: replace ( old new str -- newstr )
|
||||
[ split-subseq ] dip join ;
|
||||
|
||||
: i-dot? ( -- ? )
|
||||
locale get { "tr" "az" } member? ;
|
||||
|
||||
|
|
@ -20,57 +30,51 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
|
||||
: dot-over ( -- ch ) HEX: 307 ;
|
||||
|
||||
: lithuanian-ch>upper ( ? next ch -- ? )
|
||||
rot [ 2drop f ]
|
||||
[ swap dot-over = over "ij" member? and swap , ] if ;
|
||||
|
||||
: lithuanian>upper ( string -- lower )
|
||||
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
|
||||
"i\u000307" "i" replace
|
||||
"j\u000307" "j" replace ;
|
||||
|
||||
: mark-above? ( ch -- ? )
|
||||
combining-class 230 = ;
|
||||
|
||||
: lithuanian-ch>lower ( next ch -- )
|
||||
! This fails to add a dot above in certain edge cases
|
||||
! where there is a non-above combining mark before an above one
|
||||
! in Lithuanian
|
||||
dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
|
||||
: with-rest ( seq quot: ( seq -- seq ) -- seq )
|
||||
[ unclip ] dip swap slip prefix ; inline
|
||||
|
||||
: add-dots ( seq -- seq )
|
||||
[ [ "" ] [
|
||||
dup first mark-above?
|
||||
[ CHAR: combining-dot-above prefix ] when
|
||||
] if-empty ] with-rest ;
|
||||
|
||||
: lithuanian>lower ( string -- lower )
|
||||
[ [ lithuanian-ch>lower ] each-next ] "" make ;
|
||||
|
||||
: turk-ch>upper ( ch -- )
|
||||
dup CHAR: i =
|
||||
[ drop CHAR: I , dot-over , ] [ , ] if ;
|
||||
"i" split add-dots "i" join
|
||||
"j" split add-dots "i" join ;
|
||||
|
||||
: turk>upper ( string -- upper-i )
|
||||
[ [ turk-ch>upper ] each ] "" make ;
|
||||
|
||||
: turk-ch>lower ( ? next ch -- ? )
|
||||
{
|
||||
{ [ rot ] [ 2drop f ] }
|
||||
{ [ dup CHAR: I = ] [
|
||||
drop dot-over =
|
||||
dup CHAR: i HEX: 131 ? ,
|
||||
] }
|
||||
[ , drop f ]
|
||||
} cond ;
|
||||
"i" "I\u000307" replace ;
|
||||
|
||||
: turk>lower ( string -- lower-i )
|
||||
[ f swap [ turk-ch>lower ] each-next drop ] "" make ;
|
||||
"I\u000307" "i" replace
|
||||
"I" "\u000131" replace ;
|
||||
|
||||
: word-boundary ( prev char -- new ? )
|
||||
dup non-starter? [ drop dup ] when
|
||||
swap uncased? ;
|
||||
: fix-sigma-end ( string -- string )
|
||||
[ "" ] [
|
||||
dup peek CHAR: greek-small-letter-sigma =
|
||||
[ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
|
||||
] if-empty ;
|
||||
|
||||
: sigma-map ( string -- string )
|
||||
[
|
||||
swap [ uncased? ] keep not or
|
||||
[ drop HEX: 3C2 ] when
|
||||
] map-next ;
|
||||
{ CHAR: greek-capital-letter-sigma } split [ [
|
||||
[ { CHAR: greek-small-letter-sigma } ] [
|
||||
dup first uncased?
|
||||
CHAR: greek-small-letter-final-sigma
|
||||
CHAR: greek-small-letter-sigma ? prefix
|
||||
] if-empty
|
||||
] map ] with-rest concat fix-sigma-end ;
|
||||
|
||||
: final-sigma ( string -- string )
|
||||
HEX: 3A3 over member? [ sigma-map ] when ;
|
||||
CHAR: greek-capital-letter-sigma
|
||||
over member? [ sigma-map ] when ;
|
||||
|
||||
: map-case ( string string-quot char-quot -- case )
|
||||
[
|
||||
|
|
@ -80,22 +84,29 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
] 2curry each
|
||||
] "" make ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >lower ( string -- lower )
|
||||
i-dot? [ turk>lower ] when
|
||||
final-sigma [ lower>> ] [ ch>lower ] map-case ;
|
||||
i-dot? [ turk>lower ] when final-sigma
|
||||
[ lower>> ] [ ch>lower ] map-case ;
|
||||
|
||||
: >upper ( string -- upper )
|
||||
i-dot? [ turk>upper ] when
|
||||
[ upper>> ] [ ch>upper ] map-case ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (>title) ( string -- title )
|
||||
i-dot? [ turk>upper ] when
|
||||
[ title>> ] [ ch>title ] map-case ;
|
||||
|
||||
: title-word ( string -- title )
|
||||
unclip 1string [ >lower ] [ (>title) ] bi* prepend ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >title ( string -- title )
|
||||
final-sigma
|
||||
CHAR: \s swap
|
||||
[ tuck word-boundary swapd
|
||||
[ title>> ] [ lower>> ] if ]
|
||||
[ tuck word-boundary swapd
|
||||
[ ch>title ] [ ch>lower ] if ]
|
||||
map-case nip ;
|
||||
final-sigma >words [ title-word ] map concat ;
|
||||
|
||||
: >case-fold ( string -- fold )
|
||||
>upper >lower ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
! Copyright (C) 2009 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel ;
|
||||
IN: unicode.categories
|
||||
|
||||
HELP: LETTER
|
||||
{ $class-description "The class of upper cased letters" } ;
|
||||
|
||||
HELP: Letter
|
||||
{ $class-description "The class of letters" } ;
|
||||
|
||||
HELP: alpha
|
||||
{ $class-description "The class of code points which are alphanumeric" } ;
|
||||
|
||||
HELP: blank
|
||||
{ $class-description "The class of code points which are whitespace" } ;
|
||||
|
||||
HELP: character
|
||||
{ $class-description "The class of numbers which are pre-defined Unicode code points" } ;
|
||||
|
||||
HELP: control
|
||||
{ $class-description "The class of control characters" } ;
|
||||
|
||||
HELP: digit
|
||||
{ $class-description "The class of code coints which are digits" } ;
|
||||
|
||||
HELP: letter
|
||||
{ $class-description "The class of code points which are lower-cased letters" } ;
|
||||
|
||||
HELP: printable
|
||||
{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ;
|
||||
|
||||
HELP: uncased
|
||||
{ $class-description "The class of letters which don't have a case" } ;
|
||||
|
||||
ARTICLE: "unicode.categories" "Character classes"
|
||||
{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful."
|
||||
{ $subsection blank }
|
||||
{ $subsection letter }
|
||||
{ $subsection LETTER }
|
||||
{ $subsection Letter }
|
||||
{ $subsection digit }
|
||||
{ $subsection printable }
|
||||
{ $subsection alpha }
|
||||
{ $subsection control }
|
||||
{ $subsection uncased }
|
||||
{ $subsection character } ;
|
||||
|
||||
ABOUT: "unicode.categories"
|
||||
|
|
@ -1,10 +1,8 @@
|
|||
USING: help.syntax help.markup strings byte-arrays ;
|
||||
IN: unicode.collation
|
||||
|
||||
ABOUT: "unicode.collation"
|
||||
|
||||
ARTICLE: "unicode.collation" "Unicode collation algorithm (UCA)"
|
||||
"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
ARTICLE: "unicode.collation" "Collation and weak comparison"
|
||||
"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
{ $subsection sort-strings }
|
||||
{ $subsection collation-key }
|
||||
{ $subsection string<=> }
|
||||
|
|
@ -13,6 +11,8 @@ ARTICLE: "unicode.collation" "Unicode collation algorithm (UCA)"
|
|||
{ $subsection tertiary= }
|
||||
{ $subsection quaternary= } ;
|
||||
|
||||
ABOUT: "unicode.collation"
|
||||
|
||||
HELP: sort-strings
|
||||
{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
|
||||
{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: io io.files splitting grouping unicode.collation
|
||||
sequences kernel io.encodings.utf8 math.parser math.order
|
||||
tools.test assocs io.streams.null words ;
|
||||
tools.test assocs words ;
|
||||
IN: unicode.collation.tests
|
||||
|
||||
: parse-test ( -- strings )
|
||||
|
|
@ -25,4 +25,4 @@ IN: unicode.collation.tests
|
|||
unit-test
|
||||
|
||||
parse-test 2 <clumps>
|
||||
[ [ test-two ] assoc-each ] with-null-writer
|
||||
[ test-two ] assoc-each
|
||||
|
|
|
|||
|
|
@ -0,0 +1,51 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.data
|
||||
|
||||
ABOUT: "unicode.data"
|
||||
|
||||
ARTICLE: "unicode.data" "Unicode data tables"
|
||||
"The " { $vocab-link "unicode.data" "unicode.data" } " vocabulary contains core Unicode data tables and code for parsing this from files."
|
||||
{ $subsection load-script }
|
||||
{ $subsection canonical-entry }
|
||||
{ $subsection combine-chars }
|
||||
{ $subsection combining-class }
|
||||
{ $subsection non-starter? }
|
||||
{ $subsection name>char }
|
||||
{ $subsection char>name }
|
||||
{ $subsection property? } ;
|
||||
|
||||
HELP: load-script
|
||||
{ $values { "filename" string } { "table" "an interval map" } }
|
||||
{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
|
||||
|
||||
HELP: canonical-entry
|
||||
{ $values { "char" "a code point" } { "seq" string } }
|
||||
{ $description "Finds the canonical decomposition (NFD) for a code point" } ;
|
||||
|
||||
HELP: combine-chars
|
||||
{ $values { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
|
||||
{ $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ;
|
||||
|
||||
HELP: compatibility-entry
|
||||
{ $values { "char" "a code point" } { "seq" string } }
|
||||
{ $description "This returns the compatibility decomposition (NFKD) for a code point" } ;
|
||||
|
||||
HELP: combining-class
|
||||
{ $values { "char" "a code point" } { "n" "an integer" } }
|
||||
{ $description "Finds the combining class of a code point." } ;
|
||||
|
||||
HELP: non-starter?
|
||||
{ $values { "char" "a code point" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the code point has a combining class." } ;
|
||||
|
||||
HELP: char>name
|
||||
{ $values { "char" "a code point" } { "name" string } }
|
||||
{ $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ;
|
||||
|
||||
HELP: name>char
|
||||
{ $values { "name" string } { "char" "a code point" } }
|
||||
{ $description "Looks up the code point corresponding to a given name." } ;
|
||||
|
||||
HELP: property?
|
||||
{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } }
|
||||
{ $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ;
|
||||
|
|
@ -24,14 +24,10 @@ VALUE: properties
|
|||
: compatibility-entry ( char -- seq ) compatibility-map at ;
|
||||
: combining-class ( char -- n ) class-map at ;
|
||||
: non-starter? ( char -- ? ) class-map key? ;
|
||||
: name>char ( string -- char ) name-map at ;
|
||||
: char>name ( char -- string ) name-map value-at ;
|
||||
: name>char ( name -- char ) name-map at ;
|
||||
: char>name ( char -- name ) name-map value-at ;
|
||||
: property? ( char property -- ? ) properties at interval-key? ;
|
||||
|
||||
! Convenience functions
|
||||
: ?between? ( n/f from to -- ? )
|
||||
pick [ between? ] [ 3drop f ] if ;
|
||||
|
||||
! Loading data from UnicodeData.txt
|
||||
|
||||
: split-; ( line -- array )
|
||||
|
|
@ -206,9 +202,9 @@ SYMBOL: interned
|
|||
: expand-ranges ( assoc -- interval-map )
|
||||
[
|
||||
[
|
||||
CHAR: . pick member? [
|
||||
swap ".." split1 [ hex> ] bi@ 2array
|
||||
] [ swap hex> ] if range,
|
||||
swap CHAR: . over member? [
|
||||
".." split1 [ hex> ] bi@ 2array
|
||||
] [ hex> ] if range,
|
||||
] assoc-each
|
||||
] { } make <interval-map> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
USING: help.syntax help.markup strings ;
|
||||
IN: unicode.normalize
|
||||
|
||||
ABOUT: "unicode.normalize"
|
||||
|
||||
ARTICLE: "unicode.normalize" "Unicode normalization"
|
||||
"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings. In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: \"e\\u000301\" (the e character, followed by the combining acute accent character) and \"\\u0000e9\" (a single character, e with an acute accent). There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care. Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard."
|
||||
{ $subsection nfc }
|
||||
{ $subsection nfd }
|
||||
{ $subsection nfkc }
|
||||
{ $subsection nfkd } ;
|
||||
|
||||
HELP: nfc
|
||||
{ $values { "string" string } { "nfc" "a string in NFC" } }
|
||||
{ $description "Converts a string to Normalization Form C" } ;
|
||||
|
||||
HELP: nfd
|
||||
{ $values { "string" string } { "nfd" "a string in NFD" } }
|
||||
{ $description "Converts a string to Normalization Form D" } ;
|
||||
|
||||
HELP: nfkc
|
||||
{ $values { "string" string } { "nfkc" "a string in NFKC" } }
|
||||
{ $description "Converts a string to Normalization Form KC" } ;
|
||||
|
||||
HELP: nfkd
|
||||
{ $values { "string" string } { "nfkd" "a string in NFKD" } }
|
||||
{ $description "Converts a string to Normalization Form KD" } ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: unicode.normalize kernel tools.test sequences
|
||||
unicode.data io.encodings.utf8 io.files splitting math.parser
|
||||
locals math quotations assocs combinators ;
|
||||
locals math quotations assocs combinators unicode.normalize.private ;
|
||||
IN: unicode.normalize.tests
|
||||
|
||||
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,20 +1,24 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences namespaces make unicode.data kernel math arrays
|
||||
locals sorting.insertion accessors assocs ;
|
||||
locals sorting.insertion accessors assocs math.order ;
|
||||
IN: unicode.normalize
|
||||
|
||||
<PRIVATE
|
||||
! Conjoining Jamo behavior
|
||||
|
||||
: hangul-base HEX: ac00 ; inline
|
||||
: hangul-end HEX: D7AF ; inline
|
||||
: initial-base HEX: 1100 ; inline
|
||||
: medial-base HEX: 1161 ; inline
|
||||
: final-base HEX: 11a7 ; inline
|
||||
CONSTANT: hangul-base HEX: ac00
|
||||
CONSTANT: hangul-end HEX: D7AF
|
||||
CONSTANT: initial-base HEX: 1100
|
||||
CONSTANT: medial-base HEX: 1161
|
||||
CONSTANT: final-base HEX: 11a7
|
||||
|
||||
: initial-count 19 ; inline
|
||||
: medial-count 21 ; inline
|
||||
: final-count 28 ; inline
|
||||
CONSTANT: initial-count 19
|
||||
CONSTANT: medial-count 21
|
||||
CONSTANT: final-count 28
|
||||
|
||||
: ?between? ( n/f from to -- ? )
|
||||
pick [ between? ] [ 3drop f ] if ;
|
||||
|
||||
: hangul? ( ch -- ? ) hangul-base hangul-end ?between? ;
|
||||
: jamo? ( ch -- ? ) HEX: 1100 HEX: 11FF ?between? ;
|
||||
|
|
@ -74,19 +78,21 @@ IN: unicode.normalize
|
|||
dup reorder
|
||||
] if ; inline
|
||||
|
||||
: nfd ( string -- string )
|
||||
PRIVATE>
|
||||
|
||||
: nfd ( string -- nfd )
|
||||
[ canonical-entry ] decompose ;
|
||||
|
||||
: nfkd ( string -- string )
|
||||
: nfkd ( string -- nfkd )
|
||||
[ compatibility-entry ] decompose ;
|
||||
|
||||
: string-append ( s1 s2 -- string )
|
||||
! This could be more optimized,
|
||||
! but in practice, it'll almost always just be append
|
||||
[ append ] keep
|
||||
0 over ?nth non-starter?
|
||||
[ length dupd reorder-back ] [ drop ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Normalization -- Composition
|
||||
SYMBOL: main-str
|
||||
SYMBOL: ind
|
||||
|
|
@ -149,7 +155,7 @@ DEFER: compose-iter
|
|||
] if (compose)
|
||||
] when* ;
|
||||
|
||||
: compose ( str -- comp )
|
||||
: combine ( str -- comp )
|
||||
[
|
||||
main-str set
|
||||
0 ind set
|
||||
|
|
@ -157,8 +163,10 @@ DEFER: compose-iter
|
|||
pass-combining (compose)
|
||||
] "" make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: nfc ( string -- nfc )
|
||||
nfd compose ;
|
||||
nfd combine ;
|
||||
|
||||
: nfkc ( string -- nfkc )
|
||||
nfkd compose ;
|
||||
nfkd combine ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: unicode
|
||||
|
||||
ARTICLE: "unicode" "Unicode"
|
||||
"Unicode is a set of characters, or " { $emphasis "code points" } " covering what's used in most world writing systems. Any Factor string can hold any of these code points transparently; a factor string is a sequence of Unicode code points. Unicode is accompanied by several standard algorithms for common operations like encoding in files, capitalizing a string, finding the boundaries between words, etc. When a programmer is faced with a string manipulation problem, where the string represents human language, a Unicode algorithm is often much better than the naive one. This is not in terms of efficiency, but rather internationalization. Even English text that remains in ASCII is better served by the Unicode collation algorithm than a naive algorithm. The Unicode algorithms implemented here are:"
|
||||
{ $vocab-subsection "Case mapping" "unicode.case" }
|
||||
{ $vocab-subsection "Collation and weak comparison" "unicode.collation" }
|
||||
{ $vocab-subsection "Character classes" "unicode.categories" }
|
||||
{ $vocab-subsection "Word and grapheme breaks" "unicode.breaks" }
|
||||
{ $vocab-subsection "Unicode normalization" "unicode.normalize" }
|
||||
"The following are mostly for internal use:"
|
||||
{ $vocab-subsection "Unicode syntax" "unicode.syntax" }
|
||||
{ $vocab-subsection "Unicode data tables" "unicode.data" }
|
||||
{ $see-also "io.encodings" } ;
|
||||
|
||||
ABOUT: "unicode"
|
||||
|
|
@ -0,0 +1 @@
|
|||
IN: unicode
|
||||
|
|
@ -691,11 +691,10 @@ HELP: assert=
|
|||
{ $values { "a" object } { "b" object } }
|
||||
{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
|
||||
|
||||
|
||||
ARTICLE: "shuffle-words" "Shuffle words"
|
||||
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
|
||||
$nl
|
||||
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
|
||||
"The " { $link "cleave-combinators" } ", " { $link "spread-combinators" } " and " { $link "apply-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
|
||||
$nl
|
||||
"Removing stack elements:"
|
||||
{ $subsection drop }
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
|
||||
USING: accessors arrays assocs colors combinators.short-circuit
|
||||
kernel locals math math.functions math.matrices math.order
|
||||
math.parser math.trig math.vectors opengl opengl.demo-support
|
||||
opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ;
|
||||
USING: accessors arrays assocs calendar colors
|
||||
combinators.short-circuit help.markup help.syntax kernel locals
|
||||
math math.functions math.matrices math.order math.parser
|
||||
math.trig math.vectors opengl opengl.demo-support opengl.gl
|
||||
sbufs sequences strings threads ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ui.tools.workspace ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -255,11 +256,31 @@ DEFER: default-L-parser-values
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <L-system> < gadget
|
||||
camera display-list
|
||||
camera display-list pedestal paused
|
||||
turtle-values
|
||||
commands axiom rules string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-system ( GADGET -- ) GADGET pedestal>> 0.5 + GADGET (>>pedestal) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: start-rotation-thread ( GADGET -- )
|
||||
GADGET f >>paused drop
|
||||
[
|
||||
[
|
||||
GADGET paused>>
|
||||
[ f ]
|
||||
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
|
||||
if
|
||||
]
|
||||
loop
|
||||
]
|
||||
in-thread ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: open-paren ( -- ch ) CHAR: ( ;
|
||||
: close-paren ( -- ch ) CHAR: ) ;
|
||||
|
||||
|
|
@ -332,7 +353,7 @@ TUPLE: <L-system> < gadget
|
|||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-L-system-string ( L-SYSTEM -- )
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM string>> L-SYSTEM axiom>> or
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
|
|
@ -357,7 +378,8 @@ TUPLE: <L-system> < gadget
|
|||
L-SYSTEM display-list>> GL_COMPILE glNewList
|
||||
|
||||
turtle
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM turtle-values>> [ ] or call
|
||||
L-SYSTEM string>> L-SYSTEM axiom>> or
|
||||
L-SYSTEM commands>>
|
||||
interpret-string
|
||||
drop
|
||||
|
|
@ -387,6 +409,10 @@ M:: <L-system> draw-gadget* ( L-SYSTEM -- )
|
|||
! draw axis
|
||||
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
! rotate pedestal
|
||||
|
||||
L-SYSTEM pedestal>> 0 0 1 glRotated
|
||||
|
||||
L-SYSTEM display-list>> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
@ -403,16 +429,12 @@ M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: camera-left ( L-SYSTEM -- )
|
||||
L-SYSTEM camera>> 5 turn-left drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: with-camera ( L-SYSTEM QUOT -- )
|
||||
L-SYSTEM camera>> QUOT call drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
<L-system>
|
||||
H{
|
||||
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
|
||||
|
|
@ -423,6 +445,16 @@ H{
|
|||
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
|
||||
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] }
|
||||
{ T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] }
|
||||
|
||||
{ T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] }
|
||||
{ T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] }
|
||||
{ T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] }
|
||||
{ T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "r" } [ start-rotation-thread ] }
|
||||
|
||||
{
|
||||
T{ key-down f f "x" }
|
||||
[
|
||||
|
|
@ -432,6 +464,8 @@ H{
|
|||
drop
|
||||
]
|
||||
}
|
||||
|
||||
{ T{ key-down f f "F1" } [ drop "L-system" help-window ] }
|
||||
|
||||
}
|
||||
set-gestures
|
||||
|
|
@ -441,8 +475,36 @@ set-gestures
|
|||
: L-system ( -- L-system )
|
||||
|
||||
<L-system> new-gadget
|
||||
|
||||
0 >>pedestal
|
||||
|
||||
turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
! turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
|
||||
turtle 90 pitch-down -5 step-turtle 2 strafe-up >>camera
|
||||
|
||||
dup start-rotation-thread
|
||||
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "L-system" "L-system"
|
||||
|
||||
"Press 'x' to iterate the L-system." $nl
|
||||
|
||||
"Camera control:"
|
||||
|
||||
{ $table
|
||||
|
||||
{ "a" "Forward" }
|
||||
{ "z" "Backward" }
|
||||
|
||||
{ "LEFT" "Turn left" }
|
||||
{ "RIGHT" "Turn right" }
|
||||
{ "UP" "Pitch down" }
|
||||
{ "DOWN" "Pitch up" }
|
||||
|
||||
{ "q" "Roll left" }
|
||||
{ "w" "Roll right" } } ;
|
||||
|
||||
ABOUT: "L-system"
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: accessors kernel ui L-system ;
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-1
|
||||
|
||||
|
|
@ -12,15 +12,13 @@ IN: L-system.models.abop-1
|
|||
"c(12)FFAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
{ "A" "F [ & '(.8) ! B L ] >(137) ' !(.9) A" }
|
||||
{ "B" "F [ - '(.8) !(.9) $ C L ] ' !(.9) C" }
|
||||
{ "C" "F [ + '(.8) !(.9) $ B L ] ' !(.9) B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
{ "L" " ~ c(8) { +(30) f -(120) f -(120) f }" }
|
||||
}
|
||||
>>rules
|
||||
|
||||
dup axiom>> >>string ;
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-2
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-2 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 30 >>angle ] >>turtle-values
|
||||
|
||||
"c(12)FAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
|
||||
|
||||
{ "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" }
|
||||
{ "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" }
|
||||
|
||||
{ "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" }
|
||||
|
||||
} >>rules ;
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-3
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-3 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 30 >>angle ] >>turtle-values
|
||||
|
||||
"c(12)FA" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "!(.9)t(.4)FB>(94)B>(132)B" }
|
||||
{ "B" "[&t(.4)F$A]" }
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-3 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-4
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-4 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 18 >>angle ] >>turtle-values
|
||||
|
||||
"c(12)&(20)N" >>axiom
|
||||
|
||||
{
|
||||
{
|
||||
"N"
|
||||
"FII[&(60)rY]>(90)[&(45)'(0.8)rA]>(90)[&(60)rY]>(90)[&(45)'(0.8)rD]!FIK"
|
||||
}
|
||||
{ "Y" "[c(4){++l.--l.--l.++|++l.--l.--l.}]" }
|
||||
{ "l" "g(.2)l" }
|
||||
{ "K" "[!c(2)FF>w>(72)w>(72)w>(72)w>(72)w]" }
|
||||
{ "w" "[c(2)^!F][c(5)&(72){-(54)f(3)+(54)f(3)|-(54)f(3)+(54)f(3)}]" }
|
||||
{ "f" "_" }
|
||||
|
||||
{ "A" "B" }
|
||||
{ "B" "C" }
|
||||
{ "C" "D" }
|
||||
{ "D" "E" }
|
||||
{ "E" "G" }
|
||||
{ "G" "H" }
|
||||
{ "H" "N" }
|
||||
|
||||
{ "I" "FoO" }
|
||||
{ "O" "FoP" }
|
||||
{ "P" "FoQ" }
|
||||
{ "Q" "FoR" }
|
||||
{ "R" "FoS" }
|
||||
{ "S" "FoT" }
|
||||
{ "T" "FoU" }
|
||||
{ "U" "FoV" }
|
||||
{ "V" "FoW" }
|
||||
{ "W" "FoX" }
|
||||
{ "X" "_" }
|
||||
|
||||
{ "o" "$t(-0.03)" }
|
||||
{ "r" "~(30)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-4 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-5-angular
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-5-angular ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
"&(90)+(90)a" >>axiom
|
||||
|
||||
{
|
||||
{ "a" "F[+(45)l][-(45)l]^;ca" }
|
||||
|
||||
{ "l" "j" }
|
||||
{ "j" "h" }
|
||||
{ "h" "s" }
|
||||
{ "s" "d" }
|
||||
{ "d" "x" }
|
||||
{ "x" "a" }
|
||||
|
||||
{ "F" "'(1.17)F'(.855)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-5
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-5 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 5 >>angle ] >>turtle-values
|
||||
|
||||
"a" >>axiom
|
||||
|
||||
{
|
||||
{ "a" "F[+(45)l][-(45)l]^;ca" }
|
||||
|
||||
{ "l" "j" }
|
||||
{ "j" "h" }
|
||||
{ "h" "s" }
|
||||
{ "s" "d" }
|
||||
{ "d" "x" }
|
||||
{ "x" "a" }
|
||||
|
||||
{ "F" "'(1.17)F'(.855)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-5 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-6
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-6 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 5 >>angle ] >>turtle-values
|
||||
|
||||
! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
|
||||
"FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x"
|
||||
>>axiom
|
||||
|
||||
{
|
||||
{ "a" "F[cdx][cex]F!(.9)a" }
|
||||
{ "x" "a" }
|
||||
|
||||
{ "d" "+d" }
|
||||
{ "e" "-e" }
|
||||
|
||||
{ "F" "'(1.25)F'(.8)" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
|
||||
USING: accessors ui L-system ;
|
||||
|
||||
IN: L-system.models.airhorse
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: airhorse ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
[ 10 >>angle ] >>turtle-values
|
||||
|
||||
"C" >>axiom
|
||||
|
||||
{
|
||||
{ "C" "LBW" }
|
||||
|
||||
{ "B" "[[''aH]|[g]]" }
|
||||
{ "a" "Fs+;'a" }
|
||||
{ "g" "Ft+;'g" }
|
||||
{ "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" }
|
||||
{ "t" "[c!!!!&[FF]^^FF]" }
|
||||
|
||||
{ "L" "O" }
|
||||
{ "O" "P" }
|
||||
{ "P" "Q" }
|
||||
{ "Q" "R" }
|
||||
{ "R" "U" }
|
||||
{ "U" "X" }
|
||||
{ "X" "Y" }
|
||||
{ "Y" "V" }
|
||||
{ "V" "[cc!!!&(90)[Zp]|[Zp]]" }
|
||||
{ "p" "h>(120)h>(120)h" }
|
||||
{ "h" "[+(40)!F'''p]" }
|
||||
|
||||
{ "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" }
|
||||
{ "d" "Z!&Z!&:'d" }
|
||||
{ "e" "Z!^Z!^:'e" }
|
||||
{ "i" "-:/i" }
|
||||
|
||||
{ "W" "[%[!!cb][<<<!!cb][>>>!!cb]]" }
|
||||
{ "b" "Fl!+Fl+;'b" }
|
||||
{ "l" "[-cc{--z++z++z--|--z++z++z}]" }
|
||||
}
|
||||
>>rules ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
||||
|
|
@ -201,6 +201,9 @@ SYMBOL: :uses
|
|||
: fuel-apropos-xref ( str -- )
|
||||
words-matching fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-vocab-xref ( vocab -- )
|
||||
words fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
: fuel-filter-prefix ( seq prefix -- seq )
|
||||
|
|
@ -269,7 +272,7 @@ MEMO: fuel-article-title ( name -- title/f )
|
|||
help-path [ dup article-title swap 2array ] map ; inline
|
||||
|
||||
: (fuel-word-help) ( word -- element )
|
||||
dup \ article swap article-title rot
|
||||
\ article swap dup article-title swap
|
||||
[
|
||||
{
|
||||
[ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ]
|
||||
|
|
|
|||
|
|
@ -1,40 +0,0 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lists make math math.primes sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: count-factor ( n d -- n' c )
|
||||
0 [ [ 2dup mod zero? ] dip swap ] [ [ [ / ] keep ] dip 1+ ] [ ] while nip ;
|
||||
|
||||
: (factor) ( n d -- n' ) dup [ , ] curry [ count-factor ] dip times ;
|
||||
|
||||
: (count) ( n d -- n' )
|
||||
dup [ swap 2array , ] curry
|
||||
[ count-factor dup zero? [ drop ] ] dip if ;
|
||||
|
||||
: (unique) ( n d -- n' )
|
||||
dup [ , ] curry [ count-factor zero? ] dip unless ;
|
||||
|
||||
: (factors) ( quot list n -- )
|
||||
dup 1 > [
|
||||
swap uncons swap [ pick call ] dip swap (factors)
|
||||
] [ 3drop ] if ; inline recursive
|
||||
|
||||
: decompose ( n quot -- seq ) [ lprimes rot (factors) ] { } make ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: factors ( n -- seq ) [ (factor) ] decompose ; flushable
|
||||
|
||||
: group-factors ( n -- seq ) [ (count) ] decompose ; flushable
|
||||
|
||||
: unique-factors ( n -- seq ) [ (unique) ] decompose ; flushable
|
||||
|
||||
: totient ( n -- t )
|
||||
dup 2 < [
|
||||
drop 0
|
||||
] [
|
||||
dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
|
||||
] if ; foldable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Samuel Tardieu
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: math.primes.lists
|
||||
|
||||
HELP: lprimes
|
||||
{ $values { "list" "a lazy list" } }
|
||||
{ $description "Return a sorted list containing all the prime numbers." } ;
|
||||
|
||||
HELP: lprimes-from
|
||||
{ $values { "n" "an integer" } { "list" "a lazy list" } }
|
||||
{ $description "Return a sorted list containing all the prime numbers greater or equal to " { $snippet "n" } "." } ;
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: lists.lazy math.primes.lists tools.test ;
|
||||
|
||||
{ { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test
|
||||
{ { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test
|
||||
{ { 1000117 1000121 } } [ 2 1000100 lprimes-from ltake list>array ] unit-test
|
||||
{ { 999983 1000003 } } [ 2 999982 lprimes-from ltake list>array ] unit-test
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel lists.lazy math math.primes ;
|
||||
IN: math.primes.lists
|
||||
|
||||
: lprimes ( -- list ) 2 [ next-prime ] lfrom-by ;
|
||||
|
||||
: lprimes-from ( n -- list )
|
||||
dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Infinite stream of prime numbers through lazy lists
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
USING: arrays math.primes tools.test lists.lazy ;
|
||||
|
||||
{ 1237 } [ 1234 next-prime ] unit-test
|
||||
{ f t } [ 1234 prime? 1237 prime? ] unit-test
|
||||
{ { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test
|
||||
{ { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test
|
||||
{ { 1000117 1000121 } } [ 2 1000100 lprimes-from ltake list>array ] unit-test
|
||||
{ { 999983 1000003 } } [ 2 999982 lprimes-from ltake list>array ] unit-test
|
||||
{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
|
||||
{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test
|
||||
|
||||
{ { 4999963 4999999 5000011 5000077 5000081 } }
|
||||
[ 4999962 5000082 primes-between >array ]
|
||||
unit-test
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lists math math.primes ;
|
||||
USING: lists math math.primes.lists ;
|
||||
IN: project-euler.007
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=7
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2007 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel lists lists.lazy math.algebra math math.functions
|
||||
math.order math.primes math.ranges project-euler.common sequences ;
|
||||
math.order math.primes.lists math.ranges project-euler.common sequences ;
|
||||
IN: project-euler.134
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=134
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: update.latest
|
|||
: git-pull-master ( -- )
|
||||
image parent-directory
|
||||
[
|
||||
{ "git" "pull" "http://factorcode.org/git/factor.git" "master" }
|
||||
{ "git" "pull" "git://factorcode.org/git/factor.git" "master" }
|
||||
run-command
|
||||
]
|
||||
with-directory ;
|
||||
|
|
|
|||
|
|
@ -70,10 +70,14 @@ beast.
|
|||
- C-cC-ds : short help word at point
|
||||
- C-cC-de : show stack effect of current sexp (with prefix, region)
|
||||
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
|
||||
- C-cC-dv : show words in current file (with prefix, ask for vocab)
|
||||
|
||||
- C-cM-<, C-cC-d< : show callers of word at point
|
||||
- C-cM->, C-cC-d> : show callees of word at point
|
||||
|
||||
- C-cC-xs : extract innermost sexp (up to point) as a separate word
|
||||
- C-cC-xr : extract region as a separate word
|
||||
|
||||
*** In the listener:
|
||||
|
||||
- TAB : complete word at point
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@
|
|||
(require 'fuel-eval)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-xref)
|
||||
(require 'fuel-refactor)
|
||||
(require 'fuel-stack)
|
||||
(require 'fuel-autodoc)
|
||||
(require 'fuel-font-lock)
|
||||
|
|
@ -131,37 +132,6 @@ With prefix argument, ask for the file name."
|
|||
(let ((file (car (fuel-mode--read-file arg))))
|
||||
(when file (fuel-debug--uses-for-file file))))
|
||||
|
||||
(defvar fuel-mode--word-history nil)
|
||||
|
||||
(defun fuel-show-callers (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-mode--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callers ..." word)
|
||||
(fuel-xref--show-callers word))))
|
||||
|
||||
(defun fuel-show-callees (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-mode--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
(interactive "MFind words containing: ")
|
||||
(message "Looking up %s's references ..." str)
|
||||
(fuel-xref--apropos str))
|
||||
|
||||
;;; Minor mode definition:
|
||||
|
||||
|
|
@ -224,8 +194,12 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?e ?w 'fuel-edit-word)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
||||
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
|
||||
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
|
||||
|
||||
(fuel-mode--key ?d ?> 'fuel-show-callees)
|
||||
(fuel-mode--key ?d ?< 'fuel-show-callers)
|
||||
(fuel-mode--key ?d ?v 'fuel-show-file-words)
|
||||
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
|
||||
(fuel-mode--key ?d ?p 'fuel-apropos)
|
||||
(fuel-mode--key ?d ?d 'fuel-help)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,70 @@
|
|||
;;; fuel-refactor.el -- code refactoring support
|
||||
|
||||
;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Thu Jan 08, 2009 00:57
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; Utilities performing refactoring on factor code.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-stack)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-base)
|
||||
|
||||
|
||||
;;; Extract word:
|
||||
|
||||
(defun fuel-refactor--extract (begin end)
|
||||
(let* ((word (read-string "New word name: "))
|
||||
(code (buffer-substring begin end))
|
||||
(code-str (fuel--region-to-string begin end))
|
||||
(stack-effect (or (fuel-stack--infer-effect code-str)
|
||||
(read-string "Stack effect: "))))
|
||||
(unless (< begin end) (error "No proper region to extract"))
|
||||
(goto-char begin)
|
||||
(delete-region begin end)
|
||||
(insert word)
|
||||
(indent-region begin (point))
|
||||
(set-mark (point))
|
||||
(fuel-syntax--beginning-of-defun)
|
||||
(open-line 1)
|
||||
(let ((start (point)))
|
||||
(insert ": " word " " stack-effect "\n" code " ;\n")
|
||||
(indent-region start (point))
|
||||
(move-overlay fuel-stack--overlay start (point))
|
||||
(goto-char (mark))
|
||||
(sit-for fuel-stack-highlight-period)
|
||||
(delete-overlay fuel-stack--overlay))))
|
||||
|
||||
(defun fuel-refactor-extract-region (begin end)
|
||||
"Extracts current region as a separate word."
|
||||
(interactive "r")
|
||||
(let ((begin (save-excursion
|
||||
(goto-char begin)
|
||||
(when (zerop (skip-syntax-backward "w"))
|
||||
(skip-syntax-forward "-"))
|
||||
(point)))
|
||||
(end (save-excursion
|
||||
(goto-char end)
|
||||
(skip-syntax-forward "w")
|
||||
(point))))
|
||||
(fuel-refactor--extract begin end)))
|
||||
|
||||
(defun fuel-refactor-extract-sexp ()
|
||||
"Extracts current innermost sexp (up to point) as a separate
|
||||
word."
|
||||
(interactive)
|
||||
(fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos))
|
||||
(if (looking-at-p ";") (point)
|
||||
(fuel-syntax--end-of-symbol-pos))))
|
||||
|
||||
|
||||
|
||||
(provide 'fuel-refactor)
|
||||
;;; fuel-refactor.el ends here
|
||||
|
|
@ -312,6 +312,12 @@
|
|||
(defsubst fuel-syntax--usings ()
|
||||
(funcall fuel-syntax--usings-function))
|
||||
|
||||
(defun fuel-syntax--file-has-private ()
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(and (re-search-forward "\\_<<PRIVATE\\_>" nil t)
|
||||
(re-search-forward "\\_<PRIVATE>\\_>" nil t))))
|
||||
|
||||
(defun fuel-syntax--find-usings (&optional no-private)
|
||||
(save-excursion
|
||||
(let ((usings))
|
||||
|
|
@ -319,10 +325,7 @@
|
|||
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
|
||||
(dolist (u (split-string (match-string-no-properties 1) nil t))
|
||||
(push u usings)))
|
||||
(goto-char (point-min))
|
||||
(when (and (not no-private)
|
||||
(re-search-forward "\\_<<PRIVATE\\_>" nil t)
|
||||
(re-search-forward "\\_<PRIVATE>\\_>" nil t))
|
||||
(when (and (not no-private) (fuel-syntax--file-has-private))
|
||||
(goto-char (point-max))
|
||||
(push (concat (fuel-syntax--find-in) ".private") usings))
|
||||
usings)))
|
||||
|
|
|
|||
|
|
@ -13,6 +13,8 @@
|
|||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-edit)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-syntax)
|
||||
|
|
@ -82,7 +84,7 @@ cursor at the first ocurrence of the used word."
|
|||
((= 1 count) (format "1 word %s %s:" cc word))
|
||||
(t (format "%s words %s %s:" count cc word))))
|
||||
|
||||
(defun fuel-xref--insert-ref (ref)
|
||||
(defun fuel-xref--insert-ref (ref &optional no-vocab)
|
||||
(when (and (stringp (first ref))
|
||||
(stringp (third ref))
|
||||
(numberp (fourth ref)))
|
||||
|
|
@ -94,29 +96,28 @@ cursor at the first ocurrence of the used word."
|
|||
(fourth ref))
|
||||
'file (third ref)
|
||||
'line (fourth ref))
|
||||
(when (stringp (second ref))
|
||||
(when (and (not no-vocab) (stringp (second ref)))
|
||||
(insert (format " (in %s)" (second ref))))
|
||||
(newline)
|
||||
t))
|
||||
|
||||
(defun fuel-xref--fill-buffer (word cc refs)
|
||||
(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app)
|
||||
(let ((inhibit-read-only t)
|
||||
(count 0))
|
||||
(with-current-buffer (fuel-xref--buffer)
|
||||
(erase-buffer)
|
||||
(dolist (ref refs)
|
||||
(when (fuel-xref--insert-ref ref) (setq count (1+ count))))
|
||||
(goto-char (point-min))
|
||||
(insert (fuel-xref--title word cc count) "\n\n")
|
||||
(when (> count 0)
|
||||
(setq fuel-xref--word (and cc word))
|
||||
(goto-char (point-max))
|
||||
(insert "\n" fuel-xref--help-string "\n"))
|
||||
(goto-char (point-min))
|
||||
count)))
|
||||
(let ((start (if app (goto-char (point-max))
|
||||
(erase-buffer)
|
||||
(point-min))))
|
||||
(dolist (ref refs)
|
||||
(when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count))))
|
||||
(newline)
|
||||
(goto-char start)
|
||||
(save-excursion
|
||||
(insert (fuel-xref--title word cc count) "\n\n"))
|
||||
count))))
|
||||
|
||||
(defun fuel-xref--fill-and-display (word cc refs)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs)))
|
||||
(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab)
|
||||
(let ((count (fuel-xref--fill-buffer word cc refs no-vocab)))
|
||||
(if (zerop count)
|
||||
(error (fuel-xref--title word cc 0))
|
||||
(message "")
|
||||
|
|
@ -137,6 +138,65 @@ cursor at the first ocurrence of the used word."
|
|||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
(defun fuel-xref--show-vocab (vocab &optional app)
|
||||
(let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-buffer vocab "in vocabulary" res t app)))
|
||||
|
||||
(defun fuel-xref--show-vocab-words (vocab &optional private)
|
||||
(fuel-xref--show-vocab vocab)
|
||||
(when private
|
||||
(fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab))
|
||||
t))
|
||||
(fuel-popup--display (fuel-xref--buffer))
|
||||
(goto-char (point-min)))
|
||||
|
||||
|
||||
;;; User commands:
|
||||
|
||||
(defvar fuel-xref--word-history nil)
|
||||
|
||||
(defun fuel-show-callers (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callers for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callers ..." word)
|
||||
(fuel-xref--show-callers word))))
|
||||
|
||||
(defun fuel-show-callees (&optional arg)
|
||||
"Show a list of callers of word at point.
|
||||
With prefix argument, ask for word."
|
||||
(interactive "P")
|
||||
(let ((word (if arg (fuel-completion--read-word "Find callees for: "
|
||||
(fuel-syntax-symbol-at-point)
|
||||
fuel-xref--word-history)
|
||||
(fuel-syntax-symbol-at-point))))
|
||||
(when word
|
||||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
(interactive "MFind words containing: ")
|
||||
(message "Looking up %s's references ..." str)
|
||||
(fuel-xref--apropos str))
|
||||
|
||||
(defun fuel-show-file-words (&optional arg)
|
||||
"Show a list of words in current file.
|
||||
With prefix argument, ask for the vocab."
|
||||
(interactive "P")
|
||||
(let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-edit--read-vocabulary-name))))
|
||||
(when vocab
|
||||
(fuel-xref--show-vocab-words vocab
|
||||
(fuel-syntax--file-has-private)))))
|
||||
|
||||
|
||||
|
||||
;;; Xref mode:
|
||||
|
||||
|
|
@ -159,6 +219,7 @@ cursor at the first ocurrence of the used word."
|
|||
(kill-all-local-variables)
|
||||
(buffer-disable-undo)
|
||||
(use-local-map fuel-xref-mode-map)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(setq mode-name "FUEL Xref")
|
||||
(setq major-mode 'fuel-xref-mode)
|
||||
(font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue