From 7a6ff3449aa43a81b06ab0946686ff5b4e5d54a5 Mon Sep 17 00:00:00 2001
From: "chris.double" <chris.double@double.co.nz>
Date: Tue, 5 Sep 2006 03:04:27 +0000
Subject: [PATCH] add simple pattern matcher contrib library

---
 contrib/match/load.factor  |  8 +++++++
 contrib/match/match.factor | 38 +++++++++++++++++++++++++++++++++
 contrib/match/match.facts  | 22 +++++++++++++++++++
 contrib/match/tests.factor | 43 ++++++++++++++++++++++++++++++++++++++
 4 files changed, 111 insertions(+)
 create mode 100644 contrib/match/load.factor
 create mode 100644 contrib/match/match.factor
 create mode 100644 contrib/match/match.facts
 create mode 100644 contrib/match/tests.factor

diff --git a/contrib/match/load.factor b/contrib/match/load.factor
new file mode 100644
index 0000000000..8198cfe54d
--- /dev/null
+++ b/contrib/match/load.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+PROVIDE: match { 
+  "match.factor" 
+  "match.facts"
+} { 
+  "tests.factor" 
+} ;
diff --git a/contrib/match/match.factor b/contrib/match/match.factor
new file mode 100644
index 0000000000..6f5c2867c4
--- /dev/null
+++ b/contrib/match/match.factor
@@ -0,0 +1,38 @@
+! 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'.
+IN: match
+USING: kernel words sequences namespaces hashtables ;
+
+SYMBOL: _
+
+: match-var? ( symbol -- bool )
+  dup word? [
+    word-name first CHAR: ? = 
+  ] [
+    drop f
+  ] if ;
+
+: (match) ( seq1 seq2 -- matched? )
+  {
+    { [ 2dup = ] [ 2drop t ] }
+    { [ over _ = ] [ 2drop t ] } 
+    { [ dup _ = ] [ 2drop t ] }
+    { [ dup match-var? ] [ set t ] }
+    { [ over match-var? ] [ swap set t ] }
+    { [ over sequence? over sequence? and [ over first over first (match) ] [ f ] if ] [ >r 1 tail r> 1 tail (match) ] }
+    { [ t ] [ 2drop f ] }
+  } cond ;
+
+: match ( seq1 seq2 -- bindings )
+  [ (match) ] make-hash swap [ drop f ] unless ;
+
+SYMBOL: result
+
+: match-cond ( seq assoc -- )
+  [
+    [ first over match dup result set ] find 2nip dup [ result get [ second call ] bind ] [ no-cond ] if 
+  ] with-scope ;
+
+
diff --git a/contrib/match/match.facts b/contrib/match/match.facts
new file mode 100644
index 0000000000..5c8ef1b49b
--- /dev/null
+++ b/contrib/match/match.facts
@@ -0,0 +1,22 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help match namespaces ;
+
+HELP: match 
+{ $values { "seq1" "A sequence" } { "seq2" "A sequence" } { "bindings" "A hashtable" }
+}
+{ $description "Pattern match seq1 against seq2. The sequences 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 
+    { $example "SYMBOL: ?a\nSYMBOL: ?b\n{ ?a { 2 ?b } 5 } { 1 { 2 3 } _ } match\n => H{ { ?a 1 } { ?b 3 } }" }
+}
+{ $see-also match-cond } ;
+
+HELP: match-cond
+{ $values { "seq" "A sequence" } { "assoc" "A sequence of quotation pairs" }
+}
+{ $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against seq. 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 
+    { $example "SYMBOL: ?value\n{ increment ?value } {\n  { { increment ?value } [ ?value get do-something ] }\n  { { decrement ?value } [ ?value get do-something-else ] }\n  { _ [ no-match-found ] }\n} match-cond" }
+}
+{ $see-also match } ;
+
diff --git a/contrib/match/tests.factor b/contrib/match/tests.factor
new file mode 100644
index 0000000000..78df681b13
--- /dev/null
+++ b/contrib/match/tests.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: test match namespaces arrays ;
+IN: temporary
+
+SYMBOL: ?a
+SYMBOL: ?b
+
+[ H{ { ?a 1 } { ?b 2 } } ] [
+ { ?a ?b } { 1 2 } match
+] unit-test
+
+[ { 1 2 } ] [ 
+  { 1 2 } 
+  {
+    { { ?a ?b } [ ?a get ?b get 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
\ No newline at end of file