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

basis/bit-arrays/bit-arrays-tests.factor

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

basis/bit-arrays/bit-arrays.factor

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

basis/math/primes/factors/factors.factor

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

basis/math/primes/primes-docs.factor

@@ -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
+{ 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" } "." } ;
 
 HELP: primes-upto
 { $values { "n" "an integer" } { "seq" "a sequence" } }

basis/math/primes/primes-tests.factor

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

basis/math/primes/primes.factor

@@ -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
+USING: combinators kernel math math.functions math.miller-rabin
-math.miller-rabin math.order math.primes.erato math.ranges sequences ;
+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

basis/unicode/breaks/breaks.factor

@@ -3,7 +3,7 @@
 USING: combinators.short-circuit unicode.categories kernel math
 combinators splitting sequences math.parser io.files io assocs
 arrays namespaces make math.ranges unicode.normalize.private values
-io.encodings.ascii unicode.syntax unicode.data compiler.units
+io.encodings.ascii unicode.syntax unicode.data compiler.units fry
 alien.syntax sets accessors interval-maps memoize locals words ;
 IN: unicode.breaks
 
@@ -111,14 +111,9 @@ PRIVATE>
 
 <PRIVATE
 
-:: (>pieces) ( str quot -- )
+: >pieces ( str quot: ( str -- i ) -- graphemes )
-    str [
+    [ dup empty? not ] swap '[ dup @ cut-slice swap ]
-        dup quot call cut-slice
+    [ ] produce nip ; inline
-        swap , quot (>pieces)
-    ] unless-empty ; inline recursive
-
-: >pieces ( str quot -- graphemes )
-    [ (>pieces) ] { } make ; inline
 
 PRIVATE>
 

basis/unicode/case/case-docs.factor

@@ -1,4 +1,4 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup strings ;
 IN: unicode.case
 
 ABOUT: "unicode.case"
@@ -9,6 +9,10 @@ ARTICLE: "unicode.case" "Case mapping"
 { $subsection >lower }
 { $subsection >title }
 { $subsection >case-fold }
+"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one."
+{ $subsection ch>upper }
+{ $subsection ch>lower }
+{ $subsection ch>title }
 "To test if a string is in a given case:"
 { $subsection upper? }
 { $subsection lower? }
@@ -16,4 +20,51 @@ ARTICLE: "unicode.case" "Case mapping"
 { $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 languages." ;
+"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 } { "case-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" } "." } ;

basis/unicode/case/case-tests.factor

@@ -4,7 +4,7 @@ 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
 [ t ] [ "hello how are you?" lower? ] unit-test

basis/unicode/case/case.factor

@@ -2,17 +2,19 @@
 ! 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 ;
+assocs strings splitting kernel accessors unicode.breaks ;
 IN: unicode.case
 
 <PRIVATE
 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
+PRIVATE>
 
 : ch>lower ( ch -- lower ) simple-lower at-default ;
 : ch>upper ( ch -- upper ) simple-upper at-default ;
 : ch>title ( ch -- title ) simple-title at-default ;
-PRIVATE>
+
 SYMBOL: locale ! Just casing locale, or overall?
+
 <PRIVATE
 : i-dot? ( -- ? )
     locale get { "tr" "az" } member? ;
@@ -80,23 +82,30 @@ SYMBOL: locale ! Just casing locale, or overall?
             [ [ % ] compose ] [ [ , ] compose ] bi* ?if
         ] 2curry each
     ] "" make ; inline
-PRIVATE>
-: >lower ( string -- lower )
-    i-dot? [ turk>lower ] when
-    final-sigma [ lower>> ] [ ch>lower ] map-case ;
 
-: >upper ( string -- upper )
+: (>lower) ( string -- lower )
-    i-dot? [ turk>upper ] when
+    [ lower>> ] [ ch>lower ] map-case ;
+
+: (>title) ( string -- title )
+    [ title>> ] [ ch>title ] map-case ;
+
+: (>upper) ( string -- upper )
     [ upper>> ] [ ch>upper ] map-case ;
 
