diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index 9c5f40d883..02e0e45544 100755 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private math math.private sequences -sequences.private ; +USING: accessors kernel kernel.private math math.private +sequences sequences.private ; IN: arrays M: array clone (clone) ; -M: array length array-capacity ; +M: array length length>> ; M: array nth-unsafe >r >fixnum r> array-nth ; M: array set-nth-unsafe >r >fixnum r> set-array-nth ; M: array resize resize-array ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6cb8958298..b613147f29 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -84,7 +84,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) ] [ 3dup nth-unsafe at* [ >r 3drop r> ] [ drop >r 1- r> (assoc-stack) ] if - ] if ; inline + ] if ; inline recursive : assoc-stack ( key seq -- value ) dup length 1- swap (assoc-stack) ; @@ -158,6 +158,9 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : zip ( keys values -- alist ) 2array flip ; inline +: unzip ( assoc -- keys values ) + dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ; + : search-alist ( key alist -- pair i ) [ first = ] with find swap ; inline diff --git a/core/binary-search/binary-search-docs.factor b/core/binary-search/binary-search-docs.factor new file mode 100644 index 0000000000..db442a9ac8 --- /dev/null +++ b/core/binary-search/binary-search-docs.factor @@ -0,0 +1,43 @@ +IN: binary-search +USING: help.markup help.syntax sequences kernel math.order ; + +ARTICLE: "binary-search" "Binary search" +"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." +{ $subsection search } +"Variants of sequence words optimized for sorted sequences:" +{ $subsection sorted-index } +{ $subsection sorted-member? } +{ $subsection sorted-memq? } +{ $see-also "order-specifiers" "sequences-sorting" } ; + +ABOUT: "binary-search" + +HELP: search +{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." +$nl +"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." +$nl +"If the sequence is empty, outputs " { $link f } " " { $link f } "." } +{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ; + +{ find find-from find-last find-last find-last-from search } related-words + +HELP: sorted-index +{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } +{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ; + +{ index index-from last-index last-index-from sorted-index } related-words + +HELP: sorted-member? +{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ; + +{ member? sorted-member? } related-words + +HELP: sorted-memq? +{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ; + +{ memq? sorted-memq? } related-words diff --git a/core/binary-search/binary-search-tests.factor b/core/binary-search/binary-search-tests.factor new file mode 100644 index 0000000000..77b1c16505 --- /dev/null +++ b/core/binary-search/binary-search-tests.factor @@ -0,0 +1,17 @@ +IN: binary-search.tests +USING: binary-search math.order vectors kernel tools.test ; + +\ sorted-member? must-infer + +[ f ] [ 3 { } [ <=> ] with search drop ] unit-test +[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test +[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test +[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test +[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test +[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test +[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test + +[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test +[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test +[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test +[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test diff --git a/core/binary-search/binary-search.factor b/core/binary-search/binary-search.factor new file mode 100644 index 0000000000..2863944c8b --- /dev/null +++ b/core/binary-search/binary-search.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private accessors math +math.order combinators ; +IN: binary-search + + ) + [ midpoint swap call ] 2keep rot ; inline + +: finish ( quot slice -- i elt ) + [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi + [ drop ] [ dup ] [ ] tri* nth ; inline + +: (search) ( quot: ( elt -- <=> ) seq -- i elt ) + dup length 1 <= [ + finish + ] [ + decide { + { +eq+ [ finish ] } + { +lt+ [ dup midpoint@ head-slice (search) ] } + { +gt+ [ dup midpoint@ tail-slice (search) ] } + } case + ] if ; inline recursive + +PRIVATE> + +: search ( seq quot -- i elt ) + over empty? [ 2drop f f ] [ swap (search) ] if ; + inline + +: natural-search ( obj seq -- i elt ) + [ <=> ] with search ; + +: sorted-index ( obj seq -- i ) + natural-search drop ; + +: sorted-member? ( obj seq -- ? ) + dupd natural-search nip = ; + +: sorted-memq? ( obj seq -- ? ) + dupd natural-search nip eq? ; diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 04e53046fe..f25eafeb17 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -37,7 +37,7 @@ nl array? hashtable? vector? tuple? sbuf? node? tombstone? - array-capacity array-nth set-array-nth + array-nth set-array-nth wrap probe diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index b2b6dc4e59..b512ea6380 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -6,7 +6,8 @@ sequences strings vectors words quotations assocs layouts classes classes.builtin classes.tuple classes.tuple.private kernel.private vocabs vocabs.loader source-files definitions slots classes.union classes.intersection classes.predicate -compiler.units bootstrap.image.private io.files accessors combinators ; +compiler.units bootstrap.image.private io.files accessors +combinators ; IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush @@ -225,7 +226,9 @@ bi { "imaginary" { "real" "math" } read-only } } define-builtin -"array" "arrays" create { } define-builtin +"array" "arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "wrapper" "kernel" create { { "wrapped" read-only } @@ -261,7 +264,9 @@ bi { "sub-primitive" read-only } } define-builtin -"byte-array" "byte-arrays" create { } define-builtin +"byte-array" "byte-arrays" create { + { "length" { "array-capacity" "sequences.private" } read-only } +} define-builtin "callstack" "kernel" create { } define-builtin @@ -306,9 +311,12 @@ tuple } prepare-slots define-tuple-class "curry" "kernel" lookup -[ f "inline" set-word-prop ] -[ ] -[ tuple-layout [ ] curry ] tri +{ + [ f "inline" set-word-prop ] + [ make-flushable ] + [ ] + [ tuple-layout [ ] curry ] +} cleave (( obj quot -- curry )) define-declared "compose" "kernel" create @@ -319,9 +327,12 @@ tuple } prepare-slots define-tuple-class "compose" "kernel" lookup -[ f "inline" set-word-prop ] -[ ] -[ tuple-layout [ ] curry ] tri +{ + [ f "inline" set-word-prop ] + [ make-flushable ] + [ ] + [ tuple-layout [ ] curry ] +} cleave (( quot1 quot2 -- compose )) define-declared ! Sub-primitive words diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 64402ca2e1..5c55bb15ca 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,7 +32,6 @@ load-help? off "libc" require "io.streams.c" require - "io.thread" require "vocabs.loader" require "syntax" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 3b98e89095..c6afdfe749 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -56,6 +56,8 @@ parse-command-line "-no-crossref" cli-args member? [ do-crossref ] unless +"io.thread" require + ! Set dll paths os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 940b8ba57d..e7dd333ed8 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -59,6 +59,7 @@ IN: bootstrap.syntax "flushable" "foldable" "inline" + "recursive" "parsing" "t" "{" diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index d603470810..5461da2b84 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien.accessors sequences +USING: accessors kernel kernel.private alien.accessors sequences sequences.private math ; IN: byte-arrays M: byte-array clone (clone) ; -M: byte-array length array-capacity ; +M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 17d8e36935..4216a5dc3d 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -91,7 +91,7 @@ ERROR: bad-superclass class ; #! 4 slot == superclasses>> rot dup tuple? [ layout-of 4 slot - 2dup array-capacity fixnum< + 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if ] [ 3drop f ] if ; inline diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 0e04042bea..10324224b6 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -90,10 +90,10 @@ ERROR: no-case ; : ( initial length -- array ) next-power-of-2 swap [ nip clone ] curry map ; -: distribute-buckets ( assoc initial quot -- buckets ) - spin [ length ] keep - [ >r 2dup r> dup first roll call (distribute-buckets) ] each - nip ; inline +: distribute-buckets ( alist initial quot -- buckets ) + swapd [ >r dup first r> call 2array ] curry map + [ length dup ] keep + [ first2 (distribute-buckets) ] with each ; inline : hash-case-table ( default assoc -- array ) V{ } [ 1array ] distribute-buckets diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 3b1a5c6c85..1085feb0c6 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -30,10 +30,3 @@ words splitting grouping sorting ; \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test - -: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ; - -[ t ] [ - [ 10 quux ] ignore-errors - \ sort stack-trace-contains? -] unit-test diff --git a/core/dequeues/dequeues.factor b/core/dequeues/dequeues.factor index 67c87d79c3..ae55c57fe5 100644 --- a/core/dequeues/dequeues.factor +++ b/core/dequeues/dequeues.factor @@ -37,8 +37,7 @@ GENERIC: node-value ( node -- value ) [ peek-back ] [ pop-back* ] bi ; : slurp-dequeue ( dequeue quot -- ) - over dequeue-empty? [ 2drop ] [ - [ [ pop-back ] dip call ] [ slurp-dequeue ] 2bi - ] if ; inline + [ drop [ dequeue-empty? not ] curry ] + [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline MIXIN: dequeue diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 0095734e63..370ec4042f 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -48,11 +48,11 @@ M: dlist-node node-value obj>> ; : set-front-to-back ( dlist -- ) dup front>> [ dup back>> >>front ] unless drop ; -: (dlist-find-node) ( dlist-node quot -- node/f ? ) +: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? ) over [ [ call ] 2keep rot [ drop t ] [ >r next>> r> (dlist-find-node) ] if - ] [ 2drop f f ] if ; inline + ] [ 2drop f f ] if ; inline recursive : dlist-find-node ( dlist quot -- node/f ? ) >r front>> r> (dlist-find-node) ; inline diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 6aee6fbcb2..c221ad073b 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs -combinators accessors ; +combinators accessors arrays ; IN: effects TUPLE: effect in out terminated? ; @@ -22,15 +22,16 @@ TUPLE: effect in out terminated? ; [ t ] } cond 2nip ; -GENERIC: (stack-picture) ( obj -- str ) -M: string (stack-picture) ; -M: word (stack-picture) name>> ; -M: integer (stack-picture) drop "object" ; +GENERIC: effect>string ( obj -- str ) +M: string effect>string ; +M: word effect>string name>> ; +M: integer effect>string drop "object" ; +M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; : stack-picture ( seq -- string ) - [ [ (stack-picture) % CHAR: \s , ] each ] "" make ; + [ [ effect>string % CHAR: \s , ] each ] "" make ; -: effect>string ( effect -- string ) +M: effect effect>string ( effect -- string ) [ "( " % [ in>> stack-picture % "-- " % ] @@ -51,6 +52,9 @@ M: word stack-effect M: effect clone [ in>> clone ] [ out>> clone ] bi ; +: stack-height ( word -- n ) + stack-effect effect-height ; + : split-shuffle ( stack shuffle -- stack1 stack2 ) in>> length cut* ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 8f28450de7..93401d321c 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,15 +1,31 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: lexer sets sequences kernel splitting effects ; +USING: lexer sets sequences kernel splitting effects summary +combinators debugger arrays parser ; IN: effects.parser -: parse-effect ( end -- effect ) - parse-tokens dup { "(" "((" } intersect empty? [ - { "--" } split1 dup [ - - ] [ - "Stack effect declaration must contain --" throw +DEFER: parse-effect + +ERROR: bad-effect ; + +M: bad-effect summary + drop "Bad stack effect declaration" ; + +: parse-effect-token ( end -- token/f ) + scan tuck = [ drop f ] [ + dup { f "(" "((" } member? [ bad-effect ] [ + ":" ?tail [ + scan-word { + { \ ( [ ")" parse-effect ] } + [ ] + } case 2array + ] when ] if - ] [ - "Stack effect declaration must not contain ( or ((" throw ] if ; + +: parse-effect-tokens ( end -- tokens ) + [ parse-effect-token dup ] curry [ ] [ drop ] produce ; + +: parse-effect ( end -- effect ) + parse-effect-tokens { "--" } split1 dup + [ ] [ "Stack effect declaration must contain --" throw ] if ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3aecd4825e..a621c7fa91 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -77,6 +77,9 @@ TUPLE: check-method class generic ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; +M: method-body inline? + "method-generic" word-prop inline? ; + M: method-body stack-effect "method-generic" word-prop stack-effect ; diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 6f1773a21f..325f2ebb39 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -64,6 +64,9 @@ M: engine-word stack-effect [ extra-values ] [ stack-effect ] bi dup [ clone [ length + ] change-in ] [ 2drop f ] if ; +M: engine-word inline? + "tuple-dispatch-generic" word-prop inline? ; + M: engine-word crossref? "forgotten" word-prop not ; M: engine-word irrelevant? drop t ; diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor index 792b2ab340..f2003641de 100644 --- a/core/graphs/graphs.factor +++ b/core/graphs/graphs.factor @@ -37,14 +37,14 @@ SYMBOL: graph SYMBOL: previous -: (closure) ( obj quot -- ) +: (closure) ( obj quot: ( elt -- assoc ) -- ) over previous get key? [ 2drop ] [ over previous get conjoin dup slip [ nip (closure) ] curry assoc-each - ] if ; inline + ] if ; inline recursive : closure ( obj quot -- assoc ) H{ } clone [ diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index e804bb76fa..32fda7d2fb 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -12,7 +12,7 @@ TUPLE: hashtable > 1 fixnum-fast fixnum-bitand ; inline : hash@ ( key array -- i ) >r hashcode >fixnum dup fixnum+fast r> wrap ; inline @@ -27,10 +27,10 @@ TUPLE: hashtable dup ((empty)) eq? [ 3drop no-key ] [ = [ rot drop t ] [ probe (key@) ] if - ] if ; inline + ] if ; inline recursive : key@ ( key hash -- array n ? ) - array>> dup array-capacity 0 eq? + array>> dup length>> 0 eq? [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) @@ -51,7 +51,7 @@ TUPLE: hashtable ] [ probe (new-key@) ] if - ] if ; inline + ] if ; inline recursive : new-key@ ( key hash -- array n empty? ) array>> 2dup hash@ (new-key@) ; inline @@ -71,7 +71,7 @@ TUPLE: hashtable : hash-large? ( hash -- ? ) [ count>> 3 fixnum*fast 1 fixnum+fast ] - [ array>> array-capacity ] bi fixnum> ; inline + [ array>> length>> ] bi fixnum> ; inline : hash-stale? ( hash -- ? ) [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index b4a533597c..0543159903 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -365,7 +365,8 @@ TUPLE: unbalanced-branches-error quots in out ; [ unify-effects ] [ unify-dataflow ] bi ; inline : infer-branches ( last branches node -- ) - #! last is a quotation which provides a #return or a #values + #! last -> #return or #values + #! node -> #if or #dispatch 1 reify-curries call dup node, pop-d drop diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 7be70f1ad4..a133f008e4 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -620,6 +620,8 @@ TUPLE: declared-fixnum { x fixnum } ; [ { ascii } declare decode-char ] \ decode-char inlined? ] unit-test +[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test + ! Later ! [ t ] [ diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 734c1c551c..1438353893 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -144,7 +144,8 @@ TUPLE: #dispatch < #branch ; : #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ; -TUPLE: #merge < node ; +! Phi node: merging is a sequence of sequences of values +TUPLE: #merge < node merging ; : #merge ( -- node ) \ #merge all-out-node ; @@ -191,7 +192,7 @@ TUPLE: #declare < node ; : #drop ( n -- #shuffle ) d-tail flatten-curries \ #shuffle in-node ; -: node-exists? ( node quot -- ? ) +: node-exists? ( node quot: ( node -- ? ) -- ? ) over [ 2dup 2slip rot [ 2drop t @@ -201,7 +202,7 @@ TUPLE: #declare < node ; ] if ] [ 2drop f - ] if ; inline + ] if ; inline recursive GENERIC: calls-label* ( label node -- ? ) @@ -223,21 +224,21 @@ SYMBOL: node-stack : iterate-next ( -- node ) node@ successor>> ; -: iterate-nodes ( node quot -- ) +: iterate-nodes ( node quot: ( -- ) -- ) over [ [ swap >node call node> drop ] keep iterate-nodes ] [ 2drop - ] if ; inline + ] if ; inline recursive -: (each-node) ( quot -- next ) +: (each-node) ( quot: ( node -- ) -- next ) node@ [ swap call ] 2keep node-children [ [ [ (each-node) ] keep swap ] iterate-nodes ] each drop - iterate-next ; inline + iterate-next ; inline recursive : with-node-iterator ( quot -- ) >r V{ } clone node-stack r> with-variable ; inline @@ -260,14 +261,14 @@ SYMBOL: node-stack 2drop ] if ; inline -: (transform-nodes) ( prev node quot -- ) +: (transform-nodes) ( prev node quot: ( node -- newnode ) -- ) dup >r call dup [ >>successor successor>> dup successor>> r> (transform-nodes) ] [ r> 2drop f >>successor drop - ] if ; inline + ] if ; inline recursive : transform-nodes ( node quot -- new-node ) over [ diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index b85c8b4600..476ca3de74 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -10,16 +10,6 @@ classes classes.tuple ; [ 6 ] [ 1 2 3 compose-n-test ] unit-test -[ 0 ] [ { } bitfield-quot call ] unit-test - -[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test - -[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test - -[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test - -[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test - TUPLE: color r g b ; C: color diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index c56c8ed080..c757ff4e96 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel words sequences generic math -namespaces quotations assocs combinators math.bitfields +namespaces quotations assocs combinators inference.backend inference.dataflow inference.state classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private ; @@ -48,25 +48,6 @@ IN: inference.transforms \ spread [ spread>quot ] 1 define-transform -! Bitfields -GENERIC: (bitfield-quot) ( spec -- quot ) - -M: integer (bitfield-quot) ( spec -- quot ) - [ swapd shift bitor ] curry ; - -M: pair (bitfield-quot) ( spec -- quot ) - first2 over word? [ >r swapd execute r> ] [ ] ? - [ shift bitor ] append 2curry ; - -: bitfield-quot ( spec -- quot ) - [ (bitfield-quot) ] map [ 0 ] prefix concat ; - -\ bitfield [ bitfield-quot ] 1 define-transform - -\ flags [ - [ 0 , [ , \ bitor , ] each ] [ ] make -] 1 define-transform - ! Tuple operations : [get-slots] ( slots -- quot ) [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 0181f80af4..fc02d880f1 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -93,11 +93,10 @@ M: decoder stream-read-partial stream-read ; { CHAR: \n [ line-ends\n ] } } case ; inline -: ((read-until)) ( buf quot -- string/f sep/f ) - ! quot: -- char stop? +: ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f ) dup call [ >r drop "" like r> ] - [ pick push ((read-until)) ] if ; inline + [ pick push ((read-until)) ] if ; inline recursive : (read-until) ( quot -- string/f sep/f ) 100 swap ((read-until)) ; inline diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6b785a61ba..2540ee39cd 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -109,10 +109,13 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline -: while ( pred body tail -- ) +: loop ( pred: ( -- ? ) -- ) + dup slip swap [ loop ] [ drop ] if ; inline recursive + +: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) >r >r dup slip r> r> roll [ >r tuck 2slip r> while ] - [ 2nip call ] if ; inline + [ 2nip call ] if ; inline recursive ! Object protocol GENERIC: hashcode* ( depth obj -- code ) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 4e2a8c768e..5ff5830e7a 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -59,9 +59,7 @@ SYMBOL: error-hook ] recover ; : until-quit ( -- ) - quit-flag get - [ quit-flag off ] - [ listen until-quit ] if ; inline + quit-flag get [ quit-flag off ] [ listen until-quit ] if ; : listener ( -- ) [ until-quit ] with-interactive-vocabs ; diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index 2480012773..8864b64532 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -15,3 +15,13 @@ IN: math.bitfields.tests [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test \ foo must-infer + +[ 0 ] [ { } bitfield-quot call ] unit-test + +[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test + +[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test + +[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test + +[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index a0fb17ef48..64ae60d5b3 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math sequences words ; +USING: arrays kernel math sequences words +namespaces inference.transforms ; IN: math.bitfields GENERIC: (bitfield) ( value accum shift -- newaccum ) @@ -16,3 +17,21 @@ M: pair (bitfield) ( value accum pair -- newaccum ) : flags ( values -- n ) 0 [ dup word? [ execute ] when bitor ] reduce ; + +GENERIC: (bitfield-quot) ( spec -- quot ) + +M: integer (bitfield-quot) ( spec -- quot ) + [ swapd shift bitor ] curry ; + +M: pair (bitfield-quot) ( spec -- quot ) + first2 over word? [ >r swapd execute r> ] [ ] ? + [ shift bitor ] append 2curry ; + +: bitfield-quot ( spec -- quot ) + [ (bitfield-quot) ] map [ 0 ] prefix concat ; + +\ bitfield [ bitfield-quot ] 1 define-transform + +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 6563a1cd11..1e27d5f16c 100755 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -40,7 +40,7 @@ M: fixnum bit? neg shift 1 bitand 0 > ; : (fixnum-log2) ( accum n -- accum ) dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ; - inline + inline recursive M: fixnum (log2) 0 swap (fixnum-log2) ; diff --git a/core/math/math.factor b/core/math/math.factor index 859d0f6f29..457dddceeb 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -124,21 +124,21 @@ M: float fp-nan? PRIVATE> -: (each-integer) ( i n quot -- ) +: (each-integer) ( i n quot: ( i -- ) -- ) [ iterate-step iterate-next (each-integer) ] - [ 3drop ] if-iterate? ; inline + [ 3drop ] if-iterate? ; inline recursive -: (find-integer) ( i n quot -- i ) +: (find-integer) ( i n quot: ( i -- ? ) -- i ) [ iterate-step roll [ 2drop ] [ iterate-next (find-integer) ] if - ] [ 3drop f ] if-iterate? ; inline + ] [ 3drop f ] if-iterate? ; inline recursive -: (all-integers?) ( i n quot -- ? ) +: (all-integers?) ( i n quot: ( i -- ? ) -- ? ) [ iterate-step roll [ iterate-next (all-integers?) ] [ 3drop f ] if - ] [ 3drop t ] if-iterate? ; inline + ] [ 3drop t ] if-iterate? ; inline recursive : each-integer ( n quot -- ) iterate-prep (each-integer) ; inline @@ -152,7 +152,7 @@ PRIVATE> : all-integers? ( n quot -- ? ) iterate-prep (all-integers?) ; inline -: find-last-integer ( n quot -- i ) +: find-last-integer ( n quot: ( i -- ? ) -- i ) over 0 < [ 2drop f ] [ @@ -161,4 +161,4 @@ PRIVATE> ] [ >r 1- r> find-last-integer ] if - ] if ; inline + ] if ; inline recursive diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 15234ee310..c16a031690 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -77,10 +77,6 @@ unit-test [ "-101.0e-2" string>number number>string ] unit-test -[ 5.0 ] -[ "10.0/2" string>number ] -unit-test - [ f ] [ "1e1/2" string>number ] unit-test @@ -104,3 +100,11 @@ unit-test [ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test [ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test + +[ 0.0/0.0 ] [ "0/0." string>number ] unit-test + +[ 1.0/0.0 ] [ "1/0." string>number ] unit-test + +[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test + +[ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 5d048f0b8e..1cb2ae6cdf 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -55,8 +55,9 @@ SYMBOL: negative? dup [ (base>) ] [ drop 0 swap ] if ; : string>ratio ( str -- a/b ) + "-" ?head dup negative? set swap "/" split1 (base>) >r whole-part r> - 3dup and and [ / + ] [ 3drop f ] if ; + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; : valid-digits? ( seq -- ? ) { @@ -66,20 +67,23 @@ SYMBOL: negative? } cond ; : string>integer ( str -- n/f ) + "-" ?head swap string>digits dup valid-digits? - [ radix get digits>integer ] [ drop f ] if ; + [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; PRIVATE> : base> ( str radix -- n/f ) [ - "-" ?head dup negative? set >r - { - { [ CHAR: / over member? ] [ string>ratio ] } - { [ CHAR: . over member? ] [ string>float ] } - [ string>integer ] - } cond - r> [ dup [ neg ] when ] when + CHAR: / over member? [ + string>ratio + ] [ + CHAR: . over member? [ + string>float + ] [ + string>integer + ] if + ] if ] with-radix ; : string>number ( str -- n/f ) 10 base> ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 0d684c3261..227aa1f9dc 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -5,9 +5,8 @@ USING: arrays kernel sequences vectors system hashtables kernel.private sbufs growable assocs namespaces quotations math strings combinators ; -: (each-object) ( quot -- ) - next-object dup - [ swap [ call ] keep (each-object) ] [ 2drop ] if ; inline +: (each-object) ( quot: ( obj -- ) -- ) + [ next-object dup ] swap [ drop ] while ; inline : each-object ( quot -- ) begin-scan (each-object) end-scan ; inline diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index f3f9f51991..feb5706d97 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -70,8 +70,6 @@ M: #label collect-label-info* [ V{ } clone node-stack get length 3array ] keep node-param label-info get set-at ; -USE: prettyprint - M: #call-label collect-label-info* node-param label-info get at node-stack get over third tail diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index cd5ec7fda2..af35607ce9 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -143,6 +143,14 @@ IN: optimizer.known-words { [ dup optimize-instance? ] [ optimize-instance ] } } define-optimizers +! This is a special-case hack +: redundant-array-capacity-check? ( #call -- ? ) + dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ; + +\ array-capacity? { + { [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] } +} define-optimizers + ! eq? on the same object is always t { eq? = } { { { @ @ } [ 2drop t ] } diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index ab808d7914..1e659f1b99 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -219,7 +219,7 @@ M: number detect-number ; ! Regression USE: sorting -USE: sorting.private +USE: binary-search.private : old-binsearch ( elt quot seq -- elt quot i ) dup length 1 <= [ @@ -227,7 +227,7 @@ USE: sorting.private ] [ [ midpoint swap call ] 3keep roll dup zero? [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if + [ dup midpoint@ cut-slice old-binsearch ] if ] if ; inline [ 10 ] [ diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 9e7ded1836..617dac3323 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -5,11 +5,19 @@ kernel kernel.private math assocs quotations.private slots.private ; IN: quotations + + M: quotation call (call) ; -M: curry call dup 3 slot swap 4 slot call ; +M: curry call uncurry call ; -M: compose call dup 3 slot swap 4 slot slip call ; +M: compose call uncompose slip call ; M: wrapper equal? over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 1bb7666447..8434a99b30 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -243,6 +243,7 @@ $nl { $subsection "sequences-destructive" } { $subsection "sequences-stacks" } { $subsection "sequences-sorting" } +{ $subsection "binary-search" } { $subsection "sets" } "For inner loops:" { $subsection "sequences-unsafe" } ; @@ -585,8 +586,6 @@ HELP: index { $values { "obj" object } { "seq" sequence } { "n" "an index" } } { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ; -{ index index-from last-index last-index-from member? memq? } related-words - HELP: index-from { $values { "obj" object } { "i" "a start index" } { "seq" sequence } { "n" "an index" } } { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ", starting the search from the " { $snippet "i" } "th element. If no element is found, outputs " { $link f } "." } ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 11cfb975df..349d68adc5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -60,9 +60,6 @@ INSTANCE: immutable-sequence sequence r swap - r> new-sequence dup 0 ] 3keep @@ -653,7 +651,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : halves ( seq -- first second ) dup midpoint@ cut-slice ; -: binary-reduce ( seq start quot -- value ) +: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value ) #! We can't use case here since combinators depends on #! sequences pick length dup 0 3 between? [ @@ -668,7 +666,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; >r >r halves r> r> [ [ binary-reduce ] 2curry bi@ ] keep call - ] if ; inline + ] if ; inline recursive : cut ( seq n -- before after ) [ head ] [ tail ] 2bi ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index d52ea5e11f..18bc7f14cf 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -2,18 +2,19 @@ USING: help.markup help.syntax kernel words math sequences math.order ; IN: sorting -ARTICLE: "sequences-sorting" "Sorting and binary search" -"Sorting and binary search combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "." +ARTICLE: "sequences-sorting" "Sorting sequences" +"The " { $vocab-link "sorting" } " vocabulary implements the merge-sort algorithm. It runs in " { $snippet "O(n log n)" } " time, and is a " { $emphasis "stable" } " sort, meaning that the order of equal elements is preserved." +$nl +"The algorithm only allocates two additional arrays, both the size of the input sequence, and uses iteration rather than recursion, and thus is suitable for sorting large sequences." +$nl +"Sorting combinators all take comparator quotations with stack effect " { $snippet "( elt1 elt2 -- <=> )" } ", where the output value is one of the three " { $link "order-specifiers" } "." $nl "Sorting a sequence with a custom comparator:" { $subsection sort } "Sorting a sequence with common comparators:" { $subsection natural-sort } { $subsection sort-keys } -{ $subsection sort-values } -"Binary search:" -{ $subsection binsearch } -{ $subsection binsearch* } ; +{ $subsection sort-values } ; ABOUT: "sequences-sorting" @@ -41,24 +42,4 @@ HELP: midpoint@ { $values { "seq" "a sequence" } { "n" integer } } { $description "Outputs the index of the midpoint of " { $snippet "seq" } "." } ; -HELP: midpoint -{ $values { "seq" "a sequence" } { "elt" object } } -{ $description "Outputs the element at the midpoint of a sequence." } ; - -HELP: partition -{ $values { "seq" "a sequence" } { "n" integer } { "slice" slice } } -{ $description "Outputs a slice of the first or second half of the sequence, respectively, depending on the integer's sign." } ; - -HELP: binsearch -{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "i" "the index of the search result" } } -{ $description "Given a sequence that is sorted with respect to the " { $snippet "quot" } " comparator, searches for an element equal to " { $snippet "elt" } ", or failing that, the greatest element smaller than " { $snippet "elt" } ". Comparison is performed with " { $snippet "quot" } "." -$nl -"Outputs f if the sequence is empty. If the sequence has at least one element, this word always outputs a valid index." } ; - -HELP: binsearch* -{ $values { "elt" object } { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- <=> )" } } { "result" "the search result" } } -{ $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence." -$nl -"Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ; - { <=> compare natural-sort sort-keys sort-values } related-words diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index 17ec2d7cd1..63e193c89f 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -1,8 +1,8 @@ USING: sorting sequences kernel math math.order random -tools.test vectors ; +tools.test vectors sets ; IN: sorting.tests -[ [ ] ] [ [ ] natural-sort ] unit-test +[ { } ] [ { } natural-sort ] unit-test [ { 270000000 270000001 } ] [ T{ slice f 270000000 270000002 270000002 } natural-sort ] @@ -11,18 +11,16 @@ unit-test [ t ] [ 100 [ drop - 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic? + 100 [ 20 random [ 1000 random ] replicate ] replicate + dup natural-sort + [ set= ] [ nip [ before=? ] monotonic? ] 2bi and ] all? ] unit-test [ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test -[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test +! Is it a stable sort? +[ t ] [ { { 1 "a" } { 1 "b" } { 1 "c" } } dup sort-keys = ] unit-test -[ f ] [ 3 { } [ <=> ] binsearch ] unit-test -[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test -[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test -[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test -[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test -[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test -[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test +[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ] +[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 1a2491328c..b7bb71f602 100755 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -1,49 +1,141 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math sequences vectors math.order sequences sequences.private math.order ; IN: sorting -DEFER: sort +! Optimized merge-sort: +! +! 1) only allocates 2 temporary arrays + +! 2) first phase (interchanging pairs x[i], x[i+1] where +! x[i] > x[i+1]) is handled specially 0 tail-slice ; inline +TUPLE: merge +{ seq array } +{ accum vector } +{ accum1 vector } +{ accum2 vector } +{ from1 array-capacity } +{ to1 array-capacity } +{ from2 array-capacity } +{ to2 array-capacity } ; -: this ( slice -- obj ) - dup slice-from swap slice-seq nth-unsafe ; inline - -: next ( iterator -- ) - dup slice-from 1+ swap set-slice-from ; inline - -: smallest ( iter1 iter2 quot -- elt ) - >r over this over this r> call +lt+ eq? - -rot ? [ this ] keep next ; inline - -: (merge) ( iter1 iter2 quot accum -- ) - >r pick empty? [ - drop nip r> push-all - ] [ - over empty? [ - 2drop r> push-all +: dump ( from to seq accum -- ) + #! Optimize common case where to - from = 1, 2, or 3. + >r >r 2dup swap - dup 1 = + [ 2drop r> nth-unsafe r> push ] [ + dup 2 = [ + 2drop dup 1+ + r> [ nth-unsafe ] curry bi@ + r> [ push ] curry bi@ ] [ - 3dup smallest r> [ push ] keep (merge) + dup 3 = [ + 2drop dup 1+ dup 1+ + r> [ nth-unsafe ] curry tri@ + r> [ push ] curry tri@ + ] [ + drop r> subseq r> push-all + ] if ] if ] if ; inline -: merge ( sorted1 sorted2 quot -- result ) - >r [ [ ] bi@ ] 2keep r> - rot length rot length + - [ (merge) ] [ underlying>> ] bi ; inline +: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline +: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline +: l-done? [ from1>> ] [ to1>> ] bi number= ; inline +: r-done? [ from2>> ] [ to2>> ] bi number= ; inline +: dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline +: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline +: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline +: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline +: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline -: conquer ( first second quot -- result ) - [ tuck >r >r sort r> r> sort ] keep merge ; inline +: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- ) + over r-done? [ drop dump-l ] [ + over l-done? [ drop dump-r ] [ + 2dup decide + [ over r-next ] [ over l-next ] if + (merge) + ] if + ] if ; inline recursive + +: flip-accum ( merge -- ) + dup [ accum>> ] [ accum1>> ] bi eq? [ + dup accum1>> underlying>> >>seq + dup accum2>> >>accum + ] [ + dup accum1>> >>accum + dup accum2>> underlying>> >>seq + ] if + dup accum>> 0 >>length 2drop ; inline + +: ( seq -- merge ) + \ merge new + over >vector >>accum1 + swap length >>accum2 + dup accum1>> underlying>> >>seq + dup accum2>> >>accum + dup accum>> 0 >>length drop ; inline + +: compute-midpoint ( merge -- merge ) + dup [ from1>> ] [ to2>> ] bi + 2/ >>to1 ; inline + +: merging ( from to merge -- ) + swap >>to2 + swap >>from1 + compute-midpoint + dup [ to1>> ] [ seq>> length ] bi min >>to1 + dup [ to2>> ] [ seq>> length ] bi min >>to2 + dup to1>> >>from2 + drop ; inline + +: nth-chunk ( n size -- from to ) [ * dup ] keep + ; inline + +: chunks ( length size -- n ) [ align ] keep /i ; inline + +: each-chunk ( length size quot -- ) + [ [ chunks ] keep ] dip + [ nth-chunk ] prepose curry + each-integer ; inline + +: merge ( from to merge quot -- ) + [ [ merging ] keep ] dip (merge) ; inline + +: sort-pass ( merge size quot -- ) + [ + over flip-accum + over [ seq>> length ] 2dip + ] dip + [ merge ] 2curry each-chunk ; inline + +: sort-loop ( merge quot -- ) + [ 2 [ over seq>> length over > ] ] dip + [ [ 1 shift 2dup ] dip sort-pass ] curry + [ ] while 2drop ; inline + +: each-pair ( seq quot -- ) + [ [ length 1+ 2/ ] keep ] dip + [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline + +: (sort-pairs) ( i1 i2 seq quot accum -- ) + >r >r 2dup length = [ + nip nth r> drop r> push + ] [ + tuck [ nth-unsafe ] 2bi@ 2dup r> call +gt+ eq? + [ swap ] when r> tuck [ push ] 2bi@ + ] if ; inline + +: sort-pairs ( merge quot -- ) + [ [ seq>> ] [ accum>> ] bi ] dip swap + [ (sort-pairs) ] 2curry each-pair ; inline PRIVATE> -: sort ( seq quot -- sortedseq ) - over length 1 <= - [ drop ] [ over >r >r halves r> conquer r> like ] if ; +: sort ( seq quot -- seq' ) + [ ] dip + [ sort-pairs ] [ sort-loop ] [ drop accum>> underlying>> ] 2tri ; inline : natural-sort ( seq -- sortedseq ) [ <=> ] sort ; @@ -53,25 +145,3 @@ PRIVATE> : sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ; : sort-pair ( a b -- c d ) 2dup after? [ swap ] when ; - -: midpoint ( seq -- elt ) - [ midpoint@ ] keep nth-unsafe ; inline - -: partition ( seq n -- slice ) - +gt+ eq? not swap halves ? ; inline - -: (binsearch) ( elt quot seq -- i ) - dup length 1 <= [ - slice-from 2nip - ] [ - [ midpoint swap call ] 3keep roll dup +eq+ eq? - [ drop dup slice-from swap midpoint@ + 2nip ] - [ partition (binsearch) ] if - ] if ; inline - -: binsearch ( elt seq quot -- i ) - swap dup empty? - [ 3drop f ] [ (binsearch) ] if ; inline - -: binsearch* ( elt seq quot -- result ) - over >r binsearch [ r> ?nth ] [ r> drop f ] if* ; inline diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index c30ea462c1..38f5ae0891 100755 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -30,7 +30,7 @@ IN: splitting : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop [ [ swap subseq , ] 2keep 1+ swap (split) ] - [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline + [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index e8ee857877..54df692895 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -89,6 +89,7 @@ IN: bootstrap.syntax "POSTPONE:" [ scan-word parsed ] define-syntax "\\" [ scan-word literalize parsed ] define-syntax "inline" [ word make-inline ] define-syntax + "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax "flushable" [ word make-flushable ] define-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-syntax diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 552d64cfe7..4b32f4519d 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -195,7 +195,7 @@ M: real sleep [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) - >r [ [ ] [ ] while ] curry r> spawn ; + >r [ loop ] curry r> spawn ; : in-thread ( quot -- ) >r datastack r> diff --git a/core/words/words.factor b/core/words/words.factor index 1d84acbc14..5cf15abfa4 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -164,6 +164,9 @@ M: object redefined drop ; : make-inline ( word -- ) t "inline" set-word-prop ; +: make-recursive ( word -- ) + t "recursive" set-word-prop ; + : make-flushable ( word -- ) t "flushable" set-word-prop ; @@ -181,7 +184,7 @@ GENERIC: reset-word ( word -- ) M: word reset-word { "unannotated-def" - "parsing" "inline" "foldable" "flushable" + "parsing" "inline" "recursive" "foldable" "flushable" "predicating" "reading" "writing" "constructing" @@ -222,6 +225,10 @@ ERROR: bad-create name vocab ; : constructor-word ( name vocab -- word ) >r "<" swap ">" 3append r> create ; +GENERIC: inline? ( word -- ? ) + +M: word inline? "inline" word-prop ; + PREDICATE: parsing-word < word "parsing" word-prop ; : delimiter? ( obj -- ? ) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 78f1074eb8..8dd3c7ece5 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -6,7 +6,6 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui ui.gestures ui.gadgets - ui.gadgets.handler ui.gadgets.slate ui.gadgets.labels ui.gadgets.buttons @@ -14,8 +13,8 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.packs ui.gadgets.grids ui.gadgets.theme + ui.gadgets.handler accessors - qualified namespaces.lib assocs.lib vars rewrite-closures automata math.geometry.rect newfx ; @@ -23,13 +22,6 @@ IN: automata.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -QUALIFIED: ui.gadgets.grids - -: grid-add ( grid child i j -- grid ) - >r >r dupd swap r> r> ui.gadgets.grids:grid-add ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ; : draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ; @@ -80,13 +72,15 @@ DEFER: automata-window "5 - Random Rule" [ random-rule ] view-button add-gadget "n - New" [ automata-window ] view-button add-gadget - @top grid-add + @top grid-add* C[ display ] - { 400 400 } >>dim + { 400 400 } >>pdim dup >slate - @center grid-add + @center grid-add* + + H{ } T{ key-down f f "1" } [ start-center ] view-action is @@ -95,9 +89,7 @@ DEFER: automata-window T{ key-down f f "5" } [ random-rule ] view-action is T{ key-down f f "n" } [ automata-window ] view-action is - - - tuck set-gadget-delegate + >>table "Automata" open-window ; diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 7ab11abd6d..3c1a794121 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -1,20 +1,68 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences namespaces fry ; +USING: kernel continuations combinators sequences quotations arrays namespaces + fry summary assocs math math.order macros ; IN: backtrack SYMBOL: failure -: amb ( seq -- elt ) - failure get - '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each - , continue ] callcc1 ; +ERROR: amb-failure ; + +M: amb-failure summary drop "Backtracking failure" ; : fail ( -- ) - f amb drop ; + failure get [ continue ] + [ amb-failure ] if* ; : require ( ? -- ) [ fail ] unless ; +MACRO: checkpoint ( quot -- quot' ) + '[ failure get , + '[ '[ failure set , continue ] callcc0 + , failure set @ ] callcc0 ] ; + +: number-from ( from -- from+n ) + [ 1 + number-from ] checkpoint ; + + + +: amb-lazy ( seq -- elt ) + [ amb-integer ] [ nth ] bi ; + +: amb ( seq -- elt ) + dup empty? + [ drop fail f ] + [ unsafe-amb ] if ; inline + +MACRO: amb-execute ( seq -- quot ) + [ length 1 - ] [ [ 1quotation ] assoc-map ] bi + '[ , 0 unsafe-number-from-to nip , case ] ; + +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if + ] with-scope ; inline + diff --git a/extra/benchmark/backtrack/backtrack.factor b/extra/benchmark/backtrack/backtrack.factor new file mode 100755 index 0000000000..df67872b11 --- /dev/null +++ b/extra/benchmark/backtrack/backtrack.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: backtrack shuffle math math.ranges quotations locals fry +kernel words io memoize macros io prettyprint sequences assocs +combinators namespaces ; +IN: benchmark.backtrack + +! This was suggested by Dr_Ford. Compute the number of quadruples +! (a,b,c,d) with 1 <= a,b,c,d <= 10 such that we can make 24 by +! placing them on the stack, and applying the operations +! +, -, * and rot as many times as we wish. + +: nop ; + +: do-something ( a b -- c ) + { + - * } amb-execute ; + +: some-rots ( a b c -- a b c ) + #! Try to rot 0, 1 or 2 times. + { nop rot -rot } amb-execute ; + +MEMO: 24-from-1 ( a -- ? ) + 24 = ; + +MEMO: 24-from-2 ( a b -- ? ) + [ do-something 24-from-1 ] [ 2drop ] if-amb ; + +MEMO: 24-from-3 ( a b c -- ? ) + [ some-rots do-something 24-from-2 ] [ 3drop ] if-amb ; + +MEMO: 24-from-4 ( a b c d -- ? ) + [ some-rots do-something 24-from-3 ] [ 4drop ] if-amb ; + +: find-impossible-24 ( -- n ) + 1 10 [a,b] [| a | + 1 10 [a,b] [| b | + 1 10 [a,b] [| c | + 1 10 [a,b] [| d | + a b c d 24-from-4 + ] count + ] sigma + ] sigma + ] sigma ; + +: words { 24-from-1 24-from-2 24-from-3 24-from-4 } ; + +: backtrack-benchmark ( -- ) + words [ reset-memoized ] each + find-impossible-24 pprint "/10000 quadruples can make 24." print + words [ + dup pprint " tested " write "memoize" word-prop assoc-size pprint + " possibilities" print + ] each ; + +MAIN: backtrack-benchmark diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index f45b1cc0ff..6d57bb32ac 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -102,7 +102,7 @@ VARS: population-label cohesion-label alignment-label separation-label ; C[ display ] >slate t slate> set-gadget-clipped? - { 600 400 } slate> set-slate-dim + { 600 400 } slate> set-slate-pdim C[ [ run ] in-thread ] slate> set-slate-graft C[ loop off ] slate> set-slate-ungraft @@ -143,9 +143,11 @@ VARS: population-label cohesion-label alignment-label separation-label ; } [ call ] map [ add-gadget ] each 1 over set-pack-fill - over @top grid-add + @top grid-add* - slate> over @center grid-add + slate> @center grid-add* + + H{ } clone T{ key-down f f "1" } C[ drop randomize ] is @@ -162,7 +164,10 @@ VARS: population-label cohesion-label alignment-label separation-label ; T{ key-down f f "d" } C[ drop dec-separation-weight ] is T{ key-down f f "ESC" } C[ drop toggle-loop ] is - tuck set-gadget-delegate "Boids" open-window ; + + >>table + + "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 63fd55a550..2dfa7fae8f 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -204,7 +204,7 @@ VAR: start-shape : cfdg-window* ( -- ) [ display ] closed-quot - { 500 500 } over set-slate-dim + { 500 500 } over set-slate-pdim dup "CFDG" open-window ; : cfdg-window ( -- ) [ cfdg-window* ] with-ui ; \ No newline at end of file diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index df72572c67..3300faa125 100755 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -17,7 +17,7 @@ IN: channels.tests from ] unit-test -{ V{ 1 2 3 4 } } [ +{ { 1 2 3 4 } } [ V{ } clone [ from swap push ] in-thread [ from swap push ] in-thread @@ -30,7 +30,7 @@ IN: channels.tests natural-sort ] unit-test -{ V{ 1 2 4 9 } } [ +{ { 1 2 4 9 } } [ V{ } clone [ 4 swap to ] in-thread [ 2 swap to ] in-thread diff --git a/extra/cocoa/enumeration/enumeration.factor b/extra/cocoa/enumeration/enumeration.factor index 0cd8e90531..765fb65ef2 100644 --- a/extra/cocoa/enumeration/enumeration.factor +++ b/extra/cocoa/enumeration/enumeration.factor @@ -11,13 +11,13 @@ IN: cocoa.enumeration ] with-malloc ] with-malloc ; inline -:: (NSFastEnumeration-each) ( object quot state stackbuf count -- ) +:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: dup zero? [ drop ] [ state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* '[ , void*-nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) - ] if ; inline + ] if ; inline recursive : NSFastEnumeration-each ( object quot -- ) [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index d0d6afef3f..b7d9e46aa8 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -23,13 +23,13 @@ M: mailbox dispose* threads>> notify-all ; : wait-for-mailbox ( mailbox timeout -- ) >r threads>> r> "mailbox" wait ; -: block-unless-pred ( mailbox timeout pred -- ) +: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) pick check-disposed pick data>> over dlist-contains? [ 3drop ] [ >r 2dup wait-for-mailbox r> block-unless-pred - ] if ; inline + ] if ; inline recursive : block-if-empty ( mailbox timeout -- mailbox ) over check-disposed @@ -58,11 +58,7 @@ M: mailbox dispose* threads>> notify-all ; f mailbox-get-all-timeout ; : while-mailbox-empty ( mailbox quot -- ) - over mailbox-empty? [ - dup >r dip r> while-mailbox-empty - ] [ - 2drop - ] if ; inline + [ [ mailbox-empty? ] curry ] dip [ ] while ; inline : mailbox-get-timeout? ( mailbox timeout pred -- obj ) 3dup block-unless-pred diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 929c4d44f4..f782870783 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -47,7 +47,7 @@ SYMBOL: exit } match-cond ; [ -5 ] [ - [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set + [ 0 [ counter ] loop ] "Counter" spawn "counter" set { increment 10 } "counter" get send { decrement 15 } "counter" get send [ value , self , ] { } make "counter" get send diff --git a/extra/cords/cords.factor b/extra/cords/cords.factor index a7f4246826..52cb9914b4 100644 --- a/extra/cords/cords.factor +++ b/extra/cords/cords.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs sequences sorting math math.order -arrays combinators kernel ; +USING: accessors assocs sequences sorting binary-search math +math.order arrays combinators kernel ; IN: cords > ; M: multi-cord virtual@ dupd - seqs>> [ first <=> ] binsearch* + seqs>> [ first <=> ] with search nip [ first - ] [ second ] bi ; M: multi-cord virtual-seq diff --git a/extra/core-foundation/core-foundation-docs.factor b/extra/core-foundation/core-foundation-docs.factor index ef8f5842a2..3cd9b838d4 100644 --- a/extra/core-foundation/core-foundation-docs.factor +++ b/extra/core-foundation/core-foundation-docs.factor @@ -1,4 +1,4 @@ -USING: alien strings arrays help.markup help.syntax ; +USING: alien strings arrays help.markup help.syntax destructors ; IN: core-foundation HELP: CF>array @@ -37,6 +37,16 @@ HELP: load-framework { $values { "name" "a pathname string" } } { $description "Loads a Core Foundation framework." } ; +HELP: &CFRelease +{ $values { "alien" "Pointer to a Core Foundation object" } } +{ $description "Marks the given Core Foundation object for unconditional release via " { $link CFRelease } " at the end of the enclosing " { $link with-destructors } " scope." } ; + +HELP: |CFRelease +{ $values { "interface" "Pointer to a Core Foundation object" } } +{ $description "Marks the given Core Foundation object for release via " { $link CFRelease } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ; + +{ CFRelease |CFRelease &CFRelease } related-words + ARTICLE: "core-foundation" "Core foundation utilities" "The " { $vocab-link "core-foundation" } " vocabulary defines bindings for some frequently-used Core Foundation functions. It also provides some utility words." $nl @@ -51,7 +61,9 @@ $nl { $subsection } { $subsection } "Frameworks:" -{ $subsection load-framework } ; +{ $subsection load-framework } +"Memory management:" +{ $subsection &CFRelease } +{ $subsection |CFRelease } ; -IN: core-foundation ABOUT: "core-foundation" diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index d2376997e5..c511a24320 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax kernel -math sequences io.encodings.utf16 ; +math sequences io.encodings.utf16 destructors accessors ; IN: core-foundation TYPEDEF: void* CFAllocatorRef @@ -135,3 +135,9 @@ M: f "Cannot load bundled named " prepend throw ] ?if ; +TUPLE: CFRelease-destructor alien disposed ; +M: CFRelease-destructor dispose* alien>> CFRelease ; +: &CFRelease ( alien -- alien ) + dup f CFRelease-destructor boa &dispose drop ; inline +: |CFRelease ( alien -- alien ) + dup f CFRelease-destructor boa |dispose drop ; inline diff --git a/extra/disjoint-set/disjoint-set.factor b/extra/disjoint-set/disjoint-set.factor deleted file mode 100644 index 6f3b1e63e8..0000000000 --- a/extra/disjoint-set/disjoint-set.factor +++ /dev/null @@ -1,72 +0,0 @@ -USING: accessors arrays hints kernel locals math sequences ; - -IN: disjoint-set - -> nth ; inline - -: add-count ( p a disjoint-set -- ) - [ count [ + ] curry ] keep counts>> swap change-nth ; inline - -: parent ( a disjoint-set -- p ) - parents>> nth ; inline - -: set-parent ( p a disjoint-set -- ) - parents>> set-nth ; inline - -: link-sets ( p a disjoint-set -- ) - [ set-parent ] - [ add-count ] 3bi ; inline - -: rank ( a disjoint-set -- r ) - ranks>> nth ; inline - -: inc-rank ( a disjoint-set -- ) - ranks>> [ 1+ ] change-nth ; inline - -: representative? ( a disjoint-set -- ? ) - dupd parent = ; inline - -: representative ( a disjoint-set -- p ) - 2dup representative? [ drop ] [ - [ [ parent ] keep representative dup ] 2keep set-parent - ] if ; - -: representatives ( a b disjoint-set -- r r ) - [ representative ] curry bi@ ; inline - -: ranks ( a b disjoint-set -- r r ) - [ rank ] curry bi@ ; inline - -:: branch ( a b neg zero pos -- ) - a b = zero [ a b < neg pos if ] if ; inline - -PRIVATE> - -: ( n -- disjoint-set ) - [ >array ] - [ 0 ] - [ 1 ] tri - disjoint-set boa ; - -: equiv-set-size ( a disjoint-set -- n ) - [ representative ] keep count ; - -: equiv? ( a b disjoint-set -- ? ) - representatives = ; inline - -:: equate ( a b disjoint-set -- ) - a b disjoint-set representatives - 2dup = [ 2drop ] [ - 2dup disjoint-set ranks - [ swap ] [ over disjoint-set inc-rank ] [ ] branch - disjoint-set link-sets - ] if ; - -HINTS: equate disjoint-set ; -HINTS: representative disjoint-set ; -HINTS: equiv-set-size disjoint-set ; diff --git a/extra/disjoint-set/authors.txt b/extra/disjoint-sets/authors.txt similarity index 100% rename from extra/disjoint-set/authors.txt rename to extra/disjoint-sets/authors.txt diff --git a/extra/disjoint-sets/disjoint-sets.factor b/extra/disjoint-sets/disjoint-sets.factor new file mode 100644 index 0000000000..7879f3fbb6 --- /dev/null +++ b/extra/disjoint-sets/disjoint-sets.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2008 Eric Mertens. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays hints kernel locals math hashtables +assocs ; + +IN: disjoint-sets + +TUPLE: disjoint-set +{ parents hashtable read-only } +{ ranks hashtable read-only } +{ counts hashtable read-only } ; + +> at ; inline + +: add-count ( p a disjoint-set -- ) + [ count [ + ] curry ] keep counts>> swap change-at ; inline + +: parent ( a disjoint-set -- p ) + parents>> at ; inline + +: set-parent ( p a disjoint-set -- ) + parents>> set-at ; inline + +: link-sets ( p a disjoint-set -- ) + [ set-parent ] [ add-count ] 3bi ; inline + +: rank ( a disjoint-set -- r ) + ranks>> at ; inline + +: inc-rank ( a disjoint-set -- ) + ranks>> [ 1+ ] change-at ; inline + +: representative? ( a disjoint-set -- ? ) + dupd parent = ; inline + +PRIVATE> + +GENERIC: representative ( a disjoint-set -- p ) + +M: disjoint-set representative + 2dup representative? [ drop ] [ + [ [ parent ] keep representative dup ] 2keep set-parent + ] if ; + + + +: ( -- disjoint-set ) + H{ } clone H{ } clone H{ } clone disjoint-set boa ; + +GENERIC: add-atom ( a disjoint-set -- ) + +M: disjoint-set add-atom + [ dupd parents>> set-at ] + [ 0 -rot ranks>> set-at ] + [ 1 -rot counts>> set-at ] + 2tri ; + +GENERIC: equiv-set-size ( a disjoint-set -- n ) + +M: disjoint-set equiv-set-size [ representative ] keep count ; + +GENERIC: equiv? ( a b disjoint-set -- ? ) + +M: disjoint-set equiv? representatives = ; + +GENERIC: equate ( a b disjoint-set -- ) + +M:: disjoint-set equate ( a b disjoint-set -- ) + a b disjoint-set representatives + 2dup = [ 2drop ] [ + 2dup disjoint-set ranks + [ swap ] [ over disjoint-set inc-rank ] [ ] branch + disjoint-set link-sets + ] if ; diff --git a/extra/disjoint-set/summary.txt b/extra/disjoint-sets/summary.txt similarity index 100% rename from extra/disjoint-set/summary.txt rename to extra/disjoint-sets/summary.txt diff --git a/extra/disjoint-set/tags.txt b/extra/disjoint-sets/tags.txt similarity index 100% rename from extra/disjoint-set/tags.txt rename to extra/disjoint-sets/tags.txt diff --git a/extra/display-stack/display-stack.factor b/extra/display-stack/display-stack.factor new file mode 100644 index 0000000000..8da252f294 --- /dev/null +++ b/extra/display-stack/display-stack.factor @@ -0,0 +1,43 @@ + +USING: kernel namespaces sequences math + listener io prettyprint sequences.lib fry ; + +IN: display-stack + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: watched-variables + +: watch-var ( sym -- ) watched-variables get push ; + +: watch-vars ( seq -- ) watched-variables get [ push ] curry each ; + +: unwatch-var ( sym -- ) watched-variables get delete ; + +: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ; + +: print-watched-variables ( -- ) + watched-variables get length 0 > + [ + "----------" print + watched-variables get + watched-variables get [ unparse ] map longest length 2 + + '[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ] + each + + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: display-stack ( -- ) + V{ } clone watched-variables set + [ + print-watched-variables + "----------" print + datastack [ . ] each + "----------" print + retainstack reverse [ . ] each + ] + listener-hook set ; + diff --git a/extra/farkup/authors.txt b/extra/farkup/authors.txt index 7c1b2f2279..5674120196 100644 --- a/extra/farkup/authors.txt +++ b/extra/farkup/authors.txt @@ -1 +1,2 @@ Doug Coleman +Slava Pestov diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100755 new mode 100644 index 17d286252e..005e875d89 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,12 +1,19 @@ -USING: farkup kernel tools.test ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: farkup kernel peg peg.ebnf tools.test ; IN: farkup.tests -[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23" + "paragraph" \ farkup rule parse drop +] unit-test -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ ] [ + "abcd-*strong*\nasdifj\nweouh23ouh23\n" + "paragraph" \ farkup rule parse drop +] unit-test + +[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test [ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test [ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test [ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test @@ -15,11 +22,20 @@ IN: farkup.tests [ "

