-- -- (c) Susumu Katayama -- {-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction, PatternGuards, CPP #-} module MagicHaskeller.LibExcel(module MagicHaskeller.LibExcel, module MagicHaskeller.LibExcelStaged) where import MagicHaskeller import MagicHaskeller.LibExcelStaged import MagicHaskeller.Types(size) import Control.Monad(liftM2) import Data.List hiding (tail) import Data.Char import Data.Maybe -- import Data.Ratio import MagicHaskeller.FastRatio import qualified Data.Generics as G import MagicHaskeller.ProgGenSF(mkTrieOptSFIO) import qualified Data.IntMap as IM import Data.Hashable import Prelude hiding (tail, gcd, enumFromThenTo) -- whether succ is used only for numbers or not succOnlyForNumbers = True -- This is True for Excel. -- total variants of prelude functions last' = (\x xs -> last (x:xs)) tail = drop 1 -- init xs = zipWith const xs (drop 1 xs) -- | 'ppExcel' replaces uncommon functions like catamorphisms with well-known functions. ppExcel :: Exp -> Exp ppExcel (AppE (AppE (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) e5) e6) | Just stem <- stripPrefix "6'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4, e5, e6]) where nb = nameBase name ppExcel (AppE (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) e5) | Just stem <- stripPrefix "5'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4, e5]) where nb = nameBase name ppExcel (AppE (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) e5) | nameBase name == "." = ppExcel $ ((e1 `AppE` (e2 `AppE` e3)) `AppE` e4) `AppE` e5 -- ad hoc pattern:S ppExcel (AppE (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) e4) | nameBase name == "." = ppExcel $ (e1 `AppE` (e2 `AppE` e3)) `AppE` e4 ppExcel (AppE (AppE (AppE (AppE (ConE name) e1) e2) e3) e4) | nameBase name == "(,,,)" = ppExcel $ TupE [e1, e2, e3, e4] ppExcel (AppE (AppE (AppE (AppE (VarE name) e1) e2) e3) e4) | nb == "flip" = ppExcel $ ((e1 `AppE` e3) `AppE` e2) `AppE` e4 | nb == "sUBST4" = mkUncurried "sUBSTITUTE" (map ppExcel [e1, e2, e3, mkVarOp lit1 "+" (absE `AppE` e4)]) | Just stem <- stripPrefix "4'" $ reverse nb = mkUncurried (reverse stem) (map ppExcel [e1, e2, e3, e4]) where nb = nameBase name ppExcel (AppE (InfixE (Just e1) (VarE name) (Just e2)) e3) | nameBase name == "." = ppExcel $ e1 `AppE` (e2 `AppE` e3) ppExcel (AppE (e@(AppE (AppE (ConE name) p) t)) f) | nameBase name == "(,,)" = ppExcel $ TupE [p,t,f] ppExcel (AppE (e@(AppE (AppE (VarE name) p) t)) f) = case reverse $ nameBase name of "xIdnif" -> mkVarOp (mkUncurried "finD" [char7, mkUncurried "sUBSTITUTE" [mkUncurried "concatenate" [ppp,ppt], ppp, char7, ppExcel $ mkVarOp lit1 "+" (absE `AppE` f) ]]) "-" lit1 -- The "findIx" case. findIx c xs n = finD(char(7), sUBSTITUTE(concatenate(c,xs), c, char(7), 1+abs(n)))-1 "pilf" -> ppExcel $ (ppp `AppE` ppf) `AppE` ppt -- The "flip" case "." -> ppExcel (p `AppE` (t `AppE` f)) '3':'\'':stem -> ppExcel $ mkUncurried (reverse stem) [p,t,f] _ -> ppExcel e `AppE` ppf where ppp = ppExcel p ppt = ppExcel t ppf = ppExcel f ppExcel (AppE f@(AppE (ConE name) lj) e) | nameBase name == "(,)" = ppExcel $ TupE [lj, e] ppExcel (AppE (AppE (VarE name) e1) e2) | nb == "fLOOR0" = case ppe2 of LitE (IntegerL n) | n>0 -> floore1e2 | otherwise -> lit0 LitE (RationalL n) | n>0 -> floore1e2 | otherwise -> lit0 AppE (VarE nm) _ | nameBase nm == "pI" -> floore1e2 -- just to avoid the awkward case of iF(pI() > 0, blah) _ -> mkIF (mkVarOp ppe2 ">" lit0) floore1e2 lit0 | nb == "countStr" = case ppe2 of LitE (StringL "") -> lit0 LitE (StringL _) -> counted ListE [] -> lit0 ListE _ -> counted _ -> mkIF (mkVarOp ppe2 "<>" (LitE $ StringL "")) counted lit0 | nb == "dropLeft" = mkUncurried "right" [ppe1, mkVarOp (ppExcel $ lenE `AppE` ppe1) "-" ppe2] | Just stem <- stripPrefix "2'" $ reverse nb = ppExcel $ mkUncurried (reverse stem) [e1, e2] where nb = nameBase name ppe1 = ppExcel e1 ppe2 = ppExcel e2 counted = ppExcel $ mkVarOp (mkVarOp (lenE `AppE` e1) "-" (lenE `AppE` (mkSUBST4 [e1, ppe2, LitE (StringL "")]))) "/" (lenE `AppE` ppe2) -- countStr x str = (len(x)-len(sUBsTITUTE(x,str,""))) / len(str) floore1e2 = mkUncurried "fLOOR" [ppe1, ppe2] ppExcel (AppE (InfixE m@(Just _) op Nothing) e) = ppExcel (InfixE m op (Just e)) ppExcel (AppE (InfixE Nothing op m@(Just _)) e) = ppExcel (InfixE (Just e) op m) ppExcel (AppE v@(VarE name) e) = case nameBase name of "tail" -> ppdrop 1 e "negate" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ (-i) LitE (RationalL r) -> LitE $ RationalL $ (-r) _ -> mkVarOp (LitE $ IntegerL 0) "-" ppe -- @negate x@ should become @0 - x@ "abs" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ abs i LitE (RationalL r) -> LitE $ RationalL $ abs r ParensE _ -> AppE (ppv v) ppe _ -> AppE (ppv v) $ ParensE ppe "floor" -> ppe "fromIntegral" -> ppe "succ" -> case ppe of LitE (IntegerL i) -> LitE $ IntegerL $ succ i LitE (RationalL r) -> LitE $ RationalL $ succ r LitE (CharL c) -> LitE $ CharL $ succ c InfixE (Just (LitE (IntegerL n))) (VarE nm) (Just e) | nameBase nm == "+" -> mkVarOp (LitE $ IntegerL $ succ n) "+" e AppE (VarE nm) e | succOnlyForNumbers && nameBase nm == "succ" -> mkVarOp (LitE $ IntegerL 2) "+" e -- This is OK, if we use succ only for numbers. _ -> AppE (ppv v) ppe "left1" -> case ppe of LitE (StringL xs) -> LitE $ StringL $ take 1 xs ListE es -> ListE $ take 1 $ map ppExcel es ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ListE [LitE $ IntegerL f] AppE (VarE name) e' | nameBase name == "left1" -> ppe _ -> AppE leftE $ TupE [ppe, LitE $ IntegerL 1] "right1" -> case ppe of LitE (StringL xs) -> LitE $ StringL $ right(xs,1) ListE es -> ListE $ right(map ppExcel es, 1) AppE (VarE name) e' | nameBase name == "right1" -> ppe _ -> AppE rightE $ TupE [ppe, LitE $ IntegerL 1] "reverse" -> case ppe of LitE (StringL xs) -> LitE $ StringL $ reverse xs ListE es -> ListE $ reverse $ map ppExcel es ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> ArithSeqE $ FromThenToR (LitE $ IntegerL t) (LitE $ IntegerL $ t-1) (LitE $ IntegerL f) AppE (VarE name) e' | nameBase name == "reverse" -> e' _ -> AppE reverseE ppe "len" -> case ppe of LitE (StringL xs) -> LitE $ IntegerL $ toInteger $ length xs ListE es -> LitE $ IntegerL $ toInteger $ length es ArithSeqE (FromToR (LitE (IntegerL f)) (LitE (IntegerL t))) -> LitE $ IntegerL $ t - f + 1 -- can be bottom, if t is less than f. AppE (VarE name) e' | nameBase name == "reverse" -> AppE lenE e' -- length . reverse => length -- There can also be the length . map f => length rule. The length . map f pattern can appear when f includes some absent argument. ParensE _ -> AppE lenE ppe _ -> AppE lenE (ParensE ppe) "sum" -> case ppe of AppE (VarE name) e' | nameBase name == "reverse" -> AppE sumE e' _ -> AppE sumE ppe "product" -> case ppe of AppE (VarE name) e' | nameBase name == "reverse" -> AppE productE e' _ -> AppE productE ppe nb -> case ppe of TupE _ -> AppE (ppv v) ppe ConE name | nameBase name == "()" -> AppE (ppv v) ppe _ -> AppE (ppv v) (ParensE ppe) where ppe = ppExcel e -- The following pattern is actually unnecessary if only eta-long normal expressions will be generated. ppExcel e@(VarE _) = ppv e ppExcel e@(ConE _) = ppv e ppExcel (AppE f x) = case ppx of TupE _ -> ppExcel f `AppE` ppx _ -> ppExcel f `AppE` ParensE ppx where ppx = ppExcel x ppExcel (InfixE me1 op me2) = let j1 = fmap ppExcel me1 j2 = fmap ppExcel me2 in case op of VarE opname -> case (j1,j2) of (Just (LitE (IntegerL i1)), Just (LitE (IntegerL i2))) -> case nameBase opname of "+" -> LitE $ IntegerL $ i1+i2 "-" -> LitE $ IntegerL $ i1-i2 "*" -> LitE $ IntegerL $ i1*i2 _ -> theDefault (Just (LitE (IntegerL i1)), Just (InfixE (Just (LitE (IntegerL i2))) (VarE inopn) me3)) | nameBase opname == "+" && nameBase inopn `elem` ["+","-"] -> InfixE (Just $ LitE $ IntegerL $ i1+i2) (VarE $ ppopn inopn) me3 (Just e, Just (LitE (IntegerL 1))) | nameBase opname `elem` ["/","*"] -> e _ -> theDefault where theDefault = InfixE j1 (VarE $ ppopn opname) j2 ppExcel (LamE pats e) = LamE pats (ppExcel e) ppExcel (TupE es) = TupE (map ppExcel es) ppExcel (ListE es) = ListE (map ppExcel es) ppExcel (SigE e ty) = ppExcel e `SigE` ty ppExcel e = e {- ppv e@(VarE name) | nameBase name `elem` ["iF", "nat_cata"] = LamE [ VarP n | n <- names ] (ppExcel (AppE (AppE (AppE e p) t) f)) | nameBase name == "last'" = LamE [ VarP n | n <- tail names ] (ppExcel (AppE (AppE e t) f)) | otherwise = VarE $ ppopn name where names = [ mkName [n] | n <- "ptf" ] [p,t,f] = map VarE names -} ppv (VarE name) = VarE $ ppopn name ppv (ConE name) = ConE $ ppopn name ppopn name = mkName $ nameBase name ppdrop m0j e = case ppExcel e of AppE (AppE (VarE drn) (LitE (IntegerL i))) list | nameBase drn == "drop" -> droppy (m0j + i) list -- NB: m0j and i are both positive. ppe -> droppy m0j ppe where droppy i e = (dropE `AppE` (LitE $ IntegerL i)) `AppE` e constE = VarE $ mkName "const" flipE = VarE $ mkName "flip" plusE = VarE $ mkName "+" dropE = VarE $ mkName "drop" reverseE = VarE $ mkName "reverse" lengthE = VarE $ mkName "length" sumE = VarE $ mkName "sum" productE = VarE $ mkName "product" leftE = VarE $ mkName "left" rightE = VarE $ mkName "right" lenE = VarE $ mkName "len" absE = VarE $ mkName "abs" mkIF p t f = VarE (mkName "iF") `AppE` TupE [p, t, f] mkUncurried str es = VarE (mkName str) `AppE` TupE es mkSUBST4 = mkUncurried "sUBSTITUTE" mkVarOp e1 op e2 = InfixE (Just e1) (VarE $ mkName op) (Just e2) char7 = VarE (mkName "char") `AppE` LitE (IntegerL 7) lit0 = LitE (IntegerL 0) lit1 = LitE (IntegerL 1) procSucc n (AppE (VarE name) e) | nameBase name == "succ" = procSucc (n+1) e procSucc n (LitE (CharL c)) = LitE $ CharL $ iterate succ c `genericIndex` n procSucc n (LitE (IntegerL i)) = LitE $ IntegerL $ n+i procSucc n (LitE (RationalL r)) = LitE $ RationalL $ fromInteger n + r procSucc n e | succOnlyForNumbers = InfixE (Just $ LitE $ IntegerL n) (VarE $ mkName "+") (Just $ ppExcel e) -- This is OK, if we use succ only for numbers. | otherwise = iterate (AppE (VarE $ mkName "succ")) (ppExcel e) `genericIndex` n nrnds = repeat 5 mkPgExcel :: IO ProgGenSF mkPgExcel = mkPGXOpts mkTrieOptSFIO options{tv0=True,nrands=repeat 20,timeout=Just 100000} [] [] excel [[],[],[]] mkPgExcels :: Int -> IO ProgGenSF mkPgExcels sz = mkPGXOpts mkTrieOptSFIO options{memoCondPure = \t d -> size t < sz && 0) = (/=) -- doubleCls = $(p [| (eq :: Equivalence Double) |]) excel = [$(p [| (" " :: [Char], "," :: [Char], "-" :: [Char], fromIntegral :: Int -> Double, floor :: Double -> Int, -- These two are hidden by ppExcel. 0::Int, 1::Int, (1+)::Int->Int, 3::Int, 0::Double, 1::Double, -- (1+)::Double->Double, (<) :: Int -> Int -> Bool, (<=) :: Int -> Int -> Bool, (<>) :: Int -> Int -> Bool, (<) :: Double -> Double -> Bool, -- (<=) :: Double -> Double -> Bool, (<>) :: Double -> Double -> Bool, (<>) :: [Char] -> [Char] -> Bool, not :: (->) Bool Bool, True :: Bool, False :: Bool, aND'2 :: (->) Bool ((->) Bool Bool), oR'2 :: (->) Bool ((->) Bool Bool), iF'3 :: (->) Bool (a -> a -> a), (,) :: a -> b -> (a,b), (,,) :: a -> b -> c -> (a,b,c), (,,,) :: a -> b -> c -> d -> (a,b,c,d)) |]) ++ $(p [| ( upper::[Char]->[Char], lower::[Char]->[Char], proper::[Char]->[Char], left1 :: [Char] -> [Char], right1 :: [Char] -> [Char], left'2 :: [Char] -> Int -> [Char], right'2 :: [Char] -> Int -> [Char], dropLeft :: [Char] -> Int -> [Char], mid'3 :: [Char] -> Int -> Int -> [Char], len :: (->) [Char] Int, concatenate'2 :: (->) [Char] ([Char] -> [Char]), concatenatE'3 :: (->) [Char] ([Char] -> [Char] -> [Char]), concatenaTE'4 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char]), concatenATE'5 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char] -> [Char]), concateNATE'6 :: (->) [Char] ([Char] -> [Char] -> [Char] -> [Char] -> [Char] -> [Char]), {- sum :: [Double] -> Double, product :: [Double] -> Double, max :: [Double] -> Double, min :: [Double] -> Double, average :: [Double] -> Double, count :: [Double] -> Double, sumif :: [Maybe Double] -> Double, -} flip cEILING'2 . abs :: Double -> (->) Double Double, fLOOR0 :: (->) Double (Double -> Double), rOUND'2 :: (->) Double (Int -> Double), roundup'2 :: (->) Double (Int -> Double), rounddown'2 :: (->) Double (Int -> Double), trim::[Char]->[Char], fIND'3 :: [Char] -> [Char] -> Int -> Maybe Int, ifERROR'2 :: Maybe a -> a -> a, fact :: Int -> Maybe Int, combin'2 :: Int -> Int -> Maybe Int, mOD'2 :: Int -> Int -> Maybe Int, degrees :: Double -> Double, radians :: Double -> Double, findIx :: [Char] -> [Char] -> Int -> Int, sUBsTITUTE'3 :: [Char] -> [Char] -> [Char] -> [Char], sUBST4 :: [Char] -> [Char] -> [Char] -> Int -> [Char], countStr :: [Char] -> [Char] -> Int, negate :: Int -> Int, abs :: Int -> Int, (+) :: (->) Int ((->) Int Int), (-) :: Int -> Int -> Int, (*) :: Int -> Int -> Int, 10 :: Double, 100 :: Double, 1000 :: Double, negate :: Double -> Double, abs :: Double -> Double, sign :: Double -> Double, -- recip :: Double -> Double, -- (1/) だけど、まあ(/)と1で作れるし、いらんやろ。 (+) :: (->) Double ((->) Double Double), (-) :: Double -> Double -> Double, (*) :: Double -> Double -> Double, (/) :: Double -> Double -> Double, -- 本当はエラー処理すべし。 -- fromIntegral :: Int -> Double, pI () :: Double ) |]), $(p [| ( exp :: Double -> Double, ln :: Double -> Maybe Double, sQRT :: Double -> Maybe Double, power'2 :: Double -> Double -> Maybe Double, lOG'2 :: Double -> Double -> Maybe Double, sin :: Double -> Double, cos :: Double -> Double, tan :: Double -> Double, asin :: Double -> Double, -- この辺もエラー処理せんと。 acos :: Double -> Double, atan :: Double -> Double, sinh :: Double -> Double, cosh :: Double -> Double, tanh :: Double -> Double, asinh :: Double -> Double, acosh :: Double -> Double, atanh :: Double -> Double, -- floatDigits :: Double -> Int, -- exponent :: Double -> Int, -- significand :: Double -> Double, -- scaleFloat :: Int -> Double -> Double, aTAN2'2 :: Double -> Double -> Double ) |]), [] ]