+: title-word ( string -- title )
+    unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ;
+
+PRIVATE>
+
+: >lower ( string -- lower )
+    i-dot? [ turk>lower ] when
+    final-sigma (>lower) ;
+
+: >upper ( string -- upper )
+    i-dot? [ turk>upper ] when (>upper) ;
+
 : >title ( string -- title )
-    final-sigma
+    final-sigma >words [ title-word ] map concat ;
-    CHAR: \s swap
-    [ tuck word-boundary swapd
-        [ title>> ] [ lower>> ] if ]
-    [ tuck word-boundary swapd 
-        [ ch>title ] [ ch>lower ] if ]
-    map-case nip ;
 
 : >case-fold ( string -- fold )
     >upper >lower ;

basis/unicode/collation/collation-tests.factor

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

basis/unicode/data/data-docs.factor

@@ -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
+{ $value { "filename" string } { "table" "an interval map" } }
+{ $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ;
+
+HELP: canonical-entry
+{ $value { "char" "a code point" } { "seq" string } }
+{ $description "Finds the canonical decomposition (NFD) for a code point" } ;
+
+HELP: combine-chars
+{ $value { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } }
+{ $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ;
+
+HELP: compatibility-entry
+{ $value { "char" "a code point" } { "seq" string } }
+{ $description "This returns the compatibility decomposition (NFKD) for a code point" } ;
+
+HELP: combining-class
+{ $value { "char" "a code point" } { "n" "an integer" } }
+{ $description "Finds the combining class of a code point." } ;
+
+HELP: non-starter?
+{ $value { "char" "a code point" } { "?" "a boolean" } }
+{ $description "Returns true if the code point has a combining class." } ;
+
+HELP: char>name
+{ $value { "char" "a code point" } { "name" string } }
+{ $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ;
+
+HELP: name>char
+{ $value { "name" string } { "char" "a code point" } }
+{ $description "Looks up the code point corresponding to a given name." } ;
+
+HELP: property?
+{ $value { "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." } ;

basis/unicode/data/data.factor

@@ -28,10 +28,6 @@ VALUE: properties
 : char>name ( char -- string ) 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 CHAR: . over member? [
-                swap ".." split1 [ hex> ] bi@ 2array
+                ".." split1 [ hex> ] bi@ 2array
-            ] [ swap hex> ] if range,
+            ] [ hex> ] if range,
         ] assoc-each
     ] { } make <interval-map> ;
 

basis/unicode/normalize/normalize-docs.factor

@@ -8,9 +8,7 @@ ARTICLE: "unicode.normalize" "Unicode normalization"
 { $subsection nfc }
 { $subsection nfd }
 { $subsection nfkc }
-{ $subsection nfkd }
+{ $subsection nfkd } ;
-"If two strings in a normalization form are appended, the result may not be in that normalization form still. To append two strings in NFD and make sure the result is in NFD, the following procedure is supplied:"
-{ $subsection string-append } ;
 
 HELP: nfc
 { $values { "string" string } { "nfc" "a string in NFC" } }
@@ -27,7 +25,3 @@ HELP: nfkc
 HELP: nfkd
 { $values { "string" string } { "nfc" "a string in NFKD" } }
 { $description "Converts a string to Normalization Form KD" } ;
-
-HELP: string-append
-{ $values { "s1" "a string in NFD" } { "s2" "a string in NFD" } { "string" "a string in NFD" } }
-{ $description "Appends two strings, putting the result in NFD." } ;

basis/unicode/normalize/normalize-tests.factor

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

basis/unicode/normalize/normalize.factor

@@ -1,21 +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
+CONSTANT: hangul-base HEX: ac00
-: hangul-end HEX: D7AF ; inline
+CONSTANT: hangul-end HEX: D7AF
-: initial-base HEX: 1100 ; inline
+CONSTANT: initial-base HEX: 1100
-: medial-base HEX: 1161 ; inline
+CONSTANT: medial-base HEX: 1161
-: final-base HEX: 11a7 ; inline
+CONSTANT: final-base HEX: 11a7
 
-: initial-count 19 ; inline
+CONSTANT: initial-count 19
-: medial-count 21 ; inline
+CONSTANT: medial-count 21
-: final-count 28 ; inline
+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? ;
@@ -84,8 +87,6 @@ PRIVATE>
     [ 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 ;
@@ -154,7 +155,7 @@ DEFER: compose-iter
         ] if (compose)
     ] when* ;
 
