egison 3.5.2 → 3.5.3

raw patch · 15 files changed

+148/−91 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• egison.cabal +1/−1
• elisp/egison-mode.el +4/−1
• hs-src/Language/Egison.hs +1/−0
• hs-src/Language/Egison/Core.hs +5/−0
• hs-src/Language/Egison/Desugar.hs +20/−3
• hs-src/Language/Egison/Parser.hs +24/−4
• hs-src/Language/Egison/Types.hs +5/−1
• lib/core/array.egi +13/−0
• lib/core/base.egi +3/−3
• lib/core/collection.egi +5/−11
• lib/core/number.egi +11/−12
• lib/core/order.egi +11/−11
• lib/core/random.egi +4/−4
• sample/3sat.egi +0/−40
• sample/randomized-3sat.egi +41/−0

@@ -1,5 +1,5 @@ Name:                egison-Version:             3.5.2+Version:             3.5.3 Synopsis:            Programming language with non-linear pattern-matching against unfree data Description:   An interpreter for Egison, the programming langugage that realized non-linear pattern-matching against unfree data types.

@@ -23,6 +23,7 @@      "\\<memoize\\>"      "\\<let\\>"      "\\<letrec\\>"+     "\\<let\\*\\>"      "\\<if\\>"      "\\<seq\\>"      "\\<apply\\>"@@ -71,6 +72,7 @@    (eval-when-compile      (list       (cons "\\\$\\\w*" font-lock-variable-name-face)+      (cons "\\\%\\\w*" font-lock-variable-name-face)       )))   "Gaudy expressions to highlight in Egison modes.") @@ -141,8 +143,9 @@         ((equal "execute" name) 2)         ((equal "lambda" name) 2)         ((equal "memoized-lambda" name) 2)-        ((equal "let" name) 2)         ((equal "letrec" name) 2)+        ((equal "let" name) 2)+        ((equal "let*" name) 2)         ((equal "if" name) 2)         ((equal "apply" name) 2)         ((equal "generate-array" name) 2)

@@ -111,5 +111,6 @@   , "lib/core/number.egi"   , "lib/core/io.egi"   , "lib/core/random.egi"+  , "lib/core/array.egi"   , "lib/core/string.egi"   ]

@@ -719,6 +719,11 @@                                          | otherwise = (k', v'):(subst k nv xs)                 subst _ _ [] = []             IndexedPat pattern indices -> throwError $ strMsg ("invalid indexed-pattern: " ++ show pattern) +            TuplePat patterns -> do+              targets <- evalRef target >>= fromTuple+              if not (length patterns == length targets) then throwError $ ArgumentsNum (length patterns) (length targets) else return ()+              let trees' = zipWith3 MAtom patterns targets (take (length patterns) (repeat Something)) ++ trees+              return $ msingleton $ MState env loops bindings trees'             _ -> throwError $ strMsg "something can only match with a pattern variable"         _ ->  throwError $ EgisonBug $ "should not reach here. matcher: " ++ show matcher ++ ", pattern:  " ++ show pattern 

