diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor new file mode 100644 index 0000000000..40e14b7fca --- /dev/null +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -0,0 +1,58 @@ +IN: disjoint-sets +USING: help.markup help.syntax kernel assocs math ; + +HELP: +{ $values { "disjoint-set" disjoint-set } } +{ $description "Creates a new disjoint set data structure with no elements." } ; + +HELP: add-atom +{ $values { "a" object } { "disjoint-set" disjoint-set } } +{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ; + +HELP: equiv-set-size +{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } } +{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ; + +HELP: equiv? +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } } +{ $description "Tests if two elements belong to the same equivalence class." } ; + +HELP: equate +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } } +{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ; + +HELP: assoc>disjoint-set +{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } } +{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." } +{ $examples + { $example + "USING: disjoint-sets kernel prettyprint ;" + "H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set" + "1 2 pick equiv? ." + "4 5 pick equiv? ." + "1 5 pick equiv? ." + "drop" + "t\nt\nf" + } +} ; + +ARTICLE: "disjoint-sets" "Disjoint sets" +"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set." +$nl +"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time." +$nl +"The class of disjoint sets:" +{ $subsection disjoint-set } +"Creating new disjoint sets:" +{ $subsection } +{ $subsection assoc>disjoint-set } +"Queries:" +{ $subsection equiv? } +{ $subsection equiv-set-size } +"Adding elements:" +{ $subsection add-atom } +"Equating elements:" +{ $subsection equate } +"Additionally, disjoint sets implement the " { $link clone } " generic word." ; + +ABOUT: "disjoint-sets" diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index 284d206da4..a885e333c5 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -1,7 +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 ; +assocs fry ; IN: disjoint-sets @@ -36,8 +36,6 @@ TUPLE: disjoint-set : representative? ( a disjoint-set -- ? ) dupd parent = ; inline -PRIVATE> - GENERIC: representative ( a disjoint-set -- p ) M: disjoint-set representative @@ -45,8 +43,6 @@ M: disjoint-set representative [ [ parent ] keep representative dup ] 2keep set-parent ] if ; -> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@ disjoint-set boa ; + +: assoc>disjoint-set ( assoc -- disjoint-set ) + + [ '[ drop , add-atom ] assoc-each ] + [ '[ , equate ] assoc-each ] + [ nip ] + 2tri ; diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index d82871ec9e..d5e77caa19 100755 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ IN: io.windows.launcher.nt.tests USING: io.launcher tools.test calendar accessors namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables math continuations ; +sequences parser assocs hashtables math continuations eval ; [ ] [ diff --git a/basis/persistent/assocs/assocs.factor b/basis/persistent/assocs/assocs.factor new file mode 100644 index 0000000000..59fbd3a51e --- /dev/null +++ b/basis/persistent/assocs/assocs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs ; +IN: persistent.assocs + +GENERIC: new-at ( value key assoc -- assoc' ) + +M: assoc new-at clone [ set-at ] keep ; + +GENERIC: pluck-at ( key assoc -- assoc' ) + +M: assoc pluck-at clone [ delete-at ] keep ; + +: changed-at ( key assoc quot -- assoc' ) + [ [ at ] dip call ] [ drop new-at ] 3bi ; inline + +: conjoined ( key assoc -- assoc' ) + dupd new-at ; diff --git a/extra/persistent-vectors/authors.txt b/basis/persistent/assocs/authors.txt similarity index 100% rename from extra/persistent-vectors/authors.txt rename to basis/persistent/assocs/authors.txt diff --git a/basis/persistent/assocs/summary.txt b/basis/persistent/assocs/summary.txt new file mode 100644 index 0000000000..5fe330f444 --- /dev/null +++ b/basis/persistent/assocs/summary.txt @@ -0,0 +1 @@ +Persistent associative mapping protocol diff --git a/extra/persistent-heaps/tags.txt b/basis/persistent/assocs/tags.txt similarity index 100% rename from extra/persistent-heaps/tags.txt rename to basis/persistent/assocs/tags.txt diff --git a/basis/persistent/hashtables/authors.txt b/basis/persistent/hashtables/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/persistent/hashtables/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/persistent/hashtables/config/config.factor b/basis/persistent/hashtables/config/config.factor new file mode 100644 index 0000000000..a761e2d327 --- /dev/null +++ b/basis/persistent/hashtables/config/config.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: layouts kernel parser math ; +IN: persistent.hashtables.config + +: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable +: radix-mask ( -- n ) radix-bits 2^ 1- ; foldable +: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1- ; inline diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor new file mode 100644 index 0000000000..accebfd778 --- /dev/null +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -0,0 +1,110 @@ +IN: persistent.hashtables.tests +USING: persistent.hashtables persistent.assocs hashtables assocs +tools.test kernel namespaces random math.ranges sequences fry ; + +[ t ] [ PH{ } assoc-empty? ] unit-test + +[ PH{ { "A" "B" } } ] [ PH{ } "B" "A" rot new-at ] unit-test + +[ "B" ] [ "A" PH{ { "A" "B" } } at ] unit-test + +[ f ] [ "X" PH{ { "A" "B" } } at ] unit-test + +TUPLE: hash-0-a ; + +M: hash-0-a hashcode* 2drop 0 ; + +TUPLE: hash-0-b ; + +M: hash-0-b hashcode* 2drop 0 ; + +[ ] [ + PH{ } + "a" T{ hash-0-a } rot new-at + "b" T{ hash-0-b } rot new-at + "ph" set +] unit-test + +[ + H{ + { T{ hash-0-a } "a" } + { T{ hash-0-b } "b" } + } +] [ "ph" get >hashtable ] unit-test + +[ + H{ + { T{ hash-0-b } "b" } + } +] [ "ph" get T{ hash-0-a } swap pluck-at >hashtable ] unit-test + +[ + H{ + { T{ hash-0-a } "a" } + } +] [ "ph" get T{ hash-0-b } swap pluck-at >hashtable ] unit-test + +[ + H{ + { T{ hash-0-a } "a" } + { T{ hash-0-b } "b" } + } +] [ "ph" get "X" swap pluck-at >hashtable ] unit-test + +[ ] [ + PH{ } + "B" "A" rot new-at + "D" "C" rot new-at + "ph" set +] unit-test + +[ H{ { "A" "B" } { "C" "D" } } ] [ + "ph" get >hashtable +] unit-test + +[ H{ { "C" "D" } } ] [ + "ph" get "A" swap pluck-at >hashtable +] unit-test + +[ H{ { "A" "B" } { "C" "D" } { "E" "F" } } ] [ + "ph" get "F" "E" rot new-at >hashtable +] unit-test + +[ H{ { "C" "D" } { "E" "F" } } ] [ + "ph" get "F" "E" rot new-at "A" swap pluck-at >hashtable +] unit-test + +: random-string ( -- str ) + 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; + +: random-assocs ( -- hash phash ) + [ random-string ] replicate + [ H{ } clone [ '[ swap , set-at ] each-index ] keep ] + [ PH{ } clone swap [ spin new-at ] each-index ] + bi ; + +: ok? ( assoc1 assoc2 -- ? ) + [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ; + +: test-persistent-hashtables-1 ( n -- ) + random-assocs ok? ; + +[ t ] [ 10 test-persistent-hashtables-1 ] unit-test +[ t ] [ 20 test-persistent-hashtables-1 ] unit-test +[ t ] [ 30 test-persistent-hashtables-1 ] unit-test +[ t ] [ 50 test-persistent-hashtables-1 ] unit-test +[ t ] [ 100 test-persistent-hashtables-1 ] unit-test +[ t ] [ 500 test-persistent-hashtables-1 ] unit-test +[ t ] [ 1000 test-persistent-hashtables-1 ] unit-test +[ t ] [ 5000 test-persistent-hashtables-1 ] unit-test +[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test +[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test + +: test-persistent-hashtables-2 ( n -- ) + random-assocs + dup keys [ + [ nip over delete-at ] [ swap pluck-at nip ] 3bi + 2dup ok? + ] all? 2nip ; + +[ t ] [ 6000 test-persistent-hashtables-2 ] unit-test diff --git a/basis/persistent/hashtables/hashtables.factor b/basis/persistent/hashtables/hashtables.factor new file mode 100644 index 0000000000..a68fa7c365 --- /dev/null +++ b/basis/persistent/hashtables/hashtables.factor @@ -0,0 +1,48 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: kernel math accessors assocs fry combinators parser +prettyprint.backend namespaces +persistent.assocs +persistent.hashtables.nodes +persistent.hashtables.nodes.empty +persistent.hashtables.nodes.leaf +persistent.hashtables.nodes.full +persistent.hashtables.nodes.bitmap +persistent.hashtables.nodes.collision ; +IN: persistent.hashtables + +TUPLE: persistent-hash +{ root read-only initial: empty-node } +{ count fixnum read-only } ; + +M: persistent-hash assoc-size count>> ; + +M: persistent-hash at* + [ dup hashcode >fixnum ] [ root>> ] bi* (entry-at) + dup [ value>> t ] [ f ] if ; + +M: persistent-hash new-at ( value key assoc -- assoc' ) + [ + { [ 0 ] [ ] [ dup hashcode >fixnum ] [ root>> ] } spread + (new-at) 1 0 ? + ] [ count>> ] bi + + persistent-hash boa ; + +M: persistent-hash pluck-at + [ [ dup hashcode >fixnum ] [ root>> ] bi* (pluck-at) ] keep + { + { [ 2dup root>> eq? ] [ nip ] } + { [ over not ] [ 2drop T{ persistent-hash } ] } + [ count>> 1- persistent-hash boa ] + } cond ; + +M: persistent-hash >alist [ root>> >alist% ] { } make ; + +: >persistent-hash ( assoc -- phash ) + T{ persistent-hash } swap [ spin new-at ] assoc-each ; + +: PH{ \ } [ >persistent-hash ] parse-literal ; parsing + +M: persistent-hash pprint-delims drop \ PH{ \ } ; + +M: persistent-hash >pprint-sequence >alist ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor new file mode 100644 index 0000000000..7fb14a4541 --- /dev/null +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -0,0 +1,86 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: math math.bit-count arrays kernel accessors locals sequences +sequences.private sequences.lib +persistent.sequences +persistent.hashtables.config +persistent.hashtables.nodes ; +IN: persistent.hashtables.nodes.bitmap + +: index ( bit bitmap -- n ) [ 1- ] dip bitand bit-count ; inline + +M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry ) + [let* | shift [ bitmap-node shift>> ] + bit [ hashcode shift bitpos ] + bitmap [ bitmap-node bitmap>> ] + nodes [ bitmap-node nodes>> ] | + bitmap bit bitand 0 eq? [ f ] [ + key hashcode + bit bitmap index nodes nth-unsafe + (entry-at) + ] if + ] ; + +M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf ) + [let* | shift [ bitmap-node shift>> ] + bit [ hashcode shift bitpos ] + bitmap [ bitmap-node bitmap>> ] + idx [ bit bitmap index ] + nodes [ bitmap-node nodes>> ] | + bitmap bit bitand 0 eq? [ + [let | new-leaf [ value key hashcode ] | + bitmap bit bitor + new-leaf idx nodes insert-nth + shift + + new-leaf + ] + ] [ + [let | n [ idx nodes nth ] | + shift radix-bits + value key hashcode n (new-at) + [let | new-leaf [ ] n' [ ] | + n n' eq? [ + bitmap-node + ] [ + bitmap + n' idx nodes new-nth + shift + + ] if + new-leaf + ] + ] + ] if + ] ; + +M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' ) + [let | bit [ hashcode bitmap-node shift>> bitpos ] + bitmap [ bitmap-node bitmap>> ] + nodes [ bitmap-node nodes>> ] + shift [ bitmap-node shift>> ] | + bit bitmap bitand 0 eq? [ bitmap-node ] [ + [let* | idx [ bit bitmap index ] + n [ idx nodes nth-unsafe ] + n' [ key hashcode n (pluck-at) ] | + n n' eq? [ + bitmap-node + ] [ + n' [ + bitmap + n' idx nodes new-nth + shift + + ] [ + bitmap bit eq? [ f ] [ + bitmap bit bitnot bitand + idx nodes remove-nth + shift + + ] if + ] if + ] if + ] + ] if + ] ; + +M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ; diff --git a/basis/persistent/hashtables/nodes/collision/collision.factor b/basis/persistent/hashtables/nodes/collision/collision.factor new file mode 100644 index 0000000000..b74a2ed45d --- /dev/null +++ b/basis/persistent/hashtables/nodes/collision/collision.factor @@ -0,0 +1,59 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: kernel accessors math arrays fry sequences sequences.lib +locals persistent.sequences +persistent.hashtables.config +persistent.hashtables.nodes +persistent.hashtables.nodes.leaf ; +IN: persistent.hashtables.nodes.collision + +: find-index ( key hashcode collision-node -- n leaf-node ) + leaves>> -rot '[ , , _ matching-key? ] find ; inline + +M:: collision-node (entry-at) ( key hashcode collision-node -- leaf-node ) + key hashcode collision-node find-index nip ; + +M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node ) + hashcode collision-node hashcode>> eq? [ + [let | idx [ key hashcode collision-node find-index drop ] | + idx [ + idx collision-node leaves>> smash [ + collision-node hashcode>> + + ] when + ] [ collision-node ] if + ] + ] [ collision-node ] if ; + +M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf ) + hashcode collision-node hashcode>> eq? [ + key hashcode collision-node find-index + [let | leaf-node [ ] idx [ ] | + idx [ + value leaf-node value>> = [ + collision-node f + ] [ + hashcode + value key hashcode + idx + collision-node leaves>> + new-nth + + f + ] if + ] [ + [let | new-leaf-node [ value key hashcode ] | + hashcode + collision-node leaves>> + new-leaf-node + suffix + + new-leaf-node + ] + ] if + ] + ] [ + shift collision-node value key hashcode make-bitmap-node + ] if ; + +M: collision-node >alist% leaves>> >alist-each% ; diff --git a/basis/persistent/hashtables/nodes/empty/empty.factor b/basis/persistent/hashtables/nodes/empty/empty.factor new file mode 100644 index 0000000000..95a310acd9 --- /dev/null +++ b/basis/persistent/hashtables/nodes/empty/empty.factor @@ -0,0 +1,15 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: accessors kernel locals persistent.hashtables.nodes ; +IN: persistent.hashtables.nodes.empty + +M: empty-node (entry-at) 3drop f ; + +M: empty-node (pluck-at) 2nip ; + +M:: empty-node (new-at) ( shift value key hashcode node -- node' added-leaf ) + value key hashcode dup ; + +M: empty-node >alist% drop ; + +M: empty-node hashcode>> drop 0 ; diff --git a/basis/persistent/hashtables/nodes/full/full.factor b/basis/persistent/hashtables/nodes/full/full.factor new file mode 100644 index 0000000000..e0fcc1a0ab --- /dev/null +++ b/basis/persistent/hashtables/nodes/full/full.factor @@ -0,0 +1,51 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: math accessors kernel arrays sequences sequences.private +locals sequences.lib +persistent.sequences +persistent.hashtables.config +persistent.hashtables.nodes ; +IN: persistent.hashtables.nodes.full + +M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf ) + [let* | nodes [ full-node nodes>> ] + idx [ hashcode full-node shift>> mask ] + n [ idx nodes nth-unsafe ] | + shift radix-bits + value key hashcode n (new-at) + [let | new-leaf [ ] n' [ ] | + n n' eq? [ + full-node + ] [ + n' idx nodes new-nth shift + ] if + new-leaf + ] + ] ; + +M:: full-node (pluck-at) ( key hashcode full-node -- node' ) + [let* | idx [ hashcode full-node shift>> mask ] + n [ idx full-node nodes>> nth ] + n' [ key hashcode n (pluck-at) ] | + n n' eq? [ + full-node + ] [ + n' [ + n' idx full-node nodes>> new-nth + full-node shift>> + + ] [ + hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand + idx full-node nodes>> remove-nth + full-node shift>> + + ] if + ] if + ] ; + +M:: full-node (entry-at) ( key hashcode full-node -- node' ) + key hashcode + hashcode full-node shift>> mask + full-node nodes>> nth-unsafe + (entry-at) ; + +M: full-node >alist% nodes>> >alist-each% ; diff --git a/basis/persistent/hashtables/nodes/leaf/leaf.factor b/basis/persistent/hashtables/nodes/leaf/leaf.factor new file mode 100644 index 0000000000..7fa4cfe401 --- /dev/null +++ b/basis/persistent/hashtables/nodes/leaf/leaf.factor @@ -0,0 +1,28 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: kernel accessors locals math arrays namespaces +persistent.hashtables.config +persistent.hashtables.nodes ; +IN: persistent.hashtables.nodes.leaf + +: matching-key? ( key hashcode leaf-node -- ? ) + tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline + +M: leaf-node (entry-at) [ matching-key? ] keep and ; + +M: leaf-node (pluck-at) [ matching-key? not ] keep and ; + +M:: leaf-node (new-at) ( shift value key hashcode leaf-node -- node' added-leaf ) + hashcode leaf-node hashcode>> eq? [ + key leaf-node key>> = [ + value leaf-node value>> = + [ leaf-node f ] [ value key hashcode f ] if + ] [ + [let | new-leaf [ value key hashcode ] | + hashcode leaf-node new-leaf 2array + new-leaf + ] + ] if + ] [ shift leaf-node value key hashcode make-bitmap-node ] if ; + +M: leaf-node >alist% [ key>> ] [ value>> ] bi 2array , ; diff --git a/basis/persistent/hashtables/nodes/nodes.factor b/basis/persistent/hashtables/nodes/nodes.factor new file mode 100644 index 0000000000..6201e68c6a --- /dev/null +++ b/basis/persistent/hashtables/nodes/nodes.factor @@ -0,0 +1,64 @@ +! Based on Clojure's PersistentHashMap by Rich Hickey. + +USING: math arrays kernel sequences sequences.lib +accessors locals persistent.hashtables.config ; +IN: persistent.hashtables.nodes + +SINGLETON: empty-node + +TUPLE: leaf-node +{ value read-only } +{ key read-only } +{ hashcode fixnum read-only } ; + +C: leaf-node + +TUPLE: collision-node +{ hashcode fixnum read-only } +{ leaves array read-only } ; + +C: collision-node + +TUPLE: full-node +{ nodes array read-only } +{ shift fixnum read-only } +{ hashcode fixnum read-only } ; + +: ( nodes shift -- node ) + over first hashcode>> full-node boa ; + +TUPLE: bitmap-node +{ bitmap fixnum read-only } +{ nodes array read-only } +{ shift fixnum read-only } +{ hashcode fixnum read-only } ; + +: ( bitmap nodes shift -- node ) + pick full-bitmap-mask = + [ nip ] + [ over first hashcode>> bitmap-node boa ] if ; + +GENERIC: (entry-at) ( key hashcode node -- entry ) + +GENERIC: (new-at) ( shift value key hashcode node -- node' added-leaf ) + +GENERIC: (pluck-at) ( key hashcode node -- node' ) + +GENERIC: >alist% ( node -- ) + +: >alist-each% ( nodes -- ) [ >alist% ] each ; + +: mask ( hash shift -- n ) neg shift radix-mask bitand ; inline + +: bitpos ( hash shift -- n ) mask 2^ ; inline + +: smash ( idx seq -- seq/elt ? ) + dup length 2 = [ [ 1 = ] dip first2 ? f ] [ remove-nth t ] if ; inline + +:: make-bitmap-node ( shift branch value key hashcode -- node' added-leaf ) + shift value key hashcode + branch hashcode>> shift bitpos + branch 1array + shift + + (new-at) ; inline diff --git a/basis/persistent/hashtables/summary.txt b/basis/persistent/hashtables/summary.txt new file mode 100644 index 0000000000..27321fa936 --- /dev/null +++ b/basis/persistent/hashtables/summary.txt @@ -0,0 +1 @@ +Persistent hashtables with O(1) insertion, removal and lookup diff --git a/extra/persistent-vectors/tags.txt b/basis/persistent/hashtables/tags.txt similarity index 100% rename from extra/persistent-vectors/tags.txt rename to basis/persistent/hashtables/tags.txt diff --git a/extra/persistent-heaps/authors.txt b/basis/persistent/heaps/authors.txt similarity index 100% rename from extra/persistent-heaps/authors.txt rename to basis/persistent/heaps/authors.txt diff --git a/extra/persistent-heaps/persistent-heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor similarity index 99% rename from extra/persistent-heaps/persistent-heaps-docs.factor rename to basis/persistent/heaps/heaps-docs.factor index d538fe88d4..dbfadc4ed2 100644 --- a/extra/persistent-heaps/persistent-heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel arrays assocs ; -IN: persistent-heaps +IN: persistent.heaps HELP: { $values { "heap" "a persistent heap" } } diff --git a/extra/persistent-heaps/persistent-heaps-tests.factor b/basis/persistent/heaps/heaps-tests.factor similarity index 82% rename from extra/persistent-heaps/persistent-heaps-tests.factor rename to basis/persistent/heaps/heaps-tests.factor index 6e559971a0..cecd6dab53 100644 --- a/extra/persistent-heaps/persistent-heaps-tests.factor +++ b/basis/persistent/heaps/heaps-tests.factor @@ -1,5 +1,5 @@ -USING: persistent-heaps tools.test ; -IN: persistent-heaps.tests +USING: persistent.heaps tools.test ; +IN: persistent.heaps.tests : test-input { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 } diff --git a/extra/persistent-heaps/persistent-heaps.factor b/basis/persistent/heaps/heaps.factor similarity index 99% rename from extra/persistent-heaps/persistent-heaps.factor rename to basis/persistent/heaps/heaps.factor index 5b57898da0..81c9959f84 100644 --- a/extra/persistent-heaps/persistent-heaps.factor +++ b/basis/persistent/heaps/heaps.factor @@ -1,6 +1,6 @@ USING: kernel accessors multi-methods locals combinators math arrays assocs namespaces sequences ; -IN: persistent-heaps +IN: persistent.heaps ! These are minheaps ERROR: empty-error pvec ; -GENERIC: ppush ( val seq -- seq' ) - -M: sequence ppush swap suffix ; - -GENERIC: ppop ( seq -- seq' ) - -M: sequence ppop 1 head* ; - -GENERIC: new-nth ( val i seq -- seq' ) - -M: sequence new-nth clone [ set-nth ] keep ; - TUPLE: persistent-vector { count fixnum } { root node initial: T{ node f { } 1 } } diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index cd67fd19d2..289581a929 100755 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -45,7 +45,7 @@ C: test-implementation } } { "IUnrelated" { [ swap x>> + ] ! IUnrelated::xPlus - [ spin x>> * + ] ! IUnrealted::xMulAdd + [ spin x>> * + ] ! IUnrelated::xMulAdd } } } dup +test-wrapper+ set [ diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 40c61dfbe7..782ebae516 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -1,11 +1,11 @@ -USING: alien alien.c-types windows.com.syntax +USING: alien alien.c-types windows.com.syntax init windows.com.syntax.private windows.com continuations kernel namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units -destructors fry math.parser generalizations ; +destructors fry math.parser generalizations sets ; IN: windows.com.wrapper -TUPLE: com-wrapper vtbls disposed ; +TUPLE: com-wrapper callbacks vtbls disposed ; malloc ( byte-array -- alien ) [ byte-length malloc ] [ over byte-array>memory ] bi ; : (callback-word) ( function-name interface-name counter -- word ) @@ -99,7 +103,7 @@ unless [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] dip compose ; -: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl ) +: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) (thunk) (thunked-quots) swap [ find-com-interface-definition family-tree-functions ] keep (next-vtbl-counter) '[ @@ -114,12 +118,12 @@ unless first2 (finish-thunk) ] bi* "stdcall" swap compile-alien-callback - ] 2map >c-void*-array - (byte-array-to-malloced-buffer) ; + ] 2map ; -: (make-vtbls) ( implementations -- vtbls ) +: (make-callbacks) ( implementations -- sequence ) dup [ first ] map (make-iunknown-methods) - [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ; + [ >r >r first2 r> r> swap (make-interface-callbacks) ] + curry map-index ; : (malloc-wrapped-object) ( wrapper -- wrapped-object ) vtbls>> length "void*" heap-size * @@ -127,13 +131,34 @@ unless over 1 0 rot set-ulong-nth ; +: (callbacks>vtbl) ( callbacks -- vtbl ) + [ execute ] map >c-void*-array byte-array>malloc ; +: (callbacks>vtbls) ( callbacks -- vtbls ) + [ (callbacks>vtbl) ] map ; + +: (allocate-wrapper) ( wrapper -- ) + dup callbacks>> (callbacks>vtbls) >>vtbls + f >>disposed drop ; + +: (init-hook) ( -- ) + +live-wrappers+ get-global [ (allocate-wrapper) ] each + H{ } +wrapped-objects+ set-global ; + +[ (init-hook) ] "windows.com.wrapper" add-init-hook + PRIVATE> +: allocate-wrapper ( wrapper -- ) + [ (allocate-wrapper) ] + [ +live-wrappers+ get adjoin ] bi ; + : ( implementations -- wrapper ) - (make-vtbls) f com-wrapper boa ; + (make-callbacks) f f com-wrapper boa + dup allocate-wrapper ; M: com-wrapper dispose* - vtbls>> [ free ] each ; + [ [ free ] each f ] change-vtbls + +live-wrappers+ get-global delete ; : com-wrap ( object wrapper -- wrapped-object ) [ vtbls>> ] [ (malloc-wrapped-object) ] bi diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 237438e69a..697f3d81be 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -212,7 +212,7 @@ HELP: bit? HELP: log2 { $values { "x" "a positive integer" } { "n" integer } } -{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than " { $snippet "x" } "." } +{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than or equal to " { $snippet "x" } "." } { $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ; HELP: 1+ diff --git a/extra/animations/animations-docs.factor b/extra/animations/animations-docs.factor new file mode 100644 index 0000000000..6a1e89a28e --- /dev/null +++ b/extra/animations/animations-docs.factor @@ -0,0 +1,34 @@ +USING: help.markup help.syntax ; +IN: extra.animations + +HELP: animate ( quot duration -- ) +{ $values + { "quot" "a quot which uses " { $link progress } } + { "duration" "a duration of time" } +} +{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once." } +{ $example + "USING: extra.animations calendar threads prettyprint ;" + "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;" + "46 ms elapsed\n17 ms elapsed" +} ; + +HELP: reset-progress ( -- ) +{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ; + +HELP: progress ( -- time ) +{ $values { "time" "an integer" } } +{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." } +{ $example + "USING: extra.animations threads prettyprint ;" + "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;" + "31 ms elapsed\n18 ms elapsed\n16 ms elapsed" +} ; + +ARTICLE: "extra.animations" "Animations" +"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!" +{ $subsection animate } +{ $subsection reset-progress } +{ $subsection progress } +{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ; +ABOUT: "extra.animations" \ No newline at end of file diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor new file mode 100644 index 0000000000..7efd618bbf --- /dev/null +++ b/extra/animations/animations.factor @@ -0,0 +1,12 @@ +! Small library for cross-platform continuous functions of real time + +USING: kernel shuffle system locals +prettyprint math io namespaces threads calendar ; +IN: extra.animations + +SYMBOL: last-loop +: reset-progress ( -- ) millis last-loop set ; +: progress ( -- progress ) millis last-loop get - reset-progress ; +: set-end ( duration -- end-time ) dt>milliseconds millis + ; +: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; +: animate ( quot duration -- ) reset-progress set-end loop ; \ No newline at end of file diff --git a/extra/animations/authors.txt b/extra/animations/authors.txt new file mode 100644 index 0000000000..dac0cb42fe --- /dev/null +++ b/extra/animations/authors.txt @@ -0,0 +1 @@ +Reginald Keith Ford II \ No newline at end of file diff --git a/extra/boolean-expr/tags.txt b/extra/boolean-expr/tags.txt index cb5fc203e1..8b13789179 100644 --- a/extra/boolean-expr/tags.txt +++ b/extra/boolean-expr/tags.txt @@ -1 +1 @@ -demos + diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index 8285cd776f..e481b47161 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,6 +1,6 @@ USING: arrays bunny.model continuations destructors kernel multiline opengl opengl.shaders opengl.capabilities opengl.gl -sequences sequences.lib accessors ; +sequences sequences.lib accessors combinators ; IN: bunny.cel-shaded STRING: vertex-shader-source @@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ; ] [ f ] if ; : (draw-cel-shaded-bunny) ( geom program -- ) - { - { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } - { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } - { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } - { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } - { "shininess" [ 100.0 glUniform1f ] } - } [ bunny-geom ] with-gl-program ; + [ + { + [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ] + [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] + [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] + [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] + [ "shininess" glGetUniformLocation 100.0 glUniform1f ] + } cleave bunny-geom + ] with-gl-program ; M: bunny-cel-shaded draw-bunny program>> (draw-cel-shaded-bunny) ; diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index fcba98a0e9..bf757c4fb3 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -220,13 +220,14 @@ TUPLE: bunny-outlined [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] [ - pass2-program>> { - { "colormap" [ 0 glUniform1i ] } - { "normalmap" [ 1 glUniform1i ] } - { "depthmap" [ 2 glUniform1i ] } - { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } - } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] - with-gl-program + pass2-program>> [ + { + [ "colormap" glGetUniformLocation 0 glUniform1i ] + [ "normalmap" glGetUniformLocation 1 glUniform1i ] + [ "depthmap" glGetUniformLocation 2 glUniform1i ] + [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ] + } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices + ] with-gl-program ] } cleave ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index d821b7c180..114ebf5445 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -4,7 +4,8 @@ USING: kernel alien.c-types combinators namespaces arrays math math.functions math.vectors math.trig opengl.gl opengl.glu opengl ui ui.gadgets.slate vars colors self self.slots - random-weighted colors.hsv cfdg.gl accessors ; + random-weighted colors.hsv cfdg.gl accessors + ui.gadgets.handler ui.gestures assocs ui.gadgets macros ; IN: cfdg @@ -130,12 +131,31 @@ VAR: threshold ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: recursive ( quot -- ) iterate? swap when ; +: recursive ( quot -- ) iterate? swap when ; inline : multi ( seq -- ) random-weighted* call ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: [rules] ( seq -- quot ) + [ unclip swap [ [ do ] curry ] map concat 2array ] map + [ call-random-weighted ] swap prefix + [ when ] swap prefix + [ iterate? ] swap append ; + +MACRO: rules ( seq -- quot ) [rules] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: [rule] ( seq -- quot ) + [ [ do ] swap prefix ] map concat + [ when ] swap prefix + [ iterate? ] prepend ; + +MACRO: rule ( seq -- quot ) [rule] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: background : set-initial-background ( -- ) T{ hsva f 0 0 1 1 } clone >self ; @@ -155,6 +175,28 @@ VAR: start-shape : set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: dlist + +! : build-model-dlist ( -- ) +! 1 glGenLists dlist set +! dlist get GL_COMPILE_AND_EXECUTE glNewList +! start-shape> call +! glEndList ; + +: build-model-dlist ( -- ) + 1 glGenLists dlist set + dlist get GL_COMPILE_AND_EXECUTE glNewList + + set-initial-color + + self> set-color + + start-shape> call + + glEndList ; + : display ( -- ) GL_PROJECTION glMatrixMode @@ -172,15 +214,43 @@ VAR: start-shape init-modelview-matrix-stack init-color-stack - set-initial-color + dlist get not + [ build-model-dlist ] + [ dlist get glCallList ] + if ; - self> set-color +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - start-shape> call ; +: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ; : cfdg-window* ( -- ) - [ display ] closed-quot - { 500 500 } over set-slate-pdim + C[ display ] + { 500 500 } >>pdim + C[ delete-dlist ] >>ungraft dup "CFDG" open-window ; -: cfdg-window ( -- ) [ cfdg-window* ] with-ui ; \ No newline at end of file +: cfdg-window ( -- ) [ cfdg-window* ] with-ui ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: the-slate + +: rebuild ( -- ) delete-dlist the-slate get relayout-1 ; + +: ( -- slate ) + C[ display ] + dup the-slate set + { 500 500 } >>pdim + C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft + + H{ } clone + T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at + T{ button-down } C[ drop rebuild ] swap pick set-at + >>table ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: fry + +: cfdg-window. ( quot -- ) + '[ [ @ "CFDG" open-window ] with-scope ] with-ui ; \ No newline at end of file diff --git a/extra/cfdg/models/aqua-star/aqua-star.factor b/extra/cfdg/models/aqua-star/aqua-star.factor index f692328515..dbb7eb5ed0 100644 --- a/extra/cfdg/models/aqua-star/aqua-star.factor +++ b/extra/cfdg/models/aqua-star/aqua-star.factor @@ -25,11 +25,12 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ -1 b ] >background -{ -60 140 -120 140 } viewport set -0.1 threshold set -[ anemone-begin ] start-shape set -cfdg-window ; +: init ( -- ) + [ -1 b ] >background + { -60 140 -120 140 } >viewport + 0.1 >threshold + [ anemone-begin ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index 31f78c459e..d0474cdcb4 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -5,35 +5,34 @@ USING: kernel namespaces sequences math IN: cfdg.models.chiaroscuro +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DEFER: white -: black ( -- ) iterate? [ - { { 60 [ [ 0.6 s circle ] do - [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } - { 1 [ white black ] } } - call-random-weighted -] when ; +: black ( -- ) + { + { 60 [ 0.6 s circle ] [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] } + { 1 [ white black ] } + } + rules ; -: white ( -- ) iterate? [ - { { 60 [ - [ 0.6 s circle ] do - [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do - ] } - { 1 [ - black white - ] } } - call-random-weighted -] when ; +: white ( -- ) + { + { 60 [ 0.6 s circle ] [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] } + { 1 [ black white ] } + } + rules ; -: chiaroscuro ( -- ) [ 0.5 b black ] do ; +: chiaroscuro ( -- ) { [ 0.5 b black ] } rule ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ -0.5 b ] >background -{ -3 6 -2 6 } viewport set -0.01 threshold set -[ chiaroscuro ] start-shape set -cfdg-window ; +: init ( -- ) + [ -0.5 b ] >background + { -3 6 -2 6 } >viewport + 0.03 >threshold + [ chiaroscuro ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/flower6/flower6.factor b/extra/cfdg/models/flower6/flower6.factor index b77968c863..91fecd7fe5 100644 --- a/extra/cfdg/models/flower6/flower6.factor +++ b/extra/cfdg/models/flower6/flower6.factor @@ -18,12 +18,13 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -1 2 -1 2 } viewport set -0.01 threshold set -[ flower6 ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -1 2 -1 2 } >viewport + 0.01 >threshold + [ flower6 ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor index 0cd65242fb..3e0994112a 100644 --- a/extra/cfdg/models/game1-turn6/game1-turn6.factor +++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor @@ -37,11 +37,12 @@ DEFER: start ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ 66 hue 0.4 sat 0.5 b ] >background -{ -5 10 -5 10 } viewport set -0.001 >threshold -[ start ] >start-shape -cfdg-window ; +: init ( -- ) + [ 66 hue 0.4 sat 0.5 b ] >background + { -5 10 -5 10 } >viewport + 0.001 >threshold + [ start ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/lesson/lesson.factor b/extra/cfdg/models/lesson/lesson.factor index 287e572929..5902c121ae 100644 --- a/extra/cfdg/models/lesson/lesson.factor +++ b/extra/cfdg/models/lesson/lesson.factor @@ -96,12 +96,13 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -5 25 -15 25 } viewport set -0.03 threshold set -[ toc ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -5 25 -15 25 } >viewport + 0.03 >threshold + [ toc ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/rules08/rules08.factor b/extra/cfdg/models/rules08/rules08.factor index d14aa04fb1..20099d225a 100644 --- a/extra/cfdg/models/rules08/rules08.factor +++ b/extra/cfdg/models/rules08/rules08.factor @@ -51,12 +51,13 @@ DEFER: line ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) +: init ( -- ) [ -1 b ] >background { -20 40 -20 40 } viewport set [ centre ] >start-shape - 0.0001 >threshold - cfdg-window ; + 0.0001 >threshold ; + +: run ( -- ) [ init ] cfdg-window. ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cfdg/models/sierpinski/sierpinski.factor b/extra/cfdg/models/sierpinski/sierpinski.factor index 1acee8309a..2333506f29 100644 --- a/extra/cfdg/models/sierpinski/sierpinski.factor +++ b/extra/cfdg/models/sierpinski/sierpinski.factor @@ -26,14 +26,12 @@ iterate? [ ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -4 8 -4 8 } viewport set -0.01 >threshold -[ top ] >start-shape -cfdg-window ; - -MAIN: run - +: init ( -- ) + [ ] >background + { -4 8 -4 8 } >viewport + 0.01 >threshold + [ top ] >start-shape ; +: run ( -- ) [ init ] cfdg-window. ; +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/snowflake/snowflake.factor b/extra/cfdg/models/snowflake/snowflake.factor index 951f449e68..9efb3352fa 100644 --- a/extra/cfdg/models/snowflake/snowflake.factor +++ b/extra/cfdg/models/snowflake/snowflake.factor @@ -25,12 +25,13 @@ spike ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run ( -- ) -[ ] >background -{ -40 80 -40 80 } viewport set -0.1 threshold set -[ snowflake ] start-shape set -cfdg-window ; +: init ( -- ) + [ ] >background + { -40 80 -40 80 } >viewport + 0.1 >threshold + [ snowflake ] >start-shape ; + +: run ( -- ) [ init ] cfdg-window. ; MAIN: run diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor new file mode 100644 index 0000000000..985c21643e --- /dev/null +++ b/extra/cfdg/models/spirales/spirales.factor @@ -0,0 +1,42 @@ + +USING: namespaces sequences math random-weighted cfdg ; + +IN: cfdg.models.spirales + +DEFER: line + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: block ( -- ) + [ + [ circle ] do + [ 0.3 s 60 flip line ] do + ] + recursive ; + +: a1 ( -- ) + [ + [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do + [ block ] do + ] + recursive ; + +: line ( -- ) + -0.3 a + [ 0 rotate a1 ] do + [ 120 rotate a1 ] do + [ 240 rotate a1 ] do ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: init ( -- ) + [ -1 b ] >background + { -20 40 -20 40 } viewport set + [ line ] >start-shape + 0.03 >threshold ; + +: run ( -- ) [ init ] cfdg-window. ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/spirales/tags.txt b/extra/cfdg/models/spirales/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/spirales/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/csv/csv.factor b/extra/csv/csv.factor index 3d1fb64492..9779c37ed4 100644 --- a/extra/csv/csv.factor +++ b/extra/csv/csv.factor @@ -4,12 +4,16 @@ ! Simple CSV Parser ! Phil Dawes phil@phildawes.net -USING: kernel sequences io namespaces combinators unicode.categories vars ; +USING: kernel sequences io namespaces combinators unicode.categories ; IN: csv -DEFER: quoted-field +SYMBOL: delimiter -VAR: delimiter +CHAR: , delimiter set-global + +: delimiter> delimiter get ; inline + +DEFER: quoted-field ( -- endchar ) ! trims whitespace from either end of string : trim-whitespace ( str -- str ) @@ -44,7 +48,7 @@ VAR: delimiter : (row) ( -- sep ) field , - dup delimiter> = [ drop (row) ] when ; + dup delimiter get = [ drop (row) ] when ; : row ( -- eof? array[string] ) [ (row) ] { } make ; @@ -55,25 +59,18 @@ VAR: delimiter : (csv) ( -- ) row append-if-row-not-empty [ (csv) ] when ; - -: init-vars ( -- ) - delimiter> [ CHAR: , >delimiter ] unless ; inline : csv-row ( stream -- row ) - init-vars [ row nip ] with-input-stream ; : csv ( stream -- rows ) - init-vars [ [ (csv) ] { } make ] with-input-stream ; : with-delimiter ( char quot -- ) delimiter swap with-variable ; inline - - : needs-escaping? ( cell -- ? ) - [ "\n\"" delimiter> suffix member? ] contains? ; inline ! " + [ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! " : escape-quotes ( cell -- cell' ) [ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline @@ -85,8 +82,7 @@ VAR: delimiter dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline : write-row ( row -- ) - [ delimiter> write1 ] [ escape-if-required write ] interleave nl ; inline + [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline : write-csv ( rows outstream -- ) - init-vars [ [ write-row ] each ] with-output-stream ; diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor index c8e5a35f9e..40149bafa9 100644 --- a/extra/demos/demos.factor +++ b/extra/demos/demos.factor @@ -10,7 +10,7 @@ IN: demos : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ; : ( vocab-name -- button ) - dup '[ drop [ , run ] call-listener ] ; + dup '[ drop [ , run ] call-listener ] { 0 0 } >>align ; : ( -- gadget ) 1 >>fill demo-vocabs [ add-gadget ] each ; diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index 451bbf1c34..a31b9d6649 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -1,8 +1,19 @@ -USING: kernel system combinators parser ; +USING: multiline system parser combinators ; IN: game-input.backend -<< { - { [ os macosx? ] [ "game-input.backend.iokit" use+ ] } - { [ os windows? ] [ "game-input.backend.dinput" use+ ] } +STRING: set-backend-for-macosx +USING: namespaces game-input.backend.iokit game-input ; +iokit-game-input-backend game-input-backend set-global +; + +STRING: set-backend-for-windows +USING: namespaces game-input.backend.dinput game-input ; +dinput-game-input-backend game-input-backend set-global +; + +{ + { [ os macosx? ] [ set-backend-for-macosx eval ] } + { [ os windows? ] [ set-backend-for-windows eval ] } { [ t ] [ ] } -} cond >> +} cond + diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 69b2d41962..73c9f511a1 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input) close-device-change-window delete-dinput ; +M: dinput-game-input-backend (reset-game-input) + { + +dinput+ +keyboard-device+ +keyboard-state+ + +controller-devices+ +controller-guids+ + +device-change-window+ +device-change-handle+ + } [ f swap set-global ] each ; + M: dinput-game-input-backend get-controllers +controller-devices+ get [ drop controller boa ] { } assoc>map ; @@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; - -dinput-game-input-backend game-input-backend set-global diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index 1871569227..dcdfa6d192 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input) ] } cleave ; +M: iokit-game-input-backend (reset-game-input) + { +hid-manager+ +keyboard-state+ +controller-states+ } + [ f swap set-global ] each ; + M: iokit-game-input-backend (close-game-input) +hid-manager+ get-global [ +hid-manager+ global [ @@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) M: iokit-game-input-backend calibrate-controller ( controller -- ) drop ; - -iokit-game-input-backend game-input-backend set-global diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 4d25b06ead..208c8476fc 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -1,26 +1,34 @@ USING: arrays accessors continuations kernel symbols -combinators.lib sequences namespaces init ; +combinators.lib sequences namespaces init vocabs ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) +HOOK: (reset-game-input) game-input-backend ( -- ) : game-input-opened? ( -- ? ) game-input-opened get ; - : open-game-input ( -- ) + load-game-input-backend game-input-opened? [ (open-game-input) game-input-opened on diff --git a/extra/html/streams/streams-tests.factor b/extra/html/streams/streams-tests.factor index 14f1621346..948c998e13 100644 --- a/extra/html/streams/streams-tests.factor +++ b/extra/html/streams/streams-tests.factor @@ -1,6 +1,8 @@ + USING: html.streams html.streams.private -io io.streams.string io.styles kernel -namespaces tools.test xml.writer sbufs sequences inspector ; + io io.streams.string io.styles kernel + namespaces tools.test xml.writer sbufs sequences inspector colors ; + IN: html.streams.tests : make-html-string @@ -52,7 +54,7 @@ M: funky browser-link-href [ [ "car" - H{ { foreground { 1 0 1 1 } } } + H{ { foreground T{ rgba f 1 0 1 1 } } } format ] make-html-string ] unit-test @@ -60,7 +62,7 @@ M: funky browser-link-href [ "
cdr
" ] [ [ - H{ { page-color { 1 0 1 1 } } } + H{ { page-color T{ rgba f 1 0 1 1 } } } [ "cdr" write ] with-nesting ] make-html-string ] unit-test diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor index eae13f53ad..d21c743dcd 100755 --- a/extra/html/streams/streams.factor +++ b/extra/html/streams/streams.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.order math.parser namespaces -quotations assocs sequences strings words html.elements -xml.entities sbufs continuations destructors accessors ; + +USING: combinators generic assocs help http io io.styles io.files + continuations io.streams.string kernel math math.order math.parser + namespaces quotations assocs sequences strings words html.elements + xml.entities sbufs continuations destructors accessors arrays ; + IN: html.streams GENERIC: browser-link-href ( presented -- href ) @@ -47,9 +49,9 @@ TUPLE: html-sub-stream < html-stream style parent ; ] [ call ] if* ] [ call ] if* ; inline -: hex-color, ( triplet -- ) - 3 head-slice - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; +: hex-color, ( color -- ) + [ red>> ] [ green>> ] [ blue>> ] tri + [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index d899b75d8d..a524168d54 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -3,12 +3,13 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables colors + sorting qualified unicode.collation math.order ui ui.gadgets ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations irc.client irc.client.private irc.messages irc.messages.private - irc.ui.commandparser irc.ui.load qualified ; + irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -75,6 +76,14 @@ M: quit write-irc " has left IRC" dark-red write-color trailing>> dot-or-parens dark-red write-color ; +M: kick write-irc + "* " dark-red write-color + [ prefix>> parse-name write ] keep + " has kicked " dark-red write-color + [ who>> write ] keep + " from the channel" dark-red write-color + trailing>> dot-or-parens dark-red write-color ; + : full-mode ( message -- mode ) parameters>> rest " " sjoin ; @@ -86,6 +95,12 @@ M: mode write-irc " to " blue write-color channel>> write ; +M: nick write-irc + "* " blue write-color + [ prefix>> parse-name write ] keep + " is now known as " blue write-color + trailing>> write ; + M: unhandled write-irc "UNHANDLED: " write line>> blue write-color ; @@ -118,15 +133,18 @@ M: irc-message write-irc GENERIC: handle-inbox ( tab message -- ) -: filter-participants ( pack alist val color -- pack ) - '[ , = [