{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module Main(main) where import Control.Monad.Identity import Data.Function (on) import Data.List (group, groupBy, intercalate, sort) import Data.Map (Map) import qualified Data.Map as M groupOn f = groupBy ((==) `on` f) class Pretty t where pretty :: t -> String data SymbolicB v = Number Integer | Variable v | Add (SymbolicB v) (SymbolicB v) | Mul (SymbolicB v) (SymbolicB v) deriving (Eq, Ord, Read, Show) k = 3 :: Int problem = let aa w z = sum [ a i j * w^i * z^j | i <- [0..k], j <- [0..k] ] bb w z = sum [ b i j * w^i * z^j | i <- [0..k], j <- [0..k] ] a _ 0 = 0 -- composition of periodics a i j = Variable $ "a" ++ show i ++ "," ++ show j ++ "" b _ 0 = 0 -- periodic b i j = Variable $ "b" ++ show i ++ "," ++ show j ++ "" zz = Variable "z" ww = Variable "w" dd = Variable "d" in aa ww (bb (ww + dd) zz) count a = length . filter (a ==) instance Num (SymbolicB v) where fromInteger = Number negate = Mul (Number (-1)) (+) = Add (*) = Mul instance Pretty (SymbolicB String) where pretty (Number n) = show n pretty (Variable v) = v pretty (Add a b) = "(" ++ pretty a ++ "+" ++ pretty b ++ ")" pretty (Mul a b) = "(" ++ pretty a ++ "×" ++ pretty b ++ ")" data SymbolicL v = LNumber Integer | LVariable v | LAdd [SymbolicL v] | LMul [SymbolicL v] deriving (Eq, Ord, Read, Show) instance Num (SymbolicL v) where fromInteger = LNumber negate a = LMul [LNumber (-1), a] a + b = LAdd [a, b] a * b = LMul [a, b] instance Pretty (SymbolicL String) where pretty (LNumber n) = show n pretty (LVariable v) = v pretty (LAdd []) = "0" pretty (LAdd xs) = "(" ++ intercalate " + " (map pretty xs) ++ ")" pretty (LMul []) = "1" pretty (LMul xs) = concatMap pretty1 (group xs) where pretty1 g@(x:_) = case x of LNumber 1 -> "" _ -> case length g of 1 -> pretty x m -> pretty x ++ "" ++ show m ++ "" instance (Num s, Pretty s) => Pretty (Map [Int] s) where pretty m = let [mw,mz] = [k,k]--map maximum . transpose . M.keys $ m in "" ++ (concat ["" | i <- [0..mw]]) ++ "" ++ concat [ (if j == 0 then "" else "") ++ "" ++ (concat ["" | i <- [0..mw]]) ++ "" | j <- [0..mz] ] ++ "
ci,ji
" ++ show i ++ "
j" ++ show j ++ "" ++ pretty (M.findWithDefault 0 [i,j] m) ++ "
" sop (Number 0) = LAdd [] sop (Number 1) = LAdd [LMul []] sop (Number n) = LAdd [LMul [LNumber n]] sop (Variable v) = LAdd [LMul [LVariable v]] sop (Add a b) = case (sop a, sop b) of (LAdd as, LAdd bs) -> LAdd (as ++ bs) sop (Mul a b) = case (sop a, sop b) of (LAdd as, LAdd bs) -> LAdd [LMul (a' ++ b') | LMul a' <- as, LMul b' <- bs] multivariate vars (LAdd es) = M.unionsWith add (map collect es) where add (LAdd as) (LAdd bs) = LAdd (as ++ bs) collect (LMul fs) = M.singleton (map (`count` fs) vars) (LAdd [LMul $ filter (`notElem` vars) fs]) unmultivariate vars m = LAdd [ LMul (xs : concat (zipWith replicate ys vars)) | (ys, xs) <- M.assocs m ] sort' n@(LNumber _) = n sort' v@(LVariable _) = v sort' (LMul xs) = LMul (sort (map sort' xs)) sort' (LAdd xs) = LAdd (sort (map sort' xs)) combine (LAdd xs) = LAdd . map (\l@((_,ys):_) -> LMul $ LNumber (sum (map fst l)) : reverse ys) . groupOn snd . map (fmap reverse) $ [ acc (1, ys) | LMul ys <- xs ] where acc (x, LNumber n : ys) = acc (x * n, ys) acc (x, ys) = (x, ys) prune ks = M.filterWithKey $ \ns _ -> and (zipWith (<=) ns ks) main1 = pretty t where d = LVariable "d" w = LVariable "w" z = LVariable "z" o v n = LVariable ("O(" ++ pretty v ++ "" ++ show n ++ ")") t = runIdentity $ do s <- pure $ problem s <- pure $ sop s s <- pure $ sort' s s <- pure $ multivariate [w, z] s s <- pure $ prune [k, k] s s <- pure $ fmap combine s s <- pure $ fmap (multivariate [d]) s s <- pure $ fmap (prune [k]) s s <- pure $ fmap (\m -> case unmultivariate [d] m of LAdd xs -> LAdd (xs ++ [o d (k + 1)])) s pure s instance Pretty String where pretty s = s header = [ "" , "" , "" , "" , "" , "Bivariate Series Composition" , "" , "" , "" , "

Bivariate Series Composition:" , "A(w,z)=∑ai,jwizj," , "B(w,z)=∑bi,jwizj," , "C(w,z)=∑ci,jwizj =" , "A(w,B(w+d,z))" , "

" ] footer = [ "" , "" ] main = putStr . unlines $ header ++ [main1] ++ footer