-: compose ( str -- comp )
+: combine ( str -- comp )
     [
         main-str set
         0 ind set
@@ -165,7 +166,7 @@ DEFER: compose-iter
 PRIVATE>
 
 : nfc ( string -- nfc )
-    nfd compose ;
+    nfd combine ;
 
 : nfkc ( string -- nfkc )
-    nfkd compose ;
+    nfkd combine ;

core/kernel/kernel-docs.factor

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

extra/L-system/L-system.factor

@@ -256,7 +256,9 @@ DEFER: default-L-parser-values
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 TUPLE: <L-system> < gadget
-  camera display-list pedestal paused commands axiom rules string ;
+  camera display-list pedestal paused
+  turtle-values
+  commands axiom rules string ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -376,6 +378,7 @@ TUPLE: <L-system> < gadget
   L-SYSTEM display-list>> GL_COMPILE glNewList
 
     turtle
+    L-SYSTEM turtle-values>> [ ] or call
     L-SYSTEM string>> L-SYSTEM axiom>> or
     L-SYSTEM commands>>
     interpret-string
@@ -445,6 +448,11 @@ H{
   { 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          ] }
 
   {

extra/L-system/models/abop-2/abop-2.factor

@@ -9,20 +9,23 @@ IN: L-system.models.abop-2
 
   L-parser-dialect >>commands
 
+  [ 30 >>angle ] >>turtle-values
+
   "c(12)FAL" >>axiom
 
   {
-    { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" }
+    { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" }
-    { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" }
+    
-    { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" }
+    { "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
-  

extra/L-system/models/abop-3/abop-3.factor

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

extra/L-system/models/abop-4/abop-4.factor

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

extra/L-system/models/abop-5-angular/abop-5-angular.factor

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

extra/L-system/models/abop-5/abop-5.factor

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

extra/L-system/models/abop-6/abop-6.factor

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

extra/L-system/models/airhorse/airhorse.factor

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

extra/fuel/fuel.factor

@@ -269,7 +269,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 ]

extra/math/primes/factors/factors.factor

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

extra/math/primes/lists/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/primes/lists/lists-docs.factor

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

extra/math/primes/lists/lists-tests.factor

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

extra/math/primes/lists/lists.factor

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

extra/math/primes/lists/summary.txt

@@ -0,0 +1 @@
+Infinite stream of prime numbers through lazy lists

extra/math/primes/primes-tests.factor

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

extra/project-euler/007/007.factor

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

extra/project-euler/134/134.factor

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

extra/update/latest/latest.factor

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

misc/fuel/README

@@ -74,6 +74,8 @@ beast.
     - C-cM-<, C-cC-d< : show callers of word at point
     - C-cM->, C-cC-d> : show callees of word at point
 
+    - C-cC-xw : extract region as a separate word
+
 *** In the listener:
 
     - TAB : complete word at point

misc/fuel/fuel-mode.el

@@ -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)
@@ -224,6 +225,8 @@ 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 ?w 'fuel-refactor-extract-word)
+
 (fuel-mode--key ?d ?> 'fuel-show-callees)
 (fuel-mode--key ?d ?< 'fuel-show-callers)
 (fuel-mode--key ?d ?a 'fuel-autodoc-mode)

misc/fuel/fuel-refactor.el

@@ -0,0 +1,57 @@
+;;; 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-word (begin end)
+  "Extracts current region as a separate word."
+  (interactive "r")
+  (let* ((word (read-string "New word name: "))
+         (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)))
+         (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: "))))
+    (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))))
+
+
+(provide 'fuel-refactor)
+;;; fuel-refactor.el ends here