fix the bug of tuple pattern matching

Author: egisatoshi

hs-src/Language/Egison/Core.hs

@@ -1293,11 +1293,20 @@ processMState' (MState mode env loops bindings ((MAtom pattern target matcher):t
     _ ->
       case matcher of
         UserMatcher _ _ _ -> do
-          (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher
-          mfor targetss $ \ref -> do
-            targets <- evalRef ref >>= fromTupleWHNF
-            let trees' = zipWith3 MAtom patterns targets matchers ++ trees
-            return $ MState mode env loops bindings trees'
+          case pattern of
+            _ -> do
+              (patterns, targetss, matchers) <- inductiveMatch env' pattern target matcher
+              case (length patterns, length matchers) of
+                (1,1) -> do
+                  mfor targetss $ \ref -> do
+                    targets <- evalRef ref >>= (\x -> return [x])
+                    let trees' = zipWith3 MAtom patterns targets matchers ++ trees
+                    return $ MState mode env loops bindings trees'
+                _ -> do
+                  mfor targetss $ \ref -> do
+                    targets <- evalRef ref >>= fromTupleWHNF
+                    let trees' = zipWith3 MAtom patterns targets matchers ++ trees
+                    return $ MState mode env loops bindings trees'
 
         Tuple matchers ->
           case pattern of

sample/n-queen.egi

@@ -55,6 +55,10 @@
                    <nil>)>
       a])))
 
+(test (n-queen 4))
+(test (n-queen 5))
+(test (n-queen 6))
+(test (n-queen 7))
 (test (n-queen 8))
 (test (n-queen 9))
 (test (n-queen 10))

sample/rosetta/lcs.egi

@@ -1,10 +1,27 @@
-(define $common-seqs
-  (lambda [$xs $ys]
-    (match-all [xs ys] [(list char) (list char)]
-      [[(loop $i [1 $n] <join _ <cons $c_i ...>> _)
-        (loop $i [1 n] <join _ <cons ,c_i ...>> _)]
-       (map (lambda [$i] c_i) (between 1 n))])))
+(define $double-list
+  (lambda [$a]
+    (matcher
+      {
+       [<cons $ $> [[a a] (double-list a)]
+        {[[$xs $ys] (match-all [xs ys] [(list a) (list a)]
+                      [[<cons $x $rs1> <cons $y $rs2>]
+                       [[x y] [rs1 rs2]]])]}]
+       [<join $ $> [[(list a) (list a)] (double-list a)]
+        {[[$xs $ys] (match-all [xs ys] [(list a) (list a)]
+                      [[<join $hs1 $ts1> <join $hs2 $ts2>]
+                       [[hs1 hs2] [ts1 ts2]]])]}]
+       [<c-cons $ $> [a (double-list a)]
+        {[[$xs $ys] (match-all [xs ys] [(list a) (list a)]
+                      [[<cons $x $rs1> <cons ,x $rs2>]
+                       [x [rs1 rs2]]])]}]
+       [$ something
+        {[$tgt {tgt}]}]
+       })))
 
-(define $lcs (compose common-seqs rac))
+(define $lcs
+  (lambda [$xs $ys]
+    (match-all [(unpack "thisisatest") (unpack "testing123testing")] (double-list char)
+           [(loop $i [1 $n] <join _ <c-cons $c_i ...>> _)
+            [n (pack (map (lambda [$i] c_i) (between 1 n)))]])))
 
-(test (lcs "thisisatest" "testing123testing"))
+(sort/fn 2#(compare (2#%1 %1) (2#%1 %2)) (lcs "thisisatest" "testing123testing"))