-USING: arrays combinators crypto.common kernel io
-io.encodings.binary io.files io.streams.byte-array math.vectors
-strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols math.bitfields.lib checksums ;
+! Copyright (C) 2006, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators kernel io io.encodings.binary io.files
+io.streams.byte-array math.vectors strings sequences namespaces
+math parser sequences assocs grouping vectors io.binary hashtables
+symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.
{ 3 [ bitxor bitxor ] }
} case ;
+: nth-int-be ( string n -- int )
+ 4 * dup 4 + rot <slice> be> ; inline
+
: make-w ( str -- )
#! compute w, steps a-b of RFC 3174, section 6.1
16 [ nth-int-be w get push ] with each
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
+: seq>2seq ( seq -- seq1 seq2 )
+ #! { abcdefgh } -> { aceg } { bdfh }
+ 2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
+
+: 2seq>seq ( seq1 seq2 -- seq )
+ #! { aceg } { bdfh } -> { abcdefgh }
+ [ zip concat ] keep like ;
+
: sha1-interleave ( string -- seq )
- [ zero? ] left-trim
+ [ zero? ] trim-left
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;
--- /dev/null
--- /dev/null
++Chris Double
--- /dev/null
--- /dev/null
++! Copyright (C) 2006 Chris Double.
++! See http://factorcode.org/license.txt for BSD license.
++USING: help.markup help.syntax namespaces assocs sequences
++kernel combinators ;
++IN: match
++
++HELP: match
++{ $values { "value1" object } { "value2" object } { "bindings" assoc }
++}
++{ $description "Pattern match value1 against value2. These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The '_' symbol can be used to ignore the value at that point in the pattern for the match. " }
++{ $examples
++ { $unchecked-example "USE: match" "MATCH-VARS: ?a ?b ;\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match ." "H{ { ?a 1 } { ?b 3 } }" }
++}
++{ $see-also match-cond POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
++
++HELP: match-cond
++{ $values { "assoc" "a sequence of pairs" } }
++{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
++{ $examples
++ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
++}
++{ $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
++
++
++HELP: MATCH-VARS:
++{ $syntax "MATCH-VARS: var ... ;" }
++{ $values { "var" "a match variable name beginning with '?'" } }
++{ $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." }
++{ $examples
++ { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
++}
++{ $see-also match match-cond replace-patterns match-replace } ;
++
++HELP: replace-patterns
++{ $values { "object" object } { "result" object } }
++{ $description "Copy the object, replacing each occurrence of a pattern matching variable with the actual value of that variable." }
++{ $see-also match-cond POSTPONE: MATCH-VARS: match-replace } ;
++
++HELP: match-replace
++{ $values { "object" object } { "pattern1" object } { "pattern2" object } { "result" object } }
++{ $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." }
++{ $examples
++ { $example
++ "USING: match prettyprint ;"
++ "IN: scratchpad"
++ "MATCH-VARS: ?a ?b ;"
++ "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
++ "{ 2 1 }"
++ }
++}
++{ $see-also match-cond POSTPONE: MATCH-VARS: } ;
++
++ARTICLE: "match" "Pattern matching"
++"The " { $vocab-link "match" } " vocabulary implements ML-style pattern matching."
++$nl
++"Variables used for pattern matching must be explicitly defined first:"
++{ $subsection POSTPONE: MATCH-VARS: }
++"A basic pattern match:"
++{ $subsection match }
++"A conditional form analogous to " { $link cond } ":"
++{ $subsection match-cond }
++"Pattern replacement:"
++{ $subsection match-replace } ;
++
++ABOUT: "match"
--- /dev/null
--- /dev/null
++! Copyright (C) 2006 Chris Double.
++! See http://factorcode.org/license.txt for BSD license.
++USING: tools.test match namespaces arrays ;
++IN: match.tests
++
++MATCH-VARS: ?a ?b ;
++
++[ f ] [ { ?a ?a } { 1 2 } match ] unit-test
++
++[ H{ { ?a 1 } { ?b 2 } } ] [
++ { ?a ?b } { 1 2 } match
++] unit-test
++
++[ { 1 2 } ] [
++ { 1 2 }
++ {
++ { { ?a ?b } [ ?a ?b 2array ] }
++ } match-cond
++] unit-test
++
++[ t ] [
++ { 1 2 }
++ {
++ { { 1 2 } [ t ] }
++ { f [ f ] }
++ } match-cond
++] unit-test
++
++[ t ] [
++ { 1 3 }
++ {
++ { { 1 2 } [ t ] }
++ { { 1 3 } [ t ] }
++ } match-cond
++] unit-test
++
++[ f ] [
++ { 1 5 }
++ {
++ { { 1 2 } [ t ] }
++ { { 1 3 } [ t ] }
++ { _ [ f ] }
++ } match-cond
++] unit-test
++
++TUPLE: foo a b ;
++
++C: <foo> foo
++
++{ 1 2 } [
++ 1 2 <foo> T{ foo f ?a ?b } match [
++ ?a ?b
++ ] bind
++] unit-test
++
++{ 1 2 } [
++ 1 2 <foo> \ ?a \ ?b <foo> match [
++ ?a ?b
++ ] bind
++] unit-test
++
++{ H{ { ?a ?a } } } [
++ \ ?a \ ?a match
++] unit-test
++
++[ "match" ] [
++ "abcd" {
++ { ?a [ "match" ] }
++ } match-cond
++] unit-test
++
++[
++ { 2 1 }
++] [
++ { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
++] unit-test
++
++TUPLE: match-replace-test a b ;
++
++[
++ T{ match-replace-test f 2 1 }
++] [
++ T{ match-replace-test f 1 2 }
++ T{ match-replace-test f ?a ?b }
++ T{ match-replace-test f ?b ?a }
++ match-replace
++] unit-test
--- /dev/null
--- /dev/null
++! Copyright (C) 2006 Chris Double.
++! See http://factorcode.org/license.txt for BSD license.
++!
++! Based on pattern matching code from Paul Graham's book 'On Lisp'.
++USING: parser lexer kernel words namespaces sequences classes.tuple
++combinators macros assocs math effects ;
++IN: match
++
++SYMBOL: _
++
++: define-match-var ( name -- )
++ create-in
++ dup t "match-var" set-word-prop
++ dup [ get ] curry (( -- value )) define-declared ;
++
++: define-match-vars ( seq -- )
++ [ define-match-var ] each ;
++
++: MATCH-VARS: ! vars ...
++ ";" parse-tokens define-match-vars ; parsing
++
++: match-var? ( symbol -- bool )
++ dup word? [ "match-var" word-prop ] [ drop f ] if ;
++
++: set-match-var ( value var -- ? )
++ dup namespace key? [ get = ] [ set t ] if ;
++
++: (match) ( value1 value2 -- matched? )
++ {
++ { [ dup match-var? ] [ set-match-var ] }
++ { [ over match-var? ] [ swap set-match-var ] }
++ { [ 2dup = ] [ 2drop t ] }
++ { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
++ { [ 2dup [ sequence? ] both? ] [
++ 2dup [ length ] bi@ =
++ [ [ (match) ] 2all? ] [ 2drop f ] if ] }
++ { [ 2dup [ tuple? ] both? ]
++ [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
++ { [ t ] [ 2drop f ] }
++ } cond ;
++
++: match ( value1 value2 -- bindings )
++ [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
++
++MACRO: match-cond ( assoc -- )
++ <reversed>
++ [ "Fall-through in match-cond" throw ]
++ [
++ first2
++ >r [ dupd match ] curry r>
++ [ bind ] curry rot
++ [ ?if ] 2curry append
++ ] reduce ;
++
++: replace-patterns ( object -- result )
++ {
++ { [ dup number? ] [ ] }
++ { [ dup match-var? ] [ get ] }
++ { [ dup sequence? ] [ [ replace-patterns ] map ] }
++ { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
++ [ ]
++ } cond ;
++
++: match-replace ( object pattern1 pattern2 -- result )
++ -rot
++ match [ "Pattern does not match" throw ] unless*
++ [ replace-patterns ] bind ;
++
++: ?1-tail ( seq -- tail/f )
++ dup length zero? not [ rest ] [ drop f ] if ;
++
++: (match-first) ( seq pattern-seq -- bindings leftover/f )
++ 2dup [ length ] bi@ < [ 2drop f f ]
++ [
++ 2dup length head over match
++ [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
++ ] if ;
++
++: match-first ( seq pattern-seq -- bindings )
++ (match-first) drop ;
++
++: (match-all) ( seq pattern-seq -- )
++ tuck (match-first) swap
++ [
++ , [ swap (match-all) ] [ drop ] if*
++ ] [ 2drop ] if* ;
++
++: match-all ( seq pattern-seq -- bindings-seq )
++ [ (match-all) ] { } make ;
++
--- /dev/null
--- /dev/null
++ML-style pattern matching
--- /dev/null
--- /dev/null
++extensions
USING: assocs io.files hashtables kernel namespaces sequences
vocabs.loader io combinators io.encodings.utf8 calendar accessors
math.parser io.streams.string ui.tools.operations quotations
-strings arrays prettyprint words vocabs sorting sets cords
-classes sequences.lib combinators.lib alien math ;
+strings arrays prettyprint words vocabs sorting sets
- classes ;
++classes alien ;
IN: tools.scaffold
SYMBOL: developer-name
{ "obj3" object } { "obj4" object }
{ "quot" quotation } { "quot1" quotation }
{ "quot2" quotation } { "quot3" quotation }
+ { "quot'" quotation }
{ "string" string } { "string1" string }
{ "string2" string } { "string3" string }
{ "str" string }
{ "ch" "a character" }
{ "word" word }
{ "array" array }
+ { "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
{ "vocab-root" "a vocabulary root string" }
+ { "c-ptr" c-ptr }
+ { "seq" sequence } { "seq1" sequence } { "seq2" sequence }
+ { "seq3" sequence } { "seq4" sequence }
+ { "seq1'" sequence } { "seq2'" sequence }
+ { "newseq" sequence }
+ { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
+ { "assoc3" assoc } { "newassoc" assoc }
+ { "alist" "an array of key/value pairs" }
+ { "keys" sequence } { "values" sequence }
+ { "class" class }
} at* ;
: add-using ( object -- )
: help-file-string ( str1 -- str2 )
[
- [ "IN: " write print nl ]
- [ interesting-words. ]
- [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
- [ "ABOUT: " write unparse print ] quad
+ {
+ [ "IN: " write print nl ]
+ [ interesting-words. ]
+ [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
+ [ "ABOUT: " write unparse print ]
+ } cleave
] with-string-writer ;
: write-using ( -- )
"USING:" write
using get keys
- { "help.markup" "help.syntax" } cord-append natural-sort
+ { "help.markup" "help.syntax" } append natural-sort
[ bl write ] each
" ;" print ;
[ drop scaffold-authors ]
[ nip require ]
} 2cleave ;
+
+ SYMBOL: examples-flag
+
+ : example ( -- )
+ {
+ "{ $example \"\" \"USING: prettyprint ;\""
+ " \"\""
+ " \"\""
+ "}"
+ } [ examples-flag get [ " " write ] when print ] each ;
+
+ : examples ( n -- )
+ t \ examples-flag [
+ "{ $examples " print
+ [ example ] times
+ "}" print
+ ] with-variable ;
{ $subsection find-last }
{ $subsection find-last-from } ;
+ ARTICLE: "sequences-trimming" "Trimming sequences"
+ "Trimming words:"
+ { $subsection trim }
+ { $subsection trim-left }
+ { $subsection trim-right }
+ "Potentially more efficient trim:"
+ { $subsection trim-slice }
+ { $subsection trim-left-slice }
+ { $subsection trim-right-slice } ;
+
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
+ { $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence has zero length." } ;
+HELP: if-empty
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
+{ $example
+ "USING: kernel prettyprint sequences sequences.lib ;"
+ "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
+ "6"
+} ;
+
HELP: delete-all
{ $values { "seq" "a resizable sequence" } }
{ $description "Resizes the sequence to zero length, removing all elements. Not all sequences are resizable." }
HELP: padding
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
- { $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of { " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
+ { $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-left
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
"50"
} ;
+ HELP: pusher
+ { $values
+ { "quot" "a predicate quotation" }
+ { "quot" quotation } { "accum" vector } }
+ { $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
+ { $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
+ "10 [ even? ] pusher [ each ] dip ."
+ "V{ 0 2 4 6 8 }"
+ }
+ { $notes "Used to implement the " { $link filter } " word." } ;
+
+ HELP: trim-left
+ { $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+ { $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+ { $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ."
+ "{ 1 2 3 0 0 }"
+ } ;
+
+ HELP: trim-right
+ { $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+ { $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+ { $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ."
+ "{ 0 0 1 2 3 }"
+ } ;
+
+ HELP: trim
+ { $values
+ { "seq" sequence } { "quot" quotation }
+ { "newseq" sequence } }
+ { $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
+ { $example "" "USING: prettyprint math sequences ;"
+ "{ 0 0 1 2 3 0 0 } [ zero? ] trim ."
+ "{ 1 2 3 }"
+ } ;
+
+ { trim-left trim-right trim } related-words
generic vocabs.loader ;
IN: sequences.tests
+[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
+[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
+
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ 3 ] [ 1 4 dup <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
- [ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
- [ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test
- [ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test
- [ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test
+ [ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test
+ [ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test
+ [ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test
+ [ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
- [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
- [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+ [ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test
+ [ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
M: bogus-hashcode hashcode* 2drop 0 >bignum ;
[ 0 ] [ { T{ bogus-hashcode } } hashcode ] unit-test
+
+[ { 2 4 6 } { 1 3 5 7 } ] [ { 1 2 3 4 5 6 7 } [ even? ] partition ] unit-test
+
+[ { 1 3 7 } ] [ 2 { 1 3 5 7 } remove-nth ] unit-test
+
+[ { 1 3 "X" 5 7 } ] [ "X" 2 { 1 3 5 7 } insert-nth ] unit-test
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
: empty? ( seq -- ? ) length zero? ; inline
+
+: if-empty ( seq quot1 quot2 -- )
+ [ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
+
+: when-empty ( seq quot1 -- ) [ ] if-empty ; inline
+
+: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline
+
: delete-all ( seq -- ) 0 swap set-length ;
: first ( seq -- first ) 0 swap nth ; inline
: filter ( seq quot -- subseq )
over >r pusher >r each r> r> like ; inline
+: push-either ( elt quot accum1 accum2 -- )
+ >r >r keep swap r> r> ? push ; inline
+
+: 2pusher ( quot -- quot accum1 accum2 )
+ V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
+
+: partition ( seq quot -- trueseq falseseq )
+ over >r 2pusher >r >r each r> r> r> tuck [ like ] 2bi@ ; inline
+
: monotonic? ( seq quot -- ? )
>r dup length 1- swap r> (monotonic) all? ; inline
[ >r >r dup pick length + r> - over r> open-slice ] keep
copy ;
+: remove-nth ( n seq -- seq' )
+ [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
+
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: cut-slice ( seq n -- before after )
[ head-slice ] [ tail-slice ] 2bi ;
+: insert-nth ( elt n seq -- seq' )
+ swap cut-slice [ swap suffix ] dip append ;
+
: midpoint@ ( seq -- n ) length 2/ ; inline
: halves ( seq -- first second )
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
- : left-trim ( seq quot -- newseq )
+ : trim-left-slice ( seq quot -- slice )
over >r [ not ] compose find drop r> swap
- [ tail ] [ dup length tail ] if* ; inline
+ [ tail-slice ] [ dup length tail-slice ] if* ; inline
+
+ : trim-left ( seq quot -- newseq )
+ over [ trim-left-slice ] dip like ; inline
- : right-trim ( seq quot -- newseq )
+ : trim-right-slice ( seq quot -- slice )
over >r [ not ] compose find-last drop r> swap
- [ 1+ head ] [ 0 head ] if* ; inline
+ [ 1+ head-slice ] [ 0 head-slice ] if* ; inline
+
+ : trim-right ( seq quot -- newseq )
+ over [ trim-right-slice ] dip like ; inline
+
+ : trim-slice ( seq quot -- slice )
+ [ trim-left-slice ] [ trim-right-slice ] bi ;
: trim ( seq quot -- newseq )
- [ left-trim ] [ right-trim ] bi ; inline
+ over [ trim-slice ] dip like ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
+++ /dev/null
--Chris Double
+++ /dev/null
--! Copyright (C) 2006 Chris Double.
--! See http://factorcode.org/license.txt for BSD license.
--USING: help.markup help.syntax namespaces assocs sequences
--kernel combinators ;
--IN: match
--
--HELP: match
--{ $values { "value1" object } { "value2" object } { "bindings" assoc }
--}
--{ $description "Pattern match value1 against value2. These values can be any Factor value, including sequences and tuples. The values can contain pattern variables, which are symbols that begin with '?'. The result is a hashtable of the bindings, mapping the pattern variables from one sequence to the equivalent value in the other sequence. The '_' symbol can be used to ignore the value at that point in the pattern for the match. " }
--{ $examples
-- { $unchecked-example "USE: match" "MATCH-VARS: ?a ?b ;\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match ." "H{ { ?a 1 } { ?b 3 } }" }
--}
--{ $see-also match-cond POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
--
--HELP: match-cond
--{ $values { "assoc" "a sequence of pairs" } }
--{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." }
--{ $examples
-- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
--}
--{ $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ;
--
--
--HELP: MATCH-VARS:
--{ $syntax "MATCH-VARS: var ... ;" }
--{ $values { "var" "a match variable name beginning with '?'" } }
--{ $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." }
--{ $examples
-- { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" }
--}
--{ $see-also match match-cond replace-patterns match-replace } ;
--
--HELP: replace-patterns
--{ $values { "object" object } { "result" object } }
--{ $description "Copy the object, replacing each occurrence of a pattern matching variable with the actual value of that variable." }
--{ $see-also match-cond POSTPONE: MATCH-VARS: match-replace } ;
--
--HELP: match-replace
--{ $values { "object" object } { "pattern1" object } { "pattern2" object } { "result" object } }
--{ $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." }
--{ $examples
-- { $example
-- "USING: match prettyprint ;"
-- "IN: scratchpad"
-- "MATCH-VARS: ?a ?b ;"
-- "{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
-- "{ 2 1 }"
-- }
--}
--{ $see-also match-cond POSTPONE: MATCH-VARS: } ;
--
--ARTICLE: "match" "Pattern matching"
--"The " { $vocab-link "match" } " vocabulary implements ML-style pattern matching."
--$nl
--"Variables used for pattern matching must be explicitly defined first:"
--{ $subsection POSTPONE: MATCH-VARS: }
--"A basic pattern match:"
--{ $subsection match }
--"A conditional form analogous to " { $link cond } ":"
--{ $subsection match-cond }
--"Pattern replacement:"
--{ $subsection match-replace } ;
--
--ABOUT: "match"
+++ /dev/null
--! Copyright (C) 2006 Chris Double.
--! See http://factorcode.org/license.txt for BSD license.
--USING: tools.test match namespaces arrays ;
--IN: match.tests
--
--MATCH-VARS: ?a ?b ;
--
--[ f ] [ { ?a ?a } { 1 2 } match ] unit-test
--
--[ H{ { ?a 1 } { ?b 2 } } ] [
-- { ?a ?b } { 1 2 } match
--] unit-test
--
--[ { 1 2 } ] [
-- { 1 2 }
-- {
-- { { ?a ?b } [ ?a ?b 2array ] }
-- } match-cond
--] unit-test
--
--[ t ] [
-- { 1 2 }
-- {
-- { { 1 2 } [ t ] }
-- { f [ f ] }
-- } match-cond
--] unit-test
--
--[ t ] [
-- { 1 3 }
-- {
-- { { 1 2 } [ t ] }
-- { { 1 3 } [ t ] }
-- } match-cond
--] unit-test
--
--[ f ] [
-- { 1 5 }
-- {
-- { { 1 2 } [ t ] }
-- { { 1 3 } [ t ] }
-- { _ [ f ] }
-- } match-cond
--] unit-test
--
--TUPLE: foo a b ;
--
--C: <foo> foo
--
--{ 1 2 } [
-- 1 2 <foo> T{ foo f ?a ?b } match [
-- ?a ?b
-- ] bind
--] unit-test
--
--{ 1 2 } [
-- 1 2 <foo> \ ?a \ ?b <foo> match [
-- ?a ?b
-- ] bind
--] unit-test
--
--{ H{ { ?a ?a } } } [
-- \ ?a \ ?a match
--] unit-test
--
--[ "match" ] [
-- "abcd" {
-- { ?a [ "match" ] }
-- } match-cond
--] unit-test
--
--[
-- { 2 1 }
--] [
-- { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace
--] unit-test
--
--TUPLE: match-replace-test a b ;
--
--[
-- T{ match-replace-test f 2 1 }
--] [
-- T{ match-replace-test f 1 2 }
-- T{ match-replace-test f ?a ?b }
-- T{ match-replace-test f ?b ?a }
-- match-replace
--] unit-test
+++ /dev/null
--! Copyright (C) 2006 Chris Double.
--! See http://factorcode.org/license.txt for BSD license.
--!
--! Based on pattern matching code from Paul Graham's book 'On Lisp'.
--USING: parser lexer kernel words namespaces sequences classes.tuple
--combinators macros assocs math effects ;
--IN: match
--
--SYMBOL: _
--
--: define-match-var ( name -- )
-- create-in
-- dup t "match-var" set-word-prop
-- dup [ get ] curry (( -- value )) define-declared ;
--
--: define-match-vars ( seq -- )
-- [ define-match-var ] each ;
--
--: MATCH-VARS: ! vars ...
-- ";" parse-tokens define-match-vars ; parsing
--
--: match-var? ( symbol -- bool )
-- dup word? [ "match-var" word-prop ] [ drop f ] if ;
--
--: set-match-var ( value var -- ? )
-- dup namespace key? [ get = ] [ set t ] if ;
--
--: (match) ( value1 value2 -- matched? )
-- {
-- { [ dup match-var? ] [ set-match-var ] }
-- { [ over match-var? ] [ swap set-match-var ] }
-- { [ 2dup = ] [ 2drop t ] }
-- { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
-- { [ 2dup [ sequence? ] both? ] [
-- 2dup [ length ] bi@ =
-- [ [ (match) ] 2all? ] [ 2drop f ] if ] }
-- { [ 2dup [ tuple? ] both? ]
-- [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
-- { [ t ] [ 2drop f ] }
-- } cond ;
--
--: match ( value1 value2 -- bindings )
-- [ (match) ] H{ } make-assoc swap [ drop f ] unless ;
--
--MACRO: match-cond ( assoc -- )
-- <reversed>
-- [ "Fall-through in match-cond" throw ]
-- [
-- first2
-- >r [ dupd match ] curry r>
-- [ bind ] curry rot
-- [ ?if ] 2curry append
-- ] reduce ;
--
--: replace-patterns ( object -- result )
-- {
-- { [ dup number? ] [ ] }
-- { [ dup match-var? ] [ get ] }
-- { [ dup sequence? ] [ [ replace-patterns ] map ] }
-- { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
-- [ ]
-- } cond ;
--
--: match-replace ( object pattern1 pattern2 -- result )
-- -rot
-- match [ "Pattern does not match" throw ] unless*
-- [ replace-patterns ] bind ;
--
--: ?1-tail ( seq -- tail/f )
-- dup length zero? not [ rest ] [ drop f ] if ;
--
--: (match-first) ( seq pattern-seq -- bindings leftover/f )
-- 2dup [ length ] bi@ < [ 2drop f f ]
-- [
-- 2dup length head over match
-- [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if*
-- ] if ;
--
--: match-first ( seq pattern-seq -- bindings )
-- (match-first) drop ;
--
--: (match-all) ( seq pattern-seq -- )
-- tuck (match-first) swap
-- [
-- , [ swap (match-all) ] [ drop ] if*
-- ] [ 2drop ] if* ;
--
--: match-all ( seq pattern-seq -- bindings-seq )
-- [ (match-all) ] { } make ;
--
+++ /dev/null
--ML-style pattern matching
+++ /dev/null
--extensions
USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces
parser prettyprint quotations sequences strings vectors words
-macros math.functions math.bitfields.lib ;
+macros math.functions math.bitwise ;
IN: pack
SYMBOL: big-endian
"\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f )
- read [ zero? ] right-trim dup empty? [ drop f ] when ;
+ read [ zero? ] trim-right dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
read1
projects / factor.git / commitdiff