egison 2.3.4 → 2.3.5

raw patch · 6 files changed

+171/−237 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +2/−1
• hs-src/Language/Egison/Core.hs +104/−169
• hs-src/Language/Egison/Numerical.hs +11/−13
• hs-src/Language/Egison/Primitives.hs +28/−18
• hs-src/Language/Egison/Types.hs +13/−36
• sample/n-queen.egi +13/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             2.3.4+Version:             2.3.5 Synopsis:            An Interpreter for the Programming Language Egison Description:         An interpreter for the programming language Egison.                      A feature of Egison is the strong pattern match facility.@@ -20,6 +20,7 @@                      sample/number-test.egi sample/collection-test.egi sample/array-test.egi sample/graph-test.egi                      sample/poker-hands-test.egi sample/compile-test.egi                      sample/io/argv-test.egi sample/io/cat.egi sample/io/copy.egi sample/io/char-test.egi sample/io/hello.egi sample/io/read-write-test.egi+                     sample/n-queen.egi                      sample/icfpc2012/mine.egi sample/icfpc2012/maps/*.map                      elisp/egison-mode.el                      etc/template.hs

@@ -8,8 +8,8 @@ import Control.Monad.Error import Data.Array import qualified Data.Map-import qualified System.Exit-import System.Directory (doesFileExist, removeFile)+import qualified System.Exit ()+import System.Directory (doesFileExist) import System.IO import Data.IORef import Data.Version@@ -107,16 +107,26 @@ iEval (IInductiveData cons argRefs) = do   args <- mapM cRefEval argRefs   return $ InductiveData cons args-iEval (ICollection innerValRefs) = do-  innerVals <- mapM innerValRefEval innerValRefs-  return $ Collection innerVals-iEval (ITuple innerValRefs) = do-  innerVals <- mapM innerValRefEval innerValRefs+iEval (ICollection innerRefs) = do+  vals <- innerRefsEval innerRefs+  return $ Collection vals+iEval (ITuple innerRefs) = do+  innerVals <- innerRefsEval innerRefs   return $ Tuple innerVals -innerValRefEval :: InnerValRef -> IOThrowsError InnerVal-innerValRefEval (IElement objRef) = liftM Element $ cRefEval objRef-innerValRefEval (ISubCollection objRef) = liftM SubCollection $ cRefEval objRef+innerRefsEval :: [InnerValRef] -> IOThrowsError [EgisonVal]+innerRefsEval [] = return []+innerRefsEval ((IElement objRef):rest) = do+  val <- cRefEval objRef+  vals <- innerRefsEval rest+  return (val:vals)+innerRefsEval ((ISubCollection subObjRef):rest) = do+  subVal <- cRefEval subObjRef+  case subVal of+    Collection vals -> do+      retRest <- innerRefsEval rest+      return $ vals ++ retRest+    _ -> throwError $ Default "innerRefsEval: not collection for subcollection"  cRefEval :: ObjectRef -> IOThrowsError EgisonVal cRefEval objRef = do@@ -128,9 +138,12 @@ cRefEval1 :: ObjectRef -> IOThrowsError Object cRefEval1 objRef = do   obj <- liftIO $ readIORef objRef-  obj2 <- cEval1 obj-  liftIO $ writeIORef objRef obj2-  return obj2+  case obj of+    Closure _ _ -> do+      obj2 <- cEval1 obj+      liftIO $ writeIORef objRef obj2+      return obj2+    _ -> return obj  cEval :: Object -> IOThrowsError EgisonVal cEval (Closure env expr) = eval env expr@@ -165,7 +178,7 @@   return $ Value $ Tuple [] cEval1 (Closure env (TupleExpr innerExprs)) = do   innerRefs <- liftIO $ mapM (makeInnerValRef env) innerExprs-  objRefs <- innerRefsToObjRefList innerRefs+  objRefs <- innerRefsToObjRefs innerRefs   case objRefs of     [objRef] -> cRefEval1 objRef     _ -> return $ Intermidiate $ ITuple innerRefs@@ -271,9 +284,10 @@          patObjRef <- liftIO $ makeClosure env patExpr          matchs <- patternMatch MOne [(MState [] [(MAtom (PClosure [] patObjRef) tgtObjRef typObjRef)])]          case matchs of+           [] -> mcLoop tgtObjRef typObjRef rest            [match] -> do newEnv <- liftIO $ extendEnv env match                          cEval1 (Closure newEnv body)-           [] -> mcLoop tgtObjRef typObjRef rest+           _ -> throwError $ Default "cEval1.mcLoop: cannot reach here" cEval1 (Closure env (LoopExpr loopVar indexVar rangeExpr loopExpr tailExpr)) = do   rangeObjRef <- liftIO $ makeClosure env rangeExpr   let loopObj = Loop loopVar indexVar rangeObjRef loopExpr tailExpr@@ -283,7 +297,7 @@   rangeVal <- eval env rangeExpr   ms <- liftThrows $ mapM unpackNum $ tupleToList rangeVal   let d = fromIntegral $ length ms-  let is = map (\iss -> (Value . Tuple) $ map (Element . Number) iss) $ indexList ms+  let is = map (\iss -> (Value . Tuple) $ map Number iss) $ indexList ms   isRefs <- liftIO $ mapM newIORef is   vals <- mapM (cApply fnObjRef) isRefs   return $ Value $ Array d ms $ listArray (1, (fromIntegral (length vals))) vals@@ -304,7 +318,8 @@                                    liftIO $ putStrLn $ showExpr newBody                                    cEval1 (Closure env newBody)     _ -> throwError $ Default "not function"-cEval1 val = return val+cEval1 val = do+  return val  cApply :: ObjectRef -> ObjectRef -> IOThrowsError EgisonVal cApply fnObjRef argObjRef = do@@ -363,10 +378,10 @@          obj <- cRefEval1 objRef          case obj of            Intermidiate (ITuple innerRefs) -> do-             objRefs <- innerValRefsToObjRefList innerRefs+             objRefs <- innerValRefsToObjRefs innerRefs              liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs-           Value (Tuple innerVals) -> do-             objRefs <- liftIO $ mapM (newIORef . Value) $ innerValsToList innerVals+           Value (Tuple vals) -> do+             objRefs <- liftIO $ mapM (newIORef . Value) vals              liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss objRefs            _ -> liftM concat $ mapM (\(args,objRef3) -> helper args objRef3) $ zip argss [objRef] @@ -378,12 +393,11 @@   obj <- cRefEval1 objRef   case obj of     Intermidiate (ITuple innerRefs) -> do-      objRefs <- innerValRefsToObjRefList innerRefs+      objRefs <- innerValRefsToObjRefs innerRefs       frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs       return $ concat frames-    Value (Tuple innerVals) -> do-      let vals = innerValsToList innerVals-      objRefs <- liftIO $ valsToObjRefList vals+    Value (Tuple vals) -> do+      objRefs <- liftIO $ mapM (newIORef . Value) vals       frames <- mapM (\(fArg,objRef3) -> makeFrame fArg objRef3) $ zip fArgs objRefs       return $ concat frames     _ -> throwError $ Default "makeFrame: not tuple"@@ -398,22 +412,22 @@                                                     return (expr:retRest) innerExprsToExprList ((SubCollectionExpr _):_) = throwError $ Default "innerExprsToExprList: subcollection is not supported"     -innerValRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef]-innerValRefsToObjRefList [] = return []-innerValRefsToObjRefList (innerRef:rest) = do-  restRet <- innerValRefsToObjRefList rest+innerValRefsToObjRefs :: [InnerValRef] -> IOThrowsError [ObjectRef]+innerValRefsToObjRefs [] = return []+innerValRefsToObjRefs (innerRef:rest) = do+  restRet <- innerValRefsToObjRefs rest   case innerRef of     IElement objRef -> return $ objRef:restRet     ISubCollection objRef -> do       obj2 <- cRefEval1 objRef       case obj2 of         Intermidiate (ICollection innerRefs) -> do-          objRefs <- innerValRefsToObjRefList innerRefs+          objRefs <- innerValRefsToObjRefs innerRefs           return $ objRefs ++ restRet-        Value (Collection innerVals) -> do-          objRefs <- liftIO $ mapM newIORef $ map Value $ innerValsToList innerVals+        Value (Collection vals) -> do+          objRefs <- liftIO $ mapM newIORef $ map Value vals           return $ objRefs ++ restRet-        _ -> throwError $ Default "innerValRefsToObjRefList: not collection"+        _ -> throwError $ Default "innerValRefsToObjRefs: not collection"  patternMatch :: MatchFlag -> [MState] -> IOThrowsError [FrameList] patternMatch _ [] = return []@@ -488,14 +502,14 @@         Value Something -> throwError $ Default "patternMatch: Only pattern variable can be pattern matched with Something"         _ -> throwError $ Default "patternMatch: second argument of match expressions must be type"     Intermidiate (ITuple pats) -> do-      patObjRefs <- innerRefsToObjRefList pats-      tgtObjRefs <- tupleToObjRefList tgtObjRef-      typObjRefs <- tupleToObjRefList typObjRef+      patObjRefs <- innerRefsToObjRefs pats+      tgtObjRefs <- tupleToObjRefs tgtObjRef+      typObjRefs <- tupleToObjRefs typObjRef       patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states     Value (Tuple pats) -> do-      patObjRefs <- innerValsToObjRefList pats-      tgtObjRefs <- tupleToObjRefList tgtObjRef-      typObjRefs <- tupleToObjRefList typObjRef+      patObjRefs <- liftIO $ mapM (newIORef . Value) pats+      tgtObjRefs <- tupleToObjRefs tgtObjRef+      typObjRefs <- tupleToObjRefs typObjRef       patternMatch flag $ (MState frame ((map (\(pat,tgt,typ) -> MAtom (PClosure bf pat) tgt typ) (zip3 patObjRefs tgtObjRefs typObjRefs)) ++ atoms)):states     Value (PredPat predObjRef patObjRefs) -> do       argsObjRef <- liftIO $ newIORef $ Intermidiate $ ITuple $ map IElement $ patObjRefs ++ [tgtObjRef]@@ -535,7 +549,7 @@       case mPpmRet of         Nothing -> throwError $ Default "inductiveMatch: not matched any primitive clauses"         Just tgtObjRefs -> do-          typObjRefs <- tupleToObjRefList typObjRef+          typObjRefs <- tupleToObjRefs typObjRef           return (typObjRefs, patObjRefs, tgtObjRefs)      where helper [] = return Nothing            helper ((env, ppat, expr):pclss2) = do@@ -545,8 +559,8 @@                Just ppmRet -> do                  newEnv <- liftIO $ extendEnv env (ppmRet ++ frame)                  retObjRef <- liftIO $ makeClosure newEnv expr-                 tgtObjRefs <- collectionToObjRefList retObjRef-                 tgtObjRefss <- mapM tupleToObjRefList tgtObjRefs+                 tgtObjRefs <- collectionToObjRefs retObjRef+                 tgtObjRefss <- mapM tupleToObjRefs tgtObjRefs                  return $ Just tgtObjRefss  primitivePatPatternMatch :: PrimitivePatPattern -> ObjectRef -> IOThrowsError (Maybe ([ObjectRef], FrameList))@@ -675,8 +689,8 @@   obj <- cRefEval1 objRef   case obj of     Intermidiate (ICollection innerRefs) -> return innerRefs-    Value (Collection innerVals) -> do-      objRefs <- innerValsToObjRefList innerVals+    Value (Collection val) -> do+      objRefs <- liftIO $ mapM (newIORef . Value) val       return $ map IElement objRefs  isEmptyCollection :: ObjectRef -> IOThrowsError Bool@@ -690,24 +704,13 @@       liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ innerRefs ++ rest       isEmptyCollection objRef     Value (Collection []) -> return True-    Value (Collection innerVals) -> isEmptyInnerVals innerVals+    Value (Collection _) -> return False     _ -> throwError $ Default $ "isEmptyCollection: not collection:" ++ show obj -isEmptyInnerVals :: [InnerVal] -> IOThrowsError Bool-isEmptyInnerVals [] = return True-isEmptyInnerVals ((Element _):_) = return False-isEmptyInnerVals ((SubCollection val):rest) = do-  objRef <- liftIO $ newIORef $ Value val-  b <- isEmptyCollection objRef-  if b-    then isEmptyInnerVals rest-    else return False- isEmptyCollectionForSnoc :: ObjectRef -> IOThrowsError Bool isEmptyCollectionForSnoc objRef = do   obj <- cRefEval1 objRef   case obj of-    Intermidiate (ICollection ((IElement _):_)) -> return False     Intermidiate (ICollection innerRefs) -> do       case reverse innerRefs of         [] -> return True@@ -717,143 +720,75 @@           liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ reverse subInnerRefs           isEmptyCollectionForSnoc objRef     Value (Collection []) -> return True-    Value (Collection innerVals) -> isEmptyInnerValsForSnoc innerVals+    Value (Collection _) -> return False     _ -> throwError $ Default $ "isEmptyCollectionForSnoc: not collection:" ++ show obj -isEmptyInnerValsForSnoc :: [InnerVal] -> IOThrowsError Bool-isEmptyInnerValsForSnoc innerVals =-  case reverse innerVals of-    [] -> return True-    ((Element _):_) -> return False-    ((SubCollection val):rest) -> do-      objRef <- liftIO $ newIORef $ Value val-      b <- isEmptyCollectionForSnoc objRef-      if b-        then isEmptyInnerValsForSnoc $ reverse rest-        else return False- consDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef) consDestruct objRef = do   obj <- cRefEval1 objRef   case obj of-    Intermidiate (ICollection innerRefs) -> consDestructInnerRefs innerRefs-    Value (Collection innerVals) -> consDestructInnerVals innerVals+    Intermidiate (ICollection []) -> throwError $ Default "consDestructInnerRefs: empty collection"+    Intermidiate (ICollection ((IElement carObjRef):rest)) -> do+      cdrObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection rest+      return (carObjRef, cdrObjRef)+    Intermidiate (ICollection ((ISubCollection subObjRef):rest)) -> do+      innerRefs <- objectRefToInnerRefs subObjRef+      liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ innerRefs ++ rest+      consDestruct objRef+    Value (Collection (val:vals)) -> do+      carObjRef <- liftIO $ newIORef $ Value val+      cdrObjRef <- liftIO $ newIORef $ Value $ Collection vals+      return (carObjRef, cdrObjRef)     _ -> throwError $ Default "consDestruct: not collection" -consDestructInnerRefs :: [InnerValRef] -> IOThrowsError (ObjectRef, ObjectRef)-consDestructInnerRefs [] = throwError $ Default "consDestructInnerRefs: empty collection"-consDestructInnerRefs ((IElement objRef):rest) = do-  cdrObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection rest-  return (objRef, cdrObjRef)-consDestructInnerRefs ((ISubCollection objRef):rest) = do-  b <- isEmptyCollection objRef-  if b-    then consDestructInnerRefs rest-    else do (carObjRef, cdrObjRef) <- consDestruct objRef-            cdrObjRef2 <- liftIO $ newIORef $ Intermidiate $ ICollection $ (ISubCollection cdrObjRef):rest-            return (carObjRef, cdrObjRef2)-    -consDestructInnerVals :: [InnerVal] -> IOThrowsError (ObjectRef, ObjectRef)-consDestructInnerVals [] = throwError $ Default "consDestructInnerVals: empty collection"-consDestructInnerVals ((Element val):rest) = do-  carObjRef <- liftIO $ newIORef $ Value val-  cdrObjRef <- liftIO $ newIORef $ Value $ Collection rest-  return (carObjRef, cdrObjRef)-consDestructInnerVals ((SubCollection val):rest) = do-  objRef <- liftIO $ newIORef $ Value val-  b <- isEmptyCollection objRef-  if b-    then consDestructInnerVals rest-    else do (carObjRef, cdrObjRef) <- consDestruct objRef-            cdrObj <- liftIO $ readIORef cdrObjRef-            case cdrObj of-              Value (Collection innerVals) -> do-                cdrObjRef2 <- liftIO $ newIORef $ Value $ Collection $ (SubCollection (Collection innerVals)):rest-                return (carObjRef, cdrObjRef2)-              _ -> throwError $ Default "consDestructInnerVals: cannot reach here!"-- snocDestruct :: ObjectRef -> IOThrowsError (ObjectRef, ObjectRef) snocDestruct objRef = do   obj <- cRefEval1 objRef   case obj of-    Intermidiate (ICollection innerRefs) -> snocDestructInnerRefs innerRefs-    Value (Collection innerVals) -> snocDestructInnerVals innerVals+    Intermidiate (ICollection innerRefs) -> do+      case reverse innerRefs of+        [] -> throwError $ Default "snocDestructInnerRefs: empty collection"+        ((IElement racObjRef):rest) -> do+          rdcObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection $ reverse rest+          return (racObjRef, rdcObjRef)+        ((ISubCollection subObjRef):rest) -> do+          subInnerRefs <- objectRefToInnerRefs subObjRef+          liftIO $ writeIORef objRef $ Intermidiate $ ICollection $ reverse rest ++ reverse subInnerRefs+          snocDestruct objRef+    Value (Collection vals) -> do+      case reverse vals of+        (val:rest) -> do+          racObjRef <- liftIO $ newIORef $ Value val+          rdcObjRef <- liftIO $ newIORef $ Value $ Collection rest+          return (racObjRef, rdcObjRef)+        _ -> throwError $ Default "snocDestruct: not collection"     _ -> throwError $ Default "snocDestruct: not collection"--snocDestructInnerRefs :: [InnerValRef] -> IOThrowsError (ObjectRef, ObjectRef)-snocDestructInnerRefs innerRefs =-  case reverse innerRefs of-    [] -> throwError $ Default "snocDestructInnerRefs: empty collection"-    ((IElement objRef):rest) -> do-      rdcObjRef <- liftIO $ newIORef $ Intermidiate $ ICollection $ reverse rest-      return (objRef, rdcObjRef)-    ((ISubCollection objRef):rest) -> do-      b <- isEmptyCollectionForSnoc objRef-      if b-        then snocDestructInnerRefs $ reverse rest-        else do (racObjRef, rdcObjRef) <- snocDestruct objRef-                rdcObjRef2 <- liftIO $ newIORef $ Intermidiate $ ICollection $ (reverse rest) ++ [(ISubCollection rdcObjRef)]-                return (racObjRef, rdcObjRef2)     -snocDestructInnerVals :: [InnerVal] -> IOThrowsError (ObjectRef, ObjectRef)-snocDestructInnerVals innerVals =-  case reverse innerVals of-    [] -> throwError $ Default "snocDestructInnerVals: empty collection"-    ((Element val):rest) -> do-      racObjRef <- liftIO $ newIORef $ Value val-      rdcObjRef <- liftIO $ newIORef $ Value $ Collection $ reverse rest-      return (racObjRef, rdcObjRef)-    ((SubCollection val):rest) -> do-      objRef <- liftIO $ newIORef $ Value val-      b <- isEmptyCollectionForSnoc objRef-      if b-        then snocDestructInnerVals $ reverse rest-        else do (racObjRef, rdcObjRef) <- snocDestruct objRef-                rdcObj <- liftIO $ readIORef rdcObjRef-                case rdcObj of-                  Value (Collection innerVals2) -> do-                    rdcObjRef2 <- liftIO $ newIORef $ Value $ Collection $ (reverse rest) ++ [(SubCollection (Collection innerVals2))]-                    return (racObjRef, rdcObjRef2)-                  _ -> throwError $ Default "snocDestructInnerVals: cannot reach here!"--collectionToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]-collectionToObjRefList objRef = do+collectionToObjRefs :: ObjectRef -> IOThrowsError [ObjectRef]+collectionToObjRefs objRef = do   obj <- cRefEval1 objRef   case obj of-    Intermidiate (ICollection innerRefs) -> innerRefsToObjRefList innerRefs-    Value (Collection innerVals) -> innerValsToObjRefList innerVals-    _ -> throwError $ Default "collectionToObjRefList: not collection"+    Intermidiate (ICollection innerRefs) -> innerRefsToObjRefs innerRefs+    Value (Collection vals) -> liftIO $ mapM (newIORef . Value) vals+    _ -> throwError $ Default "collectionToObjRefs: not collection" -tupleToObjRefList :: ObjectRef -> IOThrowsError [ObjectRef]-tupleToObjRefList objRef = do+tupleToObjRefs :: ObjectRef -> IOThrowsError [ObjectRef]+tupleToObjRefs objRef = do   obj <- cRefEval1 objRef   case obj of-    Intermidiate (ITuple innerRefs) -> innerRefsToObjRefList innerRefs-    Value (Tuple innerVals) -> innerValsToObjRefList innerVals+    Intermidiate (ITuple innerRefs) -> innerRefsToObjRefs innerRefs+    Value (Tuple vals) -> liftIO $ mapM (newIORef . Value) vals     _ -> return [objRef] -innerRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef]-innerRefsToObjRefList [] = return []-innerRefsToObjRefList ((IElement objRef):rest) = do-  retRest <- innerRefsToObjRefList rest+innerRefsToObjRefs :: [InnerValRef] -> IOThrowsError [ObjectRef]+innerRefsToObjRefs [] = return []+innerRefsToObjRefs ((IElement objRef):rest) = do+  retRest <- innerRefsToObjRefs rest   return $ objRef:retRest-innerRefsToObjRefList ((ISubCollection objRef):rest) = do-  retObj <- collectionToObjRefList objRef-  retRest <- innerRefsToObjRefList rest+innerRefsToObjRefs ((ISubCollection objRef):rest) = do+  retObj <- collectionToObjRefs objRef+  retRest <- innerRefsToObjRefs rest   return $ retObj ++ retRest--innerValsToObjRefList :: [InnerVal] -> IOThrowsError [ObjectRef]-innerValsToObjRefList [] = return []-innerValsToObjRefList ((Element val):rest) = do-  valRef <- liftIO $ newIORef $ Value val-  retRest <- innerValsToObjRefList rest-  return $ valRef:retRest-innerValsToObjRefList ((SubCollection val):rest) = do-  valRef <- liftIO $ newIORef $ Value val-  retVal <- collectionToObjRefList valRef-  retRest <- innerValsToObjRefList rest-  return $ retVal ++ retRest     primitiveBindings :: IO Env

@@ -165,25 +165,23 @@   tupleToCollection :: [EgisonVal] -> ThrowsError EgisonVal-tupleToCollection vals = return $ Collection $ map Element vals+tupleToCollection vals = return $ Collection $ vals  collectionToTuple :: [EgisonVal] -> ThrowsError EgisonVal-collectionToTuple [(Collection innerVals)] = do-  let vals = innerValsToList innerVals+collectionToTuple [(Collection vals)] = do   case vals of     [val] -> return val-    _ -> return $ Tuple $ map Element vals+    _ -> return $ Tuple vals collectionToTuple [x] = throwError $ TypeMismatch "collection" [x] collectionToTuple badArgList = throwError $ NumArgs 1 badArgList  stringToChars :: [EgisonVal] -> ThrowsError EgisonVal-stringToChars [(String str)] = return $ Collection $ map (\c -> Element $ Char c) str+stringToChars [(String str)] = return $ Collection $ map Char str stringToChars [x] = throwError $ TypeMismatch "string" [x] stringToChars badArgList = throwError $ NumArgs 1 badArgList  charsToString :: [EgisonVal] -> ThrowsError EgisonVal-charsToString [(Collection innerVals)] = do-  let chars = innerValsToList innerVals+charsToString [(Collection chars)] = do   cs <- mapM (\char -> case char of                          Char c -> return c                          _ -> throwError $ TypeMismatch "chars" [char])@@ -202,7 +200,7 @@ arrayDimension badArgList = throwError $ NumArgs 1 badArgList  arrayRange :: [EgisonVal] -> ThrowsError EgisonVal-arrayRange [(Array _ ns _)] = return $ Tuple $ map (Element . Number) ns+arrayRange [(Array _ ns _)] = return $ Tuple $ map Number ns arrayRange [x] = throwError $ TypeMismatch "array" [x] arrayRange badArgList = throwError $ NumArgs 1 badArgList @@ -212,16 +210,16 @@ arraySize badArgList = throwError $ NumArgs 2 badArgList  arrayKeys :: [EgisonVal] -> ThrowsError EgisonVal-arrayKeys [(Array _ ms _)] = return $ Collection $ map (\iss -> (Element . Tuple) $ map (Element . Number) iss) $ indexList ms+arrayKeys [(Array _ ms _)] = return $ Collection $ map (\iss -> Tuple $ map Number iss) $ indexList ms arrayKeys [x] = throwError $ TypeMismatch "array" [x] arrayKeys badArgList = throwError $ NumArgs 1 badArgList  arrayIsRange :: [EgisonVal] -> ThrowsError EgisonVal-arrayIsRange [key, (Array _ ms _)] = do+arrayIsRange [(Tuple key), (Array _ ms _)] = do   ns <- mapM (\val -> case val of                         Number n -> return n                         _ -> throwError $ TypeMismatch "number" [val])-             (tupleToList key)+             key   return $ Bool $ helper ns ms  where helper [] [] = True        helper (n:ns) (m:ms) = if (n > 0 && n <= m)@@ -231,8 +229,8 @@ arrayIsRange badArgList = throwError $ NumArgs 2 badArgList  arrayRef :: [EgisonVal] -> ThrowsError EgisonVal-arrayRef [tuple, (Array _ ms arr)] = do-  ns <- mapM unpackNum $ tupleToList tuple+arrayRef [(Tuple nums), (Array _ ms arr)] = do+  ns <- mapM unpackNum nums   let i = integersToInteger ms ns   return $ (arr ! i) arrayRef [x, y] = throwError $ TypeMismatch "tuple of number, array" [x, y]

@@ -20,7 +20,7 @@   let newWorld = case mode of                    ReadMode -> World $ (OpenInputPort filename):actions                    WriteMode -> World $ (OpenOutputPort filename):actions-  return $ makeTupleFromValList [newWorld, port]+  return $ Tuple [newWorld, port] makePort _ [] = throwError $ NumArgs 2 [] makePort _ [arg] = throwError $ NumArgs 2 [arg] makePort _ args@(_:_:_:_) = throwError $ NumArgs 2 args@@ -78,11 +78,11 @@     Left e -> if isEOFError e                 then do                   let newWorld = World $ (ReadFromPort "stdin" "EOF"):actions-                  return $ makeTupleFromValList [newWorld, EOF]+                  return $ Tuple [newWorld, EOF]                 else throwError $ Default "I/O error read-char"     Right inpChr -> do       let newWorld = World $ (ReadFromPort "stdin" [inpChr]):actions-      return $ makeTupleFromValList [newWorld, Char inpChr]+      return $ Tuple [newWorld, Char inpChr] readChar _ = throwError $ Default $ "readChar: invalid arguments"  readLine :: [EgisonVal] -> IOThrowsError EgisonVal@@ -92,11 +92,11 @@     Left e -> if isEOFError e                 then do                   let newWorld = World $ (ReadFromPort "stdin" "EOF"):actions-                  return $ makeTupleFromValList [newWorld, EOF]+                  return $ Tuple [newWorld, EOF]                 else throwError $ Default "I/O error read-line"     Right inpStr -> do       let newWorld = World $ (ReadFromPort "stdin" inpStr):actions-      return $ makeTupleFromValList [newWorld, String inpStr]+      return $ Tuple [newWorld, String inpStr] readLine _ = throwError $ Default $ "readLine: invalid arguments"  readFromStdin :: [EgisonVal] -> IOThrowsError EgisonVal@@ -105,7 +105,7 @@   let newWorld = World $ (ReadFromPort "stdin" str):actions   expr <- liftThrows $ readExpr str   val <- liftThrows $ exprToVal expr-  return $ makeTupleFromValList [newWorld, val]+  return $ Tuple [newWorld, val] readFromStdin _ = throwError $ Default $ "read: invalid arguments"  @@ -154,11 +154,11 @@     Left e -> if isEOFError e                 then do                   let newWorld = World $ (ReadFromPort filename "EOF"):actions-                  return $ makeTupleFromValList [newWorld, EOF]+                  return $ Tuple [newWorld, EOF]                 else throwError $ Default "I/O error read-char-from-port"     Right inpChr -> do       let newWorld = World $ (ReadFromPort filename [inpChr]):actions-      return $ makeTupleFromValList [newWorld, Char inpChr]+      return $ Tuple [newWorld, Char inpChr] readCharFromPort _ = throwError $ Default $ "readCharFromPort: invalid arguments"  readLineFromPort :: [EgisonVal] -> IOThrowsError EgisonVal@@ -168,11 +168,11 @@     Left e -> if isEOFError e                 then do                   let newWorld = World $ (ReadFromPort filename "EOF"):actions-                  return $ makeTupleFromValList [newWorld, EOF]+                  return $ Tuple [newWorld, EOF]                 else throwError $ Default "I/O error read-line-from-port"     Right inpStr -> do       let newWorld = World $ (ReadFromPort filename inpStr):actions-      return $ makeTupleFromValList [newWorld, String inpStr]+      return $ Tuple [newWorld, String inpStr] readLineFromPort _ = throwError $ Default $ "readLineFromPort: invalid arguments"  readFromPort :: [EgisonVal] -> IOThrowsError EgisonVal@@ -181,7 +181,7 @@   let newWorld = World $ (ReadFromPort filename str):actions   expr <- liftThrows $ readExpr str   val <- liftThrows $ exprToVal expr-  return $ makeTupleFromValList [newWorld, val]+  return $ Tuple [newWorld, val] readFromPort _ = throwError $ Default $ "read: invalid arguments"  @@ -226,14 +226,24 @@   args <- mapM exprToVal argExprs   return $ InductiveData cons args exprToVal (CollectionExpr innerExprs) = do-  innerVals <- mapM innerExprToInnerVal innerExprs-  return $ Collection innerVals+  vals <- innerExprsToVals innerExprs+  return $ Collection vals exprToVal (TupleExpr innerExprs) = do-  innerVals <- mapM innerExprToInnerVal innerExprs-  return $ Tuple innerVals+  vals <- innerExprsToVals innerExprs+  return $ Tuple vals exprToVal _ = throwError $ Default "read: invalid value" -innerExprToInnerVal :: InnerExpr -> ThrowsError InnerVal-innerExprToInnerVal (ElementExpr expr) = exprToVal expr >>= return . Element-innerExprToInnerVal (SubCollectionExpr expr) = exprToVal expr >>= return . SubCollection+innerExprsToVals :: [InnerExpr] -> ThrowsError [EgisonVal]+innerExprsToVals [] = return []+innerExprsToVals ((ElementExpr expr):rest) = do+  retRest <- innerExprsToVals rest+  val <- exprToVal expr+  return (val:retRest)+innerExprsToVals ((SubCollectionExpr expr):rest) = do+  val <- exprToVal expr+  case val of+    Collection vals -> do+      retRest <- innerExprsToVals rest+      return $ vals ++ retRest+    _ -> throwError $ Default "innerExprToVals: not collection after @" 

@@ -173,8 +173,8 @@   | AndPat [ObjectRef]   | OrPat [ObjectRef]   | InductiveData String [EgisonVal]-  | Tuple [InnerVal]-  | Collection [InnerVal]+  | Tuple [EgisonVal]+  | Collection [EgisonVal]   | Array Integer [Integer] (Array Integer EgisonVal)   | Type DestructInfo   | Func Args EgisonExpr Env@@ -200,30 +200,6 @@   | ATuple [Args]  deriving (Show)   -data InnerVal = Element EgisonVal-  | SubCollection EgisonVal--innerValsToList :: [InnerVal] -> [EgisonVal]-innerValsToList [] = []-innerValsToList ((Element val):rest) = val:(innerValsToList rest)-innerValsToList ((SubCollection (Collection iVals)):rest) = (innerValsToList iVals) ++ (innerValsToList rest)--tupleToList :: EgisonVal -> [EgisonVal]-tupleToList (Tuple innerVals) = innerValsToList innerVals-tupleToList val = [val]-  -collectionToList :: EgisonVal -> [EgisonVal]-collectionToList (Collection innerVals) = innerValsToList innerVals--valsToObjRefList :: [EgisonVal] -> IO [ObjectRef]-valsToObjRefList vals = mapM newIORef (map Value vals)--makeTupleFromValList :: [EgisonVal] -> EgisonVal-makeTupleFromValList vals = Tuple $ map Element vals--makeCollectionFromValList :: [EgisonVal] -> EgisonVal-makeCollectionFromValList vals = Collection $ map Element vals- data InnerValRef = IElement ObjectRef   | ISubCollection ObjectRef @@ -376,10 +352,10 @@   if (cons1 == cons2)     then return $ Bool $ eqValList args1 args2     else return $ Bool False-eqv [(Tuple innerVals1), (Tuple innerVals2)] =-  return $ Bool $ eqValList (innerValsToList innerVals1) (innerValsToList innerVals2)-eqv [(Collection innerVals1), (Collection innerVals2)] =-  return $ Bool $ eqValList (innerValsToList innerVals1) (innerValsToList innerVals2)+eqv [(Tuple vals1), (Tuple vals2)] = -- TODO use fold?+  return $ Bool $ eqValList vals1 vals2+eqv [(Collection vals1), (Collection vals2)] =+  return $ Bool $ eqValList vals1 vals2 eqv [_, _] = return $ Bool False eqv badArgList = throwError $ NumArgs 2 badArgList @@ -436,8 +412,8 @@ showVal (PredPat _ _) = "#<pred-pat>" showVal (InductiveData cons []) = "<" ++ cons ++ ">" showVal (InductiveData cons args) = "<" ++ cons ++ " " ++ unwordsList args ++ ">"-showVal (Tuple innerVals) = "[" ++ showInnerVals innerVals ++ "]"-showVal (Collection innerVals) = "{" ++ showInnerVals innerVals ++ "}"+showVal (Tuple vals) = "[" ++ unwordsList vals ++ "]"+showVal (Collection vals) = "{" ++ unwordsList vals ++ "}" showVal (Array _ ns arr) = showArray ns $ elems arr showVal (Type _) = "#<type>" showVal (Func _ _ _) = "(lambda [" ++ "..." ++ "] ...)"@@ -461,9 +437,6 @@ --showInnerVals' ((Element val):rest) = " " ++ show val ++ showInnerVals' rest --showInnerVals' ((SubCollection val):rest) = " @" ++ show val ++ showInnerVals' rest -showInnerVals :: [InnerVal] -> String-showInnerVals iVals = unwordsList $ innerValsToList iVals- showIVal :: IntermidiateVal -> String showIVal (IInductiveData cons []) = "<" ++ cons ++ ">" showIVal (IInductiveData cons _) = "<" ++ cons ++ " " ++ "..." ++ ">"@@ -520,4 +493,8 @@ betweenNumbers m n = if m == n                        then [n]                        else (m:(betweenNumbers (m + 1) n))-       +++tupleToList :: EgisonVal -> [EgisonVal]+tupleToList (Tuple vals) = vals+tupleToList val = [val]

@@ -0,0 +1,13 @@+(define $n-queen+  (lambda [$n]+    (match-all (between 1 n) (Multiset Integer)+      [<cons $a_1+             (loop $l $i (between 2 n)+                   <cons (loop $l1 $i1 (between 1 (- i 1))+                               (& ^,(- a_i1 (- i i1))+                                  ^,(+ a_i1 (- i i1))+                                  l1)+                               $a_i)+                         l>+                   <nil>)>+       [@(loop $l $i (between 1 n)  {a_i @l} {})]])))