MagicHaskeller 0.9.6.4.3 → 0.9.6.4.4

raw patch · 38 files changed

+326/−329 lines, 38 filesdep ~ghc

Dependency ranges changed: ghc

Files

Control/Monad/Search/Best.hs +1/−1
Control/Monad/Search/Combinatorial.lhs +16/−16
Data/Memo.hs +1/−1
MagicHaskeller.cabal +2/−8
MagicHaskeller.lhs +17/−18
MagicHaskeller/Analytical/FMExpr.hs +4/−4
MagicHaskeller/Analytical/Parser.hs +13/−13
MagicHaskeller/Analytical/Syntax.hs +4/−4
MagicHaskeller/Analytical/Synthesize.hs +28/−28
MagicHaskeller/CGI.lhs +7/−6
MagicHaskeller/ClassLib.lhs +2/−2
MagicHaskeller/Classification.hs +4/−4
MagicHaskeller/Classify.hs +20/−20
MagicHaskeller/ClassifyDM.hs +4/−4
MagicHaskeller/ClassifyTr.hs +5/−5
MagicHaskeller/CoreLang.lhs +12/−12
MagicHaskeller/DebMT.lhs +2/−2
MagicHaskeller/Execute.hs +2/−2
MagicHaskeller/ExecuteAPI610.hs +38/−38
MagicHaskeller/FakeDynamic.hs +2/−2
MagicHaskeller/IOGenerator.hs +5/−5
MagicHaskeller/Instantiate.hs +26/−26
MagicHaskeller/LibTH.hs +4/−6
MagicHaskeller/MHTH.lhs +1/−0
MagicHaskeller/MemoToFiles.hs +4/−4
MagicHaskeller/Options.hs +1/−1
MagicHaskeller/PolyDynamic.hs +5/−5
MagicHaskeller/PriorSubsts.lhs +5/−5
MagicHaskeller/ProgGen.lhs +3/−3
MagicHaskeller/ProgGenSF.lhs +37/−37
MagicHaskeller/ProgGenSFIORef.lhs +25/−25
MagicHaskeller/ReadTHType.lhs +4/−4
MagicHaskeller/ReadTypeRep.hs +5/−5
MagicHaskeller/RunAnalytical.hs +1/−1
MagicHaskeller/ShortString.hs +3/−3
MagicHaskeller/SimpleServer.hs +6/−2
MagicHaskeller/T10.hs +4/−4
MagicHaskeller/TimeOut.hs +3/−3

Control/Monad/Search/Best.hs view