*

" ] [ "\\*" convert-farkup ] unit-test [ "

**

" ] [ "\\**" convert-farkup ] unit-test -[ "" ] [ "\n\n" convert-farkup ] unit-test -[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test -[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test -[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
    • \n
" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
    • \n
  • bar
    • \n
" ] [ "-foo\n-bar\n" convert-farkup ] unit-test + +[ "
  • foo
    • \n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test + + +[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test +[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test +[ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test +[ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test [ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test @@ -29,7 +45,7 @@ IN: farkup.tests [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test [ "" ] [ "" convert-farkup ] unit-test @@ -77,8 +93,5 @@ IN: farkup.tests ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test [ - "

Feature comparison:\n\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" + "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test - -[ "

a-b

" ] [ "a-b" convert-farkup ] unit-test -[ "
  • a-b
" ] [ "-a-b" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor old mode 100755 new mode 100644 index 321648136a..baf2ccaba2 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -1,72 +1,111 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io io.styles kernel memoize namespaces peg math -combinators sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string peg.parsers -sequences.deep unicode.categories ; +USING: accessors arrays combinators html.elements io io.streams.string +kernel math memoize namespaces peg peg.ebnf prettyprint +sequences sequences.deep strings xml.entities vectors splitting +xmode.code2html ; IN: farkup SYMBOL: relative-link-prefix SYMBOL: disable-images? SYMBOL: link-no-follow? - [[ drop "\n" ]] +2nl = nl nl -MEMO: text ( -- parser ) - [ delimiters member? not ] satisfy repeat1 - [ >string escape-string ] action ; +heading1 = "=" (!("=" | nl).)+ "=" + => [[ second >string heading1 boa ]] -MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap "\r\n=" member? not and ] satisfy - [ 1string ] action ; +heading2 = "==" (!("=" | nl).)+ "==" + => [[ second >string heading2 boa ]] -: surround-with-foo ( string tag -- seq ) - dup swap swapd 3array ; +heading3 = "===" (!("=" | nl).)+ "===" + => [[ second >string heading3 boa ]] -: delimited ( str html -- parser ) - [ - over token hide , - text [ surround-with-foo ] swapd curry action , - token hide , - ] seq* ; +heading4 = "====" (!("=" | nl).)+ "====" + => [[ second >string heading4 boa ]] -MEMO: escaped-char ( -- parser ) - [ "\\" token hide , any-char , ] seq* [ >string ] action ; +strong = "*" (!("*" | nl).)+ "*" + => [[ second >string strong boa ]] -MEMO: strong ( -- parser ) "*" "strong" delimited ; -MEMO: emphasis ( -- parser ) "_" "em" delimited ; -MEMO: superscript ( -- parser ) "^" "sup" delimited ; -MEMO: subscript ( -- parser ) "~" "sub" delimited ; -MEMO: inline-code ( -- parser ) "%" "code" delimited ; -MEMO: nl ( -- parser ) - "\r\n" token [ drop "\n" ] action - "\r" token [ drop "\n" ] action - "\n" token 3choice ; -MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ; -MEMO: h1 ( -- parser ) "=" "h1" delimited ; -MEMO: h2 ( -- parser ) "==" "h2" delimited ; -MEMO: h3 ( -- parser ) "===" "h3" delimited ; -MEMO: h4 ( -- parser ) "====" "h4" delimited ; +emphasis = "_" (!("_" | nl).)+ "_" + => [[ second >string emphasis boa ]] + +superscript = "^" (!("^" | nl).)+ "^" + => [[ second >string superscript boa ]] + +subscript = "~" (!("~" | nl).)+ "~" + => [[ second >string subscript boa ]] + +inline-code = "%" (!("%" | nl).)+ "%" + => [[ second >string inline-code boa ]] + +escaped-char = "\" . => [[ second ]] + +image-link = "[[image:" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi image boa ]] + | "[[image:" (!("]").)+ "]]" + => [[ second >string f image boa ]] + +simple-link = "[[" (!("|]" | "]]") .)+ "]]" + => [[ second >string dup link boa ]] + +labelled-link = "[[" (!("|") .)+ "|" (!("]]").)+ "]]" + => [[ [ second >string ] [ fourth >string ] bi link boa ]] + +link = image-link | labelled-link | simple-link + +heading = heading4 | heading3 | heading2 | heading1 + +inline-tag = strong | emphasis | superscript | subscript | inline-code + | link | escaped-char + +inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' + +table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' + => [[ first ]] +table-row = "|" (table-column)+ + => [[ second table-row boa ]] +table = ((table-row nl => [[ first ]] )+ table-row? | table-row) + => [[ table boa ]] + +paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ +paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] + | (paragraph-item nl)+ paragraph-item? + | paragraph-item) + => [[ paragraph boa ]] + +list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* + => [[ second list-item boa ]] +list = ((list-item nl)+ list-item? | list-item) + => [[ list boa ]] + +code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]" + => [[ [ second >string ] [ fourth >string ] bi code boa ]] + +stand-alone = (code | heading | list | table | paragraph | nl)* +;EBNF -MEMO: eq ( -- parser ) - [ - h1 ensure-not , - h2 ensure-not , - h3 ensure-not , - h4 ensure-not , - "=" token , - ] seq* ; -: render-code ( string mode -- string' ) - >r string-lines r> - [ - 
-            htmlize-lines
-
- ] with-string-writer ; : invalid-url "javascript:alert('Invalid URL in farkup');" ; @@ -85,116 +124,57 @@ MEMO: eq ( -- parser ) : escape-link ( href text -- href-esc text-esc ) >r check-url escape-quoted-string r> escape-string ; -: make-link ( href text -- seq ) +: write-link ( text href -- ) escape-link - [ - "r , r> "\"" , - link-no-follow? get [ " nofollow=\"true\"" , ] when - ">" , , "" , - ] { } make ; + "" write write "" write ; -: make-image-link ( href alt -- seq ) +: write-image-link ( href text -- ) disable-images? get [ - 2drop "Images are not allowed" + 2drop "Images are not allowed" write ] [ escape-link - [ - "\""" , - ] { } make + >r " + dup empty? [ drop ] [ " alt=\"" write write "\"" write ] if + "/>" write ] if ; -MEMO: image-link ( -- parser ) +: render-code ( string mode -- string' ) + >r string-lines r> [ - "[[image:" token hide , - [ "|]" member? not ] satisfy repeat1 [ >string ] action , - "|" token hide - [ CHAR: ] = not ] satisfy repeat0 2seq - [ first >string ] action optional , - "]]" token hide , - ] seq* [ first2 make-image-link ] action ; + 
+            htmlize-lines
+
+ ] with-string-writer write ; -MEMO: simple-link ( -- parser ) - [ - "[[" token hide , - [ "|]" member? not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first dup make-link ] action ; - -MEMO: labelled-link ( -- parser ) - [ - "[[" token hide , - [ CHAR: | = not ] satisfy repeat1 , - "|" token hide , - [ CHAR: ] = not ] satisfy repeat1 , - "]]" token hide , - ] seq* [ first2 make-link ] action ; - -MEMO: link ( -- parser ) - [ image-link , simple-link , labelled-link , ] choice* ; - -DEFER: line -MEMO: list-item ( -- parser ) - [ - "-" token hide , ! text , - [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action , - ] seq* [ "li" surround-with-foo ] action ; - -MEMO: list ( -- parser ) - list-item nl hide list-of - [ "ul" surround-with-foo ] action ; - -MEMO: table-column ( -- parser ) - text [ "td" surround-with-foo ] action ; - -MEMO: table-row ( -- parser ) - "|" token hide - table-column "|" token hide list-of - "|" token hide nl hide optional 4seq - [ "tr" surround-with-foo ] action ; - -MEMO: table ( -- parser ) - table-row repeat1 - [ "table" surround-with-foo ] action ; - -MEMO: code ( -- parser ) - [ - "[" token hide , - [ CHAR: { = not ] satisfy repeat1 optional [ >string ] action , - "{" token hide , - "}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action , - "}]" token hide , - ] seq* [ first2 swap render-code ] action ; - -MEMO: line ( -- parser ) - [ - nl table 2seq , - nl list 2seq , - text , strong , emphasis , link , - superscript , subscript , inline-code , - escaped-char , delimiter , eq , - ] choice* repeat1 ; - -MEMO: paragraph ( -- parser ) - line - nl over 2seq repeat0 - nl nl ensure-not 2seq optional 3seq - [ - dup [ dup string? not swap [ blank? ] all? or ] deep-all? - [ "

" swap "

" 3array ] unless - ] action ; - -PRIVATE> - -PEG: parse-farkup ( -- parser ) - [ - list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , - ] choice* repeat0 nl optional 2seq ; - -: write-farkup ( parse-result -- ) - [ dup string? [ write ] [ drop ] if ] deep-each ; +GENERIC: write-farkup ( obj -- ) +: ( string -- ) write ; +: ( string -- ) write ; +: in-tag. ( obj quot string -- ) [ call ] keep ; inline +M: heading1 write-farkup ( obj -- ) [ obj>> write-farkup ] "h1" in-tag. ; +M: heading2 write-farkup ( obj -- ) [ obj>> write-farkup ] "h2" in-tag. ; +M: heading3 write-farkup ( obj -- ) [ obj>> write-farkup ] "h3" in-tag. ; +M: heading4 write-farkup ( obj -- ) [ obj>> write-farkup ] "h4" in-tag. ; +M: strong write-farkup ( obj -- ) [ obj>> write-farkup ] "strong" in-tag. ; +M: emphasis write-farkup ( obj -- ) [ obj>> write-farkup ] "em" in-tag. ; +M: superscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sup" in-tag. ; +M: subscript write-farkup ( obj -- ) [ obj>> write-farkup ] "sub" in-tag. ; +M: inline-code write-farkup ( obj -- ) [ obj>> write-farkup ] "code" in-tag. ; +M: list-item write-farkup ( obj -- ) [ obj>> write-farkup ] "li" in-tag. ; +M: list write-farkup ( obj -- ) [ obj>> write-farkup ] "ul" in-tag. ; +M: paragraph write-farkup ( obj -- ) [ obj>> write-farkup ] "p" in-tag. ; +M: link write-farkup ( obj -- ) [ text>> ] [ href>> ] bi write-link ; +M: image write-farkup ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; +M: code write-farkup ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: table-row write-farkup ( obj -- ) + obj>> [ [ [ write-farkup ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table write-farkup ( obj -- ) [ obj>> write-farkup ] "table" in-tag. ; +M: fixnum write-farkup ( obj -- ) write1 ; +M: string write-farkup ( obj -- ) write ; +M: vector write-farkup ( obj -- ) [ write-farkup ] each ; +M: f write-farkup ( obj -- ) drop ; : convert-farkup ( string -- string' ) - parse-farkup [ write-farkup ] with-string-writer ; + farkup [ write-farkup ] with-string-writer ; diff --git a/extra/fry/fry-docs.factor b/extra/fry/fry-docs.factor index eba2f95727..05cde62c1f 100755 --- a/extra/fry/fry-docs.factor +++ b/extra/fry/fry-docs.factor @@ -19,10 +19,11 @@ HELP: fry HELP: '[ { $syntax "code... ]" } -{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ; +{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link , } " and " { $link @ } "." } +{ $examples "See " { $link "fry.examples" } "." } ; ARTICLE: "fry.examples" "Examples of fried quotations" -"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples." +"The easiest way to understand fried quotations is to look at some examples." $nl "If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":" { $code "{ 10 20 30 } '[ . ] each" } @@ -38,9 +39,10 @@ $nl "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map" "{ 10 20 30 } [ 3 5 / ] map" } -"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:" +"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following four lines are equivalent:" { $code "{ 10 20 30 } [ sq ] '[ @ . ] each" + "{ 10 20 30 } [ sq ] [ call . ] curry each" "{ 10 20 30 } [ sq ] [ . ] compose each" "{ 10 20 30 } [ sq . ] each" } @@ -50,16 +52,17 @@ $nl "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map" "{ 8 13 14 27 } [ even? dup 5 ? ] map" } -"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":" +"Occurrences of " { $link _ } " have the effect of enclosing all code to their left in a quotation passed to " { $link dip } ". The following four lines are equivalent:" { $code "{ 10 20 30 } 1 '[ , _ / ] map" + "{ 10 20 30 } 1 [ [ ] curry dip / ] curry map" "{ 10 20 30 } 1 [ swap / ] curry map" "{ 10 20 30 } [ 1 swap / ] map" } "For any quotation body " { $snippet "X" } ", the following two are equivalent:" { $code - "[ >r X r> ]" - "[ X _ ]" + "[ [ X ] dip ]" + "'[ X _ ]" } "Here are some built-in combinators rewritten in terms of fried quotations:" { $table @@ -73,8 +76,11 @@ $nl } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" -"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "." -$nl +"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:" +{ $code + "'[ [ , key? ] all? ] filter" + "[ [ key? ] curry all? ] curry filter" +} "There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" { $code "'[ 3 , + 4 , / ]" @@ -87,7 +93,7 @@ $nl } ; ARTICLE: "fry.limitations" "Fried quotation limitations" -"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ; +"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ; ARTICLE: "fry" "Fried quotations" "A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation." diff --git a/extra/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index ef6f1ca4c2..8ae8bccc25 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -1,64 +1,64 @@ + USING: kernel namespaces math math.constants math.functions arrays sequences - opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme - ui.gadgets.slate colors ; + opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme + ui.gadgets.slate colors accessors combinators.cleave ; + IN: golden-section ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! To run: -! "golden-section" run +: disk ( radius center -- ) + glPushMatrix + gl-translate + dup 0 glScalef + gluNewQuadric [ 0 1 20 20 gluDisk ] [ gluDeleteQuadric ] bi + glPopMatrix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: disk ( quadric radius center -- ) - glPushMatrix - gl-translate - dup 0 glScalef - 0 1 10 10 gluDisk - glPopMatrix ; +! omega(i) = 2*pi*i*(phi-1) + +! x(i) = 0.5*i*cos(omega(i)) +! y(i) = 0.5*i*sin(omega(i)) + +! radius(i) = 10*sin((pi*i)/720) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : omega ( i -- omega ) phi 1- * 2 * pi * ; -: x ( i -- x ) dup omega cos * 0.5 * ; +: x ( i -- x ) [ omega cos ] [ 0.5 * ] bi * ; +: y ( i -- y ) [ omega sin ] [ 0.5 * ] bi * ; -: y ( i -- y ) dup omega sin * 0.5 * ; - -: center ( i -- point ) dup x swap y 2array ; +: center ( i -- point ) { x y } 1arr ; : radius ( i -- radius ) pi * 720 / sin 10 * ; : color ( i -- color ) 360.0 / dup 0.25 1 4array ; -: rim ( quadric i -- ) - black gl-color dup radius 1.5 * swap center disk ; +: rim ( i -- ) [ drop black gl-color ] [ radius 1.5 * ] [ center ] tri disk ; +: inner ( i -- ) [ color gl-color ] [ radius ] [ center ] tri disk ; -: inner ( quadric i -- ) - dup color gl-color dup radius swap center disk ; +: dot ( i -- ) [ rim ] [ inner ] bi ; -: dot ( quadric i -- ) 2dup rim inner ; - -: golden-section ( quadric -- ) 720 [ dot ] with each ; +: golden-section ( -- ) 720 [ dot ] each ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: with-quadric ( quot -- ) - gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline - : display ( -- ) - GL_PROJECTION glMatrixMode - glLoadIdentity - -400 400 -400 400 -1 1 glOrtho - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ golden-section ] with-quadric ; + GL_PROJECTION glMatrixMode + glLoadIdentity + -400 400 -400 400 -1 1 glOrtho + GL_MODELVIEW glMatrixMode + glLoadIdentity + golden-section ; : golden-section-window ( -- ) [ - [ display ] - { 600 600 } over set-slate-dim - "Golden Section" open-window - ] with-ui ; + [ display ] + { 600 600 } >>pdim + "Golden Section" open-window + ] + with-ui ; MAIN: golden-section-window diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9ffd241915..fc0d00e94d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections" { $subsection "heaps" } { $subsection "graphs" } { $subsection "buffers" } -"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-set" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ; +"There are many other collections in " { $snippet "extra/" } ", such as " { $vocab-link "disjoint-sets" } ", " { $vocab-link "persistent-vectors" } ", and " { $vocab-link "tuple-arrays" } "." ; USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 221dca3c62..0926a30adc 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -29,7 +29,7 @@ IN: help.lint : effect-values ( word -- seq ) stack-effect [ in>> ] [ out>> ] bi append - [ (stack-picture) ] map + [ dup pair? [ first ] when effect>string ] map prune natural-sort ; : contains-funky-elements? ( element -- ? ) diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor index 5779371078..56c7118ab9 100644 --- a/extra/html/components/components-tests.factor +++ b/extra/html/components/components-tests.factor @@ -155,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ "-foo\n-bar" "farkup" set-value ] unit-test -[ "
  • foo
  • bar
" ] [ +[ "
  • foo
    • \n
  • bar
" ] [ [ "farkup" T{ farkup } render ] with-string-writer ] unit-test diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor index 95e3794e32..a62855d78f 100755 --- a/extra/interval-maps/interval-maps.factor +++ b/extra/interval-maps/interval-maps.factor @@ -1,5 +1,7 @@ -USING: kernel sequences arrays accessors grouping -math.order sorting math assocs locals namespaces ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences arrays accessors grouping math.order +sorting binary-search math assocs locals namespaces ; IN: interval-maps TUPLE: interval-map array ; @@ -7,7 +9,7 @@ TUPLE: interval-map array ; ] binsearch* ; + [ first <=> ] with search nip ; : interval-contains? ( key interval-node -- ? ) first2 between? ; diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index bd33954436..63381811d1 100755 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -55,7 +55,7 @@ os { winnt linux macosx } member? [ dup print flush dup parent-directory [ right-trim-separators "xyz" tail? ] either? not - ] [ ] [ ] while + ] loop "c1" get count-down @@ -64,7 +64,7 @@ os { winnt linux macosx } member? [ dup print flush dup parent-directory [ right-trim-separators "yxy" tail? ] either? not - ] [ ] [ ] while + ] loop "c2" get count-down ] "Monitor test thread" spawn drop diff --git a/extra/iokit/iokit.factor b/extra/iokit/iokit.factor index 1babd697c1..680723def9 100644 --- a/extra/iokit/iokit.factor +++ b/extra/iokit/iokit.factor @@ -2,10 +2,11 @@ USING: alien.syntax alien.c-types core-foundation system combinators kernel sequences debugger io accessors ; IN: iokit -<< { - { [ os macosx? ] [ "/System/Library/Frameworks/IOKit.framework" load-framework ] } - [ "IOKit only supported on Mac OS X" ] -} cond >> +<< + os macosx? + [ "/System/Library/Frameworks/IOKit.framework" load-framework ] + when +>> : kIOKitBuildVersionKey "IOKitBuildVersion" ; inline : kIOKitDiagnosticsKey "IOKitDiagnostics" ; inline diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2883e47b81..100724ea58 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -1,7 +1,7 @@ USING: kernel tools.test accessors arrays sequences qualified io.streams.string io.streams.duplex namespaces threads calendar irc.client.private irc.client irc.messages.private - concurrency.mailboxes classes ; + concurrency.mailboxes classes assocs ; EXCLUDE: irc.messages => join ; RENAME: join irc.messages => join_ IN: irc.client.tests @@ -20,28 +20,6 @@ IN: irc.client.tests : with-dummy-client ( quot -- ) rot with-variable ; inline -! Parsing tests -irc-message new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - string>irc-message f >>timestamp ] unit-test - -privmsg new - ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line - "someuser!n=user@some.where" >>prefix - "PRIVMSG" >>command - { "#factortest" } >>parameters - "hi" >>trailing - "#factortest" >>name -1array -[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line f >>timestamp ] unit-test - { "" } make-client dup "factorbot" set-nick current-irc-client [ { t } [ irc> profile>> nickname>> me? ] unit-test @@ -64,21 +42,29 @@ privmsg new ":some.where 001 factorbot :Welcome factorbot" } make-client [ connect-irc ] keep 1 seconds sleep - profile>> nickname>> ] unit-test + profile>> nickname>> ] unit-test { join_ "#factortest" } [ - { ":factorbot!n=factorbo@some.where JOIN :#factortest" + { ":factorbot!n=factorbo@some.where JOIN :#factortest" ":ircserver.net MODE #factortest +ns" ":ircserver.net 353 factorbot @ #factortest :@factorbot " ":ircserver.net 366 factorbot #factortest :End of /NAMES list." ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah" } make-client dup "factorbot" set-nick [ connect-irc ] keep 1 seconds sleep - join-messages>> 5 seconds mailbox-get-timeout + join-messages>> 1 seconds mailbox-get-timeout [ class ] [ trailing>> ] bi ] unit-test -! TODO: user join -! ":somedude!n=user@isp.net JOIN :#factortest" + +{ +join+ "somebody" } [ + { ":somebody!n=somebody@some.where JOIN :#factortest" + } make-client dup "factorbot" set-nick + [ listeners>> [ "#factortest" [ ] keep ] dip set-at ] + [ connect-irc ] + [ listeners>> [ "#factortest" ] dip at + [ read-message drop ] [ read-message drop ] [ read-message ] tri ] tri + [ action>> ] [ nick>> ] bi + ] unit-test ! TODO: channel message -! ":somedude!n=user@isp.net PRIVMSG #factortest :hello" +! ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" ! TODO: direct private message ! ":somedude!n=user@isp.net PRIVMSG factorbot2 :hello" \ No newline at end of file diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 472805f5ae..405d8ed9ed 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry - continuations threads strings classes combinators - irc.messages irc.messages.private ; + continuations threads strings classes combinators splitting hashtables + ascii irc.messages irc.messages.private ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -27,33 +27,50 @@ TUPLE: irc-client profile stream in-messages out-messages join-messages TUPLE: irc-listener in-messages out-messages ; TUPLE: irc-server-listener < irc-listener ; -TUPLE: irc-channel-listener < irc-listener name password timeout ; +TUPLE: irc-channel-listener < irc-listener name password timeout participants ; TUPLE: irc-nick-listener < irc-listener name ; SYMBOL: +server-listener+ +! participant modes +SYMBOL: +operator+ +SYMBOL: +voice+ +SYMBOL: +normal+ + +: participant-mode ( n -- mode ) + H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ; + +! participant changed actions +SYMBOL: +join+ +SYMBOL: +part+ +SYMBOL: +mode+ + +! listener objects : ( -- irc-listener ) irc-listener boa ; : ( -- irc-server-listener ) irc-server-listener boa ; : ( name -- irc-channel-listener ) - rot f 60 seconds irc-channel-listener boa ; + [ ] dip f 60 seconds H{ } clone irc-channel-listener boa ; : ( name -- irc-nick-listener ) - rot irc-nick-listener boa ; + [ ] dip irc-nick-listener boa ; ! ====================================== ! Message objects ! ====================================== +TUPLE: participant-changed nick action ; +C: participant-changed + SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) - [ in-messages>> irc-end swap mailbox-put ] - [ f >>is-running drop ] + [ [ irc-end ] dip in-messages>> mailbox-put ] + [ [ f ] dip (>>is-running) ] [ stream>> dispose ] tri ; @@ -70,22 +87,39 @@ UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : listener> ( name -- listener/f ) irc> listeners>> at ; : unregister-listener ( name -- ) irc> listeners>> delete-at ; -: to-listener ( message name -- ) +GENERIC: to-listener ( message obj -- ) + +M: string to-listener ( message string -- ) listener> [ +server-listener+ listener> ] unless* - [ in-messages>> mailbox-put ] [ drop ] if* ; + [ to-listener ] [ drop ] if* ; + +M: irc-listener to-listener ( message irc-listener -- ) + in-messages>> mailbox-put ; + +: remove-participant ( nick channel -- ) + listener> [ participants>> delete-at ] [ drop ] if* ; + +: listeners-with-participant ( nick -- seq ) + irc> listeners>> values + [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] + with filter ; + +: remove-participant-from-all ( nick -- ) + dup listeners-with-participant [ delete-at ] with each ; + +: add-participant ( mode nick channel -- ) + listener> [ participants>> set-at ] [ 2drop ] if* ; + +DEFER: me? + +: maybe-forward-join ( join -- ) + [ prefix>> parse-name me? ] keep and + [ irc> join-messages>> mailbox-put ] when* ; ! ====================================== ! IRC client messages ! ====================================== -GENERIC: irc-message>string ( irc-message -- string ) - -M: irc-message irc-message>string ( irc-message -- string ) - [ command>> ] - [ parameters>> " " sjoin ] - [ trailing>> dup [ CHAR: : prefix ] when ] - tri 3array " " sjoin ; - : /NICK ( nick -- ) "NICK " irc-write irc-print ; @@ -99,7 +133,7 @@ M: irc-message irc-message>string ( irc-message -- string ) : /JOIN ( channel password -- ) "JOIN " irc-write - [ " :" swap 3append ] when* irc-print ; + [ [ " :" ] dip 3append ] when* irc-print ; : /PART ( channel text -- ) [ "PART " irc-write irc-write ] dip @@ -133,12 +167,31 @@ M: irc-message irc-message>string ( irc-message -- string ) dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; : broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ in-messages>> mailbox-put ] with each ; + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: handle-participant-change ( irc-message -- ) + +M: join handle-participant-change ( join -- ) + [ prefix>> parse-name +join+ ] + [ trailing>> ] bi to-listener ; + +M: part handle-participant-change ( part -- ) + [ prefix>> parse-name +part+ ] + [ channel>> ] bi to-listener ; + +M: kick handle-participant-change ( kick -- ) + [ who>> +part+ ] + [ channel>> ] bi to-listener ; + +M: quit handle-participant-change ( quit -- ) + prefix>> parse-name + [ +part+ ] [ listeners-with-participant ] bi + [ to-listener ] with each ; GENERIC: handle-incoming-irc ( irc-message -- ) M: irc-message handle-incoming-irc ( irc-message -- ) - +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ; + +server-listener+ listener> [ to-listener ] [ drop ] if* ; M: logged-in handle-incoming-irc ( logged-in -- ) name>> irc> profile>> (>>nickname) ; @@ -153,17 +206,43 @@ M: privmsg handle-incoming-irc ( privmsg -- ) dup irc-message-origin to-listener ; M: join handle-incoming-irc ( join -- ) - [ [ prefix>> parse-name me? ] keep and - [ irc> join-messages>> mailbox-put ] when* ] - [ dup trailing>> to-listener ] - bi ; + { [ maybe-forward-join ] ! keep + [ dup trailing>> to-listener ] + [ [ drop f ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] + [ handle-participant-change ] + } cleave ; M: part handle-incoming-irc ( part -- ) - dup channel>> to-listener ; + [ dup channel>> to-listener ] + [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] + tri ; M: kick handle-incoming-irc ( kick -- ) - [ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when - to-listener ; + { [ dup channel>> to-listener ] + [ [ who>> ] [ channel>> ] bi remove-participant ] + [ handle-participant-change ] + [ dup who>> me? [ unregister-listener ] [ drop ] if ] + } cleave ; + +M: quit handle-incoming-irc ( quit -- ) + { [ dup prefix>> parse-name listeners-with-participant + [ to-listener ] with each ] + [ handle-participant-change ] + [ prefix>> parse-name remove-participant-from-all ] + [ ] + } cleave call-next-method ; + +: >nick/mode ( string -- nick mode ) + dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; + +: names-reply>participants ( names-reply -- participants ) + trailing>> [ blank? ] trim " " split + [ >nick/mode 2array ] map >hashtable ; + +M: names-reply handle-incoming-irc ( names-reply -- ) + [ names-reply>participants ] [ channel>> listener> ] bi + [ (>>participants) ] [ drop ] if* ; M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) broadcast-message-to-listeners ; @@ -174,24 +253,19 @@ M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) GENERIC: handle-outgoing-irc ( obj -- ) -! M: irc-message handle-outgoing-irc ( irc-message -- ) -! irc-message>string irc-print ; +M: irc-message handle-outgoing-irc ( irc-message -- ) + irc-message>client-line irc-print ; M: privmsg handle-outgoing-irc ( privmsg -- ) [ name>> ] [ trailing>> ] bi /PRIVMSG ; -M: part handle-outgoing-irc ( privmsg -- ) +M: part handle-outgoing-irc ( part -- ) [ channel>> ] [ trailing>> "" or ] bi /PART ; ! ====================================== ! Reader/Writer ! ====================================== -: irc-mailbox-get ( mailbox quot -- ) - swap 5 seconds - '[ , , , mailbox-get-timeout swap call ] - [ drop ] recover ; inline - : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ; @@ -199,11 +273,12 @@ DEFER: (connect-irc) : (handle-disconnect) ( -- ) irc> - [ in-messages>> irc-disconnected swap mailbox-put ] + [ [ irc-disconnected ] dip to-listener ] [ dup reconnect-time>> sleep (connect-irc) ] [ profile>> nickname>> /LOGIN ] tri ; +! FIXME: do something with the exception, store somewhere to help debugging : handle-disconnect ( error -- ) drop irc> is-running>> [ (handle-disconnect) ] when ; @@ -220,14 +295,14 @@ DEFER: (connect-irc) [ (reader-loop) ] [ handle-disconnect ] recover ; : writer-loop ( -- ) - irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ; + irc> out-messages>> mailbox-get handle-outgoing-irc ; ! ====================================== ! Processing loops ! ====================================== : in-multiplexer-loop ( -- ) - irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ; + irc> in-messages>> mailbox-get handle-incoming-irc ; : strings>privmsg ( name string -- privmsg ) privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ; @@ -236,12 +311,12 @@ DEFER: (connect-irc) { { [ dup string? ] [ strings>privmsg ] } { [ dup privmsg instance? ] [ swap >>name ] } + [ nip ] } cond ; : listener-loop ( name listener -- ) - out-messages>> swap - '[ , swap maybe-annotate-with-name irc> out-messages>> mailbox-put ] - irc-mailbox-get ; + out-messages>> mailbox-get maybe-annotate-with-name + irc> out-messages>> mailbox-put ; : spawn-irc-loop ( quot name -- ) [ '[ irc> is-running>> [ @ ] when irc> is-running>> ] ] dip @@ -275,7 +350,7 @@ M: irc-nick-listener (add-listener) ( irc-nick-listener -- ) [ name>> ] keep set+run-listener ; M: irc-server-listener (add-listener) ( irc-server-listener -- ) - +server-listener+ swap set+run-listener ; + [ +server-listener+ ] dip set+run-listener ; GENERIC: (remove-listener) ( irc-listener -- ) @@ -283,8 +358,8 @@ M: irc-nick-listener (remove-listener) ( irc-nick-listener -- ) name>> unregister-listener ; M: irc-channel-listener (remove-listener) ( irc-channel-listener -- ) - [ [ out-messages>> ] [ name>> ] bi - \ part new swap >>channel mailbox-put ] keep + [ [ name>> ] [ out-messages>> ] bi + [ [ part new ] dip >>channel ] dip mailbox-put ] keep name>> unregister-listener ; M: irc-server-listener (remove-listener) ( irc-server-listener -- ) @@ -294,10 +369,10 @@ M: irc-server-listener (remove-listener) ( irc-server-listener -- ) [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep swap >>stream t >>is-running - in-messages>> irc-connected swap mailbox-put ; + in-messages>> [ irc-connected ] dip mailbox-put ; : with-irc-client ( irc-client quot -- ) - >r current-irc-client r> with-variable ; inline + [ current-irc-client ] dip with-variable ; inline PRIVATE> diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor new file mode 100644 index 0000000000..1bd6088f82 --- /dev/null +++ b/extra/irc/messages/messages-tests.factor @@ -0,0 +1,37 @@ +USING: kernel tools.test accessors arrays qualified + irc.messages irc.messages.private ; +EXCLUDE: sequences => join ; +IN: irc.messages.tests + +! Parsing tests +irc-message new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + string>irc-message f >>timestamp ] unit-test + +privmsg new + ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line + "someuser!n=user@some.where" >>prefix + "PRIVMSG" >>command + { "#factortest" } >>parameters + "hi" >>trailing + "#factortest" >>name +1array +[ ":someuser!n=user@some.where PRIVMSG #factortest :hi" + parse-irc-line f >>timestamp ] unit-test + +join new + ":someuser!n=user@some.where JOIN :#factortest" >>line + "someuser!n=user@some.where" >>prefix + "JOIN" >>command + { } >>parameters + "#factortest" >>trailing +1array +[ ":someuser!n=user@some.where JOIN :#factortest" + parse-irc-line f >>timestamp ] unit-test + diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index f1beba9b26..5813c72723 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2008 Bruno Deferrari ! See http://factorcode.org/license.txt for BSD license. -USING: kernel fry sequences splitting ascii calendar accessors combinators - classes.tuple math.order ; +USING: kernel fry splitting ascii calendar accessors combinators qualified + arrays classes.tuple math.order ; +RENAME: join sequences => sjoin +EXCLUDE: sequences => join ; IN: irc.messages TUPLE: irc-message line prefix command parameters trailing timestamp ; TUPLE: logged-in < irc-message name ; TUPLE: ping < irc-message ; -TUPLE: join < irc-message channel ; +TUPLE: join < irc-message ; TUPLE: part < irc-message channel ; TUPLE: quit < irc-message ; TUPLE: privmsg < irc-message name ; @@ -16,8 +18,26 @@ TUPLE: roomlist < irc-message channel names ; TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name channel mode ; +TUPLE: names-reply < irc-message who = channel ; TUPLE: unhandled < irc-message ; +: ( command parameters trailing -- irc-message ) + irc-message new now >>timestamp + [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ; + +GENERIC: irc-message>client-line ( irc-message -- string ) + +M: irc-message irc-message>client-line ( irc-message -- string ) + [ command>> ] + [ parameters>> " " sjoin ] + [ trailing>> dup [ CHAR: : prefix ] when ] + tri 3array " " sjoin ; + +GENERIC: irc-message>server-line ( irc-message -- string ) + +M: irc-message irc-message>server-line ( irc-message -- string ) + drop "not implemented yet" ; + + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip @@ -55,6 +77,7 @@ TUPLE: unhandled < irc-message ; { "NOTICE" [ \ notice ] } { "001" [ \ logged-in ] } { "433" [ \ nick-in-use ] } + { "353" [ \ names-reply ] } { "JOIN" [ \ join ] } { "PART" [ \ part ] } { "PRIVMSG" [ \ privmsg ] } @@ -66,4 +89,3 @@ TUPLE: unhandled < irc-message ; [ [ tuple-slots ] [ parameters>> ] bi append ] dip [ all-slots over [ length ] bi@ min head ] keep slots>tuple ; -PRIVATE> diff --git a/extra/irc/ui/commandparser/commandparser.factor b/extra/irc/ui/commandparser/commandparser.factor new file mode 100755 index 0000000000..2835023c0d --- /dev/null +++ b/extra/irc/ui/commandparser/commandparser.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel vocabs.loader sequences strings splitting words irc.messages ; + +IN: irc.ui.commandparser + +"irc.ui.commands" require + +: command ( string string -- string command ) + dup empty? [ drop "say" ] when + dup "irc.ui.commands" lookup + [ nip ] + [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ; + +: parse-message ( string -- ) + "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ; diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor new file mode 100755 index 0000000000..59f4526d23 --- /dev/null +++ b/extra/irc/ui/commands/commands.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors kernel irc.client irc.messages irc.ui namespaces ; + +IN: irc.ui.commands + +: say ( string -- ) + [ client get profile>> nickname>> print-irc ] + [ listener get write-message ] bi ; + +: quote ( string -- ) + drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ircui-rc b/extra/irc/ui/ircui-rc new file mode 100755 index 0000000000..a1533c7b4d --- /dev/null +++ b/extra/irc/ui/ircui-rc @@ -0,0 +1,9 @@ +! Default system ircui-rc file +! Copy into .ircui-rc in your home directory and then change username and such +! To find your home directory, type "home ." into a Factor listener + +USING: irc.client irc.ui ; + +"irc.freenode.org" 8001 "factor-irc" f ! server port nick password +{ "#concatenative" "#terrorisland" } ! all the channels you want to autojoin +server-open diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor new file mode 100755 index 0000000000..e6f4d07b56 --- /dev/null +++ b/extra/irc/ui/load/load.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 William Schlieper +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel io.files parser editors sequences ; + +IN: irc.ui.load + +: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ; + +: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ; + +: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ; + +: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ; + +: run-ircui ( -- ) ircui-rc run-file ; diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index cc138dad92..a79920efe5 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -3,52 +3,81 @@ USING: accessors kernel threads combinators concurrency.mailboxes sequences strings hashtables splitting fry assocs hashtables - ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers - ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs - io io.styles namespaces irc.client irc.messages ; + 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.lists ui.gadgets.labels + io io.styles namespaces calendar calendar.format models + irc.client irc.client.private irc.messages irc.messages.private + irc.ui.commandparser irc.ui.load ; IN: irc.ui +SYMBOL: listener + SYMBOL: client TUPLE: ui-window client tabs ; +TUPLE: irc-tab < frame listener client listmodel ; + : write-color ( str color -- ) foreground associate format ; : red { 0.5 0 0 1 } ; : green { 0 0.5 0 1 } ; : blue { 0 0 1 1 } ; +: black { 0 0 0 1 } ; -: prefix>nick ( prefix -- nick ) - "!" split first ; +: colors H{ { +operator+ { 0 0.5 0 1 } } + { +voice+ { 0 0 1 1 } } + { +normal+ { 0 0 0 1 } } } ; + +: dot-or-parens ( string -- string ) + dup empty? [ drop "." ] + [ "(" prepend ")" append ] if ; GENERIC: write-irc ( irc-message -- ) M: privmsg write-irc "<" blue write-color - [ prefix>> prefix>nick write ] keep - ">" blue write-color - " " write + [ prefix>> parse-name write ] keep + "> " blue write-color trailing>> write ; +TUPLE: own-message message nick timestamp ; + +: ( message nick -- own-message ) + now own-message boa ; + +M: own-message write-irc + "<" blue write-color + [ nick>> bold font-style associate format ] keep + "> " blue write-color + message>> write ; + M: join write-irc "* " green write-color - prefix>> prefix>nick write + prefix>> parse-name write " has entered the channel." green write-color ; M: part write-irc "* " red write-color - [ prefix>> prefix>nick write ] keep - " has left the channel(" red write-color - trailing>> write - ")" red write-color ; + [ prefix>> parse-name write ] keep + " has left the channel" red write-color + trailing>> dot-or-parens red write-color ; M: quit write-irc "* " red write-color - [ prefix>> prefix>nick write ] keep - " has left IRC(" red write-color - trailing>> write - ")" red write-color ; + [ prefix>> parse-name write ] keep + " has left IRC" red write-color + trailing>> dot-or-parens red write-color ; + +M: mode write-irc + "* " blue write-color + [ name>> write ] keep + " has applied mode " blue write-color + [ mode>> write ] keep + " to " blue write-color + channel>> write ; M: irc-end write-irc drop "* You have left IRC" red write-color ; @@ -63,56 +92,92 @@ M: irc-message write-irc drop ; ! catch all unimplemented writes, THIS WILL CHANGE : print-irc ( irc-message -- ) - write-irc nl ; + [ timestamp>> timestamp>hms write " " write ] + [ write-irc nl ] bi ; -: send-message ( message listener client -- ) - "<" blue write-color - profile>> nickname>> bold font-style associate format - ">" blue write-color - " " write - over write nl - out-messages>> mailbox-put ; +: send-message ( message -- ) + [ print-irc ] + [ listener get write-message ] bi ; -: display ( stream listener -- ) +GENERIC: handle-inbox ( tab message -- ) + +: filter-participants ( assoc val -- alist ) + [ >alist ] dip + '[ second , = ] filter ; + +: update-participants ( tab -- ) + [ listmodel>> ] [ listener>> participants>> ] bi + [ +operator+ filter-participants ] + [ +voice+ filter-participants ] + [ +normal+ filter-participants ] tri + append append swap set-model ; + +M: participant-changed handle-inbox + drop update-participants ; + +M: object handle-inbox + nip print-irc ; + +: display ( stream tab -- ) '[ , [ [ t ] - [ , read-message print-irc ] + [ , dup listener>> read-message handle-inbox ] [ ] while ] with-output-stream ] "ircv" spawn drop ; -: ( listener -- pane ) +: ( tab -- tab pane ) - [ swap display ] keep ; + [ swap display ] 2keep ; TUPLE: irc-editor < editor outstream listener client ; -: ( pane listener client -- editor ) - [ irc-editor new-editor - swap >>listener swap >>outstream - ] dip client>> >>client ; +: ( tab pane -- tab editor ) + over irc-editor new-editor + swap listener>> >>listener swap >>outstream + over client>> >>client ; : editor-send ( irc-editor -- ) { [ outstream>> ] - [ editor-string ] [ listener>> ] [ client>> ] + [ editor-string ] [ "" swap set-editor-string ] } cleave - '[ , , , send-message ] with-output-stream ; + '[ , listener set , client set , parse-message ] with-output-stream ; irc-editor "general" f { { T{ key-down f f "RET" } editor-send } { T{ key-down f f "ENTER" } editor-send } } define-command-map -: irc-page ( name pane editor tabbed -- ) - [ [ @bottom frame, ! editor - @center frame, ! pane - ] make-frame swap ] dip add-page ; +: ( -- gadget model ) + [ drop ] + [ first2 [