diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index 2603a75cb0..c4090e1098 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -7,8 +7,8 @@ IN: lisp.test [ init-env - "#f" [ f ] lisp-define - "#t" [ t ] lisp-define + [ f ] "#f" lisp-define + [ t ] "#t" lisp-define "+" "math" "+" define-primitive "-" "math" "-" define-primitive @@ -31,6 +31,14 @@ IN: lisp.test "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval ] unit-test + { T{ lisp-symbol f "if" } } [ + "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval + ] unit-test + + { t } [ + T{ lisp-symbol f "if" } lisp-macro? + ] unit-test + { 1 } [ "(if #t 1 2)" lisp-eval ] unit-test diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 6193c3b33e..e865a2e3ed 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -2,24 +2,22 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg sequences arrays strings combinators.lib namespaces combinators math locals locals.private accessors -vectors syntax lisp.parser assocs parser sequences.lib words quotations -fry lists inspector ; +vectors syntax lisp.parser assocs parser sequences.lib words +quotations fry lists inspector ; IN: lisp DEFER: convert-form DEFER: funcall DEFER: lookup-var -DEFER: lisp-macro? DEFER: lookup-macro -DEFER: macro-call - +DEFER: lisp-macro? +DEFER: macro-expand +DEFER: define-lisp-macro + ! Functions to convert s-exps to quotations ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : convert-body ( cons -- quot ) [ ] [ convert-form compose ] foldl ; inline - -: convert-if ( cons -- quot ) - cdr 3car [ convert-form ] tri@ '[ @ , , if ] ; : convert-begin ( cons -- quot ) cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ; @@ -34,13 +32,11 @@ DEFER: macro-call ! words for convert-lambda > swap at swap or ] - [ dup cons? [ localize-body ] when nip ] if - ] with lmap>array ; - + [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ; + : localize-lambda ( body vars -- newbody newvars ) make-locals dup push-locals swap - [ swap localize-body seq>cons convert-form swap pop-locals ] dip swap ; + [ swap localize-body convert-form swap pop-locals ] dip swap ; : split-lambda ( cons -- body-cons vars-seq ) 3car -rot nip [ name>> ] lmap>array ; inline @@ -67,24 +63,24 @@ PRIVATE> [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ] [ cadr ] traverse ; -: form-dispatch ( lisp-symbol -- quot ) +: convert-defmacro ( cons -- quot ) + cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ; + +: form-dispatch ( cons lisp-symbol -- quot ) name>> { { "lambda" [ convert-lambda ] } + { "defmacro" [ convert-defmacro ] } { "quote" [ convert-quoted ] } { "unquote" [ convert-unquoted ] } { "quasiquote" [ convert-quasiquoted ] } - { "if" [ convert-if ] } { "begin" [ convert-begin ] } { "cond" [ convert-cond ] } [ drop convert-general-form ] } case ; -: macro-expand ( cons -- quot ) - uncons lookup-macro macro-call convert-form ; - : convert-list-form ( cons -- quot ) dup car - { { [ dup lisp-macro? ] [ macro-expand ] } + { { [ dup lisp-macro? ] [ drop macro-expand ] } { [ dup lisp-symbol? ] [ form-dispatch ] } [ drop convert-general-form ] } cond ; @@ -96,8 +92,17 @@ PRIVATE> [ 1quotation ] } cond ; +: compile-form ( lisp-ast -- quot ) + convert-form lambda-rewrite call ; inline + +: macro-call ( lambda -- cons ) + call ; inline + +: macro-expand ( cons -- quot ) + uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ; + : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form lambda-rewrite call ; + lisp-expr parse-result-ast compile-form ; : lisp-eval ( str -- * ) lisp-string>factor call ; @@ -105,18 +110,17 @@ PRIVATE> ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: lisp-env -ERROR: no-such-var var ; - SYMBOL: macro-env +ERROR: no-such-var variable-name ; M: no-such-var summary drop "No such variable" ; : init-env ( -- ) H{ } clone lisp-env set H{ } clone macro-env set ; -: lisp-define ( name quot -- ) - swap lisp-env get set-at ; +: lisp-define ( quot name -- ) + lisp-env get set-at ; : lisp-get ( name -- word ) dup lisp-env get at [ ] [ no-such-var ] ?if ; @@ -128,10 +132,13 @@ M: no-such-var summary drop "No such variable" ; dup lisp-symbol? [ lookup-var ] when call ; inline : define-primitive ( name vocab word -- ) - swap lookup 1quotation '[ , compose call ] lisp-define ; + swap lookup 1quotation '[ , compose call ] swap lisp-define ; -: lookup-macro ( lisp-symbol -- macro ) +: lookup-macro ( lisp-symbol -- lambda ) name>> macro-env get at ; +: define-lisp-macro ( quot name -- ) + macro-env get set-at ; + : lisp-macro? ( car -- ? ) dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ; diff --git a/extra/lists/lazy/examples/examples.factor b/extra/lists/lazy/examples/examples.factor index 9e8fb77439..f85344651d 100644 --- a/extra/lists/lazy/examples/examples.factor +++ b/extra/lists/lazy/examples/examples.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: lazy-lists math kernel sequences quotations ; -IN: lazy-lists.examples +USING: lists.lazy math kernel sequences quotations ; +IN: lists.lazy.examples : naturals 0 lfrom ; : positives 1 lfrom ; diff --git a/extra/lists/lazy/lazy-docs.factor b/extra/lists/lazy/lazy-docs.factor index 8d457ba2e1..6a9359027d 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/extra/lists/lazy/lazy-docs.factor @@ -115,7 +115,7 @@ HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } { $description "Return the result of merging the two lists in a lazy manner." } { $examples - { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } + { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents @@ -127,4 +127,3 @@ HELP: llines { $values { "stream" "a stream" } { "result" "a list" } } { $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } { $see-also lcontents } ; - diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor index a5299ba6a0..15faf8d002 100644 --- a/extra/lists/lists-docs.factor +++ b/extra/lists/lists-docs.factor @@ -19,8 +19,8 @@ HELP: cdr { $description "Returns the tail of the list." } ; HELP: nil -{ $values { "cons" "An empty cons" } } -{ $description "Returns a representation of an empty list" } ; +{ $values { "symbol" "The empty cons (+nil+)" } } +{ $description "Returns a symbol representing the empty list" } ; HELP: nil? { $values { "cons" "a cons object" } { "?" "a boolean" } } @@ -85,7 +85,7 @@ HELP: list>seq { $description "Turns the given cons object into an array, maintaing order." } ; HELP: seq>list -{ $values { "array" "an array object" } { "list" "a cons object" } } +{ $values { "seq" "a sequence" } { "list" "a cons object" } } { $description "Turns the given array into a cons object, maintaing order." } ; HELP: cons>seq @@ -97,7 +97,7 @@ HELP: seq>cons { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; HELP: traverse -{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" } +{ $values { "list" "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" } { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } } { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" " returns true for with the result of applying quot to." } ; diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 30a234214b..13d77f757a 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -8,7 +8,7 @@ IN: lists MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) -GENERIC: nil? ( cons -- ? ) +GENERIC: nil? ( object -- ? ) TUPLE: cons car cdr ; @@ -26,7 +26,7 @@ M: object nil? drop f ; : atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; -: nil ( -- +nil+ ) +nil+ ; +: nil ( -- symbol ) +nil+ ; : uncons ( cons -- cdr car ) [ cdr ] [ car ] bi ; @@ -61,9 +61,9 @@ M: object nil? drop f ; : lmap ( list quot -- result ) over nil? [ drop ] [ (leach) lmap cons ] if ; inline -: foldl ( list ident quot -- result ) swapd leach ; inline +: foldl ( list identity quot -- result ) swapd leach ; inline -: foldr ( list ident quot -- result ) +: foldr ( list identity quot -- result ) pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call diff --git a/extra/persistent-vectors/authors.txt b/extra/persistent-vectors/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/persistent-vectors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor new file mode 100644 index 0000000000..dc9222cedb --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -0,0 +1,53 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: persistent-vectors + +HELP: new-nth +{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } } +{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." } +{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppush +{ $values { "val" object } { "seq" sequence } { "seq'" sequence } } +{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: ppop +{ $values { "seq" sequence } { "seq'" sequence } } +{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } +{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ; + +HELP: PV{ +{ $syntax "elements... }" } +{ $description "Parses a literal " { $link persistent-vector } "." } ; + +HELP: >persistent-vector +{ $values { "seq" sequence } { "pvec" persistent-vector } } +{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ; + +HELP: persistent-vector +{ $class-description "The class of persistent vectors." } ; + +HELP: pempty +{ $values { "pvec" persistent-vector } } +{ $description "Outputs an empty " { $link persistent-vector } "." } ; + +ARTICLE: "persistent-vectors" "Persistent vectors" +"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." +$nl +"The class of persistent vectors:" +{ $subsection persistent-vector } +"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")." +$nl +"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:" +{ $subsection new-nth } +{ $subsection ppush } +{ $subsection ppop } +"The empty persistent vector, used for building up all other persistent vectors:" +{ $subsection pempty } +"Converting a sequence into a persistent vector:" +{ $subsection >persistent-vector } +"Persistent vectors have a literal syntax:" +{ $subsection POSTPONE: PV{ } +"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; + +ABOUT: "persistent-vectors" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor new file mode 100644 index 0000000000..f871c95e16 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors-tests.factor @@ -0,0 +1,63 @@ +IN: persistent-vectors.tests +USING: tools.test persistent-vectors sequences kernel arrays +random namespaces vectors math math.order ; + +\ new-nth must-infer +\ ppush must-infer +\ ppop must-infer + +[ 0 ] [ pempty length ] unit-test + +[ 1 ] [ 3 pempty ppush length ] unit-test + +[ 3 ] [ 3 pempty ppush first ] unit-test + +[ PV{ 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each +] unit-test + +[ { 3 1 3 3 7 } ] [ + pempty { 3 1 3 3 7 } [ swap ppush ] each >array +] unit-test + +{ 100 1060 2000 10000 100000 1000000 } [ + [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test +] each + +[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test +[ ] [ "1" get >vector "2" set ] unit-test + +[ t ] [ + 3000 [ + drop + 16 random-bits 10000 random + [ "1" [ new-nth ] change ] + [ "2" [ new-nth ] change ] 2bi + "1" get "2" get sequence= + ] all? +] unit-test + +[ PV{ } ppop ] [ empty-error? ] must-fail-with + +[ t ] [ PV{ 3 } ppop empty? ] unit-test + +[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test + +[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test + +[ ] [ PV{ } "1" set ] unit-test +[ ] [ V{ } clone "2" set ] unit-test + +[ t ] [ + 100 [ + drop + 100 random [ + 16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi + ] times + 100 random "1" get length min [ + "1" [ ppop ] change + "2" get pop* + ] times + "1" get "2" get sequence= + ] all? +] unit-test diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor new file mode 100644 index 0000000000..f9f4b68933 --- /dev/null +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -0,0 +1,183 @@ +! Based on Clojure's PersistentVector by Rich Hickey. + +USING: math accessors kernel sequences.private sequences arrays +combinators parser prettyprint.backend ; +IN: persistent-vectors + +ERROR: empty-error pvec ; + +GENERIC: ppush ( val seq -- seq' ) + +M: sequence ppush swap suffix ; + +GENERIC: ppop ( seq -- seq' ) + +M: sequence ppop 1 head* ; + +GENERIC: new-nth ( val i seq -- seq' ) + +M: sequence new-nth clone [ set-nth ] keep ; + +TUPLE: persistent-vector count root tail ; + +M: persistent-vector length count>> ; + +> ] bi* nth ; inline + +: body-nth ( i node -- i node' ) + dup level>> [ + dupd [ level>> node-shift ] keep node-nth + ] times ; inline + +: tail-offset ( pvec -- n ) + [ count>> ] [ tail>> children>> length ] bi - ; + +M: persistent-vector nth-unsafe + 2dup tail-offset >= + [ tail>> ] [ root>> body-nth ] if + node-nth ; + +: node-add ( val node -- node' ) + clone [ ppush ] change-children ; + +: ppush-tail ( val pvec -- pvec' ) + [ node-add ] change-tail ; + +: full? ( node -- ? ) + children>> length node-size = ; + +: 1node ( val level -- node ) + node new + swap >>level + swap 1array >>children ; + +: 2node ( first second -- node ) + [ 2array ] [ drop level>> 1+ ] 2bi node boa ; + +: new-child ( new-child node -- node' expansion/f ) + dup full? [ tuck level>> 1node ] [ node-add f ] if ; + +: new-last ( val seq -- seq' ) + [ length 1- ] keep new-nth ; + +: node-set-last ( child node -- node' ) + clone [ new-last ] change-children ; + +: (ppush-new-tail) ( tail node -- node' expansion/f ) + dup level>> 1 = [ + new-child + ] [ + tuck children>> peek (ppush-new-tail) + [ swap new-child ] [ swap node-set-last f ] ?if + ] if ; + +: do-expansion ( pvec root expansion/f -- pvec ) + [ 2node ] when* >>root ; + +: ppush-new-tail ( val pvec -- pvec' ) + [ ] [ tail>> ] [ root>> ] tri + (ppush-new-tail) do-expansion + swap 0 1node >>tail ; + +M: persistent-vector ppush ( val pvec -- pvec' ) + clone + dup tail>> full? + [ ppush-new-tail ] [ ppush-tail ] if + [ 1+ ] change-count ; + +: node-set-nth ( val i node -- node' ) + clone [ new-nth ] change-children ; + +: node-change-nth ( i node quot -- node' ) + [ clone ] dip [ + [ clone ] dip [ change-nth ] 2keep drop + ] curry change-children ; inline + +: (new-nth) ( val i node -- node' ) + dup level>> 0 = [ + [ node-mask ] dip node-set-nth + ] [ + [ dupd level>> node-shift node-mask ] keep + [ (new-nth) ] node-change-nth + ] if ; + +M: persistent-vector new-nth ( obj i pvec -- pvec' ) + 2dup count>> = [ nip ppush ] [ + clone + 2dup tail-offset >= [ + [ node-mask ] dip + [ node-set-nth ] change-tail + ] [ + [ (new-nth) ] change-root + ] if + ] if ; + +: (ppop-contraction) ( node -- node' tail' ) + clone [ unclip-last swap ] change-children swap ; + +: ppop-contraction ( node -- node' tail' ) + [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ; + +: (ppop-new-tail) ( root -- root' tail' ) + dup level>> 1 > [ + dup children>> peek (ppop-new-tail) over children>> empty? + [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if + ] [ + ppop-contraction + ] if ; + +: ppop-tail ( pvec -- pvec' ) + [ clone [ ppop ] change-children ] change-tail ; + +: ppop-new-tail ( pvec -- pvec' ) + dup root>> (ppop-new-tail) + [ + dup [ level>> 1 > ] [ children>> length 1 = ] bi and + [ children>> first ] when + ] dip + [ >>root ] [ >>tail ] bi* ; + +PRIVATE> + +: pempty ( -- pvec ) + T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline + +M: persistent-vector ppop ( pvec -- pvec' ) + dup count>> { + { 0 [ empty-error ] } + { 1 [ drop pempty ] } + [ + [ + clone + dup tail>> children>> length 1 > + [ ppop-tail ] [ ppop-new-tail ] if + ] dip 1- >>count + ] + } case ; + +M: persistent-vector like + drop pempty [ swap ppush ] reduce ; + +M: persistent-vector equal? + over persistent-vector? [ sequence= ] [ 2drop f ] if ; + +: >persistent-vector ( seq -- pvec ) pempty like ; inline + +: PV{ \ } [ >persistent-vector ] parse-literal ; parsing + +M: persistent-vector pprint-delims drop \ PV{ \ } ; + +M: persistent-vector >pprint-sequence ; + +INSTANCE: persistent-vector immutable-sequence diff --git a/extra/persistent-vectors/summary.txt b/extra/persistent-vectors/summary.txt new file mode 100644 index 0000000000..19f3f66ca3 --- /dev/null +++ b/extra/persistent-vectors/summary.txt @@ -0,0 +1 @@ +Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop diff --git a/extra/persistent-vectors/tags.txt b/extra/persistent-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/yahoo/yahoo-docs.factor b/extra/yahoo/yahoo-docs.factor index b5603103e1..1758d62029 100644 --- a/extra/yahoo/yahoo-docs.factor +++ b/extra/yahoo/yahoo-docs.factor @@ -2,5 +2,5 @@ USING: help.syntax help.markup ; IN: yahoo HELP: search-yahoo -{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } } -{ $description "Uses Yahoo's REST API to search for the query specified in the search string, getting the number of answers specified. Returns a sequence of 3arrays, { title url summary }, each of which is a string." } ; +{ $values { "search" search } { "seq" "sequence of arrays of length 3" } } +{ $description "Uses Yahoo's REST API to search for the specified query, getting the number of answers specified. Returns a sequence of " { $link result } " instances." } ;