egison 2.4.1 → 2.4.2

raw patch · 7 files changed

+223/−299 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• egison.cabal +3/−3
• elisp/egison-mode.el +11/−0
• hs-src/Language/Egison/Core.hs +46/−50
• hs-src/Language/Egison/Numerical.hs +16/−149
• hs-src/Language/Egison/Types.hs +34/−0
• lib/core/base.egi +1/−1
• lib/core/collection.egi +112/−96

@@ -1,7 +1,7 @@ Name:                egison-Version:             2.4.1-Synopsis:            An Interpreter for the Programming Language Egison-Description:         An interpreter for the programming language Egison.+Version:             2.4.2+Synopsis:            An Interpreter and Compiler for the Programming Language Egison+Description:         An interpreter and compiler for the programming language Egison.                      A feature of Egison is the strong pattern match facility.                      With Egison, you can represent pattern matching for unfree data intuitively,                      especially for collection data, such as lists, multisets, sets, and so on.

@@ -1,5 +1,13 @@ ;;; egison-mode.el --- Egison editing mode +;; Copyright 2011-2012 Satoshi Egi++;;; Author: Satoshi Egi <egisatoshi@gmail.com>+;;; URL: https://github.com/egisatoshi/egison2/blob/master/elisp/egison-mode.el+;;; Version: 0.1.2++;; Code goes here+ (defconst egison-font-lock-keywords-1   (eval-when-compile     (list@@ -163,6 +171,7 @@ if that value is non-nil."   (interactive)   (kill-all-local-variables)+  (setq indent-tabs-mode nil)   (use-local-map egison-mode-map)   (setq major-mode 'egison-mode)   (setq mode-name "Egison")@@ -180,3 +189,5 @@ See `run-hooks'."   :type 'hook   :group 'egison)++;;; egison-mode.el ends here

