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

basis/alien/c-types/c-types-tests.factor

@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test

basis/alien/c-types/c-types.factor

@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use def>> call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter

basis/disjoint-sets/disjoint-sets.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hints kernel locals math hashtables
-assocs fry ;
-
+assocs fry sequences ;
 IN: disjoint-sets
 
 TUPLE: disjoint-set
@@ -65,6 +64,12 @@ M: disjoint-set add-atom
     [ 1 -rot counts>> set-at ]
     2tri ;
 
+: add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
+
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;
@@ -83,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- )
         disjoint-set link-sets
     ] if ;
 
+: equate-all-with ( seq a disjoint-set -- )
+    '[ , , equate ] each ;
+
+: equate-all ( seq disjoint-set -- )
+    over dup empty? [ 2drop ] [
+        [ unclip-slice ] dip equate-all-with
+    ] if ;
+
 M: disjoint-set clone
     [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
     disjoint-set boa ;

basis/math/constants/constants.factor

@@ -1,5 +1,6 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USE: math
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
@@ -7,3 +8,5 @@ IN: math.constants
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

basis/math/ranges/ranges-docs.factor

@@ -1,21 +1,27 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup arrays sequences ;
 
 IN: math.ranges
 
 ARTICLE: "ranges" "Ranges"
-
-  "A " { $emphasis "range" } " is a virtual sequence with real elements "
-  "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
-
-  $nl
-
-  "Creating ranges:"
-
-  { $subsection <range> }
-  { $subsection [a,b]   }
-  { $subsection (a,b]   }
-  { $subsection [a,b)   }
-  { $subsection (a,b)   }
-  { $subsection [0,b]   }
-  { $subsection [1,b]   }
-  { $subsection [0,b)   } ;
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
+"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
+$nl
+"The class of ranges:"
+{ $subsection range }
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
+{ $subsection [a,b] }
+{ $subsection (a,b] }
+{ $subsection [a,b) }
+{ $subsection (a,b) }
+{ $subsection [0,b] }
+{ $subsection [1,b] }
+{ $subsection [0,b) }
+"Creating general ranges:"
+{ $subsection <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code
+    "3 10 [a,b] [ sqrt ] map"
+}
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+  
+ABOUT: "ranges"

basis/persistent/deques/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/persistent/deques/deques-docs.factor

@@ -0,0 +1,56 @@
+USING: help.markup help.syntax kernel sequences ;
+IN: persistent.deques
+
+ARTICLE: "persistent.deques" "Persistent deques"
+"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern."
+$nl
+"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one."
+$nl
+"The class of persistent deques:"
+{ $subsection deque }
+"To create a deque:"
+{ $subsection <deque> }
+{ $subsection sequence>deque }
+"To test if a deque is empty:"
+{ $subsection deque-empty? }
+"To manipulate deques:"
+{ $subsection push-left }
+{ $subsection push-right }
+{ $subsection pop-left }
+{ $subsection pop-right }
+{ $subsection deque>sequence } ;
+
+HELP: deque
+{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ;
+
+HELP: <deque>
+{ $values { "deque" "an empty deque" } }
+{ $description "Creates an empty deque." } ;
+
+HELP: sequence>deque
+{ $values { "sequence" sequence } { "deque" deque } }
+{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ;
+
+HELP: deque>sequence
+{ $values { "deque" deque } { "sequence" sequence } }
+{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ;
+
+HELP: deque-empty?
+{ $values { "deque" deque } { "?" "t/f" } }
+{ $description "Returns true if the deque is empty. This takes constant time." } ;
+
+HELP: push-left
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ;
+
+HELP: push-right
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ;
+
+HELP: pop-left
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ;
+
+HELP: pop-right
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ;

basis/persistent/deques/deques-tests.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test persistent.deques kernel math ;
+IN: persistent.deques.tests
+
+[ 3 2 1 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test
+
+[ 1 2 3 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test
+
+[ 1 3 2 t ]
+[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ]
+unit-test
+
+[ { 2 3 4 5 6 1 } ]
+[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ]
+unit-test
+
+[ 1 t ] [ <deque> 1 push-left pop-right deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-left pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-left 2 push-left pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-right 2 push-right pop-left deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-right 2 push-right pop-right deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-left 2 push-left pop-left deque-empty? ] unit-test

basis/persistent/deques/deques.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math qualified ;
+QUALIFIED: sequences
+IN: persistent.deques
+
+! Amortized O(1) push/pop on both ends for single-threaded access
+! In a pathological case, if there are m modified versions from the
+!   same source, it could take O(m) amortized time per update.
+
+<PRIVATE
+TUPLE: cons { car read-only } { cdr read-only } ;
+C: <cons> cons
+
+: each ( list quot -- )
+    over
+    [ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
+    [ 2drop ] if ; inline
+
+: reduce ( list start quot -- end )
+    swapd each ; inline
+
+: reverse ( list -- reversed )
+    f [ swap <cons> ] reduce ;
+
+: length ( list -- length )
+    0 [ drop 1+ ] reduce ;
+
+: cut ( list index -- back front-reversed )
+    f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
+
+: split-reverse ( list -- back-reversed front )
+    dup length 2/ cut [ reverse ] bi@ ;
+PRIVATE>
+
+TUPLE: deque { lhs read-only } { rhs read-only } ;
+: <deque> ( -- deque ) T{ deque } ;
+
+: deque-empty? ( deque -- ? )
+    [ lhs>> ] [ rhs>> ] bi or not ;
+
+: push-left ( deque item -- newdeque )
+    swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
+
+: push-right ( deque item -- newdeque )
+    swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
+
+<PRIVATE
+: (pop-left) ( deque -- item newdeque )
+    [ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
+
+: transfer-left ( deque -- item newdeque )
+    rhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-left ( deque -- item newdeque )
+    dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
+
+<PRIVATE
+: (pop-right) ( deque -- item newdeque )
+    [ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
+
+: transfer-right ( deque -- newdeque item )
+    lhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-right ( deque -- item newdeque )
+    dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
+
+: sequence>deque ( sequence -- deque )
+    <deque> [ push-right ] sequences:reduce ;
+
+: deque>sequence ( deque -- sequence )
+    [ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;

basis/persistent/deques/summary.txt

@@ -0,0 +1 @@
+Persistent amortized O(1) deques

basis/persistent/deques/tags.txt

@@ -0,0 +1 @@
+collections

basis/persistent/hashtables/hashtables-tests.factor

@@ -10,6 +10,10 @@ tools.test kernel namespaces random math.ranges sequences fry ;
 
 [ f ] [ "X" PH{ { "A" "B" } } at ] unit-test
 
+! We have to define these first so that they're compiled before
+! the below hashtables are parsed...
+<<
+
 TUPLE: hash-0-a ;
 
 M: hash-0-a hashcode* 2drop 0 ;
@@ -18,6 +22,8 @@ TUPLE: hash-0-b ;
 
 M: hash-0-b hashcode* 2drop 0 ;
 
+>>
+
 [ ] [
     PH{ }
     "a" T{ hash-0-a } rot new-at

basis/persistent/hashtables/hashtables.factor

@@ -41,6 +41,13 @@ M: persistent-hash >alist [ root>> >alist% ] { } make ;
 : >persistent-hash ( assoc -- phash )
     T{ persistent-hash } swap [ spin new-at ] assoc-each ;
 
+M: persistent-hash equal?
+    over persistent-hash? [ assoc= ] [ 2drop f ] if ;
+
+M: persistent-hash hashcode* nip assoc-size ;
+
+M: persistent-hash clone ;
+
 : PH{ \ } [ >persistent-hash ] parse-literal ; parsing
 
 M: persistent-hash pprint-delims drop \ PH{ \ } ;

basis/persistent/sequences/sequences-docs.factor

@@ -3,15 +3,21 @@ USING: help.markup help.syntax math sequences kernel ;
 
 HELP: new-nth
 { $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
-{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } ;
 
 HELP: ppush
 { $values { "val" object } { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } ;
 
 HELP: ppop
 { $values { "seq" sequence } { "seq'" sequence } }
-{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
-{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link "persistent.vectors" } " and " { $snippet "O(n)" } " time on all other sequences." } ;
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ;
+
+ARTICLE: "persistent.sequences" "Persistent sequence protocol"
+"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as  " { $link length } " and " { $link nth } ", together with the following operations:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The default implementations of the above run in " { $snippet "O(n)" } " time; the " { $vocab-link "persistent.vectors" } " vocabulary provides an implementation of these operations in " { $snippet "O(1)" } " time." ;
+
+ABOUT: "persistent.sequences"

basis/persistent/vectors/vectors-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel math sequences ;
-IN: persistent-vectors
+IN: persistent.vectors
 
 HELP: PV{
 { $syntax "elements... }" }
@@ -12,17 +12,11 @@ HELP: >persistent-vector
 HELP: persistent-vector
 { $class-description "The class of persistent vectors." } ;
 
-ARTICLE: "persistent-vectors" "Persistent vectors"
+ARTICLE: "persistent.vectors" "Persistent vectors"
 "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
 $nl
 "The class of persistent vectors:"
 { $subsection persistent-vector }
-"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
-$nl
-"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
-{ $subsection new-nth }
-{ $subsection ppush }
-{ $subsection ppop }
 "Converting a sequence into a persistent vector:"
 { $subsection >persistent-vector }
 "Persistent vectors have a literal syntax:"
@@ -31,4 +25,4 @@ $nl
 $nl
 "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
 
-ABOUT: "persistent-vectors"
+ABOUT: "persistent.vectors"

basis/ui/gadgets/buttons/buttons.factor

@@ -199,14 +199,11 @@ M: radio-control model-changed
 : <radio-button> ( value model label -- gadget )
     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 
-: radio-buttons-theme ( gadget -- )
-    { 5 5 } >>gap drop ;
-
 : <radio-buttons> ( model assoc -- gadget )
   <filled-pile>
     -rot
     [ <radio-button> ] <radio-controls>
-  dup radio-buttons-theme ;
+  { 5 5 } >>gap ;
 
 : <toggle-button> ( value model label -- gadget )
     <radio-control> bevel-button-theme ;