@@ -186,16 +186,21 @@   expr2' <- desugar expr2   return $ IfExpr expr0' expr1' expr2'   +desugar (LetRecExpr binds expr) = do+  binds' <- desugarBindings binds+  expr' <- desugar expr+  return $ LetRecExpr binds' expr'+   desugar (LetExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr   return $ LetExpr binds' expr' -desugar (LetRecExpr binds expr) = do+desugar (LetStarExpr binds expr) = do   binds' <- desugarBindings binds   expr' <- desugar expr-  return $ LetRecExpr binds' expr'-  +  return $ foldr (\bind ret -> LetExpr [bind] ret) expr' binds'+ desugar (MatchExpr expr0 expr1 clauses) = do     expr0' <- desugar expr0   expr1' <- desugar expr1@@ -256,6 +261,18 @@   matcherInfo' <- desugarMatcherInfo matcherInfo   return $ MatcherDFSExpr matcherInfo'   +desugar (PartialVarExpr n) = return $ VarExpr $ "::" ++ show n++desugar RecVarExpr = return $ VarExpr "::"++desugar (PartialExpr n expr) = do+  expr' <- desugar expr+  if n == 0+    then return $ LetRecExpr [(["::"], LambdaExpr [] expr')] (LambdaExpr [] expr')+    else return $ LetRecExpr [(["::"], LambdaExpr (annonVars (fromIntegral n)) expr')] (LambdaExpr (annonVars (fromIntegral n)) expr')+ where+  annonVars n = take n $ map (((++) "::") . show) [1..]+ desugar expr = return expr  desugarPattern :: EgisonPattern -> DesugarM EgisonPattern

@@ -155,8 +155,11 @@           option expr $ IndexedExpr expr <$> many1 (try $ char '_' >> expr')  expr' :: Parser EgisonExpr-expr' = (try constantExpr+expr' = (try partialExpr+             <|> try constantExpr+             <|> try partialVarExpr              <|> contExpr+             <|> recVarExpr              <|> try varExpr              <|> inductiveDataExpr              <|> try arrayExpr@@ -170,6 +173,7 @@                          <|> patternFunctionExpr                          <|> letRecExpr                          <|> letExpr+                         <|> letStarExpr                          <|> doExpr                          <|> ioExpr                          <|> matchAllExpr@@ -322,6 +326,9 @@ letExpr :: Parser EgisonExpr letExpr = keywordLet >> LetExpr <$> bindings <*> expr +letStarExpr :: Parser EgisonExpr+letStarExpr = keywordLetStar >> LetStarExpr <$> bindings <*> expr+ doExpr :: Parser EgisonExpr doExpr = keywordDo >> DoExpr <$> statements <*> option (ApplyExpr (VarExpr "return") (TupleExpr [])) expr @@ -355,6 +362,9 @@ contExpr :: Parser EgisonExpr contExpr = reservedOp "..." >> pure ContExpr +recVarExpr :: Parser EgisonExpr+recVarExpr = reservedOp "#" >> pure RecVarExpr+ applyExpr :: Parser EgisonExpr applyExpr = (keywordApply >> ApplyExpr <$> expr <*> expr)               <|> applyExpr'@@ -367,7 +377,7 @@   case vars of     [] -> return . ApplyExpr func . TupleExpr $ rights args     _ | all null vars ->-        let genVar = modify (1+) >> gets (VarExpr . ('#':) . show)+        let genVar = modify (1+) >> gets (VarExpr . (':':) . show)             args' = evalState (mapM (either (const genVar) return) args) 0         in return . LambdaExpr (annonVars $ length vars) . ApplyExpr func $ TupleExpr args'       | all (not . null) vars ->@@ -375,7 +385,7 @@             n = Set.size ns         in if Set.findMin ns == 1 && Set.findMax ns == n              then-               let args' = map (either (VarExpr . ('#':)) id) args+               let args' = map (either (VarExpr . (':':)) id) args                in return . LambdaExpr (annonVars n) . ApplyExpr func $ TupleExpr args'              else fail "invalid partial application"       | otherwise -> fail "invalid partial application"@@ -384,8 +394,16 @@   arg = try (Right <$> expr)          <|> char '$' *> (Left <$> option "" index)   index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit-  annonVars n = take n $ map (('#':) . show) [1..]+  annonVars n = take n $ map ((':':) . show) [1..] +partialExpr :: Parser EgisonExpr+partialExpr = PartialExpr <$> read <$> index <*> (char '#' >> expr)+ where+  index = (:) <$> satisfy (\c -> '1' <= c && c <= '9') <*> many digit++partialVarExpr :: Parser EgisonExpr+partialVarExpr = char '%' >> PartialVarExpr <$> integerLiteral+ algebraicDataMatcherExpr :: Parser EgisonExpr algebraicDataMatcherExpr = keywordAlgebraicDataMatcher                                 >> braces (AlgebraicDataMatcherExpr <$> sepEndBy1 inductivePat' whiteSpace)@@ -550,6 +568,7 @@   , "pattern-function"   , "letrec"   , "let"+  , "let*"   , "loop"   , "match-all"   , "match"@@ -601,6 +620,7 @@ keywordPatternFunction      = reserved "pattern-function" keywordLetRec               = reserved "letrec" keywordLet                  = reserved "let"+keywordLetStar              = reserved "let*" keywordLoop                 = reserved "loop" keywordMatchAll             = reserved "match-all" keywordMatchAllLambda       = reserved "match-all-lambda"

@@ -141,8 +141,9 @@   | PatternFunctionExpr [String] EgisonPattern      | IfExpr EgisonExpr EgisonExpr EgisonExpr-  | LetExpr [BindingExpr] EgisonExpr   | LetRecExpr [BindingExpr] EgisonExpr+  | LetExpr [BindingExpr] EgisonExpr+  | LetStarExpr [BindingExpr] EgisonExpr    | MatchExpr EgisonExpr EgisonExpr [MatchClause]   | MatchAllExpr EgisonExpr EgisonExpr MatchClause@@ -163,6 +164,9 @@   | SeqExpr EgisonExpr EgisonExpr   | ContExpr   | ApplyExpr EgisonExpr EgisonExpr+  | PartialExpr Integer EgisonExpr+  | PartialVarExpr Integer+  | RecVarExpr    | AlgebraicDataMatcherExpr [(String, [EgisonExpr])]   | GenerateArrayExpr [String] EgisonExpr EgisonExpr

@@ -0,0 +1,13 @@+;;;;;+;;;;;+;;;;; Array+;;;;;+;;;;;++(define $A.map+  (lambda [$f $a]+    (generate-array [$i] (array-size a) (f a_i))))++(define $A.update+  (lambda [$f $i $a]+    (generate-array [$j] (array-size a) (if (eq? j i) (f a_j) a_j))))

@@ -42,11 +42,11 @@       {[,y #t]        [_ #f]}))) -(define $id (lambda [$x] x))+(define $id 1#%1) -(define $fst (lambda [$x $y] x))+(define $fst 2#%1) -(define $snd (lambda [$x $y] y))+(define $snd 2#%2)  (define $compose   (lambda [$f $g]

@@ -104,15 +104,13 @@ ;; ;; list functions ;;-(define $foldl foldl')--(define $foldl'+(define $foldl   (lambda [$fn $init $ls]     (match ls (list something)       {[<nil> init]        [<cons $x $xs>         (let {[$z (fn init x)]}-          (seq z (foldl' fn z xs)))]})))+          (seq z (foldl fn z xs)))]})))  (define $map   (lambda [$fn $xs]@@ -171,13 +169,9 @@     (map2 (lambda [$x $y] [x y]) xs ys)))  (define $find-cycle-  (lambda [$fn $init]-    (letrec {[$looper (lambda [$xs $x]-                        (let {[$y (fn x)]}-                          (if (eq? y init)-                            xs-                            (looper {@xs y} y))))]}-      (looper {init} init))))+  (lambda [$xs]+    (match xs (list something)+      {[<join $s <cons $x <join $c <cons ,x _>>>> [s {x @c}]]})))  ;; ;; Simple predicate

@@ -165,21 +165,20 @@  (define $rtod   (lambda [$x]-    (let {[$m (numerator x)]-          [$n (denominator x)]}-      (let {[$q (quotient m n)]-            [$r (remainder m n)]}-          <Df q (map (lambda [$x $y] x) (rtod-helper r n))>))))+    (let* {[$m (numerator x)]+           [$n (denominator x)]+           [$q (quotient m n)]+           [$r (remainder m n)]}+      <Df q (map (lambda [$x $y] x) (rtod-helper r n))>)))  (define $rtod'   (lambda [$x]-    (let {[$m (numerator x)]-          [$n (denominator x)]}-      (let {[$q (quotient m n)]-            [$r (remainder m n)]}-        (let {[[$s $c] (match (rtod-helper r n) (list [integer integer])-                         {[<join $s <cons $x <join $c <cons ,x _>>>> [s {x @c}]]})]}-          <Df' q (map (lambda [$x $y] x) s) (map (lambda [$x $y] x) c)>)))))+    (let* {[$m (numerator x)]+           [$n (denominator x)]+           [$q (quotient m n)]+           [$r (remainder m n)]+           [[$s $c] (find-cycle (rtod-helper r n))]}+      <Df' q (map (lambda [$x $y] x) s) (map fst c)>)))  (define $show-decimal   (lambda [$n $x]

@@ -18,19 +18,19 @@  (define $min   (lambda [$ns]-    (foldl' (lambda [$x $y] (if (lt? x y) x y)) (car ns) (cdr ns))))+    (foldl 2#(if (lt? %1 %2) %1 %2) (car ns) (cdr ns))))  (define $max   (lambda [$ns]-    (foldl' (lambda [$x $y] (if (gt? x y) x y)) (car ns) (cdr ns))))+    (foldl 2#(if (gt? %1 %2) %1 %2) (car ns) (cdr ns))))  (define $min-and-max   (lambda [$ns]-    (foldl' (lambda [$ret $x]-              (match ret [integer integer]-                {[[$min $max] (if (lt? x min) [x max]-                                (if (gt? x max) [min x]-                                  [min max]))]}))+    (foldl (lambda [$ret $x]+             (match ret [integer integer]+               {[[$min $max] (if (lt? x min) [x max]+                               (if (gt? x max) [min x]+                                 [min max]))]}))            [(car ns) (car ns)]            (cdr ns)))) @@ -54,7 +54,7 @@     (match xs (list something)       {[<nil> {}]        [<cons $x <nil>> {x}]-       [_ (let {[$n (length xs)]}-            (let {[$p (nth (quotient n 2) xs)]}-              (let {[[$ys1 $ys2 $ys3] (split-by-ordering/f f p xs)]}-                {@(qsort/f f ys1) @ys2 @(qsort/f f ys3)})))]})))+       [_ (let* {[$n (length xs)]+                 [$p (nth (quotient n 2) xs)]+                 [[$ys1 $ys2 $ys3] (split-by-ordering/f f p xs)]}+            {@(qsort/f f ys1) @ys2 @(qsort/f f ys3)})]})))

@@ -12,10 +12,10 @@               (lambda [$xs $n]                 (if (eq? n 0)                   {}-                  (let {[$r (pure-rand 1 n)]}-                    (let {[$x (nth r xs)]}-                    {x @(randomize' (delete-first x xs) (- n 1))}))))]}-      (randomize' xs (length xs)))))    +                  (let* {[$r (pure-rand 1 n)]+                         [$x (nth r xs)]}+                    {x @(randomize' (delete-first x xs) (- n 1))})))]}+      (randomize' xs (length xs)))))  (define $R.between   (lambda [$s $e]

@@ -1,40 +0,0 @@-;;;-;;; Randomized 3-SAT-;;;--(define $clause-satisfy?-  (lambda [$c $a]-    (any (lambda [$i $b] (if b a_i (not a_i))) c)))--(define $random-assign-  (lambda [$n]-    (generate-array [$i] n (R.car {#t #f}))))--(define $random-walk-3sat-  (match-lambda [something integer integer integer something]-    {[[$f _ ,0 ,0 _] <Nothing>]-     [[$f $n ,0 $r _] (random-walk-3sat f n (* n 3) (- r 1) (random-assign n))]-     [[$f $n $k $r $a]-      (match (randomize f) (multiset (R.multiset [integer bool]))-        {[<cons (& ^?(clause-satisfy? $ a) <cons [$x _] _>) _>-          (random-walk-3sat f n (- k 1) r (generate-array [$i] n (if (eq? i x) (not a_i) a_i)))]-         [_ <Just a>]})]}))--(define $R.sat-solver-  (lambda [$f $n $r]-    (random-walk-3sat f n (* 3 n) r (random-assign n))))--(define $c1 {[1 #t] [2 #t] [3 #t]})-(define $c2 {[4 #t] [2 #t] [3 #f]})-(define $c3 {[1 #f] [4 #t] [3 #t]})-(define $c4 {[1 #f] [4 #f] [2 #t]})-(define $c5 {[4 #f] [2 #f] [3 #t]})-(define $c6 {[1 #f] [2 #f] [3 #f]})-(define $c7 {[1 #t] [4 #f] [3 #f]})-(define $c8 {[1 #t] [4 #t] [2 #f]})--(define $p1 {c1 c2 c3 c4 c5 c6 c7 c8})-(define $p2 {c1 c2 c3 c4 c5 c6 c8})--(R.sat-solver p1 4 3)-(R.sat-solver p2 4 3)

@@ -0,0 +1,41 @@+;;;+;;; Randomized 3-SAT+;;;++(define $clause-satisfy?+  (lambda [$c $a]+    (any (lambda [$i $b] (if b a_i (not a_i))) c)))++(define $random-assign+  (lambda [$n]+    (generate-array [$i] n (R.car {#t #f}))))++(define $random-walk-3sat+  (match-lambda [something integer integer integer something]+    {[[$p  _ ,0 ,0  _] <Nothing>]+     [[$p $n ,0 $r  _] (R.sat-solver p n (- r 1))]+     [[$p $n $k $r $a]+      (match (randomize p) (multiset (R.multiset [integer bool]))+        {[<cons (& ^?(clause-satisfy? $ a) <cons [$i _] _>) _>+          (random-walk-3sat p n (- k 1) r (A.update not i a))]+         [_ <Just a>]})]}))++(define $R.sat-solver+  (lambda [$p $n $r]+    (random-walk-3sat p n (* 3 n) r (random-assign n))))++(define $c1 {[1 #t] [2 #t] [3 #t]})+(define $c2 {[4 #t] [2 #t] [3 #f]})+(define $c3 {[1 #f] [4 #t] [3 #t]})+(define $c4 {[1 #f] [4 #f] [2 #t]})+(define $c5 {[4 #f] [2 #f] [3 #t]})+(define $c6 {[1 #f] [2 #f] [3 #f]})+(define $c7 {[1 #t] [4 #f] [3 #f]})+(define $c8 {[1 #t] [4 #t] [2 #f]})++(define $p1 {c1 c2 c3 c4 c5 c6 c7 c8})+(define $p2 {c1 c2 c3 c4 c5 c6 c8})++(R.sat-solver p1 4 3);=><Nothing>+(R.sat-solver p2 4 3);=><Just [|#f #f #t #t|]>, <Just [|#f #t #t #t|]>, or sometimes <Nothing>+