@@ -296,7 +296,7 @@ cEval1 (Closure env (GenerateArrayExpr fnExpr rangeExpr)) = do   fnObjRef <- liftIO $ makeClosure env fnExpr   rangeVal <- eval env rangeExpr-  ms <- liftThrows $ mapM unpackNum $ tupleToList rangeVal+  ms <- liftThrows $ mapM fromEgisonVal $ tupleToList rangeVal   let d = fromIntegral $ length ms   let is = map (\iss -> (Value . Tuple) $ map Number iss) $ indexList ms   isRefs <- liftIO $ mapM newIORef is@@ -828,7 +828,7 @@   constants :: [(String, EgisonVal)]-constants = [("pi", Float 3.14)+constants = [("pi", Float 3.141592653589793)              ]           {- I/O primitives -}@@ -858,67 +858,64 @@  {- "Pure" primitive functions -} primitives :: [(String, [EgisonVal] -> ThrowsError EgisonVal)]-primitives = [("+", numericBinop (+)),-              ("-", numericBinop (-)),-              ("*", numericBinop (*)),---              ("/", numericBinop (/)),-              ("mod", numericBinop mod),-              ("quotient", numericBinop quot),-              ("remainder", numericBinop rem),+primitives = [("+", multiOp ((+) :: Integer -> Integer -> Integer)),+              ("-", multiOp ((-) :: Integer -> Integer -> Integer)),+              ("*", multiOp ((*) :: Integer -> Integer -> Integer)),+--              ("/", multiOp ((/) :: Integer -> Integer -> Integer)),+              ("mod", multiOp (mod :: Integer -> Integer -> Integer)),+              ("quotient", multiOp (quot :: Integer -> Integer -> Integer)),+              ("remainder", multiOp (rem :: Integer -> Integer -> Integer)), -              ("+f", floatBinop (+)),-              ("-f", floatBinop (-)),-              ("*f", floatBinop (*)),-              ("/f", floatBinop (/)),+              ("+f", multiOp ((+) :: Double -> Double -> Double)),+              ("-f", multiOp ((-) :: Double -> Double -> Double)),+              ("*f", multiOp ((*) :: Double -> Double -> Double)),+              ("/f", multiOp ((/) :: Double -> Double -> Double)), -              ("round", floatNumSglop round),-              ("floor", floatNumSglop floor),-              ("ceiling", floatNumSglop ceiling),-              ("truncate", floatNumSglop truncate),+              ("round", singleOp (round :: Double -> Integer)),+              ("floor", singleOp (floor :: Double -> Integer)),+              ("ceiling", singleOp (ceiling :: Double -> Integer)),+              ("truncate", singleOp (truncate :: Double -> Integer)), -              ("exp", numExp),-              ("log", numLog),+              ("exp", singleOp (exp :: Double -> Double)),+              ("log", singleOp (log :: Double -> Double)), -              ("sin", floatSglop sin),-              ("cos", floatSglop cos),-              ("tan", floatSglop tan),-              ("asin", floatSglop asin),-              ("acos", floatSglop acos),-              ("atan", floatSglop atan),-              ("sinh", floatSglop sinh),-              ("cosh", floatSglop cosh),-              ("tanh", floatSglop tanh),-              ("asinh", floatSglop asinh),-              ("acosh", floatSglop acosh),-              ("atanh", floatSglop atanh),+              ("sin", singleOp (sin :: Double -> Double)),+              ("cos", singleOp (cos :: Double -> Double)),+              ("tan", singleOp (tan :: Double -> Double)),+              ("asin", singleOp (asin :: Double -> Double)),+              ("acos", singleOp (acos :: Double -> Double)),+              ("atan", singleOp (atan :: Double -> Double)),+              ("sinh", singleOp (sinh :: Double -> Double)),+              ("cosh", singleOp (cosh :: Double -> Double)),+              ("tanh", singleOp (tanh :: Double -> Double)),+              ("asinh", singleOp (asinh :: Double -> Double)),+              ("acosh", singleOp (acosh :: Double -> Double)),+              ("atanh", singleOp (atanh :: Double -> Double)), -              ("sqrt", numSqrt),-              ("expt", numExpt),+              ("sqrt", singleOp (sqrt :: Double -> Double)),+              ("expt", binaryOp ((^) :: Double -> Integer -> Double)),                ("eq?", eqv),               -              ("eq-n?", numBoolBinop (==)),-              ("lt-n?", numBoolBinop (<)),-              ("lte-n?", numBoolBinop (<=)),-              ("gt-n?", numBoolBinop (>)),-              ("gte-n?", numBoolBinop (>=)),+              ("eq-n?", binaryOp ((==) :: Integer -> Integer -> Bool)),+              ("lt-n?", binaryOp ((<) :: Integer -> Integer -> Bool)),+              ("lte-n?", binaryOp ((<=) :: Integer -> Integer -> Bool)),+              ("gt-n?", binaryOp ((>) :: Integer -> Integer -> Bool)),+              ("gte-n?", binaryOp ((>=) :: Integer -> Integer -> Bool)), -              ("eq-f?", floatBoolBinop (==)),-              ("lt-f?", floatBoolBinop (<)),-              ("lte-f?", floatBoolBinop (<=)),-              ("gt-f?", floatBoolBinop (>)),-              ("gte-f?", floatBoolBinop (>=)),+              ("eq-f?", binaryOp ((==) :: Double -> Double -> Bool)),+              ("lt-f?", binaryOp ((<) :: Double -> Double -> Bool)),+              ("lte-f?", binaryOp ((<=) :: Double -> Double -> Bool)),+              ("gt-f?", binaryOp ((>) :: Double -> Double -> Bool)),+              ("gte-f?", binaryOp ((>=) :: Double -> Double -> Bool)), -              ("eq-c?", charBoolBinop (==)),-              ("eq-s?", strBoolBinop (==)),+              ("eq-c?", binaryOp ((==) :: Char -> Char -> Bool)),+              ("eq-s?", binaryOp ((==) :: String -> String -> Bool)), -              ("string-append", stringBinop (++)),+              ("string-append", multiOp ((++) :: String -> String -> String)),                              ("string-to-chars", stringToChars),               ("chars-to-string", charsToString),-              -              ("&&", boolBinop (&&)),-              ("||", boolBinop (||)),                ("array-dimension", arrayDimension),               ("array-range", arrayRange),@@ -936,4 +933,3 @@               ("eof?", isEgisonEOF)                ]-

@@ -1,109 +1,22 @@ module Language.Egison.Numerical where import Language.Egison.Types+import Control.Applicative import Control.Monad.Error import Data.Array -boolBinop :: (Bool -> Bool -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal-boolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-boolBinop op aparams = mapM unpackBool aparams >>= return . Bool . foldl1 op--numericSglop :: (Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal-numericSglop op [x] = unpackNum x >>= return . Number . op-numericSglop _ params = throwError $ NumArgs 1 params--floatSglop :: (Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal-floatSglop op [x] = unpackFloat x >>= return . Float . op-floatSglop _ params = throwError $ NumArgs 1 params--floatNumSglop :: (Double -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal-floatNumSglop op [x] = unpackFloat x >>= return . Number . op-floatNumSglop _ params = throwError $ NumArgs 1 params--numericBinop :: (Integer -> Integer -> Integer) -> [EgisonVal] -> ThrowsError EgisonVal-numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op--floatBinop :: (Double -> Double -> Double) -> [EgisonVal] -> ThrowsError EgisonVal-floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op--stringBinop :: (String -> String -> String) -> [EgisonVal] -> ThrowsError EgisonVal-stringBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-stringBinop op aparams = mapM unpackString aparams >>= return . String . foldl1 op--charBoolBinop :: (Char -> Char -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal-charBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-charBoolBinop op aparams = mapM unpackChar aparams >>= doOp-  where doOp [a, b] = return $ Bool $ op a b-        doOp _ = throwError $ Default "Unexpected error in numCharBinop"--strBoolBinop :: (String -> String -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal-strBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-strBoolBinop op aparams = mapM unpackString aparams >>= doOp-  where doOp [a, b] = return $ Bool $ op a b-        doOp _ = throwError $ Default "Unexpected error in numCharBinop"--numBoolBinop :: (Integer -> Integer -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal-numBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-numBoolBinop op aparams = mapM unpackNum aparams >>= doOp-  where doOp [a, b] = return $ Bool $ op a b-        doOp _ = throwError $ Default "Unexpected error in numBoolBinop"--floatBoolBinop :: (Double -> Double -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal-floatBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal-floatBoolBinop op aparams = mapM unpackFloat aparams >>= doOp-  where doOp [a, b] = return $ Bool $ op a b-        doOp _ = throwError $ Default "Unexpected error in floatBoolBinop"---- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs-foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a-foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs-foldlM _ v [] = return v--foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a-foldl1M f (x : xs) = foldlM f x xs-foldl1M _ _ = error "Unexpected error in foldl1M"--- end GenUtil--floatRound, floatFloor, floatCeiling, floatTruncate :: [EgisonVal] -> ThrowsError EgisonVal-floatRound [(Float n)] = return $ Float $ fromInteger $ round n-floatRound [x] = throwError $ TypeMismatch "floatber" [x]-floatRound badArgList = throwError $ NumArgs 1 badArgList--floatFloor [(Float n)] = return $ Float $ fromInteger $ floor n-floatFloor [x] = throwError $ TypeMismatch "number" [x]-floatFloor badArgList = throwError $ NumArgs 1 badArgList--floatCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n-floatCeiling [x] = throwError $ TypeMismatch "number" [x]-floatCeiling badArgList = throwError $ NumArgs 1 badArgList--floatTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n-floatTruncate [x] = throwError $ TypeMismatch "number" [x]-floatTruncate badArgList = throwError $ NumArgs 1 badArgList--numSqrt, numExpt :: [EgisonVal] -> ThrowsError EgisonVal-numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n-                                else throwError $ Default "negative number to sqrt"-numSqrt [x] = throwError $ TypeMismatch "number" [x]-numSqrt badArgList = throwError $ NumArgs 1 badArgList--numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p-numExpt [(Float n), (Number p)] = return $ Float $ n ^ p-numExpt [_, y] = throwError $ TypeMismatch "integer" [y]-numExpt badArgList = throwError $ NumArgs 2 badArgList+singleOp :: (PrimitiveVal a, PrimitiveVal b) => (a -> b) -> [EgisonVal] -> ThrowsError EgisonVal+singleOp op [x] = toEgisonVal . op <$> fromEgisonVal x+singleOp _ params = throwError $ NumArgs 1 params -numExp :: [EgisonVal] -> ThrowsError EgisonVal-numExp [(Number n)] = return $ Float $ exp $ fromInteger n-numExp [(Float n)] = return $ Float $ exp n-numExp [x] = throwError $ TypeMismatch "number" [x]-numExp badArgList = throwError $ NumArgs 1 badArgList+multiOp :: PrimitiveVal a => (a -> a -> a) -> [EgisonVal] -> ThrowsError EgisonVal+multiOp _ emptyList@[] = throwError $ NumArgs 2 emptyList+multiOp _ singleVal@[_] = throwError $ NumArgs 2 singleVal+multiOp op aparams = toEgisonVal . foldl1 op <$> mapM fromEgisonVal aparams -numLog :: [EgisonVal] -> ThrowsError EgisonVal-numLog [(Number n)] = return $ Float $ log $ fromInteger n-numLog [(Float n)] = return $ Float $ log n-numLog [x] = throwError $ TypeMismatch "number" [x]-numLog badArgList = throwError $ NumArgs 1 badArgList+binaryOp :: (PrimitiveVal a, PrimitiveVal b, PrimitiveVal c) => (a -> b -> c) -> [EgisonVal] -> ThrowsError EgisonVal+binaryOp _ emptyList@[] = throwError $ NumArgs 2 emptyList+binaryOp _ singleVal@[_] = throwError $ NumArgs 2 singleVal+binaryOp op [a, b] = toEgisonVal <$> liftM2 op (fromEgisonVal a) (fromEgisonVal b)  -- |Convert a number to a string; radix is optional, defaults to base 10 --numToString :: [EgisonVal] -> IOThrowsError EgisonVal@@ -129,48 +42,13 @@  -- - end Numeric operations section --- |Extract an bool from the given value, throwing a type error if---  the wrong type is passed.-unpackBool :: EgisonVal -> ThrowsError Bool-unpackBool (Bool b) = return b-unpackBool notBool = throwError $ TypeMismatch "bool" [notBool]---- |Extract an char from the given value, throwing a type error if---  the wrong type is passed.-unpackChar :: EgisonVal -> ThrowsError Char-unpackChar (Char c) = return c-unpackChar notChar = throwError $ TypeMismatch "char" [notChar]---- |Extract an char from the given value, throwing a type error if---  the wrong type is passed.-unpackString :: EgisonVal -> ThrowsError String-unpackString (String str) = return str-unpackString notString = throwError $ TypeMismatch "string" [notString]---- |Extract an integer from the given value, throwing a type error if---  the wrong type is passed.-unpackNum :: EgisonVal -> ThrowsError Integer-unpackNum (Number n) = return n-unpackNum notNum = throwError $ TypeMismatch "number" [notNum]---- |Extract an double from the given value, throwing a type error if---  the wrong type is passed.-unpackFloat :: EgisonVal -> ThrowsError Double-unpackFloat (Float n) = return n-unpackFloat notFloat = throwError $ TypeMismatch "float" [notFloat]- stringToChars :: [EgisonVal] -> ThrowsError EgisonVal 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 chars)] = do-  cs <- mapM (\char -> case char of-                         Char c -> return c-                         _ -> throwError $ TypeMismatch "chars" [char])-             chars-  return $ String cs+charsToString [(Collection chars)] = String <$> mapM fromEgisonVal chars charsToString [x] = throwError $ TypeMismatch "collection of chars" [x] charsToString badArgList = throwError $ NumArgs 1 badArgList @@ -194,29 +72,18 @@ arraySize badArgList = throwError $ NumArgs 2 badArgList  arrayKeys :: [EgisonVal] -> ThrowsError EgisonVal-arrayKeys [(Array _ ms _)] = return $ Collection $ map (\iss -> Tuple $ map Number iss) $ indexList ms+arrayKeys [(Array _ ms _)] = return $ Collection $ map (Tuple . map Number) $ indexList ms arrayKeys [x] = throwError $ TypeMismatch "array" [x] arrayKeys badArgList = throwError $ NumArgs 1 badArgList  arrayIsRange :: [EgisonVal] -> ThrowsError EgisonVal-arrayIsRange [(Tuple key), (Array _ ms _)] = do-  ns <- mapM (\val -> case val of-                        Number n -> return n-                        _ -> throwError $ TypeMismatch "number" [val])-             key-  return $ Bool $ helper ns ms- where helper [] [] = True-       helper (n:ns) (m:ms) = if (n > 0 && n <= m)-                                then helper ns ms-                                else False+arrayIsRange [(Tuple key), (Array _ ms _)] = Bool . and . zipWith (\m n -> n > 0 && n <= m) ms <$> mapM fromEgisonVal key arrayIsRange [x, y] = throwError $ TypeMismatch "key, array" [x, y] arrayIsRange badArgList = throwError $ NumArgs 2 badArgList  arrayRef :: [EgisonVal] -> ThrowsError EgisonVal arrayRef [(Tuple nums), (Array _ ms arr)] = do-  ns <- mapM unpackNum nums-  let i = integersToInteger ms ns+  i <- integersToInteger ms <$> mapM fromEgisonVal nums   return $ (arr ! i) arrayRef [x, y] = throwError $ TypeMismatch "tuple of number, array" [x, y] arrayRef badArgList = throwError $ NumArgs 2 badArgList-

@@ -1,3 +1,4 @@+{-# Language TypeSynonymInstances, FlexibleInstances #-} module Language.Egison.Types where  import Control.Monad.Error@@ -206,6 +207,39 @@   | ISubCollection ObjectRef  type DestructInfo = [(PrimitivePatPattern, ObjectRef, [(Env, PrimitivePattern, EgisonExpr)])]++-- +-- Class for primitive data+--+class PrimitiveVal a where+    fromEgisonVal :: EgisonVal -> ThrowsError a+    toEgisonVal :: a -> EgisonVal++instance PrimitiveVal Bool where+    fromEgisonVal (Bool b) = return b+    fromEgisonVal notBool = throwError $ TypeMismatch "bool" [notBool]+    toEgisonVal = Bool++instance PrimitiveVal Char where+    fromEgisonVal (Char c) = return c+    fromEgisonVal notChar = throwError $ TypeMismatch "char" [notChar]+    toEgisonVal = Char++instance PrimitiveVal String where+    fromEgisonVal (String str) = return str+    fromEgisonVal notString = throwError $ TypeMismatch "string" [notString]+    toEgisonVal = String++instance PrimitiveVal Integer where+    fromEgisonVal (Number n) = return n+    fromEgisonVal notNum = throwError $ TypeMismatch "number" [notNum]+    toEgisonVal = Number++instance PrimitiveVal Double where+    fromEgisonVal (Float n) = return n+    fromEgisonVal (Number n) = return . fromInteger $ n+    fromEgisonVal notNum = throwError $ TypeMismatch "float" [notNum]+    toEgisonVal = Float  -- -- Internal Data

@@ -5,7 +5,7 @@ (define $Bool   (type     {[,$val []-      {[$tgt (if (eq? val tgt)+      {[$tgt (if (and (or (not val) tgt) (or val (not tgt)))                  {[]}                  {})]}]      [<true> []

@@ -26,23 +26,23 @@                                       [[<cons $x $xs> <cons ,x $ys>] (helper xs ys)]                                       [[_ _] {}]}))]}                  (helper pxs tgt))]}]-       [<join _ ,$pys> [(List a)]-        {[$tgt (letrec {[$helper (lambda [$pys $tgt]-                                   (match [pys tgt] [(List a) (List a)]-                                     {[[<nil> _] {tgt}]-                                      [[<snoc $x $xs> <snoc ,x $ys>] (helper xs ys)]-                                      [[_ _] {}]}))]}-                 (helper pys tgt))]}]+;;       [<join _ ,$pys> [(List a)]+;;        {[$tgt (letrec {[$helper (lambda [$pys $tgt]+;;                                   (match [pys tgt] [(List a) (List a)]+;;                                     {[[<nil> _] {tgt}]+;;                                      [[<snoc $x $xs> <snoc ,x $ys>] (helper xs ys)]+;;                                      [[_ _] {}]}))]}+;;                 (helper pys tgt))]}]        [<join _ _> [(List a) (List a)]-		{[$tgt (letrec {[$helper (lambda [$xs $ys]-					   (match ys (List a)-					     {[<nil> {[xs {}]}]-					      [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}-			 (helper {} tgt))]}]+	{[$tgt (letrec {[$helper (lambda [$xs $ys]+				   (match ys (List a)+				     {[<nil> {[xs {}]}]+				      [<cons $z $zs> {[xs ys] @(helper {@xs z} zs)}]}))]}+		 (helper {} tgt))]}]        [<nioj ,$pxs _> [(List a)]         {[$tgt (match-all tgt (List a) [<join $ys ,pxs> ys])]}]-       [<nioj _ ,$pys> [(List a)]-        {[$tgt (match-all tgt (List a) [<join ,pys $xs> xs])]}]+;;       [<nioj _ ,$pys> [(List a)]+;;        {[$tgt (match-all tgt (List a) [<join ,pys $xs> xs])]}]        [<nioj _ _> [(List a) (List a)] 	{[$tgt (letrec {[$helper (lambda [$xs $ys] 				   (match ys (List a)@@ -52,7 +52,7 @@        [_ [Something]         {[$tgt {tgt}]}]        })))-  + (define $map   (lambda [$fn $ls]     (match ls (List Something)@@ -124,33 +124,33 @@         {[<nil> xs]          [<cons $y $rs> ((union a) ((add a) xs y) rs)]})))) -(define $occurence+(define $occurrence   (lambda [$a]-	(lambda [$xs]-	  (letrec-		{[$remove&count (lambda [$x $xs]-						  (match xs (List a)-							{[<nil> [{} 1]]-							 [<cons ,x $ys> (let {[[$r $i] (remove&count x ys)]}-											  [r (+ i 1)])]-							 [<cons $y $ys> (let {[[$r $i] (remove&count x ys)]}-											  [{y @r} i])]}))]}-		(match xs (List Something)-		  {[<nil> {}]-		   [<cons $x $ys> (let {[[$rs $i] (remove&count x ys)]}-							{[x i] @((occurence a) rs)})]})))))+    (lambda [$xs]+      (letrec+	{[$remove&count (lambda [$x $xs]+			  (match xs (List a)+			    {[<nil> [{} 1]]+			     [<cons ,x $ys> (let {[[$r $i] (remove&count x ys)]}+					      [r (+ i 1)])]+			     [<cons $y $ys> (let {[[$r $i] (remove&count x ys)]}+					      [{y @r} i])]}))]}+	(match xs (List Something)+	  {[<nil> {}]+	   [<cons $x $ys> (let {[[$rs $i] (remove&count x ys)]}+			    {[x i] @((occurrence a) rs)})]})))))  (define $subcollections   (lambda [$a]-	(lambda [$xs]-	  (foldr-			 (lambda [$x $rs]-			   (let {[[$y $i] x]} -				 (map&concat (lambda [$sub] -							   (match-all (loop $l $j (between 1 i) {y @l} {}) (List a) [<join $ys _> {@ys @sub}]))-							 rs)))-			 {{}}-			 ((occurence a) xs)))))+    (lambda [$xs]+      (foldr+	     (lambda [$x $rs]+	       (let {[[$y $i] x]} +		 (map&concat (lambda [$sub] +			       (match-all (loop $l $j (between 1 i) {y @l} {}) (List a) [<join $ys _> {@ys @sub}]))+			     rs)))+	     {{}}+	     ((occurrence a) xs)))))   (define $size@@ -180,7 +180,7 @@       {[<snoc _ $ys> ys]})))  (define $nth (lambda [$i $l]-  (match l (List Something) {[<cons $x $xs> (if (eq? i 0) x (nth (- i 1) xs))]})))+               (match l (List Something) {[<cons $x $xs> (if (eq? i 0) x (nth (- i 1) xs))]})))  (define $reverse   (lambda [$xs]@@ -228,84 +228,100 @@ (define $Multiset   (lambda [$a]     (type-	  {[,$val []+      {[,$val []         {[$tgt (match [val tgt] [(List a) (Multiset a)]                  {[[<nil> <nil>] {[]}]-				  [[<cons $x $xs> <cons ,x ,xs>] {[]}]-				  [[_ _] {}]})]}]-	   [<nil> []+		  [[<cons $x $xs> <cons ,x ,xs>] {[]}]+		  [[_ _] {}]})]}]+       [<nil> []         {[{} {[]}]          [_ {}]}]-	   [<cons ,$px _> [(Multiset a)]+       [<cons ,$px _> [(Multiset a)]         {[$tgt (if ((member? a) px tgt)-				   {((remove a) tgt px)}-				   {})]}]-	   [<cons _ _> [a (Multiset a)]+		   {((remove a) tgt px)}+		   {})]}]+       [<cons _ _> [a (Multiset a)]         {[$tgt (letrec {[$helper (lambda [$xs $ys]-								   (match ys (List a)-									 {[<nil> {}]-									  [<cons $z $zs> (if ((member? a) z xs)-														 (helper {@xs z} zs)-														 {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]}-				 (helper {} tgt))]}]-	   [<join ,$pxs _> [(Multiset a)]+				   (match ys (List a)+				     {[<nil> {}]+				      [<cons $z $zs> (if ((member? a) z xs)+							 (helper {@xs z} zs)+							 {[z {@xs @zs}] @(helper {@xs z} zs)})]}))]}+		 (helper {} tgt))]}]+       [<join ,$pxs _> [(Multiset a)]         {[$tgt (letrec {[$helper (lambda [$xs $ys]-								   (match xs (List Something)-									 {[<nil> ys]-									  [<cons $z $zs> (if ((member? a) z ys)-														 (helper zs ((remove a) ys z))-														 {})]}))]}-				 {(helper pxs tgt)})]}]-	   [<join _ ,$pys> [(Multiset a)]-        {[$tgt (match-all tgt (Multiset a) [<join ,pys $xs> xs])]}]-	   [<join _ _> [(Multiset a) (Multiset a)]-		{[$tgt-		  (foldr-				 (lambda [$xi $xs]-				   (let {[[$x $i] xi]}-					 (map&concat-								 (lambda [$sub] -								   (do {[[$ys $zs] sub]-										[$zs ((remove-all a) zs x)]}-									   (match-all (loop $l $j (between 1 i) {x @l} {}) (List a) [<join $us $vs> [{@us @ys} {@zs @vs}]])))-								 xs)))-				 {[{} tgt]}-				 ((occurence a) tgt))]}]-	   [_ [Something]+				   (match xs (List Something)+				     {[<nil> ys]+				      [<cons $z $zs> (if ((member? a) z ys)+							 (helper zs ((remove a) ys z))+							 {})]}))]}+		 {(helper pxs tgt)})]}]+;;	   [<join _ ,$pys> [(Multiset a)]+;;        {[$tgt (match-all tgt (Multiset a) [<join ,pys $xs> xs])]}]+       [<join _ _> [(Multiset a) (Multiset a)]+	{[$tgt+	  (foldr+		 (lambda [$xi $xs]+		   (let {[[$x $i] xi]}+		     (map&concat+				 (lambda [$sub] +				   (do {[[$ys $zs] sub]+					[$zs ((remove-all a) zs x)]}+				     (match-all (loop $l $j (between 1 i) {x @l} {}) (List a) [<join $us $vs> [{@us @ys} {@zs @vs}]])))+				 xs)))+		 {[{} tgt]}+		 ((occurrence a) tgt))]}]+       [_ [Something]         {[$tgt {tgt}]}]-	   })))+       })))  (define $Set   (lambda [$a]     (type       {[,$val []-        {[$tgt (if (and ((subcollection? a) val tgt)-                        ((subcollection? a) tgt val))+        {[$tgt (if ((= (Multiset a)) ((unique a) val) ((unique a) tgt))                    {[]}                    {})]}]        [<nil> []         {[{} {[]}]          [_ {}]}]+       [<cons ,$px _> [(Set2 a)]+        {[$tgt (let {[$tgt2 ((unique a) tgt)]}+                 (if ((member? a) px tgt)+		     {tgt}+		     {}))]}]+       [<cons _ _> [a (Set2 a)]+        {[$tgt (let {[$tgt2 ((unique a) tgt)]}+                 (match-all tgt2 (Multiset a)+                   [<cons $x _> [x tgt2]]))]}]+       [<join _ _> [(Set2 a) (Set2 a)]+        {[$tgt (let {[$tgt2 ((unique a) tgt)]}+                 (match-all tgt2 (Multiset a)+                   [<join $xs _> [xs tgt2]]))]}]+       [_ [Something]+        {[$tgt {tgt}]}]+       })))++(define $Set2 ; handle already uniqued target collection+  (lambda [$a]+    (type+      {[,$val []+        {[$tgt (if ((= (Multiset a)) ((unique a) val) tgt)+                   {[]}+                   {})]}]+       [<nil> []+        {[{} {[]}]+         [_ {}]}]        [<cons ,$px _> [(Set a)]-        {[$tgt (letrec {[$helper (lambda [$xs $ys]-				   (match xs (List a)-				     {[<nil> {}]-				      [<cons ,px $zs> {{@ys @zs} tgt}]-				      [<cons $z $zs> (helper zs {@ys z})]}))]}-		 (helper ((unique a) tgt) {}))]}]+        {[$tgt (if ((member? a) px tgt)+		   {tgt}+		   {})]}]        [<cons _ _> [a (Set a)]-        {[$tgt (let {[$tgt2 ((unique a) tgt)]}-		 (letrec {[$helper (lambda [$xs $ys]-				     (match xs (List a)-				       {[<nil> {}]-					[<cons $z $zs> -					 {[z {@ys @zs}] [z tgt2] @(helper zs {@ys z})}]}))]}-		   (helper tgt2 {})))]}]+        {[$tgt (match-all tgt (Multiset a)+                 [<cons $x _> [x tgt]])]}]        [<join _ _> [(Set a) (Set a)]-        {[$tgt (let {[$tgt2 ((unique a) tgt)]}-                 (map&concat (lambda [$xs $ys] (map (lambda [$sxs] [xs {@ys @sxs}])-                                                     ((subcollections a) xs)))-                              (match-all tgt2 (Multiset a) [<join $xs $ys> [xs ys]])))]}]+        {[$tgt (match-all tgt (Multiset a)+                 [<join $xs _> [xs tgt]])]}]        [_ [Something]         {[$tgt {tgt}]}]        })))