@@ -2,7 +2,7 @@ -- (c) Susumu Katayama -- --- best¤Î¤ä¤Ä¤À¤±keep¤¹¤ë¤ä¤Ä¡¥analytical¤ËÅ¬ÍÑ¤¹¤ë¤ÈIgorII¤ÈÆ±¤¸¤Ë¤Ê¤ë¤·¡¤exhaustive¤ËÅ¬ÍÑ¤¹¤ë¤ÈDjinn¤ß¤¿¤¤¤Ê´¶¤¸¤Ë¤Ê¤ë¡¥+-- bestのやつだけkeepするやつ．analyticalに適用するとIgorIIと同じになるし，exhaustiveに適用するとDjinnみたいな感じになる． {-# LANGUAGE MultiParamTypeClasses #-} module Control.Monad.Search.Best where import Control.Monad

Control/Monad/Search/Combinatorial.lhs view

@@ -106,7 +106,7 @@  -- should be slightly more efficient than msum msumMx xs = Mx (xs : nils)--- msumRc xs = Rc (const xs) $B4V0c$$(B+-- msumRc xs = Rc (const xs) 間違い msumRc = listToRc listToRc l = Rc f where f 0 = l                         f _ = mempty@@ -129,8 +129,8 @@ instance Monad Recomp where     return = pure     Rc f >>= g = Rc ( \n  ->  mconcat $  map  (\i -> cat $ fmap (\a -> unRc (g a) (n-i)) (f i))  [0..n] )---    Rc f >>= g = Rc (\n -> [ y | i <- [0..n], x <- f i, y <- unRc (g x) (n-i) ]) -- Bag a = [a]$B$N>l9g!%(B---    Rc f >>= g = Rc (\n -> concat $ map (\i -> concat $ map (\a -> unRc (g a) (n-i)) (f i)) [0..n]) -- STRecomp$B$KAjEv$9$k=q$-J}!%$H$/$KCY$/$O$J$i$J$$(B....+--    Rc f >>= g = Rc (\n -> [ y | i <- [0..n], x <- f i, y <- unRc (g x) (n-i) ]) -- Bag a = [a]の場合．+--    Rc f >>= g = Rc (\n -> concat $ map (\i -> concat $ map (\a -> unRc (g a) (n-i)) (f i)) [0..n]) -- STRecompに相当する書き方．とくに遅くはならない....  instance (Functor m, Monad m) => Applicative (RecompT m) where     pure x = RcT f where f 0 = return [x]@@ -156,7 +156,7 @@     (<|>) = mplus instance (Functor m, Monad m) => MonadPlus (RecompT m) where     mzero = RcT (const $ return [])-    RcT f `mplus` RcT g = RcT (\i -> do xs <- f i        -- f i $B$H(B g i$B$NN>J}$r<B9T$9$k$3$H$K$J$k$1$I!$(BIO$B$G;H$&>e$G4V0c$C$F$O$$$J$$!%(B+    RcT f `mplus` RcT g = RcT (\i -> do xs <- f i        -- f i と g iの両方を実行することになるけど，IOで使う上で間違ってはいない．                                         ys <- g i                                         return (xs++ys)) @@ -178,7 +178,7 @@                               g n = f (n-1)  {---- mapDepth$B$,$"$l$P!$Dj5A$9$kI,MW$O$J$$!%(B+-- mapDepthがあれば，定義する必要はない． -- filterMx f (Mx xss) = Mx (map (filter f) xss) filterMx f = mapDepth (filter f) -}@@ -214,7 +214,7 @@           pmx n [] = return () printNMx n (Mx xss) = printMx (Mx (take n xss)) --- join (liftM2 mtf mtx)$B$h$j$b(Bstrict+-- join (liftM2 mtf mtx)よりもstrict zipWithBF :: Monad m => (a -> b -> m c) -> m a -> m b -> m c zipWithBF f xss yss = do x <- xss                          y <- yss@@ -352,21 +352,21 @@ \end{code}  \begin{code}--- a$B$O$"$i$+$8$a(Bannotate$B$7$?$b$N$rMQ$$$k(B+-- aはあらかじめannotateしたものを用いる categorizeDB :: DBound a -> Int -> Array Int [a]-categorizeDB (DB f) b = categorize b $ f b -- $B$3$NJU$OITMW(B+categorizeDB (DB f) b = categorize b $ f b -- この辺は不要 categorize b ts = accumArray (flip (:)) [] (0,b) $ map swap ts uncategorizeDB :: (Int -> Array Int [a]) -> DBound a-uncategorizeDB f = DB $ \b -> uncategorize (f b) -- $B$3$l$bITMW(B+uncategorizeDB f = DB $ \b -> uncategorize (f b) -- これも不要 uncategorize ar = [ (x,i) | (i,xs) <- assocs ar, x <- xs ]  -- | shrinkDB can be used instead of mergesortDepthWithBy when you want to shrink each depth in different ways using different annotations. shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k-shrinkDB combiner comparer = zipDepthDB $ shrink combiner comparer -- $B$3$l$bITMW(B+shrinkDB combiner comparer = zipDepthDB $ shrink combiner comparer -- これも不要 shrink   combiner comparer = \b ts -> uncategorize $ fmap (mergesortWithByBot combiner comparer) $ categorize b ts -{-  $B85!9$3$C$A$GDj5A$7$F$?$1$I!$(BzipDepthDB$B$r;H$C$?J}$,NI$5$=$&$J$N$G!%(B--- a$B$O$"$i$+$8$a(Bannotate$B$7$?$b$N$rMQ$$$k(B+{-  元々こっちで定義してたけど，zipDepthDBを使った方が良さそうなので．+-- aはあらかじめannotateしたものを用いる categorizeDB :: DBound a -> Int -> Array Int [a] categorizeDB (DB f) b = accumArray (flip (:)) [] (0,b) $ map swap $ f b uncategorizeDB :: (Int -> Array Int [a]) -> DBound a@@ -376,7 +376,7 @@ shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k -- shrinkDB combiner comparer db = uncategorizeDB (fmap (mergesortWithByBot combiner comparer) . categorizeDB db) shrinkDB combiner comparer = uncategorizeDB . (.) (fmap (mergesortWithByBot combiner comparer)) . categorizeDB--- Control.Monad.Instances$B$K(Binstance Functor (a->) where fmap = (.) $B$,Dj5A$5$l$F$$$k!%$I$C$A$G$b$$$$$O$:$@$1$I!$2<$NJ}$,e:No$+$J$H!%(B+-- Control.Monad.Instancesにinstance Functor (a->) where fmap = (.) が定義されている．どっちでもいいはずだけど，下の方が綺麗かなと． -}  swap (b,x) = (x,b)@@ -454,7 +454,7 @@         where fun depth | pred depth = t depth                         | otherwise  = f depth #ifdef QUICKCHECK--- 0$B$+$i$+(B1$B$+$i$+$G$d$d$3$7$$$N$G!$0l1~(BquickCheck$B$7$F$*$/$Y$7!%(B+-- 0からか1からかでややこしいので，一応quickCheckしておくべし． prop_fromMxToMx, prop_fromRcToRc :: DBound Int -> Int -> Property prop_fromMxToMx = \db d -> d>=0 ==> sort (unDB (fromMx (toMx db)) d) == sort (unDB db d) -- passed 100 tests prop_fromRcToRc = \db d -> d>=0 ==> sort (unDB (fromRc (toRc db)) d) == sort (unDB db d) -- passed 100 tests@@ -464,7 +464,7 @@ #endif  -- Dunno if "Memoable" is a correct English. Or maybe I should use IsMemoOf?-class (Search n) => Memoable m n where -- $B$J$s$+(Bm$B$r(Bmonad$B$K$9$k$N$,LLE]$K$J$C$F$-$?$C$F$$$&$+!$$=$NI,MW$J$$$G$7$g!%(B+class (Search n) => Memoable m n where -- なんかmをmonadにするのが面倒になってきたっていうか，その必要ないでしょ．     tabulate  :: n a -> m a     applyMemo :: m a -> n a instance Memoable Matrix Recomp where@@ -477,7 +477,7 @@ newtype DBMemo a = DBM {unDBM :: Stream (Bag (a,Int))} {- instance Monad DBMemo where-    return x = tabulate $ return x -- $B%3%s%Q%$%kDL$k(B?+    return x = tabulate $ return x -- コンパイル通る?              -- = DBM $ map (\n->[(x,n)]) [0..]     DBM p >>= f = DBM $  -}

Data/Memo.hs view

@@ -159,7 +159,7 @@ prop_inversePosNat :: Int -> Function Int Int -> Property prop_inversePosNat n f = n>0 ==> appPosNat (memoPosNat (getFunction f)) n == getFunction f n prop_bitsToFromPosNat :: [Bool]->Bool-prop_bitsToFromPosNat is = posNatToBits (bitsToPosNat is::Integer) == is -- Integer¤Ç¤Ê¤¯Int¤Ë¤¹¤ë¤ÈÄÌ¤é¤Ê¤¤¡¥+prop_bitsToFromPosNat is = posNatToBits (bitsToPosNat is::Integer) == is -- IntegerでなくIntにすると通らない．  memoIx10, memoIx3 :: (Integral i, Ix i) => (i->a) -> MapIx i a memoIx10 = memoIx (0,10)

MagicHaskeller.cabal view

@@ -1,5 +1,5 @@ Name:            MagicHaskeller-Version:         0.9.6.4.3+Version:         0.9.6.4.4 Cabal-Version:   >= 1.8 License:         BSD3 License-file:	 LICENSE @@ -28,10 +28,6 @@   Description: Enable execution using the GHC API rather than the combinatory interpreter   Default:     True -Flag GHC7-  Description: GHC API version 7.*-  Default:     True- Flag READFILE   Description: Enable to read a component library file   Default:     True@@ -65,7 +61,6 @@                    MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged, MagicHaskeller.LibExcelStagedStaged                    Paths_MagicHaskeller   Extensions:    CPP, TemplateHaskell-  GHC-options:   -O2 -fvia-C   cpp-options:   -DCHTO -DCABAL    if flag(TFRANDOM)@@ -110,8 +105,7 @@      Build-depends:   haskell-src      cpp-options:     -DHASKELLSRC  -   if flag(GHC7)-     Build-depends:   ghc >= 7+   if impl(ghc >= 7)      GHC-options:     -with-rtsopts=-N     if flag(NETWORKURI)

MagicHaskeller.lhs view

@@ -34,7 +34,7 @@        --   you may write @'setPrimitives' $('p' [| \'A\' |])@,        --   while you have to write @'setPrimitives' $('p' [| [] :: [a] |])@ instead of @'setPrimitives' $('p' [| [] |])@.        p, setPrimitives, mkPG, mkPGSF, setPG,-       --   'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). ¤È¤¤¤¦¥³¥á¥ó¥È¤Ï¤½¤°¤ï¤Ê¤¯¤Ê¤Ã¤Æ¤¤¿¤Î¤Ç»ß¤á¤ë¡¥+       --   'mkPG' and 'setPG' used to be called @mkMemo@ and @setMemo@ respectively (because the main ingredient of a program generator is a memoization table). というコメントはそぐわなくなってきたので止める．         -- | Older versions prohibited data types holding functions such as @[a->b]@, @(Int->Char, Bool)@, etc. just for efficiency reasons.        --   They are still available if you use 'mkMemo' and 'mkMemoSF' instead of 'mkPG' and 'mkPGSF' respectively, though actually this limitation does not affect the efficiency a lot.@@ -126,10 +126,9 @@ #endif        -- other stuff which will not be documented by Haddock        unsafeCoerce#, {- unifyablePos, -} exprToTHExp, trToTHType, printAny, p1, Filtrable, zipAppend, mapIO, fpIO, fIO, fpartial, fpartialIO, etup, mkCurriedDecls-       , useArrowT, uAT       ) where -import Data.Generics(everywhere, mkT, Data, gmapT)+import Data.Generics(everywhere, mkT, Data)  import Data.Array.IArray import MagicHaskeller.CoreLang@@ -281,13 +280,13 @@ Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int Bool |])) 3  <interactive>:5:13:-    Illegal type constructor or class name: ¡Æ(->)¡Ç+    Illegal type constructor or class name: ‘(->)’     When splicing a TH type: GHC.Prim.(->) GHC.Types.Int GHC.Types.Bool     In the splice: $([t| (->) Int Bool |]) Prelude Language.Haskell.TH> ((/=0) :: $([t| (->) Int|]) Bool) 3  <interactive>:7:13:-    Illegal type constructor or class name: ¡Æ(->)¡Ç+    Illegal type constructor or class name: ‘(->)’     When splicing a TH type: GHC.Prim.(->) GHC.Types.Int     In the splice: $([t| (->) Int |]) Prelude Language.Haskell.TH> ((/=0) :: $([t| Int -> Bool |])) 3@@ -393,7 +392,7 @@ mkPGSF   = mkPGSF' True mkMemoSF = mkPGSF' False mkPGSF' cont gen nrnds classes optups tups = mkPGOpt (options{primopt = Just [optups], contain = cont, stdgen = gen, nrands = nrnds}) classes tups---   Currently only the pg==ConstrLSF case makes sense. ¤Ã¤Æ¤Î¤Ï¡¤optups¤Î¤ß¤Ë´Ø¤¹¤ëÏÃ¤Ç¡¤rnds¤Ï´Ø·¸¤Ê¤¤¡¥+--   Currently only the pg==ConstrLSF case makes sense. ってのは，optupsのみに関する話で，rndsは関係ない．  mkPG075 :: ProgramGenerator pg => [Primitive] -> [Primitive] -> pg mkPG075 = mkPGOpt (options{primopt = Nothing, contain = True, guess = True})@@ -471,24 +470,24 @@ refmemodeb = unsafePerformIO (newIORef defaultMD) defaultMD = mkPG [] :: ProgGen -trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLib¤ò»²¹Í¤Ë¤Ç¤¤ë¡¥ -- ¤³¤Î2¹Ô¤È+trsToTCL :: [TypeRep] -> TyConLib -- ReadType.extractTyConLib :: [HsDecl] -> TyConLibを参考にできる． -- この2行と trsToTCL trs     = (Map.fromListWith (\new old -> old) [ tup | k <- [0..7], tup <- tcsByK ! k ], tcsByK)     where tnsByK :: Array Types.Kind [TypeName]-          tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs )   -- ¤³¤³¤òÊÑ¤¨¤¿¡¥+          tnsByK = accumArray (flip (:)) [] (0,7) ( trsToTCstrs trs )   -- ここを変えた．           tcsByK :: Array Types.Kind [(TypeName,Types.TyCon)]           tcsByK = listArray (0,7) [ tnsToTCs (tnsByK ! k) | k <- [0..7] ]           tnsToTCs :: [TypeName] -> [(TypeName,Types.TyCon)]           tnsToTCs tns = zipWith (\ i tn -> (tn, i)) [0..] tns--- x ¼ÂºÝ¤Ë¤Ï(->)¤ÏTyCon°·¤¤¤Ë¤Ï¤·¤Ê¤¤¤ó¤À¤±¤É¡¤¤Û¤ó¤Î¤Á¤ç¤Ã¤È¤À¤±ÌµÂÌ¤Ë¤Ê¤ë¤À¤±¤Ê¤Î¤Ç¤¤¤¤¤Ç¤·¤ç¡¥+-- x 実際には(->)はTyCon扱いにはしないんだけど，ほんのちょっとだけ無駄になるだけなのでいいでしょ．  trsToTCstrs :: [TypeRep] -> [(Int, String)] -- Int is the arity of the TyCon. There can be duplicates. trsToTCstrs [] = [] trsToTCstrs (tr:ts) = case splitTyConApp tr of (tc,trs) -> (length trs, tyConName tc) : trsToTCstrs (trs++ts)  --- Memo¤ägetEverything¼«ÂÎ¤ÏIORef¤ò»È¤ï¤º¤ËIO¤Ê¤·¤Ç¼ÂÁõ¤Ç¤¤ëÌõ¤Ç¡¤¤½¤Î°ÕÌ£¤Ç¤Ï¡¤IORef¤ò»È¤ï¤Ê¤¤Êý¤¬¤¤¤¤¤«¤â¡¥--- x ¤Ä¤¤¤Ç¤Ë¤¤¤¦¤È¡¤1ÉÃ¤Ç¤Î¥¿¥¤¥à¥¢¥¦¥È¤òÉ½¤¹PTO¡Ê¤ÎGLOBAL_VAR¡Ë¤âIO¤Ê¤·¤ÇÍÑ°Õ¤Ç¤¤ë¡¥¡ÊunsafePerformIO»È¤¦¤±¤É¡Ë+-- MemoやgetEverything自体はIORefを使わずにIOなしで実装できる訳で，その意味では，IORefを使わない方がいいかも．+-- x ついでにいうと，1秒でのタイムアウトを表すPTO（のGLOBAL_VAR）もIOなしで用意できる．（unsafePerformIO使うけど）  -- | 'getEverything' uses the \'global\' values set with @set*@ functions. 'getEverythingF' is its filtered version getEverything :: Typeable a => @@ -557,7 +556,7 @@     where ty  = trToType (extractTCL memodeb) (typeOf dmy)           cmn = extractCommon memodeb {--Ìµ¸Â¥ê¥¹¥È¤ò»È¤¦¤Ê¤é¡¤unsafeInterleaveIO¤¬É¬Í×¤Ê¤Ï¤º¡¥¤½¤Î¾ì¹çIO¤ËÆÃ²½¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥+無限リストを使うなら，unsafeInterleaveIOが必要なはず．その場合IOに特化することになる． -} everythingM :: (ProgramGenerator pg, Typeable a, Monad m, Functor m) =>                      pg   -- ^ program generator@@ -611,7 +610,7 @@         ty -> fmap (exprToTHExp (extractVL memodeb) . toCE) $               filt memodeb ty $ fmap (toAnnExpr (reducer $ extractCommon memodeb)) (rawGenProgs ty memodeb) --   Another advantage of these functions is that you do not need to define @instance Typeable@ for user defined types.---   ¤È»×¤Ã¤¿¤±¤É¡¤GHC¤Ç¤Ïderiving Typeable¤Ç´ÊÃ±¤ËÄêµÁ¤Ç¤¤ë¤·¡¤Typeable¤¬ÄêµÁ¤Ç¤¤Ê¤¤·¿¤Ê¤ó¤Æ¤Ê¤µ¤½¤¦¡Êderiving Typeable¤·Ëº¤ì¤¿data type¤ò´Þ¤àdata¤¬¤½¤¦¡©¡Ë+--   と思ったけど，GHCではderiving Typeableで簡単に定義できるし，Typeableが定義できない型なんてなさそう（deriving Typeableし忘れたdata typeを含むdataがそう？）  -- specializedPossi  memodeb tht =  unMx $ toMx $ fmap show (specializedPossibleTypes (thTypeToType (extractTCL memodeb) tht) memodeb) @@ -626,7 +625,7 @@            -> (a->Bool) -> TH.Exp findOne withAbsents pred = unsafePerformIO $ findDo (\e _ -> return e) withAbsents pred -{- x Ç°¤Î¤¿¤á¤ä¤Ã¤Æ¤ß¤¿¤±¤É¡¤¤ä¤Ã¤Ñ¥À¥á¤ä¤Í¡¥¤Æ¤æ¡¼¤«¡¤Recomp¤Î¤Þ¤Þ¤ä¤Ã¤Æ³Æ¿¼¤µ¤Ç¸«¤ë¼ê¤Ï¤¢¤ë¤«¤â¡¥+{- x 念のためやってみたけど，やっぱダメやね．てゆーか，Recompのままやって各深さで見る手はあるかも． findAny :: Typeable a => (a->Bool) -> [TH.Exp] findAny pred = unsafePerformIO $ findDo (\e r -> r >>= \es -> return (e:es)) pred -}@@ -667,7 +666,7 @@                                   case result of Just True  -> e `op` fp mpto ts                                                  Just False -> fp mpto ts                                                  Nothing    -> hPutStrLn stderr ("timeout on "++pprintUC e) >> fp mpto ts--- x ËÜÅö¤Ïrecomp¤Î¤Þ¤Þ¤Ç¤ä¤Ã¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥+-- x 本当はrecompのままでやった方が速いはず．  -- | 'filterFirst' is like 'printAll', but by itself it does not print anything. Instead, it creates a stream of expressions represented in tuples of 'TH.Exp' and the expressions themselves.  filterFirst :: Typeable a =>@@ -688,7 +687,7 @@                        memodeb <- readIORef refmemodeb                        let o = opt $ extractCommon memodeb                        return $ everyF o fd-{- refmemodeb ¤Ë¤¢¤ë¤â¤Î¤¬¼ÂºÝ¤Ë»È¤ï¤ì¤Æ¤¤¤ë¤â¤Î¤È¤Ï¸Â¤é¤Ê¤¤¡¥refmemodeb¤ò»È¤ï¤Ê¤¤¤È¤¤¤¦ÁªÂò¤â¤¢¤ë¤Î¤Ç¡¥+{- refmemodeb にあるものが実際に使われているものとは限らない．refmemodebを使わないという選択もあるので． filterFirstF pred = do et <- getEverything                        filterThenF pred et filterThenF pred ts = do@@ -760,7 +759,7 @@                           case mbb2 of                                                      Just True  -> return $ Just ea                                                      _          -> return Nothing-{- ¤³¤ì¤À¤Èinterleave¤Ç¤¤Ê¤¤¡¥+{- これだとinterleaveできない． fpartialIO _    pred []            = return [] fpartialIO mpto pred ((ea@(_,a),eap@(_,ap)):ts)    = do mbb <- (maybeWithTO seq mpto (return $! pred ap)) @@ -796,7 +795,7 @@       return mv  #ifdef PAR--- ¥Û¥ó¥È¤Ïspawn¤ò»È¤Ã¤¿¤Û¤¦¤¬ÎÉ¤µ¤½¤¦¤À¤¬¡¤NFDataÄêµÁ¤¹¤ë¤Î¤¬ÌÌÅÝ¤Ê¤Î¤Ç¡¥+-- ホントはspawnを使ったほうが良さそうだが，NFData定義するのが面倒なので． mapParIO :: (a -> ParIO b) -> [a] -> ParIO [b] mapParIO f as = mapM (spawn_ . f) as >>= mapM get #endif

MagicHaskeller/Analytical/FMExpr.hs view

@@ -61,9 +61,9 @@ unifyFME' :: Expr b -> FMExpr a -> Subst b -> [(a, Subst b)] unifyFME' x         EmptyFME s = [] -- unifyFME' (E i)        fme s = error "cannot happen for now"-unifyFME' (E{})        fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤unifyFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂÎ¤¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥+unifyFME' (E{})        fme s = [ (x, s) | x <- valsFME fme ] -- ただし，unifyFME (E _) fmeの場合（全体がexistentialの場合）はそもそもintroBKせずにundefinedな引数にしてしまうべき．どうせその引数は使われないってことだから．   {--unifyFME' x@(E i)        fme s o = case lookup i s of Nothing -> [ (x, [(i,e')] `plusSubst` s) | (e,x) <- assocsFME fme, let e' = fresh (o+) e ] -- assocsFME :: FMExpr a -> [(Expr,a)]¤À¤±¤É¡¤FMExpr¤Ë¾ðÊó¤ò»Ä¤·¤Æ¤ª¤±¤ÐÌµÂÌ¤Ê·×»»¤¬¤Ê¤¯¤Ê¤ë¤«¡¥¤Æ¤æ¡¼¤«¡¤Typed Constr¤ÎType¤ÎÉôÊ¬¤Î¤¿¤á¤Ë¤½¤¦¤¹¤ëÉ¬Í×¤¬¤¢¤ë¡¥+unifyFME' x@(E i)        fme s o = case lookup i s of Nothing -> [ (x, [(i,e')] `plusSubst` s) | (e,x) <- assocsFME fme, let e' = fresh (o+) e ] -- assocsFME :: FMExpr a -> [(Expr,a)]だけど，FMExprに情報を残しておけば無駄な計算がなくなるか．てゆーか，Typed ConstrのTypeの部分のためにそうする必要がある． 	       		       	   	       	      Just e  -> unifyFME' e fme s o -} unifyFME' x@(U _ i)      fme s = [ (v, subst `plusSubst` s)@@ -105,12 +105,12 @@ valsFMEs EmptyFMEs = [] valsFMEs fmes = nilFMEs fmes : [ v | fmes' <- valsFME (consFMEs fmes), v <- valsFMEs fmes' ] --- Ã»¤¯¤·¤¿Êª¡¥¸úÎ¨¤Ï³ÎÇ§¤·¤Æ¤Ê¤¤¡¥+-- 短くした物．効率は確認してない． matchFME :: Expr b -> FMExpr a -> [(a, Subst b)] matchFME x fme = matchFME' x fme emptySubst matchFME' :: Expr b -> FMExpr a -> Subst b -> [(a, Subst b)] matchFME' x         EmptyFME s = []-matchFME' (E {}) fme s = [ (x, s) | x <- valsFME fme ] -- ¤¿¤À¤·¡¤matchFME (E _) fme¤Î¾ì¹ç¡ÊÁ´ÂÎ¤¬existential¤Î¾ì¹ç¡Ë¤Ï¤½¤â¤½¤âintroBK¤»¤º¤Ëundefined¤Ê°ú¿ô¤Ë¤·¤Æ¤·¤Þ¤¦¤Ù¤¡¥¤É¤¦¤»¤½¤Î°ú¿ô¤Ï»È¤ï¤ì¤Ê¤¤¤Ã¤Æ¤³¤È¤À¤«¤é¡¥+matchFME' (E {}) fme s = [ (x, s) | x <- valsFME fme ] -- ただし，matchFME (E _) fmeの場合（全体がexistentialの場合）はそもそもintroBKせずにundefinedな引数にしてしまうべき．どうせその引数は使われないってことだから． -- Universal variables only match to existentials matchFME' x@(U{}) fme s = matchExistential x fme s -- Constractor applications can match to both existentials and constructor applications with the same constructor.

MagicHaskeller/Analytical/Parser.hs view

@@ -88,8 +88,8 @@ parseIOPairss xvl (_:decs) = parseIOPairss xvl decs parseIOPairss _   []       = return [] --- ·¿Àë¸À¤¬¤¢¤ë¾ì¹ç¡¤¤½¤Îforall¤Ê¤ä¤Ä¤Ë¥Þ¥Ã¥Á¤·¤Æ½ªÎ»¡¥--- ¤Ê¤¤¾ì¹ç¡¤¤½¤Î¤Þ¤Þ´Ø¿ô¤Ë¤·¤Æ½ªÎ»¡¥+-- 型宣言がある場合，そのforallなやつにマッチして終了．+-- ない場合，そのまま関数にして終了． clauseToIOPair :: (Functor m, MonadPlus m) => XVarLib -> Clause -> PriorSubsts m (T.Typed (IOPair T.Type)) clauseToIOPair ivl cl = fmap fst $ runStateT (clauseToIOPair' ivl cl) IntMap.empty clauseToIOPair' ivl (Clause inpats (NormalB ex) []) =do ins <- mapM inferT (reverse $ map (patToExp ivl) inpats)@@ -148,12 +148,12 @@ tapplyExpr sub (C t sz (i T.:::cty) es) = C (T.apply sub t) sz (i T.:::T.apply sub cty) (map (tapplyExpr sub) es) tapplyExpr _   v               = v {--substitution¤ò°ìÅÙget¤·¤¿¤é¡¤¤½¤ì¤òÁ´ÂÎ¤ËÇÈµÚ¤µ¤»¤ëÉ¬Í×¤¬¤¢¤ë¡©-¤Æ¤æ¡¼¤«¡¤³Æ¥³¥ó¥¹¥È¥é¥¯¥¿¤Îforall¤ÇfreshVar¤·¤¿¤ä¤Ä¤À¤±¤¹¤ì¤Ð¤è¤¤¡©-¹Í¤¨¤ë¤ÎÌÌÅÝ¤¯¤µ¤¤¤·¡¤Î§Â®¤Ç¤Ï¤Ê¤¤¤Î¤Ç2¥Ñ¥¹¤Ç¡¥+substitutionを一度getしたら，それを全体に波及させる必要がある？+てゆーか，各コンストラクタのforallでfreshVarしたやつだけすればよい？+考えるの面倒くさいし，律速ではないので2パスで． -} --- MagicHaskeller.Types¤ËÃÖ¤¯¤Ù¤¤È¤¤¤¦µ¤¤¬¤·¤Ê¤¤¤Ç¤â¤Ê¤¤¡¥+-- MagicHaskeller.Typesに置くべきという気がしないでもない． unzipTyped [] = ([],[]) unzipTyped ((e T.:::t):ets) = let (es,ts) = unzipTyped ets in (e:es,t:ts) @@ -166,7 +166,7 @@ mkTypedConstr  xvl c   = c T.::: PD.dynType (varLib xvl!c) patToExp ivl (LitP (IntegerL i)) | i>=0      = natToConExp ivl i                                  | otherwise = cap () (mkTypedConstr ivl (negateID ivl)) [natToConExp ivl (-i)]--- patToExp tcl (LitP (CharL c))     = C (Ctor (ord c) (c¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) []+-- patToExp tcl (LitP (CharL c))     = C (Ctor (ord c) (cに相当する奴. ある訳ない?)) [] -- patToExp tcl (LitP (StringL str)) = strToConExp tcl str patToExp ivl (VarP name)   = U () (strToInt $ nameBase name) patToExp ivl (TupP pats)         = cap () (getTypedConstr ivl (tupleDataName (length pats))) (map (patToExp ivl) pats)@@ -186,11 +186,11 @@ strToInt (x:xs) = ord x + 256 * strToInt xs  natLimit = 32-natToConExp ivl i -- x | i > natLimit = C (Ctor i  (i¤ËÁêÅö¤¹¤ëÅÛ. ¤¢¤ëÌõ¤Ê¤¤?)) []+natToConExp ivl i -- x | i > natLimit = C (Ctor i  (iに相当する奴. ある訳ない?)) []                   | otherwise    = smallNat ivl i smallNat ivl 0 = C () 1 (mkTypedConstr ivl (zeroID ivl)) [] smallNat ivl i = cap () (mkTypedConstr ivl (succID ivl)) [smallNat ivl (i-1)]--- strToConExp tcl "" = C (Ctor 0 ([]¤ËÁêÅö¤¹¤ëÅÛ)) []+-- strToConExp tcl "" = C (Ctor 0 ([]に相当する奴)) []  thExpToExpr :: XVarLib -> Exp -> Expr () thExpToExpr ivl (VarE name) = case getMbTypedConstr ivl name of Nothing -> U () (strToInt $ nameBase name)@@ -210,9 +210,9 @@ thExpToExpr ivl (SigE e _t) = thExpToExpr ivl e thExpToExpr _ _ = error "Unsupported expression in IO examples." {--case¤Î¾ì¹ç¡¤´û¤Ë¤¢¤ëprimitive component¤Ë¹ç¤ï¤»¤ë¤Î¤Ï·ë¹½¤ä¤ä¤³¤·¤¤¡¥¡Ê¤¿¤È¤¨¤Ð¡¤¥³¥ó¥¹¥È¥é¥¯¥¿¤Î½ç½ø¤Å¤±¤È¤«¤ò¹ç¤ï¤»¤ë¤Î¤Ï¤Ã¤Æ¤³¤È¤Í¡¥¡Ë-¥³¥ó¥¹¥È¥é¥¯¥¿¤Î½ç½ø¤Å¤±¤Ïreify¤Ç¥²¥Ã¥È¤·¤¿½ç¤Ë¤¹¤ë¤³¤È¤Ë¤·¤Æ¡¤case¤ÏÄ¾ÀÜTH¤òÀ¸À®¤¹¤ë¤³¤È¤Ë¤¹¤ë¡¥-¤³¤ì¤¬²ÄÇ½¤Ê¤Î¤Ï¡¤¤Þ¤ºanalytical¤ä¤Ã¤Æ¤½¤ì¤«¤ésystematic¤ò¤ä¤ë¤«¤é¡¥+caseの場合，既にあるprimitive componentに合わせるのは結構ややこしい．（たとえば，コンストラクタの順序づけとかを合わせるのはってことね．）+コンストラクタの順序づけはreifyでゲットした順にすることにして，caseは直接THを生成することにする．+これが可能なのは，まずanalyticalやってそれからsystematicをやるから． -¤½¤¦¤Ê¤ë¤È¡¤clauseToIOPair¤È¤«¤ËVarLib¤Ï¤¤¤é¤Ê¤¯¤Ê¤ë¤·¡¤Constr¤ÏCoreExpr¤ÎÂå¤ï¤ê¤ËTH.Exp(¤«TH.Name)¤ò»ý¤Ä¤³¤È¤Ë¤Ê¤ë¡¥+そうなると，clauseToIOPairとかにVarLibはいらなくなるし，ConstrはCoreExprの代わりにTH.Exp(かTH.Name)を持つことになる． -}

MagicHaskeller/Analytical/Syntax.hs view

@@ -26,7 +26,7 @@ type TBS = [Bool]                 -- ^ the to-be-sought list data Expr a = E {ann :: a, iD :: Int} -- ^ existential variable. When doing analytical synthesis, there is no functional variable.              | U {ann :: a, iD :: Int} -- ^ universal variable. When doing analytical synthesis, there is no functional variable. -                     --   Int¤Ç¤Ï¤Ê¤¯TH.Name¤òÄ¾ÀÜ»È¤Ã¤¿Êý¤¬¤è¤¤¡©+                     --   IntではなくTH.Nameを直接使った方がよい？             | C {ann :: a, sz :: Int, ctor :: T.Typed Constr, fields :: [Expr a]}             deriving (Show) instance Eq (Expr a) where   -- We just ignore the annotations and compare syntactically.@@ -86,7 +86,7 @@ -- | 'apply' applies a substitution which replaces existential variables to an expression. apply subst v@(E _ i)  = maybe v id $ lookup i subst apply subst v@(U _ _)  = v-apply subst (C a _ i xs) = cap a i (map (apply subst) xs) -- ÃÙ¤¤¤«¤Í+apply subst (C a _ i xs) = cap a i (map (apply subst) xs) -- 遅いかね  i `occursIn` (E _ j)      = i==j i `occursIn` (U _ _)      = False@@ -144,8 +144,8 @@ revAWise   = lessListsLex cmpExprSzs -- linear is really slow, so is not recommended. linear ls rs = sum (map size ls) < sum (map size rs)--- ¤Ç¤â¡¤case¤Ç¤Ö¤Ã¤¿ÀÚ¤Ã¤¿¤¢¤È¤Î¤¹¤Ù¤Æ¤Î°ú¿ô¤òÈæ³Ó¤·¤Æ¤¤¤ë¤«¤éÃÙ¤¤¤Î¤Ç¤¢¤Ã¤Æ¡¤°ìÈÖºÇ½é¤ÎÃÊ³¬¤Î°ú¿ô¤À¤±¤ÇÈæ³Ó¤¹¤ì¤ÐÂ®¤¤¤Î¤Ç¤Ï¡©--- ¤Ç¤â¡¤Ackermann's function¤Ç¹Í¤¨¤ë¤È¡¤¤ä¤Ã¤Ñ¤½¤ì¤Ç¤Ï¥À¥á¤Ã¤Ý¤¤¡¥+-- でも，caseでぶった切ったあとのすべての引数を比較しているから遅いのであって，一番最初の段階の引数だけで比較すれば速いのでは？+-- でも，Ackermann's functionで考えると，やっぱそれではダメっぽい．  revArgs :: ([Expr a]->[Expr a]->Bool) -> [Expr a]->[Expr a]->Bool revArgs cmp ls rs = cmp (reverse ls) (reverse rs)

MagicHaskeller/Analytical/Synthesize.hs view

@@ -53,7 +53,7 @@                    aritar = length $ inputs iop                    aritar8 = fromIntegral aritar                    bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes-               in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar8 [aritar8-1, aritar8-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òÅ¬ÍÑ¤·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥+               in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar8 [aritar8-1, aritar8-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- 本当はこの結果のそれぞれに bknamesを適用したいのだが，bknamesなHValueがないので.... てゆーか，Expなら作れる．CoreExprも，BKが全部VarLibにはいっていれば作れる．                    fastAnalSynthNoUniT bk (target Types.::: ty)                   ,foldr (Types.:->) ty bktypes)         _ -> error "MagicHaskeller.Synthesize.analyticSynth*: More than one I/O pairs are defined as the target."@@ -128,7 +128,7 @@                    tbs = replicate aritar True                                       aritar = length $ inputs iop                    bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes-               in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òÅ¬ÍÑ¤·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥+               in (fmap (\e -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- 本当はこの結果のそれぞれに bknamesを適用したいのだが，bknamesなHValueがないので.... てゆーか，Expなら作れる．CoreExprも，BKが全部VarLibにはいっていれば作れる．                    analSynthNoUniT_debug tree bk (target Types.:::ty)                   )         _ -> error "TypedIOPairs.analyticSynth*: More than one I/O pairs are defined as the target."@@ -157,7 +157,7 @@                    tbs = replicate aritar True                    aritar = length $ inputs iop                    bk = reverse $ zipWith (Types.:::) (map mkBKFun $ bkiopss) bktypes-               in fmap (\(e,_st) -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- ËÜÅö¤Ï¤³¤Î·ë²Ì¤Î¤½¤ì¤¾¤ì¤Ë bknames¤òÅ¬ÍÑ¤·¤¿¤¤¤Î¤À¤¬¡¤bknames¤ÊHValue¤¬¤Ê¤¤¤Î¤Ç.... ¤Æ¤æ¡¼¤«¡¤Exp¤Ê¤éºî¤ì¤ë¡¥CoreExpr¤â¡¤BK¤¬Á´ÉôVarLib¤Ë¤Ï¤¤¤Ã¤Æ¤¤¤ì¤Ðºî¤ì¤ë¡¥+               in fmap (\(e,_st) -> napply (length bktups) FunLambda $ napply aritar Lambda (Fix e aritar [aritar-1, aritar-2..0])) $   --  $ Fix e $ map X [arity-1, arity-2 .. 0]) $     -- 本当はこの結果のそれぞれに bknamesを適用したいのだが，bknamesなHValueがないので.... てゆーか，Expなら作れる．CoreExprも，BKが全部VarLibにはいっていれば作れる．                         runStateT (analSynthUT_debug tree bk (target Types.::: ty)) emptySt -- ONLY DIFFER HERE.            _ -> error "analyticSynth: More than one I/O pairs are defined as the target."     where xvl = mkXVarLib vl@@ -195,17 +195,17 @@ liftList :: MonadPlus m => StateT s [] a -> StateT s m a liftList = mapStateT (msum . map return) -introVarm, introVarm', introConstr, introCase :: (Functor m, MonadPlus m) => Introducer a m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥-introBKm :: (Search m) => Introducer a m -- introConstr¤Ç¤Ï¡¤¼ÂºÝ¤Ë¤ÏCoreExpr¤ÏConstr¤Ç¤è¤¤¡¥+introVarm, introVarm', introConstr, introCase :: (Functor m, MonadPlus m) => Introducer a m -- introConstrでは，実際にはCoreExprはConstrでよい．+introBKm :: (Search m) => Introducer a m -- introConstrでは，実際にはCoreExprはConstrでよい． introVarUTm, introBKUTm :: MonadPlus m => IntroUniT a m--- introVarUTm¤Ï°ìÏ¢¤ÎIgor´Ø·¸¤ÎÏÀÊ¸¤Ë¤Ï¤Ê¤¤¤â¤Î¤Î¡¤introBK¤¬Í¸ú¤ËÆ¯¤¯¤Ë¤ÏÉ¬Í×¡¥¤³¤ì¤¬¤Ê¤¤¤È¡¤f¤òºî¤ë¤Î¤ËBK¤È¤·¤Æf¤ò»È¤Ã¤Æ¤â¡¤introBK¤À¤±¤Ç½ª¤ï¤Ã¤Æ¤¯¤ì¤º¡¤À¸À®¤µ¤ì¤Ê¤¤¡¥-{- introBK¤Î¤¢¤È¤ÎintroVarUTm¤òintroBK¤Ë´Þ¤á¤è¤¦¤È¤·¤Æ¡¤¤ä¤Ã¤Ñ»ß¤á¤¿¡¥+-- introVarUTmは一連のIgor関係の論文にはないものの，introBKが有効に働くには必要．これがないと，fを作るのにBKとしてfを使っても，introBKだけで終わってくれず，生成されない．+{- introBKのあとのintroVarUTmをintroBKに含めようとして，やっぱ止めた． introVarUTm (iops,_,_,True) = mzero introVarUTm (iops,_,_,False)  = msum $ map (\(ix,_) -> return (const (X ix), [])) $ filter (\(_,inp) -> inp == map output iops) $ zip [0..] $ transpose $ map inputs iops -} -- introVarUTm (iops,_,_,_)  = msum $ map (\(ix,_) -> return (const (X ix), [])) $ filter (\(_,inp) -> inp == map output iops) $ zip [0..] $ transpose $ map inputs iops introVarUTm b f = liftList $ introVar (zipWithM_ appUnifyUT) b f--- introVarm b f  = introVar (zipWithM_ unify) b f  *************************************** ¤³¤ì¤Ï¥Ç¥Ð¥Ã¥°»þ¤ËÍÍÑ¤Ê¤³¤È¤â¡¥+-- introVarm b f  = introVar (zipWithM_ unify) b f  *************************************** これはデバッグ時に有用なことも． introVarm   = introVar (\a b -> guard $ a==b)  introVarm' = introVar (zipWithM_ unify)@@ -246,7 +246,7 @@  shareConstr (C _ _ (cid Types.::: _) _ : iops) = all (`sConstrIs` cid) iops  shareConstr _                = False--- type¤¬°ã¤¦¤ÈÆ±¤¸cid¤ò°Û¤Ê¤ëconstructor¤Ç»È¤¤ÆÀ¤ë¾ì¹ç¡¤type¤´¤ÈÈæ³Ó¤¹¤ëÉ¬Í×¤¬¤¢¤ë¤¬¡¤¸½ºß¤Ï¤½¤¦¤Ç¤Ï¤Ê¤¤¤Î¤Ç¡¥+-- typeが違うと同じcidを異なるconstructorで使い得る場合，typeごと比較する必要があるが，現在はそうではないので． C _ _ (c Types.::: _) _ `sConstrIs` cid = cid==c _                       `sConstrIs` cid = False @@ -329,17 +329,17 @@ subtractIOPairsFromIOPairsBKUTm []         bkf = return [] subtractIOPairsFromIOPairsBKUTm (fun:funs) bkf = do                                                   iops <- subtractIOPairsBKUTm fun bkf-                                                 iopss <- subtractIOPairsFromIOPairsBKUTm funs bkf -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥+                                                 iopss <- subtractIOPairsFromIOPairsBKUTm funs bkf -- iopsは，subfunctionが複数あって，それらsubfunctionsのそれぞれに関してIOPair1個ずつに過ぎない．                                                  return (iops:iopss) -- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples.  {--subtractIOPairs :: IOPair -> [IOPair] -> [[IOPair]] -- ÆâÂ¦¥ê¥¹¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤«-                                                    -- ¤Æ¤æ¡¼¤«¡¤ÆâÂ¦¤Ïbk¤Îarity¤Ç¤Ï¡©+subtractIOPairs :: IOPair -> [IOPair] -> [[IOPair]] -- 内側リストの基数はfunのarity, 外側はbkのIO pairのうちmatchするのはいくつあるか+                                                    -- てゆーか，内側はbkのarityでは？ subtractIOPairs fun bkpairs = [ iops | bk <- bkpairs, iops <- subtractIOPair fun bk ] -}-subtractIOPairsBKUTm :: MonadPlus m => IOPair a -> (Fun a) -> UniT a m [IOPair a] -- ÆâÂ¦¥ê¥¹¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤«-                                                    -- ¤Æ¤æ¡¼¤«¡¤ÆâÂ¦¤Ïbk¤Îarity¤Ç¤Ï¡©+subtractIOPairsBKUTm :: MonadPlus m => IOPair a -> (Fun a) -> UniT a m [IOPair a] -- 内側リストの基数はfunのarity, 外側はbkのIO pairのうちmatchするのはいくつあるか+                                                    -- てゆーか，内側はbkのarityでは？ subtractIOPairsBKUTm tgt bkf = do                                 s <- gets subst                                let aptgt = applyIOP  s tgt@@ -357,10 +357,10 @@ subtractIOPairsFromIOPairsUTm' ts []         bkf = return [] subtractIOPairsFromIOPairsUTm' ts (fun:funs) bkf = do                                 (iops,newts) <- subtractIOPairsUTm ts fun bkf-                                iopss        <- subtractIOPairsFromIOPairsUTm' newts funs bkf -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥+                                iopss        <- subtractIOPairsFromIOPairsUTm' newts funs bkf -- iopsは，subfunctionが複数あって，それらsubfunctionsのそれぞれに関してIOPair1個ずつに過ぎない．                                 return (iops:iopss)-subtractIOPairsUTm :: MonadPlus m => TermStat -> IOPair a -> (Fun a) -> UniT a m ([IOPair a], TermStat) -- ÆâÂ¦¥ê¥¹¥È¤Î´ð¿ô¤Ïfun¤Îarity, ³°Â¦¤Ïbk¤ÎIO pair¤Î¤¦¤Ámatch¤¹¤ë¤Î¤Ï¤¤¤¯¤Ä¤¢¤ë¤«-                                                    -- ¤Æ¤æ¡¼¤«¡¤ÆâÂ¦¤Ïbk¤Îarity¤Ç¤Ï¡©+subtractIOPairsUTm :: MonadPlus m => TermStat -> IOPair a -> (Fun a) -> UniT a m ([IOPair a], TermStat) -- 内側リストの基数はfunのarity, 外側はbkのIO pairのうちmatchするのはいくつあるか+                                                    -- てゆーか，内側はbkのarityでは？ subtractIOPairsUTm ts tgt bkf = do                                 s <- gets subst                                 let aptgt = applyIOP s tgt@@ -369,7 +369,7 @@                                     apvistgt = reverse $ visibles (reverse bktbs) $ reverse $ inputs aptgt                                 bkiop <- msum $ map return $ iopairs bkf                                 let visbki = visibles bktbs $ inputs bkiop-                                guard $ evalTS $ updateTS visbki apvistgt ts  -- apply¤¹¤ë¤Þ¤¨¤Îbkf¤ÇÅêµ¡Åª¤Ëfilter¤·¤Æ¤ß¤¿¤±¤É¡¤¤¤¤Þ¤¤¤Á¡¥+                                guard $ evalTS $ updateTS visbki apvistgt ts  -- applyするまえのbkfで投機的にfilterしてみたけど，いまいち．                                 let apvisbki = map (apply s) visbki                                 iops <- subtractIOPairUTm aptgt bkiop{inputs=apvisbki, output=apply s $ output bkiop}                                 let newts = updateTS apvisbki apvistgt ts -- This makes sure that the generated program does not go into a loop.@@ -377,10 +377,10 @@ --                                guard $ lessExprss (reverse bkis) (reverse apis)                                 return (iops, newts) --- Îã¤¨¤Ð¡¤join [x,y] [z,w] = [x,y,z,w]¤«¤ébk [a,b] [c,d] = [a,c,b,d]¤ò°ú¤¯¤³¤È¤ò¹Í¤¨¤ë¡¥--- join [x,y] [z,w] = bk (f [x,y] [z,w]) (g [x,y] [z,w])¤Ë¤ª¤¤¤Æf [x,y] [z,w] = [x,z], g [x,y] [z,w] = [y,w]¤Ê¤Î¤Ç¡¤+-- 例えば，join [x,y] [z,w] = [x,y,z,w]からbk [a,b] [c,d] = [a,c,b,d]を引くことを考える．+-- join [x,y] [z,w] = bk (f [x,y] [z,w]) (g [x,y] [z,w])においてf [x,y] [z,w] = [x,z], g [x,y] [z,w] = [y,w]なので， -- subtractIOPair IOP{inputs=[[x,y],[z,w]],output=[x,y,z,w]} IOP{inputs=[[a,b],[c,d]],output=[a,c,b,d]} = [IOP{inputs=[[x,y],[z,w]],output=[x,z]}, IOP{inputs=[[x,y],[z,w]],output=[y,w]}]--- ¤È¤¤¤¦¤³¤È¤Ë¤Ê¤ë¡¥+-- ということになる． subtractIOPairUTm :: MonadPlus m => IOPair a -> IOPair a -> UniT a m [IOPair a] subtractIOPairUTm fun bkiop                       = do frbkiop <- freshIOP bkiop@@ -388,7 +388,7 @@                            s <- gets subst                            return [ fun{output=apply s o} | o <- inputs frbkiop ] -- This @apply@ is necessary here because introBKm will soon forget the substitution. -subtractIOPairsFromIOPairsm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤¤ëÃÍ¡¥+subtractIOPairsFromIOPairsm :: Int -- maxNumBVsでゲットできる値．                                -> TermStat -> Fun a -> Fun a -> [] [[IOPair a]] subtractIOPairsFromIOPairsm addendum ts tgt bkf     = subtractIOPairsFromIOPairsmFME addendum ts (length $ filter id $ toBeSought tgt) -- the actual arity@@ -400,13 +400,13 @@ subtractIOPairsFromIOPairsmFME addendum ts ary []         bkf offset = return [] subtractIOPairsFromIOPairsmFME addendum ts ary (fun:funs) bkf offset = do                                                   (iops,newts) <- subtractIOPairsmFME ts ary fun bkf offset-                                                 iopss <- subtractIOPairsFromIOPairsmFME addendum newts ary funs bkf (offset+addendum) -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥+                                                 iopss <- subtractIOPairsFromIOPairsmFME addendum newts ary funs bkf (offset+addendum) -- iopsは，subfunctionが複数あって，それらsubfunctionsのそれぞれに関してIOPair1個ずつに過ぎない．                                                  return (iops:iopss) -- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples. -subtractIOPairsmFME :: TermStat -> Int -> IOPair a -> Fun a -> Int -> [([IOPair a], TermStat)] -- ÊÖ¤êÃÍ¤Î[IOPair]¤Ï³Æ°ú¿ô¤ËÂÐ±þ+subtractIOPairsmFME :: TermStat -> Int -> IOPair a -> Fun a -> Int -> [([IOPair a], TermStat)] -- 返り値の[IOPair]は各引数に対応 subtractIOPairsmFME ts ary tgtiop bkf offset -  = case output tgtiop of E{}  -> [(replicate (arity bkf) tgtiop, ts)] -- target¤ÎÊÖ¤êÃÍ¤¬Ã±¤Ëexistential variable¤Î¾ì¹ç¡¤»È¤ï¤ì¤Ê¤¤¤Î¤Ç¤Ê¤ó¤Ç¤â¤è¤¤¡¥¤¬¡¤arity¤òÂ·¤¨¤ëÉ¬Í×¤¬¤¢¤ë¡¥+  = case output tgtiop of E{}  -> [(replicate (arity bkf) tgtiop, ts)] -- targetの返り値が単にexistential variableの場合，使われないのでなんでもよい．が，arityを揃える必要がある．                           tgto -> do                                  let vistgt = reverse $ visibles (reverse $ toBeSought bkf) $ reverse $ inputs tgtiop                                 visbkis <- unifyingIOPairs tgto (fmexpr bkf) offset@@ -417,7 +417,7 @@                                 return (iops, newts)                                                                  -subtractIOPairsFromIOPairsBKm :: Int -- maxNumBVs¤Ç¥²¥Ã¥È¤Ç¤¤ëÃÍ¡¥+subtractIOPairsFromIOPairsBKm :: Int -- maxNumBVsでゲットできる値．                                  -> [IOPair a] -> (Fun a) -> [] [[IOPair a]] subtractIOPairsFromIOPairsBKm addendum tgt bkf = subtractIOPairsFromIOPairsBKmFME addendum tgt (iopsToFME $ iopairs bkf) addendum subtractIOPairsFromIOPairsBKmFME :: Int -> [IOPair a] -> FMExpr [IOPair a] -> Int -> [] [[IOPair a]]@@ -427,13 +427,13 @@ subtractIOPairsFromIOPairsBKmFME addendum []         bkf offset = return [] subtractIOPairsFromIOPairsBKmFME addendum (fun:funs) bkf offset = do                                                   iops <- subtractIOPairsBKmFME fun bkf offset-                                                 iopss <- subtractIOPairsFromIOPairsBKmFME addendum funs bkf (offset+addendum) -- iops¤Ï¡¤subfunction¤¬Ê£¿ô¤¢¤Ã¤Æ¡¤¤½¤ì¤ésubfunctions¤Î¤½¤ì¤¾¤ì¤Ë´Ø¤·¤ÆIOPair1¸Ä¤º¤Ä¤Ë²á¤®¤Ê¤¤¡¥+                                                 iopss <- subtractIOPairsFromIOPairsBKmFME addendum funs bkf (offset+addendum) -- iopsは，subfunctionが複数あって，それらsubfunctionsのそれぞれに関してIOPair1個ずつに過ぎない．                                                  return (iops:iopss) -- Applying substitutions to funs is not currently necessary (because funs does not include existential variables), but that will be useful in future versions which fill gaps of input examples.                                                                                                 -subtractIOPairsBKmFME :: IOPair a -> FMExpr [IOPair a] -> Int -> [] [IOPair a] -- ÊÖ¤êÃÍ¤Î[IOPair a]¤Ï³Æ°ú¿ô¤ËÂÐ±þ+subtractIOPairsBKmFME :: IOPair a -> FMExpr [IOPair a] -> Int -> [] [IOPair a] -- 返り値の[IOPair a]は各引数に対応 subtractIOPairsBKmFME tgtiop bkfme offset = do                                  visbkis <- unifyingIOPairs (output tgtiop) bkfme offset                                 return [ tgtiop{output=o} | o <- visbkis ]

MagicHaskeller/CGI.lhs view

@@ -172,11 +172,11 @@  "  </FORM>" ++  "  <BR> satisfies the following input-output relation: <BR><BR>" -- about `display: inline;', See newnotes on Nov. 1, 2012 and http://www.cs.tut.fi/~jkorpela/forms/extraspace.html--- input-output examples²èÌÌ¤Çabsentbox¤òÉ½¼¨¤·¤Æ¤â¥´¥Á¥ã¥´¥Á¥ã¤¹¤ë¤À¤±¤Ê¤Î¤Ç¡¤±£¤·¤Æ¤ª¤¯¡¥--- Ãí*1 #absentbox¤Î¤È¤³¤í¤Ï¡¢²¼µ¤Î*1¤Ç½ñ¤¤¤¿ÌäÂê¤ò²ò·è¤·¤Æ¤«¤é¥Æ¥¹¥È¤·¤¿¤¤¤Î¤Ç¡¤¤½¤Î»þ¤Ïdisplay: none¤Ç¤Ï¤Ê¤¯font-size: small¤Ë¤·¤Æ¤«¤é¥Á¥§¥Ã¥¯¤·¤Æ¤ª¤¤¿¤¤¡¥+-- input-output examples画面でabsentboxを表示してもゴチャゴチャするだけなので，隠しておく．+-- 注*1 #absentboxのところは、下記の*1で書いた問題を解決してからテストしたいので，その時はdisplay: noneではなくfont-size: smallにしてからチェックしておきたい． --- details ¤Î²èÌÌ¤ÇboxÆâ¤ò¥«¥Ã¥³¤Ç¤¯¤¯¤ëworkaround. ËÜÅö¤Ï¥µ¡¼¥Ð¡¼Â¦¤ÇºÇ½é¤«¤é¥«¥Ã¥³¤Ç¤¯¤¯¤Ã¤Æ¤ª¤¤¤¿Êý¤¬²ó¤ê¤¯¤É¤¯¤Ê¤¤¡¥-parenthesize xs | last xs == ')' = xs           -- ¥¯¥¨¥ê¡¼Ëè¤Ë¥«¥Ã¥³¤¬Áý¤¨¤Æ¤¤¤«¤Ê¤¤¤è¤¦¤Ë¡¤¤¹¤Ç¤Ë¥«¥Ã¥³¤¬¤¢¤ë¤È»×¤ï¤ì¤ë¤È¤¤Ï³ç¤é¤Ê¤¤¡¥+-- details の画面でbox内をカッコでくくるworkaround. 本当はサーバー側で最初からカッコでくくっておいた方が回りくどくない．+parenthesize xs | last xs == ')' = xs           -- クエリー毎にカッコが増えていかないように，すでにカッコがあると思われるときは括らない．                 | otherwise      = '(':xs++")"  predicateBox myPathName size showAbsents predicate = queryBox  myPathName size showAbsents predicate "Synthesize f"@@ -223,6 +223,7 @@  unavailable config = detailsHead config ++ "<p>We are sorry, but this functionality is not provided by the CGI frontend built for non-UNIX servers.</p>" ++ lastLines False + main = main' runCGI main' run = do            progName <- getProgName@@ -297,7 +298,7 @@                                              Right b -> do let pb = if b then predBox else "<strong>not</strong> ("++predBox++")"                                                            when (not b) $ logCGI $ "MagHLogErr " ++ pb                                                            output ((if suggesting then thanks else detail) config candi ++ pb ++ "<br><table border=0 cellspacing=0 align=left>"++result ++"</table>"++ lastLines useJS) -- <BR> is necessary for Safari.-                                  -- Exemplify¥Ü¥¿¥ó¤¬¤Á¤ã¤ó¤Èabsent¤òÀßÄê¤·¤Æ¤¤¤Ê¤¤¤Î¤Ç¡¤showAbsents¤òÁ÷¤Ã¤Æ¤â¤¢¤Þ¤ê°ÕÌ£¤¬¤Ê¤¤¡¥Ãí*1+                                  -- Exemplifyボタンがちゃんとabsentを設定していないので，showAbsentsを送ってもあまり意味がない．注*1 #else                                         output $ unavailable config #endif@@ -570,7 +571,7 @@                                                               _    -> fmap (('(':).(cs++).("::Int)"++)) $ addSignature rest                                       | otherwise -> fmap ((cs++).(' ':)) $ addSignature rest --- splitAtNBRs¤Ë¤¹¤ì¤Ð¤è¤«¤Ã¤¿¡¥+-- splitAtNBRsにすればよかった．  takeNBRs 0 _  = (True, "") takeNBRs n "" = (False,"")

MagicHaskeller/ClassLib.lhs view

@@ -56,7 +56,7 @@                          (fmap (\ (exprs, sub, m) -> (exprs, retrieve decoder sub `plusSubst` subst, mx+m)) $ fromMemo $ lmt mt tn)                  --        (unPS (behalf memodeb reqret) subst mx)           )-                         -- ¾ò·ï¤Ë¤è¤Ã¤ÆºÆ·×»»¤·¤¿¤¤¤È¤¤Ïuncomment¤¹¤Ù¤·¡£¥á¥â¤ê¤Ï¿©¤ï¤Ê¤¤¤Ï¤º¤Ê¤Î¤Ç¡¢¾ï¤Ëmemoize¤ÇÌäÂê¤Ê¤¤¤Ï¤º¡£+                         -- 条件によって再計算したいときはuncommentすべし。メモりは食わないはずなので、常にmemoizeで問題ないはず。  type MemoDeb a = (MemoTrie a, [[Prim]], Common) @@ -90,7 +90,7 @@                             lookupFunsPoly mguFuns memodeb (apply subst ty) mguFuns memodeb = generateFuns  mguPrograms memodeb --- MemoDeb¤Î·¿¤¬°ã¤¦¤È»È¤¨¤Ê¤¤¡¥+-- MemoDebの型が違うと使えない． generateFuns :: (Search m, Expression e) =>                 Generator m e                            -- ^ recursive call                 -> Generator m e

MagicHaskeller/Classification.hs view

@@ -192,12 +192,12 @@  #ifdef TESTEQ instance Eq a => Filtrable a where-    filt      = filtNullary  (==)-    filtFun   = filtUnary    (==)+    filt     = filtNullary  (==)+    filtFun  = filtUnary    (==) #else instance Ord a => Filtrable a where-    filt      = filtNullary compare-    filtFun   = filtUnary   compare+    filt     = filtNullary  compare+    filtFun  = filtUnary    compare     unsafeFilt    mto = filtNullary  (unsafeOpWithPTO mto compare)     unsafeFiltFun mto = filtUnary    (unsafeOpWithPTO mto compare) instance Filtrable Double where

MagicHaskeller/Classify.hs view

@@ -8,7 +8,7 @@                ) where #define CHTO import Control.Monad.Search.Combinatorial--- import Types(Subst) -- Subst¤Ëspecialize¤¹¤ëÉ¬Í×¤Ï¤Ê¤¤¤±¤É¡¥+-- import Types(Subst) -- Substにspecializeする必要はないけど． import Data.Maybe import Control.Monad(mplus) @@ -55,7 +55,7 @@            typeToRandomsOrd tcl rtrie typ of                            Nothing        -> id                            Just ([],  op) -> fmap snd . ofilter (op,pto) . fmap opreexecute---                           Just (rnds,op) -> unscanl . fmap snd . repEqClsBy_simple op . fmap (spreexecute rnds) -- Feb. 10, 2007¤Înotes¤ÎºÇ¸å¤ÎÊÕ¤ê»²¾È¡¥Matrix¤Î¾ì¹ç¤Í¡¥+--                           Just (rnds,op) -> unscanl . fmap snd . repEqClsBy_simple op . fmap (spreexecute rnds) -- Feb. 10, 2007のnotesの最後の辺り参照．Matrixの場合．                            Just (rnds,op) -> fmap snd . sfilter (op,pto) . fmap (spreexecute (uncurryDyn (mkUncurry tcl) typ) rnds) spreexecute uncurrier rnds e@(AE _ dyn) = let f = uncurrier dyn in (map (dynAppErr "in Classify.spreexecute" f) rnds, e) @@ -80,13 +80,13 @@     sfilter = sfilterDB     ofilter = ofilterDB --- x ¤³¤Î[([k],e)]¤ÎÉôÊ¬¤Ï¡¤ËÜÅö¤Î¤È¤³¤íStreamTrie¤Ç¼ÂÁõ¤·¤¿Êý¤¬¸úÎ¨Åª¤Ê¤Ï¤º¡¥+-- x この[([k],e)]の部分は，本当のところStreamTrieで実装した方が効率的なはず．  sfilterMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) -- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)--- x ¤³¤ì¤À¤È¡¤mergeMxBy¤¬¥×¥í¥°¥é¥à¥µ¥¤¥º¤Î¤³¤È¤òÃÎ¤é¤º¤ËºÇ½é¤Î1¸Ä¤Îkey¤ÎÈæ³Ó¤«¤é»Ï¤á¤Æ¤·¤Þ¤¦ ... ¤È»×¤Ã¤¿¤±¤É¼Â¤Ï¤½¤¦¤Ç¤â¤Ê¤¤¡¥mergeMxBy¤¬(Mx (_:ys))¤Î¤è¤¦¤ËÀèÆ¬¤òdrop¤¹¤ë¤Î¤¬¥Ý¥¤¥ó¥È¤Ç¡¤¤¿¤È¤¨¤Ð(map repEqClsBy xss) !! n¤ÏÀèÆ¬¤În¸ÄÊ¬¤¬(·ë²Ì¤È¤·¤Æ)drop¤µ¤ì¤ë¤³¤È¤Ë¤Ê¤ë¡¥--- x ¤ä¤Ã¤Ñ¥À¥á¡¥--- x Â¿Ê¬ÌäÂê¤Ï¡¤eqClsBy¤Ï¿¼¤µ£²°Ê¹ß¤â¿¼¤µ£±¤Ëdepend¤·¤Æ¤¤¤Æ¡¤¤½¤¦¤Ê¤ë¤È¥µ¥¤¥º£²°Ê¹ß¤Î¥×¥í¥°¥é¥à¤¬...¤ß¤¿¤¤¤Ê´¶¤¸+-- x これだと，mergeMxByがプログラムサイズのことを知らずに最初の1個のkeyの比較から始めてしまう ... と思ったけど実はそうでもない．mergeMxByが(Mx (_:ys))のように先頭をdropするのがポイントで，たとえば(map repEqClsBy xss) !! nは先頭のn個分が(結果として)dropされることになる．+-- x やっぱダメ．+-- x 多分問題は，eqClsByは深さ２以降も深さ１にdependしていて，そうなるとサイズ２以降のプログラムが...みたいな感じ sfilterMx op mx = trace "sfilterMx" $                       unscanlByList op $ repEqClsBy op mx @@ -103,13 +103,13 @@ filterRc :: TyConLib -> RTrie -> Opt () -> Type -> Recomp AnnExpr -> Recomp AnnExpr filterRc = filterBF --- x ¤³¤Î[([k],e)]¤ÎÉôÊ¬¤Ï¡¤ËÜÅö¤Î¤È¤³¤íStreamTrie¤Ç¼ÂÁõ¤·¤¿Êý¤¬¸úÎ¨Åª¤Ê¤Ï¤º¡¥+-- x この[([k],e)]の部分は，本当のところStreamTrieで実装した方が効率的なはず．  sfilterRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e) -- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)--- x ¤³¤ì¤À¤È¡¤mergeMxBy¤¬¥×¥í¥°¥é¥à¥µ¥¤¥º¤Î¤³¤È¤òÃÎ¤é¤º¤ËºÇ½é¤Î1¸Ä¤Îkey¤ÎÈæ³Ó¤«¤é»Ï¤á¤Æ¤·¤Þ¤¦ ... ¤È»×¤Ã¤¿¤±¤É¼Â¤Ï¤½¤¦¤Ç¤â¤Ê¤¤¡¥mergeMxBy¤¬(Mx (_:ys))¤Î¤è¤¦¤ËÀèÆ¬¤òdrop¤¹¤ë¤Î¤¬¥Ý¥¤¥ó¥È¤Ç¡¤¤¿¤È¤¨¤Ð(map repEqClsBy xss) !! n¤ÏÀèÆ¬¤În¸ÄÊ¬¤¬(·ë²Ì¤È¤·¤Æ)drop¤µ¤ì¤ë¤³¤È¤Ë¤Ê¤ë¡¥--- x ¤ä¤Ã¤Ñ¥À¥á¡¥--- x Â¿Ê¬ÌäÂê¤Ï¡¤eqClsBy¤Ï¿¼¤µ£²°Ê¹ß¤â¿¼¤µ£±¤Ëdepend¤·¤Æ¤¤¤Æ¡¤¤½¤¦¤Ê¤ë¤È¥µ¥¤¥º£²°Ê¹ß¤Î¥×¥í¥°¥é¥à¤¬...¤ß¤¿¤¤¤Ê´¶¤¸+-- x これだと，mergeMxByがプログラムサイズのことを知らずに最初の1個のkeyの比較から始めてしまう ... と思ったけど実はそうでもない．mergeMxByが(Mx (_:ys))のように先頭をdropするのがポイントで，たとえば(map repEqClsBy xss) !! nは先頭のn個分が(結果として)dropされることになる．+-- x やっぱダメ．+-- x 多分問題は，eqClsByは深さ２以降も深さ１にdependしていて，そうなるとサイズ２以降のプログラムが...みたいな感じ sfilterRc op mx = trace "sfilter" $                      unscanlByListRc op $ repEqClsByRc op mx {-@@ -199,7 +199,7 @@ eqClsBy_naive :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)] eqClsBy_naive cmp (Mx xss) = Mx $ zipWith (\dep ys -> ys /// liftCompareBot dep cmp) (cnrnds cmp) $ scanl1 (++) xss -{- Â¿¾¯¸úÎ¨²½¤·¤è¤¦¤«¤È¤â»×¤Ã¤¿¤±¤É¡¤¤È¤ê¤¢¤¨¤º¤ÏËÜÅö¤Ënaive¤Ë¤ä¤ë+{- 多少効率化しようかとも思ったけど，とりあえずは本当にnaiveにやる eqClsBy_naive cmp mx =         scanl (mergeBy cmp) (eqClsByFstNs cmp mx)  scanlx cmp [a0,a1,...] = [a0, mergeBy @@ -214,21 +214,21 @@ cnrnds  tup = map (fcnrnd tup) [0..] tcnrnds tup = map (fcnrnd tup) [1..] --- repEqClsBy cmp = [([k]¤ÎºÇ½é¤Î1¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎÆ±ÃÍÎàÊ¬²ò¤ÎÂåÉ½¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î2¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎÆ±ÃÍÎàÊ¬²ò¤ÎÂåÉ½¸µ¤¿¤Á), ([k]¤ÎºÇ½é¤Î3¸Ä¤Î¤ß¤ò¸«¤¿¤È¤¤ÎÆ±ÃÍÎàÊ¬²ò¤ÎÂåÉ½¸µ¤¿¤Á), ....]+-- repEqClsBy cmp = [([k]の最初の1個のみを見たときの同値類分解の代表元たち), ([k]の最初の2個のみを見たときの同値類分解の代表元たち), ([k]の最初の3個のみを見たときの同値類分解の代表元たち), ....] repEqClsBy :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e) repEqClsBy cmp = trace "repEqClsBy" .                   fmap head . eqClsBy cmp--- eqClsBy¤Î·ë²Ì¤Î¿¼¤µnÈÖÌÜ¤Ë¤Ï¡¤[k]¤ÎºÇ½é¤În¸Ä¤òcmp¤ÇÈæ³Ó¤·¤¿¤È¤¤ÎÆ±ÃÍ´Ø·¸¤Ë¤è¤ëÆ±ÃÍÎàÊ¬²ò¤¬Æþ¤Ã¤Æ¤¤¤ë¡¥--- x ¿¼¤µ1¤Ç¥µ¥¤¥º1¤Ê¤ä¤Ä¤é¤òÆ±ÃÍÎàÊ¬²ò : ¿¼¤µ1¤Ç¤ÎÊ¬²ò·ë²Ì¤ò2Ê¸»úÌÜ¤ÇÆ±ÃÍÎàÊ¬²ò¤·¤¿¥ä¥Ä¤È¡¤¥µ¥¤¥º2¤Î¤ä¤Ä¤é¤ò2Ê¸»úÊ¬¸«¤ÆÆ±ÃÍÎàÊ¬²ò¤·¤¿¤ä¤Ä¤é¤ò¥Þ¡¼¥¸ : ¿¼¤µ2¤Ç¤ÎÊ¬²ò·ë²Ì¤ò3Ê¸»úÌÜ¤ÇÆ±ÃÍÎàÊ¬²ò¤·¤¿ÅÛ¤È¡¤....+-- eqClsByの結果の深さn番目には，[k]の最初のn個をcmpで比較したときの同値関係による同値類分解が入っている．+-- x 深さ1でサイズ1なやつらを同値類分解 : 深さ1での分解結果を2文字目で同値類分解したヤツと，サイズ2のやつらを2文字分見て同値類分解したやつらをマージ : 深さ2での分解結果を3文字目で同値類分解した奴と，.... eqClsBy :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)] eqClsBy cb@(cmp,opt) mx = Mx $                  scanl (\xs (n,ys) -> mergeBy (liftCompareBot n cb) (eqClsByNth cmp n xs) ys) ecb0 $ zip (tcnrnds cb) ecbs-{- scanl¤Î1¹Ô¤ÎÂå¤ï¤ê¤Ë¤³¤Ã¤Á¤ò»È¤Ã¤Æ¤¿¡¥+{- scanlの1行の代わりにこっちを使ってた．                  let result = ecb0 : zipWith3 (\n xs ys -> mergeBy (liftCompareBot n cmp) (eqClsByNth n xs) ys) (tail cnrnds) result ecbs                  in result -}     where Mx (ecb0:ecbs) = eqClsByFstNs cb mx--- n-2ÈÖÌÜ¤Îequivalence¤Ç¤Îquotient set¤ò¸µ¤Ë¡¤n-1ÈÖÌÜ¤Îequivalence¤ÇºÙÊ¬¡¥¤à¤·¤í¡¤refine¤È¤¤¤¦´Ø¿ô¤òÄêµÁ¤·¤¿Êý¤¬¤è¤¤?+-- n-2番目のequivalenceでのquotient setを元に，n-1番目のequivalenceで細分．むしろ，refineという関数を定義した方がよい? eqClsByNth :: (a->a->Ordering) -> Int -> [[([a],e)]] -> [[([a],e)]] eqClsByNth cmp n = concatMap ((/// (\ (xs,_) (ys,_) -> Just $ cmp (xs!!(n-1)) (ys!!(n-1))))) @@ -250,16 +250,16 @@  mergeBy :: (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]] mergeBy cmp = mergeWithByBot (++) (\x y -> head x `cmp` head y)--- ¤³¤ÎÊÕ(mergeBy)¤Î¥Í¡¼¥ß¥ó¥°¤â¤¤¤Þ¤¤¤Á+-- この辺(mergeBy)のネーミングもいまいち  {- mergeMxBy :: (k->k->Ordering) -> Int -> Matrix ([k],e) -> Matrix ([k],e) -> Matrix ([k],e) mergeMxBy op len (Mx ~(xs:xss)) (Mx yss) = Mx (xs : zipWith3 (\i xs ys -> mergeBy (\ (ks,_) (ls,_) -> liftCmp i op ks ls) i (filterEligibles i xs) (filterEligibles i ys)) [len..] xss yss)--- merge¤Ïtrie¤Ë¤ª¤±¤ëunionBy¤ß¤¿¤¤¤Ê´¶¤¸¡¥+-- mergeはtrieにおけるunionByみたいな感じ． mergeBy :: (k->k->Ordering) -> Int -> [k] -> [k] -> [k] mergeBy op len xs ys = foldl (insertBy (\x y -> op x y == EQ)) xs ys insertBy :: (k->k->Bool) -> [k] -> k -> [k]-insertBy op xs y = case filter (op y) xs of [] -> y:xs -- ÀèÆ¬¤ËµÕ½ç¤Ë²Ã¤¨¤ÆOK¤À¤Ã¤¿¤È¤Ï»×¤¦¤Î¤À¤¬¡¤°ì±þµ¤¤òÉÕ¤±¤ë+insertBy op xs y = case filter (op y) xs of [] -> y:xs -- 先頭に逆順に加えてOKだったとは思うのだが，一応気を付ける                                             _  -> xs -} @@ -279,7 +279,7 @@                              cumulative = scanl (mergeWithByBot const op) [] sorted                          in Mx $ zipWith (diffSortedByBot op) sorted cumulative     where op (k,_) (l,_) = cmpBot cmp k l-{- ¤³¤Ã¤Á¤ÎÄêµÁ¤À¤È¡¤sorted¤Ç¤Ï¤Ê¤¯cumulative¤«¤é[]:cumulative¤ò°ú¤¯¤Î¤Ç¡¤¤Á¤ç¤Ã¤ÈÈó¸úÎ¨+{- こっちの定義だと，sortedではなくcumulativeから[]:cumulativeを引くので，ちょっと非効率 ofilterMx cmp (Mx xss) = unscanlBy op $ Mx $ scanl1 (mergeWithBy const op) $ map (mergesortWithBy const op) xss     where op (k,_) (l,_) = cmp k l -}

MagicHaskeller/ClassifyDM.hs view

@@ -20,7 +20,7 @@ #endif import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot, mergesortWithByBotIO) import MagicHaskeller.PriorSubsts-import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot, cmpBot, cmpBotIO) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥+import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot, cmpBot, cmpBotIO) -- ofilterDB はこっちで定義されていてもいいようなもの．  import MagicHaskeller.Expression @@ -86,9 +86,9 @@                                                             (\ (k,_) (l,_) -> nthCompareBotIO (nrands $ opt cmn) d (op, opt cmn) k l)                                                             (map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae d, i)) $ unDB db d) --- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌÜ¤«¤ò·è¤á¤ë¤â¤Î¡¥--- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListÆ±ÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥--- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂÎ¤ò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃÊ¤Ë¥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥+-- depth bound(つまり，Int->[(a,Int)]における引数のInt)の代わりに，depth boundからの距離(つまり，Int->[(a,Int)]におけるInt->[(a,ここのInt)])を使ってnrndsの何番目かを決めるもの．+-- filterDMと違って，同じdepth boundでも違う乱数を使うので，filterList同様depthを跨いだfiltrationができず，結果はいまいち．+-- ただし，dynamicな関数自体をメモ化すれば，格段にメモにヒットしやすくなるはず． filterDMlite :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr filterDMlite cmn typ     = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of

MagicHaskeller/ClassifyTr.hs view

@@ -25,7 +25,7 @@     = case typeToRandomsOrdDM nrnds (tcl cmn) (rt cmn) typ of         Nothing         -> \x -> (undefined, undefined, x)         Just ([], op)   -> \x -> (undefined, undefined, mapDepth (mergesortWithByBot const (\(AE _ k) (AE _ l) -> cmpBot (op, opt cmn) k l)) x)-        Just (rndss,op) -> -- trace ("take 1 rndss = "++show (take 1 rndss)) $ -- nrndss¤òÉ½¼¨¤·¤è¤¦¤È¤¹¤ë¤Èbehaviour¤¬ÊÑ¤ï¤ë¡¥+        Just (rndss,op) -> -- trace ("take 1 rndss = "++show (take 1 rndss)) $ -- nrndssを表示しようとするとbehaviourが変わる．                            -- trace ("ty = "++show typ++" and take 10 nrands = "++show (take 10 $ nrands $ opt cmn)) $                            let finrndss = zipWith take nrnds rndss                                unsafeCmp ks ls = unsafeWithPTOOpt (opt cmn) (bagCmp op ks ls)@@ -60,16 +60,16 @@ mkForests cmp (Mx xss) = map (\xs -> trace ("before filtration"++ show (map snd xs)) $                                      mkForest cmp xs) xss -}-mkForest :: (k->k->Maybe Ordering) -> [(Stream k,r)] -> Forest (k,r) -- Stream k¤Ê¤Î¤Ç¡¤[(Stream k,r)]¤ò¤¢¤é¤«¤¸¤á¥½¡¼¥È¤Ç¤¤Ê¤¤¤³¤È¤ËÃí°Õ¡¥+mkForest :: (k->k->Maybe Ordering) -> [(Stream k,r)] -> Forest (k,r) -- Stream kなので，[(Stream k,r)]をあらかじめソートできないことに注意． mkForest cmp = map (\(k,ts@((_,r):_)) -> Tr (k, r) (mkForest cmp ts)) . mergesortWithByBot (\(k,xs) (_,ys) -> (k,xs++ys)) (\(k,_) (l,_) -> cmp k l) . map (\(k:ks, r) -> (k,[(ks,r)]))--- ¤â¤¦°ì¤Ä¤Î¼ÂÁõÊýË¡: ¤É¤Ã¤Á¤¬¸úÎ¨Åª¤«¤Ï? mkForest cmp [(ks,r)]¤Ï[mkTree cmp ks r]¤ß¤¿¤¤¤Ëspecialize¤·¤¿¤â¤Î¤òÍÑ°Õ¤·¤¿Êý¤¬¤¤¤¤¤«¤â¡¥+-- もう一つの実装方法: どっちが効率的かは? mkForest cmp [(ks,r)]は[mkTree cmp ks r]みたいにspecializeしたものを用意した方がいいかも． -- mkForest cmp = map (\(Tr k ts@(Tr (_,r) _ : _)) -> Tr (k, r) ts) . mergesortWithBy (\(Tr k xs) (Tr _ ys) -> Tr k (mergeForests xs ys)) (\(Tr (k,_) _) (Tr (l,_) _) -> cmp k l) . map (\(k:ks, r) -> (k, mkForest cmp [(ks,r)]))   accumulateForests :: (k->k->Maybe Ordering) -> Stream (Forest k) -> Stream (Forest k) accumulateForests cmp forests = cumulatives    where cumulatives = zipWith (mergeForests cmp) ([]:cumulatives) forests--- merge¤Ã¤Æ¤Î¤ÏmonoidÅª¤Ë¤Ïmappend¤Ê¥ï¥±+-- mergeってのはmonoid的にはmappendなワケ mergeForests :: (k->k->Maybe Ordering) -> Forest k -> Forest k -> Forest k mergeForests _   [] trs = trs mergeForests _   tls [] = tls@@ -96,7 +96,7 @@ flattenTr (Tr k f) = [k] `consMx` removeFirstOfFirst (msum $ map flattenTr f)  removeFirstOfFirst mx@(Mx ([]:xss))  = mx-removeFirstOfFirst (Mx ((_:xs):xss)) = Mx $ xs:xss -- ¤³¤ì¤¬Ä¹»Ò¤ò¼è¤ê½ü¤¯+removeFirstOfFirst (Mx ((_:xs):xss)) = Mx $ xs:xss -- これが長子を取り除く   {-

MagicHaskeller/CoreLang.lhs view

@@ -78,7 +78,7 @@     rnf (Lambda e) = rnf e     rnf (X i)      = rnf i     rnf (Tuple i)  = rnf i-    rnf (Primitive _) = () -- ºÇ¸å¤Î¥Ñ¥¿¡¼¥ó¤Ë¥Þ¥Ã¥Á¤¹¤ë¤Î¤Ç¤³¤ì¤ÏÍ×¤é¤Ê¤«¤Ã¤¿¤«¡¥+    rnf (Primitive _) = () -- 最後のパターンにマッチするのでこれは要らなかったか．     rnf (c :$ d)         = rnf c `seq` rnf d     rnf e                = () #endif@@ -93,14 +93,14 @@ isa bits Primitive{} = bits isa bits Context{}   = bits {- unused due to inefficiency-ceToInteger (Lambda e)    = ceToInteger e -- ·¿¤¬ÊÑ¤ï¤Ã¤Á¤ã¤¦¤Î¤ÇLambda¤ÏÌµ»ë¤Ç¤¤ë¤Ï¤º¡¥...  ¤È¤¤¤¤¤Ä¤Ä¼«¿®Ìµ¡¥July 24, 2008¤Înotes¤ò»²¾È. ¤Þ¡¤hash¤Ë¤Ï»È¤¨¤ë¤È¤¤¤¦ÄøÅÙ¤Î¤Ä¤â¤ê¡¥+ceToInteger (Lambda e)    = ceToInteger e -- 型が変わっちゃうのでLambdaは無視できるはず．...  といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり． ceToInteger (f :$ e)      = 3 * (ceToInteger f `interleave` ceToInteger e) ceToInteger (X n)         = 3 * toInteger n + 1 ceToInteger (Primitive n _) = 3 * toInteger n + 2  0 `interleave` 0 = 0 i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2)--- Integer¤Ç¤Ê¤¯Int¤ò»È¤¦¾ì¹ç¡¤»»½Ñ±¦¥·¥Õ¥ÈshiftR¤Ç¤Ê¤¯ÏÀÍý±¦¥·¥Õ¥È¤ò»È¤¦É¬Í×¤¬¤¢¤ë...¤Î¤Ï¤¤¤¤¤±¤É¡¤¤Ê¤¼¥é¥¤¥Ö¥é¥ê¤ËÏÀÍý±¦¥·¥Õ¥È¤¬¤Ê¤¤?+-- IntegerでなくIntを使う場合，算術右シフトshiftRでなく論理右シフトを使う必要がある...のはいいけど，なぜライブラリに論理右シフトがない? logShiftR1 n = (n `clearBit` 0) `rotateR` 1  -} #if __GLASGOW_HASKELL__ < 710@@ -116,7 +116,7 @@                                                               c  -> c     compare (AppE _ _) _        = LT -    compare a b = show a `compare` show b -- Ä¶ÃÙ¤½¤¦....+    compare a b = show a `compare` show b -- 超遅そう.... #endif instance Read Exp where     readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)]@@ -130,7 +130,7 @@ stripByd_ ('-':'-':'#':name) = dropWhile (=='#') name stripByd_ name = name --- x Âè1°ú¿ô¤Îpl¤ÏArray Con String¤Ê¤ó¤À¤±¤É¡¤¤â¤¦Á´ÉôPrimitive¤ò»È¤¦¤³¤È¤Ë¤Ê¤Ã¤¿¤Î¤ÇÉÔÍ×¡¥+-- x 第1引数のplはArray Con Stringなんだけど，もう全部Primitiveを使うことになったので不要． -- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp exprToTHExp, exprToTHExpLite :: VarLib -> CoreExpr -> Exp exprToTHExp vl e = exprToTHExp' True vl $ lightBeta e@@ -149,8 +149,8 @@               where var  = mkName ['f',chr (fdep+1)]                     pvar | not pretty || 0 `funOccursIn` e = VarP var                          | otherwise                        = WildP-          x2hsx dep fdep (X n)            = VarE (mkName [chr $ fromIntegral (dep - n :: Int8)])         -- X n¤ÏX 0, X 1, ....-          x2hsx dep fdep (FunX n)            = VarE (mkName ['f', chr $ fromIntegral (fdep - n)])         -- X n¤ÏX 0, X 1, ....+          x2hsx dep fdep (X n)            = VarE (mkName [chr $ fromIntegral (dep - n :: Int8)])         -- X nはX 0, X 1, ....+          x2hsx dep fdep (FunX n)            = VarE (mkName ['f', chr $ fromIntegral (fdep - n)])         -- X nはX 0, X 1, .... --          x2hsx _   (Qualified con)  = VarE (mkName (pl ! con))           x2hsx _   _    (Primitive n)  = x2hsxPrim n           x2hsx _   _    (PrimCon   n)  = x2hsxPrim n@@ -168,20 +168,20 @@           x2hsx dep fdep (e0 :$ e1) | hdIsCxt e1 = x2hsx dep fdep e0                                     | otherwise  = x2hsx dep fdep e0 `AppE` x2hsx dep fdep e1           x2hsx dep fdep (Case ce ts)     = CaseE (x2hsx dep fdep ce) (map (tsToMatch dep fdep) ts)---          x2hsx dep fdep (Fix ce n is)    = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is)          -- let¤ò»È¤Ã¤Æ½ñ¤¤¤¿Êý¤¬¤¤¤¤´¶¤¸¤Ë¤Ê¤ë¡¥+--          x2hsx dep fdep (Fix ce n is)    = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is)          -- letを使って書いた方がいい感じになる．           x2hsx dep fdep (Fix ce n is)               = case x2hsx dep fdep (FunLambda (napply (fromIntegral n) Lambda ce)) of                   LamE (WildP:ps) e -> foldl AppE (LamE ps e) $ map (x2hsx dep fdep . X) is  --- let ¤Î¤¢¤È case¤¬¤¢¤ë¾ì¹ç¤Ë¤µ¤é¤Ërefactor¤·¤Æ¤¿¤Î¤À¤¬¡¤+-- let のあと caseがある場合にさらにrefactorしてたのだが， -- \a -> let fa (b@0) = 0 --           fa (b@succc) | succc > 0 = GHC.Enum.succ (GHC.Enum.succ (GHC.Enum.succ (fa c))) --                  where c = succc - 1 --        in fa a--- ¤ß¤¿¤¤¤Ê¤Î¤¬¤Ç¤¤Æ¤á¤ó¤É¤¯¤µ¤¤¡¥+-- みたいなのができてめんどくさい． --- ¤Æ¤æ¡¼¤«¡¤pretty print¤·¤¹¤®¤ë¤È¡¤ExecuteAPI¤¹¤ë¤È¤µÕ¤ËÃÙ¤½¤¦¡¥+-- てゆーか，pretty printしすぎると，ExecuteAPIするとき逆に遅そう．                   LamE (VarP name : ps) (CaseE (VarE n) ms)                       | VarP n `elem` ps -> LetE [FunD name (map (\(Match p b decls) -> Clause (map (replacePat n p) ps) b decls) ms)]                                                   (foldl AppE (VarE name) $ map (x2hsx dep fdep . X) is)@@ -244,7 +244,7 @@                             mkPat (':':_) [pv1,pv2] = InfixP pv1 (mkName nameb) pv2                             mkPat nmb     pvs       = ConP (mkName nameb) pvs                   VarE name | nameBase name == "succ" ->-                                case x2hsx (dep+1) fdep expr of -- ¤³¤³¤Îcase¤ÏºÇ½éx2hsx dep $ Lambda expr¤Ë¤·¤Æ¤¤¤¿¤Î¤À¤¬¡¤WildP¤Ë¤Ê¤Ã¤Æ¤·¤Þ¤¦¤Èguard¤Ç¤¤Ê¤¯¤Ê¤ë¤·¡¤¤«¤È¤¤¤Ã¤ÆCase¤ÎÆâÂ¦¤ÇWildP¤Ø¤ÎÃÖ´¹¤ò¤ä¤é¤Ê¤¤¤È¤¹¤ë¤È¤ß¤Ë¤¯¤¤¤·¡¤¤³¤Î¥Ñ¥¿¡¼¥ó¤À¤±WildP¤ò»ß¤á¤ë¤¯¤é¤¤¤Ê¤éLambda¤ÎÊ¬¤òÅ¸³«¤·¤¿Êý¤¬Áá¤¤¤ä¡¤¤Ã¤Æ¤³¤È¤Ç¡¥+                                case x2hsx (dep+1) fdep expr of -- ここのcaseは最初x2hsx dep $ Lambda exprにしていたのだが，WildPになってしまうとguardできなくなるし，かといってCaseの内側でWildPへの置換をやらないとするとみにくいし，このパターンだけWildPを止めるくらいならLambdaの分を展開した方が早いや，ってことで．                                   ex -> Match (VarP succn) (GuardedB [(NormalG (InfixE (Just $ VarE succn) (VarE $ mkName ">") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB (InfixE (Just $ VarE succn) (VarE $ mkName "-") (Just $ LitE (IntegerL 1)))) []]                                                     where str   = [chr $ fromIntegral (dep+1)]                                                           name  = mkName str

MagicHaskeller/DebMT.lhs view

@@ -64,7 +64,7 @@       funTree = if k==0 then mkMT tcl (\t0 -> mkMT tcl (\t1 -> f (t0 :-> t1))) else error "mkMT': the kind of functions must always be *" mkMTIO :: TyConLib -> (Type -> IO a) -> IO (MapType a) mkMTIO tcl f = mkMTIO' tcl 0 f-mkMTIO' :: TyConLib -> Kind -> (Type -> IO a) -> IO (MapType a) -- IO¤Î¤È¤³¤í¤ÏMonad m => m¤Ç¤è¤µ¤½¤¦¡¥¼ÂºÝ¤Ë¤ÏMonadIO¤Ç¤ä¤ë¤«¤â¡¥+mkMTIO' :: TyConLib -> Kind -> (Type -> IO a) -> IO (MapType a) -- IOのところはMonad m => mでよさそう．実際にはMonadIOでやるかも． mkMTIO' tcl k f = unsafeInterleaveIO $ liftM5 MT tvTree tcTree genTree taTree funTree where       tcs = snd tcl ! k       lazyf = unsafeInterleaveIO . f@@ -73,7 +73,7 @@       genTree = interleaveActions $ map (f . TC) [-1,-2..]       taTree  = mkMTIO' tcl (k+1) (\t0 -> mkMTIO tcl  (\t1 -> lazyf (TA t0 t1)))       funTree = mkMTIO tcl $ if k==0 then (\t0 -> mkMTIO tcl (\t1 -> lazyf (t0 :-> t1))) else error "mkMTIO': the kind of functions must always be *"---      funTree = if k==0 then mkMTIO tcl (\t0 -> mkMTIO tcl (\t1 -> lazyf (t0 :-> t1))) else error "mkMTIO': the kind of functions must always be *" -- ¤³¤ì¤Ï´Ö°ã¤¤¡¥°ìÈÖ³°Â¦¤ËunsafeInterleaveIO¤¬¤Ê¤¤¤È¡¤kind¤¬0¤Ç¤Ê¤¤invalid¤Ê´Ø¿ô¤Î·¿¤âºî¤í¤¦¤È¤·¤Æ¤·¤Þ¤¦¡¥+--      funTree = if k==0 then mkMTIO tcl (\t0 -> mkMTIO tcl (\t1 -> lazyf (t0 :-> t1))) else error "mkMTIO': the kind of functions must always be *" -- これは間違い．一番外側にunsafeInterleaveIOがないと，kindが0でないinvalidな関数の型も作ろうとしてしまう．  -- I do not add unsafe because I do not understand in what sense unsafeInterleaveIO is unsafe! interleaveActions :: [IO a] -> IO [a]

MagicHaskeller/Execute.hs view

@@ -46,8 +46,8 @@ v `isFreeIn` _        = True  -- checks if there is a free variable. usually used after unDeBruijn is applied and before tiExpression is applied. --- $B$H;W$C$?$N$@$,!$(BtiExpression$B$,FbIt$G(BunDeBruijn$B$r8F$s$G$k!%(B--- $B$d$C$Q(BtiExpression$B$G(Bfail$B;H$C$F%a%C%;!<%81?$s$@J}$,$h$$!)(B+-- と思ったのだが，tiExpressionが内部でunDeBruijnを呼んでる．+-- やっぱtiExpressionでfail使ってメッセージ運んだ方がよい？ freeVar :: CoreExpr -> Maybe String freeVar (Lambda e)        = freeVar e freeVar (e0 :$ e1)        = freeVar e0 `mplus` freeVar e1

MagicHaskeller/ExecuteAPI610.hs view

@@ -8,22 +8,22 @@ import GHC import GHC.Exts import GHC.Paths(libdir) -- as instructed in http://haskell.org/haskellwiki/GHC/As_a_library-import DynFlags         -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) ¤Ïexport¤µ¤ì¤Æ¤¤¤Ê¤¤¤é¤·¤¤.+import DynFlags         -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) はexportされていないらしい. import SrcLoc           (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, noLoc)  -- import MyCorePrep( corePrepExpr )-import CorePrep(corePrepExpr) -- ¥³¥ó¥Ñ¥¤¥ë¤¬ÄÌ¤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë+import CorePrep(corePrepExpr) -- コンパイルが通らないのでオリジナルにしてみる  import FastString import ByteCodeGen      ( coreExprToBCOs )  -- import MyLink                -- ( HValue, linkExpr, initDynLinker )-import Linker -- ¥³¥ó¥Ñ¥¤¥ë¤¬ÄÌ¤é¤Ê¤¤¤Î¤Ç¥ª¥ê¥¸¥Ê¥ë¤Ë¤·¤Æ¤ß¤ë+import Linker -- コンパイルが通らないのでオリジナルにしてみる  -- import Flattening import HscTypes        -- ( HscEnv(..), Session(..), withSession, InteractiveContext(..), mkTypeEnv ) -- also import instance MonadIO Ghc import SimplCore--- import SimplOnce -- ¥³¥ó¥Ñ¥¤¥ë¤¬ÄÌ¤é¤Ê¤¤¤Î¤Ç¥³¥á¥ó¥È¥¢¥¦¥È+-- import SimplOnce -- コンパイルが通らないのでコメントアウト import VarEnv           ( emptyTidyEnv ) import CoreSyn          ( CoreExpr, Expr(..), Bind(..) )     -- compiler/coreSyn/CoreSyn.lhs import CoreTidy         ( tidyExpr )@@ -31,7 +31,7 @@  import Parser           (parseStmt) import Lexer-import TcRnDriver        ( tcRnStmt, tcRnExpr, tcRnType ) +import TcRnDriver        ( tcRnStmt, tcRnExpr, tcRnType ) import Desugar          (deSugarExpr) #if __GLASGOW_HASKELL__ < 708 import PrelNames        ( iNTERACTIVE )@@ -76,7 +76,7 @@ import HsUtils import HsExpr --- ºÇ¸å¤ÎCoreExpr ---> CoreExpr¤ÇÍ×¤ë¤â¤Î¡¥+-- 最後のCoreExpr ---> CoreExprで要るもの． import IdInfo import Data.Char(ord,chr) import qualified Data.Map as Map@@ -102,8 +102,8 @@ loadObj fss = fmap unsafeExecuteAPI $ prepareAPI [] fss  -- Just follow http://haskell.org/haskellwiki/GHC/As_a_library--- ÌäÂê¤Ï¡¤¤¹¤Ç¤ËÆÉ¤Þ¤ì¤Æ¤¤¤ëmodule¤Ï¤É¤¦¤¹¤ë¤«¤Ã¤Æ¤³¤È¤À¤±¤É¡¤:load¥³¥Þ¥ó¥ÉÆ±ÍÍºÆÆÉ¤ß¹þ¤ß--- addNonPackageTarget¤Ã¤Æ¤Î¤òÄêµÁ¤·¤¿¤Î¤Ç¡¤Ê¬¤±¤ëÉ¬Í×¤Ï¤Ê¤¯¤Ê¤Ã¤¿¤Ï¤º¡¥+-- 問題は，すでに読まれているmoduleはどうするかってことだけど，:loadコマンド同様再読み込み+-- addNonPackageTargetってのを定義したので，分ける必要はなくなったはず． prepareAPI :: [FilePath] -- ^ modules to be loaded (except package modules)            -> [FilePath] -- ^ visible modules (including package modules)            -> IO HscEnv@@ -129,18 +129,18 @@            dfs     <- getSessionDynFlags --          when (flags dfs /= flags defaultDynFlags) $ error "flags are different"-          let newf = dfs{ -- opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs,           -- defaultDynFlags¤Î¥½¡¼¥¹¤¬·ë¹½»²¹Í¤Ë¤Ê¤Ã¤¿¤ê¡¥+          let newf = dfs{ -- opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs,           -- defaultDynFlagsのソースが結構参考になったり．                          packageFlags = [ packageNameToFlag "ghc", packageNameToFlag "old-time", packageNameToFlag "ghc-paths" ] -- , packageNameToFlag "MagicHaskeller" ]                          {-                          flags = Opt_TemplateHaskell  : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec :                                  Opt_MagicHash :                                  Opt_RankNTypes :                                  filter (/=Opt_MonomorphismRestriction) (flags dfs) -}-                        } -- Was: Opt_TH   --  ¤Æ¤æ¡¼¤«¡¤LibTH¤ò¤³¤³¤ÇÆÉ¤à¤Ë¤Ï¤¤¤í¤ó¤Ê¥Õ¥é¥°¤¬....+                        } -- Was: Opt_TH   --  てゆーか，LibTHをここで読むにはいろんなフラグが....           setSessionDynFlags newf   -- result abandoned-          -- ¥½¡¼¥¹¤Ë¤è¤ë¤È·ë²Ì¤ÏDynamic linking¤Î»þ¤ËÉ¬Í×¤Ã¤Æ¤³¤È¤À¤±¤É¡¤¤Þ¡¤´ðËÜÅª¤Ë¤ÏDynamic linking¤Ïunsupported¤Ã¤Æ¤³¤È¤«¡¥+          -- ソースによると結果はDynamic linkingの時に必要ってことだけど，ま，基本的にはDynamic linkingはunsupportedってことか．           -- http://hackage.haskell.org/trac/ghc/wiki/DynamicLinking-          -- ...°ã¤¦¡¥¤½¤Îdynamic linking¤Ç¤Ï¤Ê¤¤¡¥+          -- ...違う．そのdynamic linkingではない．            -- liftIO $ hPutStrLn stderr "loading modules" -- This IS necessary.           ts <- mapM (\fs -> guessTarget fs Nothing) loadfss@@ -183,7 +183,7 @@ addNonPackageTarget target@(Target targetid _)     = catchDyn (addTarget target >> depanal [] False >> return ())                (\str -> if "is a package module" `isSuffixOf` str then removeTarget targetid else throwDyn str)--- depanal¤¬Nothing¤òÊÖ¤¹¾ì¹ç¡¤·ë¶É¸å¤Îload¤¬fail¤¹¤ëÌõ¤À¤¬¡¤ÌÌÅÝ¤Ê¤Î¤Ç¤³¤ÎÃÊ³¬¤Ç¤ÏÊüÃÖ¥×¥ì¥¤¤Ã¤Æ¤³¤È¤Ç¡¥+-- depanalがNothingを返す場合，結局後のloadがfailする訳だが，面倒なのでこの段階では放置プレイってことで． -}  -- At least I should use a customized version of toString....@@ -197,7 +197,7 @@  compileCoreExpr ::  HscEnv -> TH.Exp -> IO CoreSyn.CoreExpr  compileCoreExpr hscEnv the-    = -- defaultErrorHandler defaultDynFlags $ -- thread killed ¤òÉ½¼¨¤µ¤»¤¿¤¤¾ì¹ç¤Ï¤³¤Ã¤Á¡¥+    = -- defaultErrorHandler defaultDynFlags $ -- thread killed を表示させたい場合はこっち． {-        do res <- compileExpr session $ TH.pprint $ CoreLang.exprToTHExp cece           case res of Nothing -> hPutStrLn stderr "Could not execute" >> error "could not execute"@@ -212,7 +212,7 @@                       Just ([i ], ce) -> return ce  --- unwrapCore, unwrapCore' ¤ÎÎ¾Êý¤¬Àµ¤·¤¯Æ°¤¯¡¥unwrapCore¤Ïghc6.8¤ÇÆ°¤¤¤Æ¤¤¤¿¤Î¤ò»ý¤Ã¤Æ¤¤¿¤â¤Î¤Ç¡¤compileExprHscMain¤ÎÊý¤ò¥³¥á¥ó¥È¥¢¥¦¥È¤·¤ÆrunCoreExpr¤Ë¤¹¤ë¤È¿§¡¹¤Ï¤·¤ç¤ëÂå¤ï¤ê¤ËÀµ¤·¤¯Æ°¤«¤Ê¤¤¡¥+-- unwrapCore, unwrapCore' の両方が正しく動く．unwrapCoreはghc6.8で動いていたのを持ってきたもので，compileExprHscMainの方をコメントアウトしてrunCoreExprにすると色々はしょる代わりに正しく動かない． unwrapCore :: HscEnv -> CoreSyn.CoreExpr -> IO a unwrapCore hscEnv ce =                  do -- iohvs <- runCoreExpr hscEnv ce -- (removeIdInfo ce)                                            iohvs <- unsafeCoerce# $ compileExprHscMain hscEnv ce@@ -233,9 +233,9 @@       do          let dfs = hsc_dflags hscEnv #if __GLASGOW_HASKELL__ >= 706-         pe <- corePrepExpr dfs hscEnv ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤±+         pe <- corePrepExpr dfs hscEnv ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ #else-         pe <- corePrepExpr dfs ce -- runPrepedCoreExpr¤È¤Î°ã¤¤¤Ï¤³¤ÎcorePrepExpr¤¬¤¢¤ë¤«¤É¤¦¤«¤À¤±+         pe <- corePrepExpr dfs ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ #endif          bcos <- -- repeatIO 10 $                  ce2b dfs pe@@ -318,7 +318,7 @@ #if __GLASGOW_HASKELL__ >= 706                     Left  msg -> error $ showSDoc (hsc_dflags hscEnv) msg #else-                    Left  msg -> error $ showSDoc msg +                    Left  msg -> error $ showSDoc msg #endif                     Right expr -> expr @@ -399,24 +399,24 @@ -- if necessary. TyConLib can be undefined here. compileVar :: HscEnv -> (a, TH.Exp, TH.Type) -> IO CoreSyn.CoreExpr compileVar hscEnv (_, the, ty)-    = do csce <- compileCoreExpr hscEnv the -- ¤³¤ì¤À¤È¡¤[| (==)::Char->Char->Bool |]¤ß¤¿¤¤¤Ê¾ì¹ç¤Ëthe¤¬Ã±¤ËVarE '(==)¤Ë¤Ê¤Ã¤Æ¤¦¤Þ¤¯¤¤¤«¤Ê¤¤¡¥(ad hoc¤Êtyvar¤¬instantiate¤µ¤ì¤Ê¤¤)+    = do csce <- compileCoreExpr hscEnv the -- これだと，[| (==)::Char->Char->Bool |]みたいな場合にtheが単にVarE '(==)になってうまくいかない．(ad hocなtyvarがinstantiateされない)          -- Just (_,csce) <- strToCore session ("let __compileExpr = ("++TH.pprint the ++")::"++TH.pprint (unforall ty))          let unr = unwrap csce          putStrLn ("csce = "++show unr)          case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv                                               simplifyExpr dfs $ foldl CoreSyn.App unr $ replicate (length tvs) $ CoreSyn.Type anyPrimTy-                                              -- CorePrep ¤Ï ÉÔÍ×¤Ê¤Ï¤º¤Ç¤Ï¤¢¤ë¤¬¡¤¤É¤¦¤¹¤ë¤è¡©+                                              -- CorePrep は 不要なはずではあるが，どうするよ？                     _                   -> return unr unwrap (Let (Rec ((_,e):_)) _) = e--- unwrap (Let (Rec [(_,e)]) _) = e -- ¤³¤Ã¤Á¤À¤È¤Ê¤¼¤«¥À¥á¤Ç¡¤¤½¤ÎÊÕ¤Ë¥Ð¥°¤Î¤Ë¤Û¤Ò¤¬....+-- unwrap (Let (Rec [(_,e)]) _) = e -- こっちだとなぜかダメで，その辺にバグのにほひが.... unwrap st                    = error (show st) unforall (TH.ForallT _ _ t) = t unforall t = t -type GlobalMap = Map.Map String CoreSyn.CoreExpr -- String¤ÎÂå¤ï¤ê¤ËTH.Name¤Ê¤É¤Ë¤·¤è¤¦¤È¤¹¤ë¤È¡¤¤Á¤ã¤ó¤Èequivalence¤¬»×¤¤ÄÌ¤ê¤Î·ë²Ì¤Ë¤Ê¤Ã¤Æ¤¯¤ì¤Ê¤¤¡¥¡¥+type GlobalMap = Map.Map String CoreSyn.CoreExpr -- Stringの代わりにTH.Nameなどにしようとすると，ちゃんとequivalenceが思い通りの結果になってくれない．． mkGlobalMap :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalMap--- ¤Æ¤æ¡¼¤«¡¤CoreLang.CoreExpr¤ÎPrimitive¤¬CoreSyn.CoreExpr¤Î¾ðÊó¤ò»ý¤Ä¤Î¤¬Â®¤¤¡¥--- data CoreExpr a = ... ¤ß¤¿¤¤¤Ë¤·¤Æ¡¤CoreExpr CoreSyn.CoreExpr¤ß¤¿¤¤¤Ë»È¤¦¡¥+-- てゆーか，CoreLang.CoreExprのPrimitiveがCoreSyn.CoreExprの情報を持つのが速い．+-- data CoreExpr a = ... みたいにして，CoreExpr CoreSyn.CoreExprみたいに使う． mkGlobalMap hscEnv tups =  do ces <- mapM (compileVar hscEnv) tups                               return $ Map.fromList $ zip (map (\(_,b,_) -> thToBaseString b) tups) ces @@ -426,7 +426,7 @@ linkDeps :: Session -> [Module] -> IO Bool linkDeps session mods =  -¤Æ¤æ¡¼¤«ºÇ½é¤Ë"([],(:),list_para,lines,take)"¤ß¤¿¤¤¤Ê¤Î¤òcompileExpr¤·¤Æ¤·¤Þ¤¨¤Ðprelink¤µ¤ì¤ë¤Î¤Ç¤Ï¡©+てゆーか最初に"([],(:),list_para,lines,take)"みたいなのをcompileExprしてしまえばprelinkされるのでは？   -- obtain the set of modules required to be linked@@ -458,8 +458,8 @@           ctc pvs (e0 `TH.AppE` e1)       = ctc pvs e0 `CoreSyn.App` ctc pvs e1           ctc pvs (InfixE (Just e0) e (Just e1)) = lup e `CoreSyn.App` ctc pvs e0 `CoreSyn.App` ctc pvs e1            ctc pvs (TH.VarE name) | VarP name `elem` pvs = CoreSyn.Var $ mkStrVar $ show name-          -- VarE¤Î¾ì¹ç¡¤lambda bound¤Î¾ì¹ç¤È¡¤global¤Î¾ì¹ç¤È¤Ç°·¤¤¤¬°Û¤Ê¤ë¡¥-          -- ¥¹¥³¡¼¥×¤ò¤Þ¤¸¤á¤Ë¹Í¤¨¤ë¤È¡¤lambda bound¤«¤É¤¦¤«¤ò¥Á¥§¥Ã¥¯¤·¤Æ¤«¤églobal¤Ë¤¢¤ë¤«¤É¤¦¤«¤ò¤ß¤ë¤³¤È¤Ë¤Ê¤ë¡¥ +          -- VarEの場合，lambda boundの場合と，globalの場合とで扱いが異なる．+          -- スコープをまじめに考えると，lambda boundかどうかをチェックしてからglobalにあるかどうかをみることになる．            ctc pvs e                       = lup e           lup e = case Map.lookup (thToBaseString e) gm of Nothing   -> error (show e ++ ", i.e.,\n" ++ TH.pprint e ++ " : could not convert to CoreSyn.CoreExpr")                                                            Just csce -> csce@@ -487,9 +487,9 @@   es = map mkIntVar [ord 'e'..]-as = map mkIntVar [128..] -- ÌµÍý¤¬¤¢¤ë?+as = map mkIntVar [128..] -- 無理がある? xs = map mkIntVar [192..]-hd = mkIntVar (ord 'a')   -- ¤³¤ì¤Ï°ú¿ô¤Ë¤·¤Æ¤âÎÉ¤¤+hd = mkIntVar (ord 'a')   -- これは引数にしても良い  mkTV :: Int -> Types.Type mkTV = Types.TV@@ -498,13 +498,13 @@ tvr  = mkTV 0  -- ({} \ hd e1..em a1..an -> {hd e1..em a1..an} let x1 = {e1 a1..an} e1 a1..an in {hd x1 e2..em a1..an} let x2 = {e2 a1..an} e2 a1..an in .. {hd x1..xm-1 em a1..an} let xm = {em a1..an} em a1..an in {hd x1..xm} hd x1..xm--- ¤Æ¤«¡¤°ìÈÖ¾å¤¬emptyVarSet¤Ç¤¢¤ë¤³¤È¤ò½ü¤±¤Ð¡¤¤¢¤È¤Ïundefined¤Ç¤¤¤¤¤Ï¤º¡¥... ¤È»×¤Ã¤¿¤±¤É¡¤schemeE¤ÎÄêµÁ¤ò¸«¤¿´¶¤¸let bindings¤Î±¦ÊÕ¤Î°ìÈÖ³°Â¦¤Ë´Ø¤·¤Æ¤ÏÉ¬Í×¤ß¤¿¤¤¡¥see notes on Aug. 12, 2008+-- てか，一番上がemptyVarSetであることを除けば，あとはundefinedでいいはず．... と思ったけど，schemeEの定義を見た感じlet bindingsの右辺の一番外側に関しては必要みたい．see notes on Aug. 12, 2008 -- ({} \ hd e1..em a1..an -> let x1 = {e1 a1..an} e1 a1..an in let x2 = {e2 a1..an} e2 a1..an in .. let xm = {em a1..an} em a1..an in hd x1..xm--- ¤È¤¤¤¦ÄøÅÙ¤Î¾ðÊó¤¬¤¢¤ì¤Ð½½Ê¬¡¥+-- という程度の情報があれば十分．  -- (\hd e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in hd x1..xm) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r hdmnPreped :: Int -> Int -> CoreSyn.CoreExpr-hdmnPreped m 0 = hdmn m 0 -- Í×¤Ïid¤òÀ¸À®¤¹¤ë¤Ã¤Æ¤³¤È¡¥+hdmnPreped m 0 = hdmn m 0 -- 要はidを生成するってこと． hdmnPreped m n = lambdas $ lets $ foldl CoreSyn.App (CoreSyn.Var hd) (map CoreSyn.Var mxs)     where        mes = take m es@@ -514,7 +514,7 @@        lets = flip (foldr CoreSyn.Let) binds             where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes                      where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas--- CorePrep Á°¤Î¤â¤Î¤òÀ¸À®¤¹¤ë¾ì¹ç+-- CorePrep 前のものを生成する場合 -- (\hd e1..em a1..an -> hd (e1 a1..an) .. (em a1..an)) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r hdmn m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var hd) $ map appa1an mes  where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas@@ -532,7 +532,7 @@ -- (\e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in ai x1 .. xm) -- more exactly, not ai but ai-1 because (!!) counts starting 0 --   :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> --       a1->..->(r1->..->rm->r)->..->an -> r--- aimnPreped i m 0 = aimn i m 0 -- ¤³¤ì¤Ï¤¢¤ê¤¨¤Ê¤¤¥±¡¼¥¹+-- aimnPreped i m 0 = aimn i m 0 -- これはありえないケース aimnPreped i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) (map CoreSyn.Var mxs)  where mes = take m es        mxs = take m xs@@ -541,7 +541,7 @@        lets = flip (foldr CoreSyn.Let) binds             where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes                      where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas--- CorePrepÁ°¤Î¤â¤Î¤òÀ¸À®¤¹¤ë¾ì¹ç+-- CorePrep前のものを生成する場合 -- (\e1..em a1..an -> ai (e1 a1..an) .. (em a1..an)) -- more exactly, not ai but ai-1 because (!!) counts starting 0 --   :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> --       a1->..->(r1->..->rm->r)->..->an -> r@@ -555,12 +555,12 @@ aimnty i m n = foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs)     where hdty = foldr (Types.:->) tvr mrs           mrs  = take m tvrs-          nas  = case splitAt i tvas of (tk,_:dr) -> tk ++ hdty : take (n-i-1) dr -- hdmnty¤È¤Î°ã¤¤¤Ï¤³¤³¤À¤±+          nas  = case splitAt i tvas of (tk,_:dr) -> tk ++ hdty : take (n-i-1) dr -- hdmntyとの違いはここだけ  mkHdmn :: HscEnv -> Int -> Int -> IO Dynamic mkHdmn hscEnv m n =  do let ce = hdmn m n                         val <- runCoreExpr hscEnv ce-                        return $ unsafeToDyn undefined (hdmnty m n) val undefined -- (CoreLang.exprToTHExp undefined ce) CoreLang¤Ç¤Ï¤Ê¤¯¤ÆCoreSyn¤«¤é+                        return $ unsafeToDyn undefined (hdmnty m n) val undefined -- (CoreLang.exprToTHExp undefined ce) CoreLangではなくてCoreSynから mkAimn :: HscEnv -> Int -> Int -> Int -> IO Dynamic mkAimn hscEnv i m n =  do let ce = aimn i m n                           val <- runCoreExpr hscEnv ce@@ -568,7 +568,7 @@ #endif -- ifdef GHC6 --- ¤³¤Ã¤«¤é¥×¥í¥Õ¥¡¥¤¥ëÍÑ+-- こっからプロファイル用   repeatN  n f x = force $ map f $ replicate n x

MagicHaskeller/FakeDynamic.hs view

@@ -63,10 +63,10 @@ fromPD = Dynamic  .  PD.unsafeFromDyn  --- °Ê²¼¤ÏMyDynamic¤«¤é¤È¤Ã¤Æ¤¤¿¤â¤Î¤Ç¡¤PolyDynamic¤Ë¤¢¤ë¤Î¤ÈÁ´¤¯Æ±¤¸¡¥+-- 以下はMyDynamicからとってきたもので，PolyDynamicにあるのと全く同じ． {- $(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |])-¤Î¤è¤¦¤Ë¤Ç¤¤ë¤è¤¦¤Ë¤¹¤ë¡¥CLEAN¤Îdynamic¤ß¤¿¤¤¤Ê´¶¤¸¡¥+のようにできるようにする．CLEANのdynamicみたいな感じ． -} dynamic :: ExpQ -> ExpQ -> ExpQ dynamic eqtcl eq = eq >>= p' eqtcl

MagicHaskeller/IOGenerator.hs view

@@ -76,7 +76,7 @@        -> Int        -> ShownIOPair        -> String--- predicate¤Èinputs¤Èoutput¤¬¤¢¤ì¤Ð¤è¤¤¡¥CGIÂ¦¤Ç¤Ï¡¤  '(':predicate++") && f "++inputs++" == "++output  ¤òpredicate¤È¤·¤Æ¼Â¹Ô+-- predicateとinputsとoutputがあればよい．CGI側では，  '(':predicate++") && f "++inputs++" == "++output  をpredicateとして実行 mkForm begin boxSize (args,ret)     = begin ++ concatMap escapeQuote (showsInputs args "") ++ "'> <INPUT TYPE=TEXT NAME='output' VALUE='"++concatMap escapeQuote ret ++ "' SIZE="++show boxSize ++"> <INPUT TYPE=SUBMIT VALUE='Narrow search'> </FORM>" showsInputs args = \s -> foldr (\arg str -> ' ' : arg id str) s args@@ -125,7 +125,7 @@     generateIOPairs f = [ (const (shows a) : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ "" : "12345" : "Abc\nd Ef" : take 2 arbitraries,                                                   (args, ret) <- generateIOPairs (f a) ] {----------------------------------------------------------------------- Do not use these in order to deal with types like [Int->Int]->Int.-    -- ¤¿¤À¡¢¥³¥á¥ó¥È¥¢¥¦¥È¤¹¤ë¤È¡¢[Int]¤È¤«¤Ç¤âeverythingF¤ò»È¤¦¤¿¤á´ÊÌó¤µ¤ì¤Æ¤¤¤Ê¤¤·Á¤ÇÉ½¼¨¤µ¤ì¤Æ¤·¤Þ¤¦¤Î¤Ç¡¤Ê¬¤«¤ê¤Ë¤¯¤¯¤Ê¤Ã¤Æ¤·¤Þ¤¦¡¥Î¾Êý¤Î¥Ð¡¼¥¸¥ç¥ó¤òÍÑ°Õ¤·¤Æ¥¨¥é¡¼¤Ë¤Ê¤Ã¤¿¤é¤â¤¦°ìÊý¤Ã¤Æ¤Î¤¬¤è¤µ¤½¤¦¡£+    -- ただ、コメントアウトすると、[Int]とかでもeverythingFを使うため簡約されていない形で表示されてしまうので，分かりにくくなってしまう．両方のバージョンを用意してエラーになったらもう一方ってのがよさそう。 instance (Arbitrary a, Show a, Ord a, IOGenerator r) => IOGenerator ([a]->r) where --    generate     f = generateFun False f     generateIOPairs f = [ (shows a : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ [] : take 4 arbitraries,@@ -193,7 +193,7 @@       showArbitraries = (const ("Nothing"++), Nothing) : map (mapSA "Just " Just) showArbitraries instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (Either a b) where       showArbitraries = zipWith3 (\b l r -> if b then mapSA "Left " Left l else mapSA "Right " Right r) arbitraries showArbitraries showArbitraries--- ¤Û¤ó¤È¤Ï¤â¤Ã¤È¥é¥ó¥À¥à¤Ë¤¹¤Ù¤¤Ç¤Ï¤¢¤ë¡¥2ËÜEither¤¬¤¢¤ë¾ì¹ç¡¤Æ±¤¸arbitraries::[Bool]¤ò¶¦Í¤¹¤ë¤Î¤Ç¡¤Æ±¤¸²Õ½ê¤ÇLeft¤äRight¤Ë¤Ê¤ë¡¥+-- ほんとはもっとランダムにすべきではある．2本Eitherがある場合，同じarbitraries::[Bool]を共有するので，同じ箇所でLeftやRightになる． mapSA str fun (f,x) =  (\annotater -> showParen True ((str++) . f annotater), fun x) instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (a, b) where       showArbitraries = zipWith (\(f1,x1) (f2,x2) -> (\annotater -> ('(':) . f1 annotater . (',':) . f2 annotater . (')':), (x1,x2))) @@ -208,9 +208,9 @@ skip n (x:xs) = x : skip n (drop n xs) instance ShowArbitrary a => ShowArbitrary [a] where       showArbitraries = map cvt $ chopBy arbitraries showArbitraries--- ¤Û¤ó¤È¤Ï¤â¤Ã¤È¥é¥ó¥À¥à¤Ë¤¹¤Ù¤¤Ç¤Ï¤¢¤ë¡¥2ËÜ[a]¤¬¤¢¤ë¾ì¹ç¡¤Æ±¤¸arbitraries::[Int]¤ò¶¦Í¤¹¤ë¤Î¤Ç¡¤Æ±¤¸²Õ½ê¤ÇÆ±¤¸Ä¹¤µ¤Ë¤Ê¤ë¡¥+-- ほんとはもっとランダムにすべきではある．2本[a]がある場合，同じarbitraries::[Int]を共有するので，同じ箇所で同じ長さになる． chopBy :: [Int] -> [a] -> [[a]]-chopBy _      [] = []         -- everythingF¤ò»È¤Ã¤Æ¤¢¤ëÅÀ¤ÇÀÚ¤ë¸Â¤ê¡¤Í¸Â¤Î²ÄÇ½À¤âÉ¬¤º»Ä¤ë¡¥¶õ¥ê¥¹¥È¤Ç¤¢¤ë¤³¤È¤â¤¢¤ê¤¨¤ë¤Î¤Ç¡¤cycle¤·¤Æ¤â¥À¥á¡¥+chopBy _      [] = []         -- everythingFを使ってある点で切る限り，有限の可能性も必ず残る．空リストであることもありえるので，cycleしてもダメ． chopBy is     xs = cb is $ cycle xs   where cb (i:is) xs | i < 0     = cb is xs                      | otherwise = case splitAt i xs of (tk,dr) -> tk : cb is dr

MagicHaskeller/Instantiate.hs view

@@ -76,17 +76,17 @@ uniqueVars (TV _)   = TV 0 uniqueVars tc       = tc --- uniqueVars ¤Ïmemoize¤·¤Ê¤¤¾ì¹ç¤Ï¤ä¤Ã¤Æ¤â¤·¤ç¤¦¤¬¤Ê¤¤¤·¡¤memoize¤¹¤ë¾ì¹ç¤Ïsynergetic¤È¤½¤¦¤Ç¤Ê¤¤¤Î¤ÈÎ¾Êý¤Ç¤ä¤ë¤Ù¤¤Ç¤Ï?+-- uniqueVars はmemoizeしない場合はやってもしょうがないし，memoizeする場合はsynergeticとそうでないのと両方でやるべきでは?  --- memoize¤·¤Ê¤¤¾ì¹ç+-- memoizeしない場合 typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order typeToRandomsOrd tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandoms tcl cmap maps) tcl typeToRandomsOrdDM :: [Int] -> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd) typeToRandomsOrdDM nrnds tcl = ttro (\(cmap,maps,_,_,_) -> argTypeToRandomss nrnds tcl cmap maps) tcl  {---- memoize¤¹¤ë¾ì¹ç+-- memoizeする場合 typeToRandomsOrd :: TyConLib -> RTrie -> Type -> Order typeToRandomsOrd tcl rtrie = ttro (\(_,_,(mtrands,_)) -> lookupMT mtrands) tcl rtrie . uniqueVars typeToRandomsOrdDM :: TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)@@ -109,7 +109,7 @@ dynToCompare tcl dyn d0 d1 = fromDyn tcl (dynAppErr "in dynToCompare (1)" (dynAppErr "in dynToCompare (2)" dyn d0) d1) (error "dynToCompare: type mismatch") --dynToCompare tcl dyn d0 d1 = aLittleSafeFromDyn (readType' tcl "Ordering") (dynApp (dynApp dyn d0) d1) --- °ú¿ô¤Î·¿¤¬³ÎÄê¤·¤Æ¤âÊÖ¤êÃÍ¤Î·¿¤¬³ÎÄê¤·¤Ê¤¤¾ì¹ç¡§¤¿¤È¤¨¤Ðundefined¤äerror¤È¤«¡¥¤³¤Î¤Ø¤ó¤ò¤Á¤ã¤ó¤Ètake care¤·¤È¤«¤Ê¤¤¤È¡¤¤à¤ê¤ä¤êInt¤ËÊÑ´¹¤¹¤ë¤³¤È¤Ë¤Ê¤ë¡¥...¤Þ¤¢¤¤¤Ã¤«¡©+-- 引数の型が確定しても返り値の型が確定しない場合：たとえばundefinedやerrorとか．このへんをちゃんとtake careしとかないと，むりやりIntに変換することになる．...まあいっか？ -- procUndef = Just ([], mkHV (\_ _ -> True))  -- | 'uncurryTy' converts  @a->b->c->d->e->r@ into @((((a,b),c),d),e)->r@@@ -123,17 +123,17 @@  pair tcl a b = (TA (TA (TC (tuple tcl 2)) a) b) {--tuple¤ËÂÐ±þ¤¹¤ë¤ä¤Ä¤Ê¤¤¤·¡¤¤ä¤Ã¤ÑTH.Type¤Ë°ìÃ¶ÊÑ´¹¤·¤¿Êý¤¬¤è¤¤¡© ¤¢¤ë¤¤¤Ï¡¤Types.Type¤ÇTuple¤òÆÃÊÌ»ë¤¹¤ë¤«¡¥¤Þ¤¢¡¤Î§Â®ÃÊ³¬¤Ç¤Ï¤Ê¤¤¤Î¤Ç"(,)"¤ß¤¿¤¤¤Ê´¶¤¸¤Ç¤ä¤Ã¤Æ¤â¤¤¤¤¤±¤É¡¥-¤¿¤À¡¤tcl¤Ë"(,)"¤È¤«¤¬´Þ¤Þ¤ì¤Ê¤¤¾ì¹ç¤Ï¡© Ã±¤ËdefaultTyCons¤ËÆþ¤ì¤Æ¤ª¤±¤Ð¤¤¤¤¤«¡¥¤¿¤À¡¤Arbitrary¤Ï(,,,)¤Þ¤Ç¤·¤«ÄêµÁ¤µ¤ì¤Æ¤¤¤Ê¤¤¡¥+tupleに対応するやつないし，やっぱTH.Typeに一旦変換した方がよい？ あるいは，Types.TypeでTupleを特別視するか．まあ，律速段階ではないので"(,)"みたいな感じでやってもいいけど．+ただ，tclに"(,)"とかが含まれない場合は？ 単にdefaultTyConsに入れておけばいいか．ただ，Arbitraryは(,,,)までしか定義されていない．  $(support [t| forall a b c. ((Int,Integer,Char), ([a], Maybe a), (Either a b, (a,b))) |])-¤ß¤¿¤¤¤Ë½ñ¤¯¤ÈtypeToOrd¤ätypeToRandoms¤¬À¸À®¤µ¤ì¤Æ¤¯¤ì¤ë¤ÈÊØÍø¡¥-¤Þ¤¢¤È¤ê¤¢¤¨¤º¤Ï¸Â¤é¤ì¤¿·¿¤À¤±¤Ç¤ä¤Ã¤Æ¤â¤¤¤¤¤±¤É¡¥+みたいに書くとtypeToOrdやtypeToRandomsが生成されてくれると便利．+まあとりあえずは限られた型だけでやってもいいけど． -¤Æ¤æ¡¼¤«¡¤Ord¤Ê·¿¤ÈArbitrary¤Ê·¿¤ÏÊÌ¤Ê¤Î¤Ç¡¤supportOrd, supportArb¤Î£²¤Ä¤òÍÑ°Õ¤·¤Æ¤ª¤¯¤«¡¥+てゆーか，Ordな型とArbitraryな型は別なので，supportOrd, supportArbの２つを用意しておくか．  -¤Æ¤æ¡¼¤«¡¤Dynamic¤Ï¤É¤¦¤è¡© Æ±¤¸¤³¤È¤«+てゆーか，Dynamicはどうよ？ 同じことか -}  type PackedOrd = Dynamic -> Dynamic -> Ordering@@ -172,9 +172,9 @@          case typeToCompare tcl cmap a of Nothing  -> return arbssDyn                                           Just cmp -> return $ map (nubByCmp cmp . take 20) arbssDyn nubByCmp cmp = nubBy (\a b -> cmp a b == EQ)--- nubByCmp¤ÏÆ±¤¸Íð¿ô¤¬Æþ¤é¤Ê¤¤¤è¤¦¤Ë¤¹¤ëÆ¯¤¤¬¤¢¤ë¡¥¤¿¤À¤·¡¤Bool¤Ê¤É¤Î¤è¤¦¤ËËÜ¼ÁÅª¤Ë2¼ïÎà¤·¤«¤Ê¤¤¤â¤Î¤ËÂÐ¤·¤ÆnubByCmp¤·¤ÆÍð¿ô¤ò5¤Ä¼è¤í¤¦¤È¤¹¤ë¤ÈÌµ¸Â¥ë¡¼¥×¤ËÆþ¤Ã¤Æ¤·¤Þ¤¦¤Î¤Ç¡¤¤½¤ì¤òÈò¤±¤ë¤¿¤á¤Ëtake 20¤òÆþ¤ì¤Æ¤¤¤ë¡¥--- argTypeToRandoms¤Ç¤â¤½¤ì¤ò¤·¤è¤¦¤È¤¹¤ë¤È·ë¹½¤ä¤ä¤³¤·¤¤¤³¤È¤Ë¤Ê¤ë¤Î¤Ç¡¤¤½¤Ã¤Á¤Ç¤ÏnubByCmp¤·¤Ê¤¤¤³¤È¤Ë¤¹¤ë¡¥2012/5/29¤Înewnotes»²¾È¡¥--- ¤Æ¤æ¡¼¤«¡¤argTypeToRandomss¤À¤±¤ÇÁ´Éô¤ä¤ì¤Ð¤¤¤¤¤ó¤À¤±¤É¡¥+-- nubByCmpは同じ乱数が入らないようにする働きがある．ただし，Boolなどのように本質的に2種類しかないものに対してnubByCmpして乱数を5つ取ろうとすると無限ループに入ってしまうので，それを避けるためにtake 20を入れている．+-- argTypeToRandomsでもそれをしようとすると結構ややこしいことになるので，そっちではnubByCmpしないことにする．2012/5/29のnewnotes参照．+-- てゆーか，argTypeToRandomssだけで全部やればいいんだけど．  type MapTC a = IntMap.IntMap (IntMap.IntMap a) type CmpMap = (MapTC Dynamic, SpecialMap, Dynamic)@@ -245,7 +245,7 @@           tto k (TA t u) = liftM2 dynApp (tto (k+1) t) (tto 0 u) -- Higher-order kinds break everything.           tto _ (_:->_)  = Nothing -- error "Functions in containers are not allowed." -- note that ty is (part of) the return type, so this means higher-order datatype is returned.           tto 0 (TV _)   = Just cmpchar -- same as the Char case-          tto _ (TV _)   = Nothing -- ¤³¤ì¤Ë¤Ä¤¤¤Æ¤Ï°ìÈÌÅª¤Ê¤ä¤ê¤«¤¿¤Ï¤Ê¤µ¤½¤¦¡¥+          tto _ (TV _)   = Nothing -- これについては一般的なやりかたはなさそう．           tto k (TC tc)  = do guard (tc >= 0)                               imap <- IntMap.lookup k cmpmap                               IntMap.lookup (fromIntegral tc) imap@@ -285,12 +285,12 @@ mkSpecialMap :: TyConLib -> [(String,String,Dynamic)] -> IntMap.IntMap Dynamic mkSpecialMap tcl@(mapNameTyCon,_) = IntMap.fromList . map (\ (name1, name2, dyn) -> (combineTCs (mapNameTyCon Map.! name1) (mapNameTyCon Map.! name2),  dyn))  -{- ¤³¤Ã¤Á¤Ë¤¹¤Ù¤ ---------------------------------------+{- こっちにすべき --------------------------------------- -- This signature silently makes sure that TyCon == Int8. This should cause an error when TyCon /= Int8. combineTCs :: Int8 -> Int8 -> Int combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 -}--- debugÌÜÅª¤Ç¤³¤Ã¤Á¤Ë¤·¤Æ¤¤¤ë¡£---------------------------------+-- debug目的でこっちにしている。--------------------------------- combineTCs :: TyCon -> TyCon -> Int combineTCs tc1 tc2 = fromIntegral tc1 * 256 + fromIntegral tc2 @@ -303,7 +303,7 @@                                   return (-- trace ("t = "++show t++" and u = "++show u ++ " and coarb = "++show coarb) $                                           dynApp (dynApp arbfun coarb) arb)           tta 0 (TV _)  = Just arbchar -- same as the Char case-          tta _ (TV _)  = Nothing -- ¤³¤ì¤Ë¤Ä¤¤¤Æ¤Ï°ìÈÌÅª¤Ê¤ä¤ê¤«¤¿¤Ï¤Ê¤µ¤½¤¦¡¥+          tta _ (TV _)  = Nothing -- これについては一般的なやりかたはなさそう．           tta k (TC tc)               = do guard (tc >= 0)                    imap <- IntMap.lookup k arbmap@@ -357,7 +357,7 @@                                 arb1 <- ttc 0     t1                                 return (-- trace ("arb0 = "++show arb0++"arb1 = "++show arb1) $                                         dynApp arb0 arb1)-          ttc _ _ = Nothing -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¼è¤ê¹ç¤¨¤º¡¥+          ttc _ _ = Nothing -- めんどくさいので取り合えず．   @@ -383,7 +383,7 @@                                $(dynamic  [|tcl|] [| appReal      :: MapReal a -> (Double->a) |]))),                   ("Float",   ($(dynamic  [|tcl|] [| memoReal     :: (Float->a) -> MapReal a |]),                                $(dynamic  [|tcl|] [| appReal      :: MapReal a -> (Float->a) |])))]-          mct1 = [("[]",      ($(dynamicH [|tcl|] 'memoList      [t| forall m b a. (forall c. (b->c) -> m c) -> ([b] -> a) -> MapList m b a |]), -- use an undefined type, because forall is not supported. (But then does this work? I don't think so....) ¤Ç¤â¡¤Ã±¤Ëforall¤ò¼è¤Ã¤Æinfinite type¤òµö¤»¤ÐOK¤Ã¤Æµ¤¤â¤¹¤ë¡¥¤É¤¦¤è¡©+          mct1 = [("[]",      ($(dynamicH [|tcl|] 'memoList      [t| forall m b a. (forall c. (b->c) -> m c) -> ([b] -> a) -> MapList m b a |]), -- use an undefined type, because forall is not supported. (But then does this work? I don't think so....) でも，単にforallを取ってinfinite typeを許せばOKって気もする．どうよ？                                $(dynamicH [|tcl|] 'appList1     [t| forall m b a. (forall c. m c -> (b->c)) -> MapList m b a -> ([b]->a) |]))),                   ("Maybe",   ($(dynamic  [|tcl|] [| memoMaybe    :: ((b->a)->m a) -> (Maybe b->a) -> MapMaybe m a |]),                                $(dynamic  [|tcl|] [| appMaybe     :: (m a->(b->a)) -> MapMaybe m a -> (Maybe b -> a) |])))]@@ -413,7 +413,7 @@                                                                         MapTriplet l m n a -> ((b,c,d) -> a) |])))] memoLength = 10 typeToMemo :: MemoMap -> Type -> (Dynamic,Dynamic)-typeToMemo memotup@(memomap,memochar) ty = case ttc 0 ty of Nothing -> (dynI,dynI) -- ¥á¥â¤Ç¤¤Ê¤¤¾ì¹ç¡¥¥Æ¥¹¥È¤¹¤ë¤È¤¤Ï¼è¤ê¹ç¤¨¤ºÁ´Éô(dynI,dynI)¤Ë¤·¤Æ¤â¤¤¤¤¤«¤â¡¥+typeToMemo memotup@(memomap,memochar) ty = case ttc 0 ty of Nothing -> (dynI,dynI) -- メモできない場合．テストするときは取り合えず全部(dynI,dynI)にしてもいいかも．                                                             Just t  -> t     where ttc 0 (t:->u) = Nothing           ttc 0 (TV _)  = Just memochar@@ -425,8 +425,8 @@                                 (m1,a1) <- ttc 0     t1                                 return (dynApp m0 m1, dynApp a0 a1)           ttc _ _          = Nothing--- Test.QuickCheck.Gen¤ÏRandom.StdGen¸ÂÄê¤Ç¡¤¤½¤ì°Ê³°¤ÎRandomGen g => g¤Ç¤Ï¥À¥á¤ß¤¿¤¤¡¥--- Test.QuickCheck.generate¤ÎÄêµÁ¤¬¤Á¤ç¤Ã¤ÈÊÑ¤À¤È»×¤¦¡¥usable¤À¤È¤Ï»×¤¦¤±¤É¡¥+-- Test.QuickCheck.GenはRandom.StdGen限定で，それ以外のRandomGen g => gではダメみたい．+-- Test.QuickCheck.generateの定義がちょっと変だと思う．usableだとは思うけど．  type Arb a = Generator -> [a] @@ -438,7 +438,7 @@ genAppDyn :: TyConLib -> Dynamic -> Int -> Generator -> Dynamic genAppDyn tcl arbDyn size stdgen = dynApp $(dynamic [|tcl|] [| (\(Gen f) -> f size stdgen) :: Gen a -> a |] ) arbDyn -{- ¼ÂºÝ¤â¤¦»È¤ï¤ì¤Æ¤¤¤Ê¤¤¤·¡¥´Ö°ã¤¨¤Æ¤³¤Ã¤Á¤òÊÔ½¸¤·¤Á¤ã¤¦¤Î¤Ç¡¤±£¤¹¡¥+{- 実際もう使われていないし．間違えてこっちを編集しちゃうので，隠す． arbitrariesBy :: Gen a -> Arb a arbitrariesBy arb = arbsBy arb 0 arbsBy :: Gen a -> Int -> StdGen -> [a]@@ -450,11 +450,11 @@   --- nrnds¤Ï¼Â¤Ïsize¤ò·è¤á¤ë¤¿¤á¤Ë¤·¤«»È¤ï¤ì¤Æ¤¤¤Ê¤¤¡¥ÆÀ¤é¤ì¤ë¤Î¤ÏStream (Bag Dynamic)¤Ç¤Ï¤Ê¤¯Stream (Stream Dynamic)+-- nrndsは実はsizeを決めるためにしか使われていない．得られるのはStream (Bag Dynamic)ではなくStream (Stream Dynamic) arbitrariessByDyn :: [Int] -> TyConLib -> Dynamic -> Generator -> [[Dynamic]] arbitrariessByDyn nrnds tcl arb gen = abd nrnds tcl arb 0 gen--- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò¾®¤µ¤¤ÃÍ¤«¤éÁý¤ä¤·¤Æ¤¤¤¯¾ì¹ç-abd nrnds tcl arb depth gen = zipWith (arbsByDyn' nrnds tcl arb) [depth..] (gens gen) -- Íð¿ô¥µ¥¤¥º¤ò°ìÄê¤Ë¤¹¤ë¾ì¹ç+-- abd _ _ arb depth gen = zipWith (arbsByDyn arb) [depth..] (gens gen) -- 乱数サイズを小さい値から増やしていく場合+abd nrnds tcl arb depth gen = zipWith (arbsByDyn' nrnds tcl arb) [depth..] (gens gen) -- 乱数サイズを一定にする場合 arbsByDyn' nrnds tcl arbDyn depth stdgen = map (genAppDyn tcl arbDyn size) (gens stdgen)     where size = max depth (nrnds !! depth) #ifdef TFRANDOM

MagicHaskeller/LibTH.hs view

@@ -271,8 +271,6 @@ by1 name   = name -} --- ¤³¤ÎÊÕ¤ÏCoreLang¤Ç¤ä¤ë¤Ù¤¤È¤¤¤¦µ¤¤â¡¥¾¯¤Ê¤¯¤È¤â¡¤¤½¤Ã¤Á¤Ç´Ø¿ô¤òÄêµÁ¤¹¤Ù¤¡¥--- \x -> iF foo bar x ¤Î¾ì¹ç¤âÀè¤Ë¦Ç´ÊÌó¤µ¤ì¤Æ¤·¤Þ¤¦¤È¥¤¥Þ¥¤¥Á¤Ç¤Ï¤¢¤ë¡¥¤Î¤Ç¡¤¦Ç´ÊÌó¤ÏiF, nat_cata, tail¤Ê¤É¤Î½èÍý¤Î¸å¤Ë¤ä¤ë¡¥ -- For readability, we apply eta-reduction only when we can fully eta-reduce at the outermost lambda-abstraction. ppLambda [VarP n] (AppE e (VarE n')) | shown == show n' && not (shown `appearsIn` e) = e                                                where shown = show n@@ -397,7 +395,7 @@ -} newtype Partial a = Part {undef :: a} undefs = map (\[a,b] -> (a,b)) $-         [-- Bool ã Orderingã®ããã«ããããã¡ãªå¤ãè¿ãã¦ãã¾ããã®ã¯ãæ¡ç¨ãã¹ãã§ãªãã$(p [| (Part False :: Partial Bool,     undefined :: Partial Bool) |]), $(p [| (Part EQ    :: Partial Ordering, undefined :: Partial Ordering) |]),+         [-- x $(p [| (Part False :: Partial Bool,     undefined :: Partial Bool) |]), $(p [| (Part EQ    :: Partial Ordering, undefined :: Partial Ordering) |]),           $(p [| (Part 53        :: Partial Int,      undefined :: Partial Int) |]),            $(p [| (Part '\29'     :: Partial Char,     undefined :: Partial Char) |]),           $(p [| (Part [43]      :: Partial [Int],    undefined :: Partial [Int]) |]), @@ -508,7 +506,7 @@ by2_cmpPair (Ord compare1) (Ord compare2) = Ord $ comparePairBy compare1 compare2 comparePairBy compare1 compare2 (x,y) (z,w) = case compare1 x z of EQ -> compare2 y w                                                                    o  -> o-ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering, -- ãªããcomment outããã¦ããã®ã§å¾©æ´»ããã¦ã¿ããåé¡ãããªãæ»ããã+ords = $(p [| (cmp :: Ordered Bool, cmp :: Ordered Ordering,                cmp :: Ordered Int, cmp :: Ordered Char, -- cmp :: Ordered (Ratio Int) is defined in ratioCls                by1_cmpMaybe :: Ordered a -> Ordered (Maybe a), by1_cmpList :: Ordered a -> Ordered [a],                by2_cmpEither :: Ordered a -> Ordered b -> Ordered (Either a b), by2_cmpPair :: Ordered a -> Ordered b -> Ordered (a,b)) |])@@ -649,7 +647,7 @@  -- Library used by the program server backend pgfull :: ProgGenSF--- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until ::  (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst)  -- rich ã¨ãã¾ãå¤ãããªãï¼+-- pgfull = mkPG ($(MagicHaskeller.LibTH.load "libsrc/PreludeList.hs") ++ mb ++ bool ++ boolean ++ $(p [| ([], (:), (+) :: Int -> Int -> Int, replicate :: Int -> a -> [a]) |]) ++ $(p [| until ::  (a -> Bool) -> (a -> a) -> a -> a |]) ++ nat ++ intinst) pgfull = mkPGXOpt options{tv1=True,nrands=repeat 20,timeout=Just 100000} (eqs++ords) clspartialss full tupartialssNormal -- A pgfull must be a CAF, so we must have pgfulls and access pgfullSized via pgfulls. Directly calling pgfullSized is heap-inefficient. pgfulls :: [ProgGenSF]@@ -712,7 +710,7 @@                                flip (flip . either) :: (->) (Either a b) ((a -> c) -> (b -> c) -> c)) |])                ++ intinst2 ++ $(p [| (sum :: (->) [Int] Int, product :: (->) [Int] Int) |]),                 list2 ++ $(p [| (scanl :: (a -> b -> a) -> a -> [b] -> [a], scanr :: (a -> b -> b) -> b -> [a] -> [b], scanl1 :: (a -> a -> a) -> [a] -> [a], scanr1 :: (a -> a -> a) -> [a] -> [a],-               -- until ::  (a -> Bool) -> (a -> a) -> a -> a) ãå¥ãã¦ããï¼ã©ããuntilãããã¨æ¥ã«éããªãï¼ãã®å²ã«ï¼å¨ãä½¿ãããªãï¼ä½ããããã¤+               -- until ::  (a -> Bool) -> (a -> a) -> a -> a)                 show :: Int -> [Char]) |])++ $(p [| ((,) :: a -> b -> (a,b), flip uncurry :: (->) (a,b) ((a->b->c) -> c)) |]),                 $(p [| ((,,) :: a -> b -> c -> (a,b,c), Left :: a -> Either a b, Right :: b -> Either a b,                                     zip  :: (->) [a] ((->) [b] [(a, b)]),

MagicHaskeller/MHTH.lhs view

@@ -15,6 +15,7 @@  import MagicHaskeller.ReadTHType(showTypeName, plainTV, unPlainTV) + #ifdef __GLASGOW_HASKELL__ nameToNameStr :: (Name -> String) -> Name -> ExpQ nameToNameStr shw name = return $ LitE (StringL (shw name))

MagicHaskeller/MemoToFiles.hs view

@@ -18,7 +18,7 @@   --- copied from ProgGen.lhs. toMemoºï¤Ã¤Æ·¿ÊÑ¤¨¤¿¡¥¤Æ¤æ¡¼¤«¤½¤ì°ÊÁ°¤Ë¡¤»¶¤é¤Ð¤Ã¤Æ¤ëfreezePS¤òProgramGeneratorÊÕ¤ê¤Ë¤Þ¤È¤á¤¿¤¤µ¤¤â+-- copied from ProgGen.lhs. toMemo削って型変えた．てゆーかそれ以前に，散らばってるfreezePSをProgramGenerator辺りにまとめたい気も freezePS :: Search m => Type -> PriorSubsts m (Bag e) -> m (Possibility e) freezePS ty ps     = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail)@@ -31,7 +31,7 @@     where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]           filterSubst sub  mx = [ t | t@(i,_) <- sub, inRange (0,mx) i ] -- note that the assoc list is NOT sorted. --- ¤³¤ì¤Ã¤ÆProgGen¸ÂÄê¤«+-- これってProgGen限定か memoPSRTIO :: ShortString b =>              MemoCond                  -> MapType (Matrix (Possibility b))@@ -72,7 +72,7 @@ data MemoType = Recompute -- ^ Recompute instead of memoizing.               | Ram       -- ^ Use the memoization table based on lazy evaluation, like in older versions.               | Disk FilePath -- ^ Use the directory specified by @FilePath@ as the persistent memoization table.-type MemoCond = Type -> Int -> IO MemoType -- IO¤òÊÖ¤¹¡¥¤Ä¤Þ¤ê¡¤¥á¥â¥ê¤ä¥Ï¡¼¥É¥Ç¥£¥¹¥¯¤Î¶õ¤¤Ë¤è¤Ã¤Æ¤âÊÑ¤¨¤é¤ì¤ë¤è¤¦¤Ë¤¹¤ë¡¥+type MemoCond = Type -> Int -> IO MemoType -- IOを返す．つまり，メモリやハードディスクの空きによっても変えられるようにする．   -- | General-purposed memoizer (This could be put in a different module.)@@ -88,7 +88,7 @@       in do there <- doesFileExist filepath             if there then do cs <- C.readFile filepath -- Read strictly, and close (not semi-close) it. System.IO.readFile cannot achieve this behavior.                               case parser cs of Just x -> return x-                                               _      -> do -- If the file is broken, just fix it. ¤Ç¤âÃ¯¤«¤¬½ñ¤¹þ¤ßÃæ¤À¤Èº¤¤ë?+                                               _      -> do -- If the file is broken, just fix it. でも誰かが書き込み中だと困る?                                                               System.IO.hPutStrLn stderr ("File " ++ filepath ++ " was broken.")                                                               write                      else write

MagicHaskeller/Options.hs view

@@ -19,7 +19,7 @@                   , memodepth :: Int -- ^ memoization depth. (Sub)expressions within this size are memoized, while greater expressions will be recomputed (to save the heap space). Only effective when using 'ProgGen' and unless using the 'everythingIO' family.                   , memoCondPure  :: Type -> Int -> Bool        -- ^ This represents when to memoize. It takes the query type and the query depth, and returns @True@ if the corresponding entry should be looked up from the lazy memo table. Currently this only works for ProgGenSF.                   , memoCond  :: MemoCond        -- ^ This represents which memoization table to be used based on the query type and the search depth, when using the 'everythingIO' family.-                  , execute :: VarLib -> CoreExpr -> Dynamic -- timeout ¤Ï¤³¤ÎÃæ¤Ç¤ä¤ë¤Ù¤¡¥IO Dynamic¤Î¾ì¹ç¤ËunsafePerformIO¤ò2²ó¤ä¤ë¤ÈÊÑ¤Ê¤³¤È¤Ë¤Ê¤ê¤½¤¦¤Ê¤Î¤Ç¡¥+                  , execute :: VarLib -> CoreExpr -> Dynamic -- timeout はこの中でやるべき．IO Dynamicの場合にunsafePerformIOを2回やると変なことになりそうなので．                   , timeout :: Maybe Int         -- ^ @Just ms@ sets the timeout to @ms@ microseconds. Also, my implementation of timeout also catches inevitable exceptions like stack space overflow. Note that setting timeout makes the library referentially untransparent. (But currently @Just 20000@ is the default!) Setting this option to @Nothing@ disables both timeout and capturing exceptions.                   , forcibleTimeout :: Bool      -- ^ If this option is @True@, 'System.Posix.Process.forkProcess' instead of 'Control.Concurrent.forkIO' is used for timeout.                                                  --   The former is much heavier than the latter, but is more preemptive and thus is necessary for interrupting some infinite loops.

MagicHaskeller/PolyDynamic.hs view

@@ -43,11 +43,11 @@ infixl `dynApp`  data Dynamic = Dynamic {dynType::Type, unsafeFromDyn::forall a. a, dynExp::Exp}--- CoreExpr¤ÏPrimitive¤¬Dynamic¤ò»È¤Ã¤Æ¤¤¤ë¤Î¤Ç¡¤Exp¤ÎÂå¤ï¤ê¤Ë»È¤¦¤Èhiboot¤·¤Ê¤¤¤È¤¤¤±¤Ê¤¯¤Ê¤ë¡¥+-- CoreExprはPrimitiveがDynamicを使っているので，Expの代わりに使うとhibootしないといけなくなる．  unsafeToDyn :: TyConLib -> Type -> a -> Exp -> Dynamic unsafeToDyn tcl tr a e = Dynamic tr (unsafeCoerce# a) e--- unsafeToDyn tcl tr a e = Dynamic tr (unsafeCoerce# a) (SigE e (typeToTHType tcl tr)) -- ¤³¤Ã¤Á¤Ï¤³¤Ã¤Á¤ÇÊØÍø¤Ã¤Ý¤¤¤Î¤À¤¬¡¥+-- unsafeToDyn tcl tr a e = Dynamic tr (unsafeCoerce# a) (SigE e (typeToTHType tcl tr)) -- こっちはこっちで便利っぽいのだが．  aLittleSafeFromDyn :: Type -> Dynamic -> a aLittleSafeFromDyn tr (Dynamic t o _)@@ -85,10 +85,10 @@ fromPD = id  --- °Ê²¼¤ÏMyDynamic¤«¤é¤È¤Ã¤Æ¤¤¿¤â¤Î¤Ç¡¤PolyDynamic¤Ë¤¢¤ë¤Î¤ÈÁ´¤¯Æ±¤¸¡¥+-- 以下はMyDynamicからとってきたもので，PolyDynamicにあるのと全く同じ． {- $(dynamic [|tcl|] [| (,) :: forall a b. a->b->(a,b) |])-¤Î¤è¤¦¤Ë¤Ç¤¤ë¤è¤¦¤Ë¤¹¤ë¡¥CLEAN¤Îdynamic¤ß¤¿¤¤¤Ê´¶¤¸¡¥+のようにできるようにする．CLEANのdynamicみたいな感じ． -} dynamic :: ExpQ -> ExpQ -> ExpQ dynamic eqtcl eq = eq >>= p' eqtcl@@ -102,6 +102,6 @@ -- p' is like MagicHaskeller.p' p' eqtcl (SigE e ty) = px eqtcl e ty p' eqtcl e           = [| unsafeToDyn $eqtcl (trToType $eqtcl (typeOf $(return e)))    $(return e)  $(expToExpExp e) |]--- px eqtcl e ty        = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp se) |] -- ¤³¤Ã¤Á¤Ï¤³¤Ã¤Á¤ÇÊØÍø¤Ã¤Ý¤¤¤Î¤À¤¬¡¥+-- px eqtcl e ty        = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp se) |] -- こっちはこっちで便利っぽいのだが． px eqtcl e ty        = [| unsafeToDyn $eqtcl (thTypeToType $eqtcl $(typeToExpType ty)) $(return se) $(expToExpExp e) |]     where se = SigE e ty

MagicHaskeller/PriorSubsts.lhs view

@@ -62,8 +62,8 @@     return     = pure     PS x >>= f = PS (\s i -> do (a,t,j) <- x s i                                 unPS (f a) t j)---    {-# INLINE (>>=) #-} °ÕÌ£¤Ê¤«¤Ã¤¿¡¥---    PS x >>= f = x `thenPS` f ¤³¤ì¤â°ÕÌ£¤Ê¤«¤Ã¤¿¡¥¤Þ¤¢¡¤Monad¤Ï¥Ç¥Õ¥©¥ë¥È¤Çinline¤·¤Æ¤ë¤«¤â¡©+--    {-# INLINE (>>=) #-} 意味なかった．+--    PS x >>= f = x `thenPS` f これも意味なかった．まあ，Monadはデフォルトでinlineしてるかも？  -- {-# INLINE listThenPS #-} -- {-# INLINE thenPS #-}@@ -116,7 +116,7 @@ mguPS, matchPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m () mguPS t0 t1 = do subst <- mgu t0 t1                  updatePS subst--- ¤Æ¤æ¡¼¤«mgtPS¤òmguPS¤ÎÄêµÁ¤Ë¤·¤Æ¤â¤¤¤¤¤¯¤é¤¤¡¥+-- てゆーかmgtPSをmguPSの定義にしてもいいくらい． mgtPS :: (Functor m, MonadPlus m) => Type -> Type -> PriorSubsts m Type mgtPS t1 t2 = do mguPS t1 t2                  applyPS t1@@ -158,7 +158,7 @@ newTVar = PS (\ s n -> return (n, s, n+1))  --- Æ±¤¸Ì¾Á°¤Î´Ø¿ô¤¬allifdefs/PSList.hs¤Ë¤â¤¢¤Ã¤¿¤ê¤¹¤ë¡¥Ìò³ä¤â»÷¤¿¤è¤¦¤Ê¤â¤ó¡¥+-- 同じ名前の関数がallifdefs/PSList.hsにもあったりする．役割も似たようなもん． psListToPSRecomp :: (Int -> PriorSubsts [] a) -> PriorSubsts Recomp a psListToPSRecomp f = PS (\subst int -> Rc (\dep -> case f dep of PS g -> g subst int)) psRecompToPSList :: PriorSubsts Recomp a -> Int -> PriorSubsts [] a@@ -182,7 +182,7 @@ -- | reserveTVars takes the number of requested tvIDs, reserves consecutive tvIDs, and returns the first tvID.  reserveTVars :: Monad m => TyVar -> PriorSubsts m TyVar reserveTVars n = PS (\s i -> return (i,s,i+n))-{- ¤³¤Ã¤Á¤ÎÄêµÁ¤Ë¤·¤¿¤é°¤Êò¤ß¤¿¤¤¤Ë»þ´Ö¤ò¿©¤Ã¤¿¡¥Ìõ¥ï¥«¥á+{- こっちの定義にしたら阿呆みたいに時間を食った．訳ワカメ reserveTVars n = do i <- getMx                     updateMx (n+)                     return i

MagicHaskeller/ProgGen.lhs view

@@ -128,7 +128,7 @@  mguProgramsIO memodeb = applyDo (mguProgsIO memodeb) -mguProgsIO memodeb@(_,mt,_,cmn) = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> (\memodeb avail reqr -> memoPSRTIO (memoCond $ opt cmn) -- (\_ty _dep -> return (Disk "/tmp/memo/mlist")  {- ¤È¤ê¤¢¤¨¤º¤³¤ì¤Ç¥Æ¥¹¥È -})+mguProgsIO memodeb@(_,mt,_,cmn) = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> (\memodeb avail reqr -> memoPSRTIO (memoCond $ opt cmn) -- (\_ty _dep -> return (Disk "/tmp/memo/mlist")  {- とりあえずこれでテスト -})                                                                                                                                                 mt                                                                                                                                                 (\ty -> let (av,rr) = splitArgs ty in generateFuns mguProgramsIO memodeb av rr)                                                                                                                                                 (popArgs avail reqr)) memodeb newavail reqret) avail)@@ -143,7 +143,7 @@  mguProgs memodeb = wind (>>= (return . fmap (mapCE Lambda))) (lookupFunsShared mguFuns memodeb) --mguProgs memodeb = wind (>>= (return . fmap Lambda)) (\avail reqret -> reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail)-{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ+{- どっちがわかりやすいかは不明 mguProgs memodeb avail (t0:->t1) = do result <- mguProgs memodeb (t0 : avail) t1                                       return (fmap Lambda result) mguProgs memodeb avail reqret = reorganize (\newavail -> lookupFunsPoly mguFuns memodeb newavail reqret) avail@@ -151,7 +151,7 @@  mguFuns memodeb = generateFuns  mguPrograms memodeb --- MemoDeb¤Î·¿¤¬°ã¤¦¤È»È¤¨¤Ê¤¤¡¥+-- MemoDebの型が違うと使えない． generateFuns :: (Search m) =>                 Generator m CoreExpr                               -- ^ recursive call                 -> Generator m CoreExpr

MagicHaskeller/ProgGenSF.lhs view

@@ -85,18 +85,18 @@  lmt :: Expression e => ExpTrie e -> Type -> Matrix e lmt mt fty = traceExpTy fty $-                                     lookupMT mt fty -- ¤³¤Ã¤Á¤À¤Èlookup---                                   filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty --  ¤³¤Ã¤Á¤À¤Èrecompute+                                     lookupMT mt fty -- こっちだとlookup+--                                   filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty --  こっちだとrecompute  filtBF :: Expression e => Common -> Type -> Recomp e -> Matrix e --          filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate --filtBF cmn ty = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty)  .  mapDepthDB uniqSorter -- . mondepth filtBF cmn ty | classify  = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . fromRc . mapDepth uniqSort               | otherwise = toMx . mapDepth uniqSort-fDM = filterDM -- ¤³¤Ã¤Á¤¬½¾Íè--- fDM = filterDMlite -- depth bound(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ë°ú¿ô¤ÎInt)¤ÎÂå¤ï¤ê¤Ë¡¤depth bound¤«¤é¤Îµ÷Î¥(¤Ä¤Þ¤ê¡¤Int->[(a,Int)]¤Ë¤ª¤±¤ëInt->[(a,¤³¤³¤ÎInt)])¤ò»È¤Ã¤Ænrnds¤Î²¿ÈÖÌÜ¤«¤ò·è¤á¤ë¤â¤Î¡¥-                      -- filterDM¤È°ã¤Ã¤Æ¡¤Æ±¤¸depth bound¤Ç¤â°ã¤¦Íð¿ô¤ò»È¤¦¤Î¤Ç¡¤filterListÆ±ÍÍdepth¤ò¸Ù¤¤¤Àfiltration¤¬¤Ç¤¤º¡¤·ë²Ì¤Ï¤¤¤Þ¤¤¤Á¡¥-                      -- ¤¿¤À¤·¡¤dynamic¤Ê´Ø¿ô¼«ÂÎ¤ò¥á¥â²½¤¹¤ì¤Ð¡¤³ÊÃÊ¤Ë¥á¥â¤Ë¥Ò¥Ã¥È¤·¤ä¤¹¤¯¤Ê¤ë¤Ï¤º¡¥+fDM = filterDM -- こっちが従来+-- fDM = filterDMlite -- depth bound(つまり，Int->[(a,Int)]における引数のInt)の代わりに，depth boundからの距離(つまり，Int->[(a,Int)]におけるInt->[(a,ここのInt)])を使ってnrndsの何番目かを決めるもの．+                      -- filterDMと違って，同じdepth boundでも違う乱数を使うので，filterList同様depthを跨いだfiltrationができず，結果はいまいち．+                      -- ただし，dynamicな関数自体をメモ化すれば，格段にメモにヒットしやすくなるはず．  filtBFIO :: Expression e => Common -> Type -> Recomp e -> IO (Matrix e) filtBFIO cmn ty rc | classify  = dbtToCumulativeMx $ fmap fromAnnExpr $ filterDMIO cmn ty $ fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) $ fromRc $ mapDepth uniqSort rc@@ -109,7 +109,7 @@ -- memocond i = i<10 memocond i = True --- memocond ty = size ty < 10 -- popArgs avail t¤·¤Æ¤«¤é¤ä¤ë¤Î¤Ï¤Á¤ç¤Ã¤ÈÌµÂÌ¡¥¤È»×¤Ã¤¿¤±¤É¡¤¼ÂºÝ¤Ï´Ø·¸¤Ê¤¤¤ß¤¿¤¤¡¥+-- memocond ty = size ty < 10 -- popArgs avail tしてからやるのはちょっと無駄．と思ったけど，実際は関係ないみたい． -- memocond av ty = size ty + sum (map size av) < 10  @@ -124,11 +124,11 @@ unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0  matchProgs :: Common -> ExpTrie CoreExpr -> Type -> Matrix AnnExpr-matchProgs cmn etrie ty = fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupReorganized etrie ty -- ¤³¤Ã¤Á¤À¤Èlookup+matchProgs cmn etrie ty = fmap (toAnnExprWindWind (reducer cmn) ty) $ lookupReorganized etrie ty -- こっちだとlookup {--matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty)                 -- ¤³¤Ã¤Á¤À¤Èrecompute ¤È¤¤¤¦¤È¸ìÊÀ¤¬¤¢¤ë¡¥recompute¤·¤¿¤¤ãlmt¤Î¤È¤³¤í¤òÊÑ¤¨¤ë¤Ù¤·¡¥+matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty)                 -- こっちだとrecompute というと語弊がある．recomputeしたきゃlmtのところを変えるべし． --- matchProgs¤Î¤ß¤Î²¼ÀÁ¤±¡¤matchFuns¤È¸ò´¹²ÄÇ½+-- matchProgsのみの下請け，matchFunsと交換可能 lookupFuns :: (Expression e, Ord e) => MemoDeb e -> [Type] -> Type -> BF e lookupFuns memodeb@((_,mt),_,tcl,rtrie) avail reqret = {-@@ -157,8 +157,8 @@           typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb typeTrie ty)) dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a dbToCumulativeMx (DB f) = Mx $ case map (sort . map fst . f) [0..] of-                                 xss -> let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result in result -- Â¿Ê¬ËÜÅö¤ÏÌÀ¼¨Åª¤Ëlookup¤·Ä¾¤¹¤Ù¤¡¥-{- The following does not accurately give other chances to the expressions once dropped. ¥³¡¼¥É¤ò¤¤¤¸¤Ã¤Æ¤¤¤ë¤¦¤Á¤Ë¤¤¤Ä¤Î´Ö¤Ë¤«ºÇ½é¤ÎÀß·×¤òËº¤ì¤Æ¤³¤ó¤Ê¤ó¤Ê¤Ã¤Æ¤¿¡¥+                                 xss -> let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result in result -- 多分本当は明示的にlookupし直すべき．+{- The following does not accurately give other chances to the expressions once dropped. コードをいじっているうちにいつの間にか最初の設計を忘れてこんなんなってた． -- dbToCumulativeMx (DB f) = Mx $ map (map fst . f) [0..] dbToCumulativeMx (DB f) = let foo = map (sort . map fst . f) [0..]                           in Mx $ zipWith (diffSortedBy compare) foo ([]:foo)@@ -175,12 +175,12 @@ dbtToCumulativeMx (DBT f) = do ts <- interleaveActions $ map f [0..]                                let xss = map (sort . map fst) ts                                let result = zipWith (diffSortedBy compare) xss $ scanl (++) [] result -                               return $ Mx result -- Â¿Ê¬ËÜÅö¤ÏÌÀ¼¨Åª¤Ëlookup¤·Ä¾¤¹¤Ù¤¡¥+                               return $ Mx result -- 多分本当は明示的にlookupし直すべき．  mkMTty = mkMT mkMTexp = mkMT -mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depth¤ÈÉ½¼¨¤¹¤ë¤Ê¤é+1¤¹¤ë¤Ù¤¤Ç¤¢¤Ã¤¿¡¥(0¤«¤é»Ï¤Þ¤ë¤Î¤Ç)+mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depthと表示するなら+1するべきであった．(0から始まるので)   type BFT = Recomp@@ -212,8 +212,8 @@ -- tokoro10ap = mergesortWithBy const (\ (t,_,_) (u,_,_) -> compare t u) tokoro10ap = M.elems . M.fromListWith const . map (\ t@(ty,_,_) -> ( {- normalize -} ty, t)) --- avail¤Ë¤·¤íType¤Ë¤·¤íapply¤µ¤ì¤Æ¤¤¤ë¡¥--- ¤À¤«¤é¤³¤½¡¤runAnotherPSÅª¤ËemptySubst¤ËÂÐ¤·¤Æ¼Â¹Ô¤·¤¿Êý¤¬¸úÎ¨Åª¤Ê¤Ï¤º¡© ¤Ç¤â¡¤Substitution¤Ã¤Æ¤½¤ó¤Ê¤Ë¤Ç¤«¤¯¤Ê¤é¤Ê¤«¤Ã¤¿¤Î¤Ç¤Ï¡©FiniteMap¤Ç¤âassoc list¤Ç¤âÊÑ¤ï¤é¤Ê¤«¤Ã¤¿µ¤¤¬¡¥+-- availにしろTypeにしろapplyされている．+-- だからこそ，runAnotherPS的にemptySubstに対して実行した方が効率的なはず？ でも，Substitutionってそんなにでかくならなかったのでは？FiniteMapでもassoc listでも変わらなかった気が．   @@ -274,7 +274,7 @@                            = let (avail,t) = splitArgs ty                              in convertPS (zipDepthRc (\i es -> if i < length avail - 1 then [] else es)) $ do                                 reorganize_ (\av -> specCases' memodeb ttrie av t) avail--- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ×+-- quantifyはmemo先で既にやられているので不要                                 applyPS ty  instance Monoid BitSet where@@ -340,9 +340,9 @@                           fasf ty $ fullBits .&. complement ix           -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()           retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $-                                             do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃÍ¤ÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë-                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©-                                               --                                                              -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌÜ¤«+                                             do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる+                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？+                                               --                                                              -- unitSubstをinlineにしないと駄目か                                                 mkSubsts (tvndelay $ opt cmn) tvid reqret                                                 funApSub_forcingNil_cont_spec clbehalf behalf (mapTV (tvid+) ty) fullBits $ \i -> do                                                   gentvar <- applyPS (TV tvid)@@ -350,7 +350,7 @@                                                   guard (orderedAndUsedArgs gentvar)                                                   fasf gentvar i --- absent¤ò´Þ¤á¤ë¾ì¹ç¤³¤Ã¤Á¤ò»È¤¦+-- absentを含める場合こっちを使う lookupWithAbsents :: Search m => PGSF CoreExpr -> Type -> m CoreExpr lookupWithAbsents memodeb ty   = case splitArgs ty of @@ -391,8 +391,8 @@   = Rc $ \d -> if memoCondPure (opt cmn) t d                  then [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i)                             | (_ty, s, i) <- unMx (lookupNormReorganized (lmtty ttrie) t) !! d {- if d<8 then d else 7 -} ]-                 else -- [ (unMx (filtBF cmn ty $ matchFunctions memodeb ty) !! d, s, i) -- exptrie¤âÆ±ÍÍ¤ËmemoCondPure¤ò»È¤¦¾ì¹ç¡¥-                     [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i)  -- exptrie¤Ç¤ÏÁ´Éômemoize¤¹¤ë¾ì¹ç¡¥+                 else -- [ (unMx (filtBF cmn ty $ matchFunctions memodeb ty) !! d, s, i) -- exptrieも同様にmemoCondPureを使う場合．+                     [ (unMx (lookupReorganized etrie $ apply s t) !! d, s, i)  -- exptrieでは全部memoizeする場合．                             | (ty, s, i) <- unMx (freezePS t $ specTypes memodeb ttrie t) !! d {- if d<8 then d else 7 -} ]  lookupNormReorganized fun typ = let (avs, retty) = splitArgs typ@@ -456,7 +456,7 @@ matchFuns memodeb avail reqret = zipDepthRc (\i es -> if i < length avail - 1 then [] else es) $ catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret)  matchFuns' :: Generator Recomp CoreExpr -> PGSF CoreExpr -> [Type] -> Type -> PriorSubsts Recomp [CoreExpr]--- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥+-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ． matchFuns' rec md@(PGSF (CL classLib, (_,(primgen,primmono)),cmn) _ _) avail reqret     = let clbehalf  = mguPrograms classLib           behalf    = rec md avail@@ -565,25 +565,25 @@     in fromIntegral $ ((((hex + (hex `unsafeShiftR` 4)) .&. 0x0F0F0F0F) * 0x01010101) `unsafeShiftR` 24) .&. 0xFF -- The last (.&. 0xFF) should not be necessary when using Word32.  retGenOrdBits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty) -  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃÍ¤ÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë-                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©-                                               --                                                              -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌÜ¤«+  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる+                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？+                                               --                                                              -- unitSubstをinlineにしないと駄目か                                                a <- mkSubsts (tvndelay $ opt cmn) tvid reqret                                                (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits)                                                gentvar <- applyPS (TV tvid)-                                               guard (orderedAndUsedArgs gentvar) -- ¤³¤ÎÊÕ¤Îcheck¤òTVn¤ËÆþ¤ëÁ°¤ÎÁá¤¤ÃÊ³¬¤Ë¤ä¤ë¤Î¤Ï1¤Ä¤Î¹Í¤¨Êý¤À¤¬¡¤TVnÃæ¤Ëreplace¤µ¤ì¤¿¤ê¤Ï¤·¤Ê¤¤¤Î¤«?+                                               guard (orderedAndUsedArgs gentvar) -- この辺のcheckをTVnに入る前の早い段階にやるのは1つの考え方だが，TVn中にreplaceされたりはしないのか?                                                (es, bs2) <- funApSub'' False gentvar (fe gentvar ty exprs, bs1)                                                guard $ bs2 == 0                                                return es     where---                    funApSub'' filtexp (TV _ :-> _)     funs = mzero -- mkSubsts¤ÇÆ³Æþ¤µ¤ì¤¿tyvars¤¬»È¤ï¤ì¤Æ¤¤¤Ê¤¤¥±¡¼¥¹¡¥replace¤µ¤ì¤¿·ë²ÌTV¤Ã¤Æ¥±¡¼¥¹¤Ï¤È¤ê¤¢¤¨¤ºÌµ»ë....+--                    funApSub'' filtexp (TV _ :-> _)     funs = mzero -- mkSubstsで導入されたtyvarsが使われていないケース．replaceされた結果TVってケースはとりあえず無視....                     funApSub'' filtexp (t:->ts@(u:->_)) (funs, bs) --                        | t > u     = mzero                         | otherwise = do (args, ixs) <- behalf t                                          funApSub'' (t==u) ts (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e ]                                                                          else liftM2 (<$>) funs args,                                                                  bs .&. complement ixs)--- ¤Æ¤æ¡¼¤«t¤Èu¤¬Æ±¤¸¤Ê¤é¤Ð¤â¤Ã¤È¤¤¤í¤ó¤Ê¤³¤È¤¬¤Ç¤¤½¤¦¡¥+-- てゆーかtとuが同じならばもっといろんなことができそう．                     funApSub'' filtexp (t:->ts) (funs, bs)                                     = do (args, ixs) <- behalf t                                          return (if filtexp then [ f <$> e | f <- funs, e <- args, let _:$d = toCE f, d <= toCE e]@@ -592,9 +592,9 @@                     funApSub'' _fe _t tups = return tups  retGenTV1Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)-  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃÍ¤ÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë-                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©-                                               --                                                              -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌÜ¤«+  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる+                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？+                                               --                                                              -- unitSubstをinlineにしないと駄目か                                                a <- mkSubst (tvndelay $ opt cmn) tvid reqret {-                                                                                               (exprs, bs1) <- funApSubBits_resetting clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty+a)) xs, fullBits)@@ -608,9 +608,9 @@                                                  funApSubBits_forcingNil clbehalf lltbehalf behalf gentvar (fe gentvar ty exprs, bs1)  retGenTV0Bits cmn lenavails fullBits fe clbehalf lltbehalf behalf reqret (arity, _retty, numtvs, xs:::ty)-  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃÍ¤ÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë-                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©-                                               --                                                              -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌÜ¤«+  = convertPS (ndelay arity) $              do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる+                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？+                                               --                                                              -- unitSubstをinlineにしないと駄目か                                                updatePS (unitSubst tvid reqret)                                                exprs <- funApSubBits_forcingNil clbehalf lltbehalf behalf (mapTV (tvid+) ty) (map (mkHead (reducer cmn) lenavails (getLongerArity ty)) xs, fullBits)                                                gentvar <- applyPS (TV tvid)@@ -624,7 +624,7 @@     = do s <- getSubst          let newty = apply s reqty          msum $ zipWith (\n t -> matchPS newty t >> return ([mkHead (reducer cmn) lenavails (getLongerArity newty) (X n)], 1 `shiftL` fromIntegral n)) [0..] assumptions--- match ¤Î¾ì¹ç¡¤ÄÌ¾ï¤Ïreqty¤ÎÊý¤À¤±apply subst¤¹¤ì¤Ð¤è¤¤¡¥+-- match の場合，通常はreqtyの方だけapply substすればよい．  lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e lookupListrie lenavails rec memodeb avail t

MagicHaskeller/ProgGenSFIORef.lhs view

@@ -72,7 +72,7 @@ --   Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault....  type ExpTrie  e = IORef (FMType (Array Int [e]))--- type ExpTrie  e = MapType (ExpMatrix e) -- PGSF, PGSFIO¤À¤È¤³¤Ã¤Á¤À¤Ã¤¿¡¥+-- type ExpTrie  e = MapType (ExpMatrix e) -- PGSF, PGSFIOだとこっちだった．  type TypeTrie = MapType (Matrix (Type, Subst, TyVar)) @@ -86,7 +86,7 @@ -- memocond i = i<10 memocond i = True --- memocond ty = size ty < 10 -- popArgs avail t¤·¤Æ¤«¤é¤ä¤ë¤Î¤Ï¤Á¤ç¤Ã¤ÈÌµÂÌ¡¥¤È»×¤Ã¤¿¤±¤É¡¤¼ÂºÝ¤Ï´Ø·¸¤Ê¤¤¤ß¤¿¤¤¡¥+-- memocond ty = size ty < 10 -- popArgs avail tしてからやるのはちょっと無駄．と思ったけど，実際は関係ないみたい． -- memocond av ty = size ty + sum (map size av) < 10  @@ -109,7 +109,7 @@       in memoDeb     where qtlopt = splitPrimss txsopt           qtl    = splitPrimss txs--- Èó¸úÎ¨¤À¤±¤É¡¤DBoundT¤ËÌ·½â¤¬¤¢¤Ã¤Æ¤â¤¤¤¤¤ä¤Ä¡¥+-- 非効率だけど，DBoundTに矛盾があってもいいやつ． inconsistentDBTToRcT :: (Functor m, Monad m, Ord a) => DBoundT m a -> RecompT m a inconsistentDBTToRcT (DBT f) = RcT $ \d -> do tss <- mapM f [0..d-1]                                               ts  <- f d@@ -121,7 +121,7 @@ mkMTty = mkMT mkMTexp = mkMT -mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depth¤ÈÉ½¼¨¤¹¤ë¤Ê¤é+1¤¹¤ë¤Ù¤¤Ç¤¢¤Ã¤¿¡¥(0¤«¤é»Ï¤Þ¤ë¤Î¤Ç)+mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depthと表示するなら+1するべきであった．(0から始まるので)   type BFT = Recomp@@ -147,7 +147,7 @@ specializedCases, specCases, specCases' :: (Search m) => MemoDeb CoreExpr -> [Type] -> Type -> PriorSubsts m () specializedCases memodeb = applyDo (specCases memodeb) specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail)-{- ¤É¤Ã¤Á¤¬¤ï¤«¤ê¤ä¤¹¤¤¤«¤ÏÉÔÌÀ+{- どっちがわかりやすいかは不明 specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1 specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail -}@@ -180,7 +180,7 @@ specTypes memodeb ty                            = do let (avail,t) = splitArgs ty                                 reorganize_ (\av -> specCases' memodeb av t) avail--- quantify¤ÏmemoÀè¤Ç´û¤Ë¤ä¤é¤ì¤Æ¤¤¤ë¤Î¤ÇÉÔÍ×+-- quantifyはmemo先で既にやられているので不要                                 typ <- applyPS ty                                 return (normalize typ) @@ -205,9 +205,9 @@                           fas ty           -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT ()           retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $-                                             do tvid <- reserveTVars numtvs -- ¤³¤Î¡ÊºÇ½é¤Î¡ËID¤½¤Î¤â¤Î¡Ê¤Ä¤Þ¤êÊÖ¤êÃÍ¤ÎtvID¡Ë¤Ï¤¹¤°¤Ë»È¤ï¤ì¤Ê¤¯¤Ê¤ë-                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTV¤Èapply¤Ïhylo-fusion¤Ç¤¤ë¤Ï¤º¤À¤¬¡¤¾¡¼ê¤Ë¤µ¤ì¤ë¡©-                                               --                                                              -- unitSubst¤òinline¤Ë¤·¤Ê¤¤¤ÈÂÌÌÜ¤«+                                             do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる+                                               -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？+                                               --                                                              -- unitSubstをinlineにしないと駄目か                                                 mkSubsts (tvndelay $ opt cmn) tvid reqret                                                 fas (mapTV (tvid+) ty) @@ -221,7 +221,7 @@ unifyableExprsIO :: Generator (DBoundT IO) CoreExpr unifyableExprsIO memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrieIO memodeb))) -memocondexp _ d = 0<d -- ¤Ê¤ó¤«¾ò·ï¤¬ProgGenSFIO¤Ç¤ÏµÕ¤Ë¤Ê¤Ã¤Æ¤ë¤«¤â¡¥+memocondexp _ d = 0<d -- なんか条件がProgGenSFIOでは逆になってるかも． memodepth _ = 1  @@ -241,7 +241,7 @@ lookupReorganizedIO md typ = let (avs, retty) = splitArgs $ normalize typ                              in reorganizerId' (\av -> lmtIO md $ popArgs av retty) avs --- ¥Û¥ó¥È¤ÏProgGenSF¤Îmt¤ò»È¤Ã¤¿¤Û¤¦¤¬Â®¤¤¤Ï¤º¡¥+-- ホントはProgGenSFのmtを使ったほうが速いはず． lmtIO :: PGSFIOR CoreExpr -> Type -> RecompT IO CoreExpr lmtIO md@(PGSFIOR fmtref (_,_,_,cmn)) ty = memoRTIO fmtref (computeExpTip md) ty @@ -269,7 +269,7 @@                                                                             return result -}                                                                     else atomicModifyIORef fmtref (mkSingle ty depth result)--- exptip¤òlookup¤¹¤ë¤È¤¤ânormalize¤¹¤Ù¤¡¥¤È»×¤Ã¤¿¤±¤É¡¤typetip¤Ë¤¢¤ëtype¤Ïnormalize¤µ¤ì¤Æ¤ë¡¥+-- exptipをlookupするときもnormalizeすべき．と思ったけど，typetipにあるtypeはnormalizeされてる．  addToLast :: Expression e => Type -> Int -> [e] -> FMType (Array Int [e]) -> (FMType (Array Int [e]), [e]) addToLast ty depth result fmt = (updateFMT upd (error "addToLast: cannot happen") ty fmt, result)@@ -283,21 +283,21 @@ modify :: Type -> Int -> FMType (Array Int [AnnExpr]) -> (FMType (Array Int [AnnExpr]), [AnnExpr]) modify ty depth fmt     = case lookupFMT fmt ty of-        Nothing -> do result <- compute  ¤Ã¤Æ¤³¤È¤Ï, IO ¤¬´Ö¤ËÆþ¤ë¤Î¤Ç, atomic ¤Ç¤Ï¤Ê¤¤.+        Nothing -> do result <- compute  ってことは, IO が間に入るので, atomic ではない. -atomic¤«¤É¤¦¤«¤Ï¸å¤Ç¹Í¤¨¤ë¡¥+atomicかどうかは後で考える． -Í×¤Ï¡¤-¡¦³ºÅö²Õ½ê¤¬memoÂÐ¾Ý¤Ç¤Ê¤¤¾ì¹ç¡¤compute¤·¤Æ½ªÎ»¡¥-            memoÂÐ¾Ý¤Î¾ì¹ç(X)¡¤memo¤Ë¤¢¤ë¤Ê¤é¡¤¤½¤ì¤ò¼è¤Ã¤Æ¤¤Æ½ªÎ»¡¥-                                     ¤Ê¤¤¤Î¤Ç¤¢¤ì¤Ð¡¤{result <- compute;-                                                      ³ºÅö²Õ½ê¤Î1¸ÄÀõ¤¤¤È¤³¤í¤¬memoÂÐ¾Ý¤Ç¤Ê¤¤¾ì¹ç¡¤³ºÅö²Õ½ê¤Î¤ß¤ò¤â¤Äsingleton array¤ò½ñ¤¹þ¤ó¤Ç½ªÎ»(A)-                                                                               memoÂÐ¾Ý¤Ê¤é¡¤{(X)¤ò£±¤³Àõ¤¤¤È¤³¤í¤Ç¼Â¹Ô¡Ê·ë²Ì¤Ï¼Î¤Æ¡Ë;-                                                                                              ¡Ê£±¸ÄÀõ¤¤¤È¤³¤í¤Þ¤Ç¤Îarray¤¬¤Ç¤¤Æ¤ë¤Î¤Ç¡¤¡Ë³ºÅö²Õ½ê¤òËöÈø¤Ë²Ã¤¨¤Æ½ªÎ»(B)}}+要は，+・該当箇所がmemo対象でない場合，computeして終了．+            memo対象の場合(X)，memoにあるなら，それを取ってきて終了．+                                     ないのであれば，{result <- compute;+                                                      該当箇所の1個浅いところがmemo対象でない場合，該当箇所のみをもつsingleton arrayを書き込んで終了(A)+                                                                               memo対象なら，{(X)を１こ浅いところで実行（結果は捨て）;+                                                                                              （１個浅いところまでのarrayができてるので，）該当箇所を末尾に加えて終了(B)}} -atomically¤Ë¤ä¤ë¤Î¤Ï(A)¤È(B)¤À¤±¤«¡¥atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b-¼Â¤Ïmemocondexp¤Ç(memodepth¤Ê¤·¤Ç)¤Ç¤¤½¤¦¡¥-´Ø¿ô(X)¤¬ËÜ¼ÁÅª¡¥loop¤¹¤ë¤Î¤Ç¡¥(X)¤òensureAtHand¤È¤¤¤¦Ì¾Á°¤Ë¡¥+atomicallyにやるのは(A)と(B)だけか．atomicModifyIORef :: IORef a -> (a -> (a, b)) -> IO b+実はmemocondexpで(memodepthなしで)できそう．+関数(X)が本質的．loopするので．(X)をensureAtHandという名前に． -}  @@ -312,7 +312,7 @@ matchFunsIO memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprsIO memodeb avail reqret)  matchFuns' :: (Search m) => Generator m CoreExpr -> Generator m CoreExpr--- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDeb¤Î·¿¤Î°ã¤¤¤Ç¤³¤ì¤Ï¤¦¤Þ¤¯¤¤¤«¤Ê¤ó¤À¡¥+-- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ． matchFuns' rec md@(PGSFIOR _ (CL classLib, _, (_,(primgen,primmono)),cmn)) avail reqret     = let clbehalf  = mguPrograms classLib []           behalf    = rec md avail

MagicHaskeller/ReadTHType.lhs view

@@ -17,7 +17,7 @@ showTypeName = TH.nameBase -- Use the unqualified name to avoid confusion because Data.Typeable.tyConString shows the unqualified name for types defined in the Standard Hierarchical Library (though the qualified name is shown when Typeable is derived). -- showTypeName = show -- maybe in future, when TypeRep can be shown qualified. --- MyDynamicÅµ©gíêÄ¢È¢ÌÅCForallTÍPÉ³·éDPolyDynamicÌ`FbNª¿åÁÆÉÈé¾¯D+-- MyDynamicでしか使われていないので，ForallTは単に無視する．PolyDynamicのチェックがちょっと緩くなるだけ． thTypeToType :: TyConLib -> TH.Type -> Types.Type thTypeToType tcl t = normalize $ thTypeToType' tcl [] t thTypeToType' tcl vs (ForallT bs []    t) = thTypeToType' tcl (vs++map tyVarBndrToName bs) t@@ -34,7 +34,7 @@                                           Nothing -> -- TC $ (-1 - bakaHash nstr)                                                      error $ "thTypeToType' : "++nstr++" : unknown TyCon"                                           Just c  -> TC c-{- ±ÌÓÍPÈéRgAEgÅ¢¢ñ¾Á¯H +{- この辺は単なるコメントアウトでいいんだっけ？  thTypeToType' tcl (HsTyCon (Special HsUnitCon)) = TC (unit tcl) thTypeToType' tcl (HsTyCon (Special HsListCon)) = TC (list tcl) -}@@ -46,7 +46,7 @@ tyVarBndrToName (PlainTV name)    = name tyVarBndrToName (KindedTV name _) = name -{- tcKindðp~·éÌÅDÜCtcKindªÈÄàhigher-order kindÅÈ¯êÎgbvxÌkind©ç_Å«éµD+{- tcKindを廃止するので．ま，tcKindがなくてもhigher-order kindでなければトップレベルのkindから推論できるし． -- copied from svn/MagicHaskeller/memodeb/RandomFilter.hs typeToTHType :: TyConLib -> Types.Type -> TH.Type typeToTHType tcl ty = TH.ForallT (map tvToName $ tyvars ty) [] (typeToTHType' tcl ty)@@ -82,7 +82,7 @@ #endif tvToName n = TH.mkName ('t':show n) --- secionedArrow = TH.ConT ''(->) -- ½ª±Á¿ÅàOK+-- secionedArrow = TH.ConT ''(->) -- 多分こっちでもOK sectionedArrow = TH.ConT (mkName "GHC.Prim.(->)")  {-

MagicHaskeller/ReadTypeRep.hs view

@@ -19,19 +19,19 @@ typeToTR ::  TyConLib -> Type -> TypeRep typeToTR tcl ty = tyToTR tcl 0 ty tyToTR :: TyConLib -> Kind -> Type -> TypeRep-tyToTR _      0 (TV _)    = typeOf 'c' -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¤È¤ê¤¢¤¨¤ºChar+tyToTR _      0 (TV _)    = typeOf 'c' -- めんどくさいのでとりあえずChar tyToTR (_,ar) k (TC tc)   | tc >= 0   = mkTyConApp (mkTyCon $ fst ((ar!k) !! fromIntegral tc)) []                           | otherwise = error "tyToTR: impossible (tc<0)." tyToTR tcl    k (TA a b)  = mkAppTy (tyToTR tcl (k+1) a) (tyToTR tcl 0 b) tyToTR tcl    0 (a :-> b) = mkFunTy (tyToTR tcl 0 a) (tyToTR tcl 0 b) -} --- ¤È¤ê¤¢¤¨¤º¤ÏFake¤Ç¤Ê¤¤Dynamic¤Ç¤Îtype check¤Ë»È¤¦¤À¤±¤Ê¤Î¤Ç¡¤¸úÎ¨¤Ï¹Í¤¨¤Ê¤¯¤Æ¤è¤¤¡¥--- ¤Ç¤â¤Þ¤¢¡¤monomorphic¸ÂÄê¤Ê¤éTypeRep¤ÎÊý¤¬Â®¤¤¤ß¤¿¤¤¡Ê¡©¡Ë¡¥¥½¡¼¥¹¤ò¸«¤¿´¶¤¸¡¤ÆÃ¤Ë¡¤equality¤Ë´Ø¤·¤Æ¤Ï¸úÎ¨Åª¤Ê¼ÂÁõ¤ò¤ä¤Ã¤Æ¤ë¤ß¤¿¤¤¡¥+-- とりあえずはFakeでないDynamicでのtype checkに使うだけなので，効率は考えなくてよい．+-- でもまあ，monomorphic限定ならTypeRepの方が速いみたい（？）．ソースを見た感じ，特に，equalityに関しては効率的な実装をやってるみたい． -{- -- ´Ö°ã¤Ã¤Æ¤â¤¦°ì²óÆ±¤¸¤â¤Î¤òºî¤Ã¤Æ¤·¤Þ¤Ã¤¿¡¥kind¤Ë´Ø¤·¤Æ¤ÏtcID¤ò»È¤Ã¤¿Êý¤¬¤¤¤¤¤«¤â¡©+{- -- 間違ってもう一回同じものを作ってしまった．kindに関してはtcIDを使った方がいいかも？ typeToTR ::  TyConLib -> Type -> TypeRep-typeToTR _       (TV _) = typeOf 'c' -- ¤á¤ó¤É¤¯¤µ¤¤¤Î¤Ç¤È¤ê¤¢¤¨¤ºChar+typeToTR _       (TV _) = typeOf 'c' -- めんどくさいのでとりあえずChar typeToTR (_,ar) (TC tc) | tcid >= 0 = mkTyConApp (mkTyCon $ fst ((ar ! tcKind tc) !! tcid)) []                         | otherwise = error "tyToTR: impossible (tcid<0)."                         where tcid = tcID tc

MagicHaskeller/RunAnalytical.hs view

@@ -198,4 +198,4 @@                               thExpssToEvery session (synthTyped tgtdecs bkdecs) thExpssToEvery :: HscEnv -> [[Exp]] -> IO (Every a) thExpssToEvery session ess = return $ map (map (\e -> (e, unsafePerformIO $ executeTHExp session e))) ess--- thExpssToEvery session ess = mapM (mapM (\e -> fmap ((,) e) $ executeTHExp session e)) ess -- ¤³¤ì¤À¤È¥À¥á. unsafeInterleaveIO¤ò¤¦¤Þ¤¯»È¤¦¼ê¤â¤¢¤ë¤Î¤«¤â¡¥+-- thExpssToEvery session ess = mapM (mapM (\e -> fmap ((,) e) $ executeTHExp session e)) ess -- これだとダメ. unsafeInterleaveIOをうまく使う手もあるのかも．

MagicHaskeller/ShortString.hs view

@@ -10,7 +10,7 @@ import Data.Int import Data.Word --- LC.cons' ¤À¤ÈÂ¿Ê¬¥À¥á+-- LC.cons' だと多分ダメ  showBriefly :: ShortString a => a -> LC.ByteString showBriefly = flip showsBriefly LC.empty@@ -19,7 +19,7 @@  class ShortString a where     showsBriefly :: a -> LC.ByteString -> LC.ByteString-    readsBriefly :: C.ByteString -> Maybe (a,C.ByteString)  --  ReadS a -- Maybe ¤ÎÊý¤¬Â®¤¤? ¤Æ¤æ¡¼¤«¡¤parse error¤Î³ä¹ç¤Ï¤¹¤´¤¯¾¯¤Ê¤¤¤Ï¤º¤Ê¤Î¤Çerror¤È¤·¤Æcatch¤·¤¿Êý¤¬Â®¤¤¤Ï¤º¡¥¤È»×¤Ã¤¿¤±¤É¡¤lazy¤Ê¥Ç¡¼¥¿¤Ê¤Î¤ÇÀµ¤·¤¯catch¤Ç¤¤Ê¤¤¤«¡¥+    readsBriefly :: C.ByteString -> Maybe (a,C.ByteString)  --  ReadS a -- Maybe の方が速い? てゆーか，parse errorの割合はすごく少ないはずなのでerrorとしてcatchした方が速いはず．と思ったけど，lazyなデータなので正しくcatchできないか．  instance ShortString a => ShortString [a] where     showsBriefly []     = LC.cons ']'@@ -39,7 +39,7 @@     showsBriefly (PrimCon   i) = (LC.cons 'P')  . showsBriefly i     showsBriefly (Context _) = LC.cons 'C'     showsBriefly (c :$ e)      = (LC.cons '$')  . showsBriefly c . showsBriefly e-    readsBriefly cs = case C.uncons cs of -- Int(Nat)¤È1Ê¸»ú¤á°ì½ï¤Ë1¥Ð¥¤¥È¤Ë¤Ç¤¤Ê¤¤¤«?¤¢¤È¡¤lambda¤ÏÂ³¤¯¤Î¤Ç¤Þ¤È¤á¤é¤ì¤½¤¦¡¥+    readsBriefly cs = case C.uncons cs of -- Int(Nat)と1文字め一緒に1バイトにできないか?あと，lambdaは続くのでまとめられそう．                                           Just ('\\',xs) -> do (ce,ys) <- readsBriefly xs                                                                return (Lambda ce, ys)                                           Just ('X', xs) -> do (i, ys) <- readsBriefly xs

MagicHaskeller/SimpleServer.hs view

@@ -406,9 +406,13 @@ prepareGHCAPI allfss = runGhc (Just libdir) $ do           dfs     <- getSessionDynFlags #if __GLASGOW_HASKELL__ >= 700-          let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ]} Opt_ExtendedDefaultRules+-- x # if __GLASGOW_HASKELL__ >= 708+-- x           let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2, parMakeCount=Nothing} Opt_ExtendedDefaultRules -- parMakeCount=Nothing corresponds to -j. See http://downloads.haskell.org/~ghc/7.10.2/docs/html/libraries/ghc-7.10.2/DynFlags.html -- but seemingly this does not make the code faster, so is commented out.+-- x # else+          let newf = xopt_set dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2} Opt_ExtendedDefaultRules+-- x # endif #else-          let newf = dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ]}+          let newf = dfs{packageFlags = [ packageNameToFlag "MagicHaskeller" ], optLevel=2} #endif           setSessionDynFlags newf   -- result abandoned

MagicHaskeller/T10.hs view

@@ -99,13 +99,13 @@                                         ([], diff) -> diff                                         (same@((_,_,i):_), diff) -> (concat (map (\ (a,_,_) -> a) same), [], i) : diff {---- $B$A$c$s$H7W;;$7$F$J$$$1$I!$(BO(n^2)$B$/$i$$!)(B $B$?$@!$MWAG?t(Bn$B$O>/$J$$$C$]$$$N$G$3$C$A$NJ}$,B.$$$+$b(B+-- ちゃんと計算してないけど，O(n^2)くらい？ ただ，要素数nは少ないっぽいのでこっちの方が速いかも tokoro10             :: Eq k => [([a],k,i)] -> [([a],k,i)] tokoro10 []          =  [] tokoro10 ((es,k,i):xs) =  case partition (\ (_,k',_) -> k==k' ) xs of                                         (same, diff) -> (es ++ concat (map (\ (a,_,_) -> a) same), k, i) : tokoro10 diff -}-{- quicksort$B$NJQ7A(B+{- quicksortの変形 tokoro10             :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)] tokoro10 []             = [] tokoro10 ((t@(x,k,i)):ts) = case partition3 k ts of (ls,es,gs) -> tokoro10 ls ++ (x ++ concat es, k, i) : tokoro10 gs@@ -120,7 +120,7 @@ -- merge sort could be much faster. tokoro10             :: (Monoid a, Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)] tokoro10 = mergesortWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> k `compare` l)-{- sort$B$O$7$J$$$1$I!$<B$O$3$C$A$NJ}$,8zN($,0-$$$N$G$O(B? $BD9$5$KBP$7$F(B2$B>h$N%*!<%@!<$K$J$j$=$&!%%=!<%H$9$l$P!$(BO(n log n)$B!J8eH>$O(BO(n)$B$G$9$_$=$&!K$7$+$b!$(B(\\\)$B$r;H$&$K$O%=!<%H$7$F$J$$$H$@$a!%(B+{- sortはしないけど，実はこっちの方が効率が悪いのでは? 長さに対して2乗のオーダーになりそう．ソートすれば，O(n log n)（後半はO(n)ですみそう）しかも，(\\\)を使うにはソートしてないとだめ． tokoro10 :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)] tokoro10 ((t@(xs,k,i)):ts) = case partition (\ (_,k',_) -> k'==k) ts of (es,ns) -> (xs ++ concat (map (\ (a,_,_) -> a) es),  k,  i) : tokoro10 ns -}@@ -133,7 +133,7 @@   {---- nlambda n e = iterate Lambda e !! n$B$NJ}$,H~$7$$!)8zN($O!)(B+-- nlambda n e = iterate Lambda e !! nの方が美しい？効率は？ nlambda 0 e = e nlambda n e = Lambda $ nlambda (n-1) e -}

MagicHaskeller/TimeOut.hs view

@@ -64,7 +64,7 @@ unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r) --- ¥½¡¼¥¹¤ò¤ß¤¿´¶¤¸¡¤MVar¤äMSampleVar¤òºî¤ëoverhead¤ÏÌµ»ë¤Ç¤¤½¤¦¡¥+-- ソースをみた感じ，MVarやMSampleVarを作るoverheadは無視できそう． -- data CHTO a = CHTO {timeInMicroSecs :: Int, sv :: MSampleVar (Maybe a)}  {-@@ -75,9 +75,9 @@ maybeWithTO' :: (a -> IO () -> IO ()) -> Maybe Int -> ((IO b -> IO b) -> IO a) -> IO (Maybe a) maybeWithTO' _   Nothing  action = do a <- action id                                       return (Just a)---maybeWithTO' dsq (Just t) action = withTO' dsq t action -- ¸Å¤¤¤ä¤Ä+--maybeWithTO' dsq (Just t) action = withTO' dsq t action -- 古いやつ {--maybeWithTO' dsq (Just t) action = System.Timeout.timeout t (action undefined) -- System.Timeout.timeout¤ò»È¤¦¤ÈÂ®¤¯¤Ê¤ë¡¥+maybeWithTO' dsq (Just t) action = System.Timeout.timeout t (action undefined) -- System.Timeout.timeoutを使うと速くなる．                                         `catch` \(e :: SomeException) -> -- trace ("within maybeWithTO': " ++ show e) $                                                                          return Nothing -}