├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── DDF ├── Bimap.hs ├── Bool.hs ├── Char.hs ├── DBI.hs ├── Diff.hs ├── DiffWrapper.hs ├── Double.hs ├── Dual.hs ├── Eval.hs ├── Fix.hs ├── Float.hs ├── FreeVector.hs ├── IO.hs ├── ImpW.hs ├── ImportMeta.hs ├── Int.hs ├── Lang.hs ├── List.hs ├── Map.hs ├── Meta │ ├── Diff.hs │ ├── DiffWrapper.hs │ ├── Dual.hs │ ├── FreeVector.hs │ ├── Util.hs │ └── VectorTF.hs ├── Option.hs ├── Ordering.hs ├── PE.hs ├── Prod.hs ├── Sam │ ├── Hello.lhs │ ├── Poly.lhs │ └── Xor.lhs ├── Show.hs ├── Size.hs ├── Sum.hs ├── Term.hs ├── TermGen.hs ├── Unit.hs ├── Vector.hs ├── VectorTF.hs ├── WithDiff.hs └── Y.hs ├── DeepDarkFantasy.cabal ├── LICENSE ├── NOTICE ├── README.md ├── Setup.hs ├── Talk ├── Talk.pdf └── Talk.pptx ├── img ├── I_Want_You.png └── I_Want_You_Image_Courtesy.png ├── stack.yaml └── test ├── TestPE.hs ├── TestPoly.hs └── TestXor.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .idea/ 2 | target/ 3 | local.sbt 4 | dist/ 5 | *.o 6 | *.hi 7 | .stack-work/ 8 | *.exe 9 | *~ 10 | *.tix -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | sudo: false 3 | 4 | git: 5 | submodules: false 6 | 7 | cache: 8 | directories: 9 | - $HOME/.stack 10 | 11 | addons: 12 | apt: 13 | packages: 14 | - libgmp-dev 15 | 16 | before_install: 17 | - mkdir -p ~/.local/bin 18 | - export PATH=$HOME/.local/bin:$PATH 19 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 20 | 21 | 22 | install: 23 | - stack --no-terminal --install-ghc test --only-dependencies 24 | 25 | script: 26 | - stack test --coverage --no-terminal 27 | - stack install hpc-coveralls 28 | 29 | after_script: 30 | - travis_retry curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.4.0/shc-linux-x64-8.0.1.tar.bz2 | tar -xj 31 | - ./shc DeepDarkFantasy TestXor TestPoly TestPE -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | There are 2 easy ways to contribute to DDF. They are also great way to get knowledge of DDF quickly. 2 | 3 | 0: Write some test and increase the coverage. 4 | 5 | 1: Write an example, which is a lhs library file, inside directory DDF.Sam. 6 | The example can probably be turned into test to increase the coverage, so feel free to do that. 7 | 8 | But, dont worry if you are decreasing the coverage, we just treat it as some sort of eye-candy. 9 | -------------------------------------------------------------------------------- /DDF/Bimap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | UndecidableSuperClasses, 5 | TypeApplications, 6 | ScopedTypeVariables 7 | #-} 8 | 9 | module DDF.Bimap (module DDF.Bimap, module DDF.Prod, module DDF.Option) where 10 | 11 | import qualified DDF.Map as Map 12 | import DDF.Prod 13 | import DDF.Option 14 | import DDF.Int 15 | import qualified Data.Bimap as M 16 | import qualified Prelude as M 17 | import qualified Data.Map as M 18 | 19 | class (Int r, Map.Map r) => Bimap r where 20 | size :: r h (M.Bimap a b -> M.Int) 21 | lookupL :: forall h a b. (Ord r a, Ord r b) => r h (M.Bimap a b -> a -> Maybe b) 22 | lookupL = withDict (getOrdC @r @a Proxy) $ withDict (getOrdC @r @b Proxy) lookupL' 23 | lookupL' :: (OrdWC r a, OrdWC r b) => r h (M.Bimap a b -> a -> Maybe b) 24 | lookupR :: forall h a b. (Ord r a, Ord r b) => r h (M.Bimap a b -> b -> Maybe a) 25 | lookupR = withDict (getOrdC @r @a Proxy) $ withDict (getOrdC @r @b Proxy) lookupR' 26 | lookupR' :: (OrdWC r a, OrdWC r b) => r h (M.Bimap a b -> b -> Maybe a) 27 | empty :: r h (M.Bimap a b) 28 | singleton :: r h ((a, b) -> M.Bimap a b) 29 | toMapL :: r h (M.Bimap a b -> M.Map a b) 30 | toMapR :: r h (M.Bimap a b -> M.Map b a) 31 | insert :: forall h a b. (Ord r a, Ord r b) => r h ((a, b) -> M.Bimap a b -> M.Bimap a b) 32 | insert = withDict (getOrdC @r @a Proxy) $ withDict (getOrdC @r @b Proxy) insert' 33 | insert' :: (OrdWC r a, OrdWC r b) => r h ((a, b) -> M.Bimap a b -> M.Bimap a b) 34 | updateL :: forall h a b. (Ord r a, Ord r b) => r h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b) 35 | updateL = withDict (getOrdC @r @a Proxy) $ withDict (getOrdC @r @b Proxy) updateL' 36 | updateL' :: (OrdWC r a, OrdWC r b) => r h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b) 37 | updateR :: forall h a b. (Ord r a, Ord r b) => r h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b) 38 | updateR = withDict (getOrdC @r @a Proxy) $ withDict (getOrdC @r @b Proxy) updateR' 39 | updateR' :: (OrdWC r a, OrdWC r b) => r h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b) 40 | 41 | lookupL2 = app2 lookupL 42 | size1 = app size 43 | insert2 = app2 insert 44 | -------------------------------------------------------------------------------- /DDF/Bool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-} 2 | module DDF.Bool (module DDF.Bool, module DDF.DBI) where 3 | 4 | import DDF.DBI 5 | import qualified Prelude as M 6 | 7 | class DBI r => Bool r where 8 | bool :: M.Bool -> r h M.Bool 9 | true :: r h M.Bool 10 | true = bool M.True 11 | false :: r h M.Bool 12 | false = bool M.False 13 | ite :: r h (a -> a -> M.Bool -> a) 14 | 15 | ite1 = app ite 16 | ite2 = app2 ite 17 | ite3 = app3 ite 18 | -------------------------------------------------------------------------------- /DDF/Char.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module DDF.Char (module DDF.Char, module DDF.DBI) where 3 | 4 | import DDF.DBI 5 | import qualified Prelude as M 6 | 7 | class DBI r => Char r where 8 | char :: M.Char -> r h M.Char 9 | -------------------------------------------------------------------------------- /DDF/DBI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | MultiParamTypeClasses, 3 | RankNTypes, 4 | ScopedTypeVariables, 5 | FlexibleInstances, 6 | FlexibleContexts, 7 | UndecidableInstances, 8 | PolyKinds, 9 | LambdaCase, 10 | NoMonomorphismRestriction, 11 | TypeFamilies, 12 | LiberalTypeSynonyms, 13 | FunctionalDependencies, 14 | ExistentialQuantification, 15 | InstanceSigs, 16 | ConstraintKinds, 17 | DefaultSignatures, 18 | TypeOperators, 19 | TypeApplications, 20 | PartialTypeSignatures, 21 | NoImplicitPrelude 22 | #-} 23 | 24 | module DDF.DBI (module DDF.DBI, module DDF.ImportMeta) where 25 | import DDF.ImportMeta 26 | 27 | class Monoid r m where 28 | zero :: r h m 29 | plus :: r h (m -> m -> m) 30 | 31 | class DBI (r :: * -> * -> *) where 32 | z :: r (a, h) a 33 | s :: r h b -> r (a, h) b 34 | abs :: r (a, h) b -> r h (a -> b) 35 | app :: r h (a -> b) -> r h a -> r h b 36 | -- | We use a variant of HOAS so it can be compile to DBI, which is more compositional (No Negative Occurence). 37 | -- It require explicit lifting of variables. 38 | -- Use lam to do automatic lifting of variables. 39 | hoas :: (r (a, h) a -> r (a, h) b) -> r h (a -> b) 40 | hoas f = abs $ f z 41 | com :: r h ((b -> c) -> (a -> b) -> (a -> c)) 42 | com = lam3 $ \f g x -> app f (app g x) 43 | flip :: r h ((a -> b -> c) -> (b -> a -> c)) 44 | flip = lam3 $ \f b a -> app2 f a b 45 | id :: r h (a -> a) 46 | id = lam $ \x -> x 47 | const :: r h (a -> b -> a) 48 | const = lam2 $ \x _ -> x 49 | scomb :: r h ((a -> b -> c) -> (a -> b) -> (a -> c)) 50 | scomb = lam3 $ \f x arg -> app2 f arg (app x arg) 51 | dup :: r h ((a -> a -> b) -> (a -> b)) 52 | dup = lam2 $ \f x -> app2 f x x 53 | let_ :: r h (a -> (a -> b) -> b) 54 | let_ = flip1 id 55 | 56 | class LiftEnv r where 57 | liftEnv :: r () a -> r h a 58 | 59 | const1 = app const 60 | map2 = app2 map 61 | return = pure 62 | bind2 = app2 bind 63 | map1 = app map 64 | join1 = app join 65 | bimap2 = app2 bimap 66 | bimap3 = app3 bimap 67 | flip1 = app flip 68 | flip2 = app2 flip 69 | let_2 = app2 let_ 70 | 71 | class DBI r => Functor r f where 72 | map :: r h ((a -> b) -> (f a -> f b)) 73 | 74 | class Functor r a => Applicative r a where 75 | pure :: r h (x -> a x) 76 | ap :: r h (a (x -> y) -> a x -> a y) 77 | pure1 = app1 pure 78 | ap1 = app1 ap 79 | ap2 = app2 ap 80 | 81 | class Applicative r m => Monad r m where 82 | bind :: r h (m a -> (a -> m b) -> m b) 83 | join :: r h (m (m a) -> m a) 84 | join = lam $ \m -> bind2 m id 85 | bind = lam2 $ \m f -> join1 (app2 map f m) 86 | {-# MINIMAL (join | bind) #-} 87 | 88 | class BiFunctor r p where 89 | bimap :: r h ((a -> b) -> (c -> d) -> p a c -> p b d) 90 | 91 | com2 = app2 com 92 | 93 | class NT repr l r where 94 | conv :: repr l t -> repr r t 95 | 96 | class NTS repr l r where 97 | convS :: repr l t -> repr r t 98 | 99 | instance (DBI repr, NT repr l r) => NTS repr l (a, r) where 100 | convS = s . conv 101 | 102 | instance {-# OVERLAPPABLE #-} NTS repr l r => NT repr l r where 103 | conv = convS 104 | 105 | instance {-# OVERLAPPING #-} NT repr x x where 106 | conv x = x 107 | 108 | lam :: forall repr a b h. DBI repr => 109 | ((forall k. NT repr (a, h) k => repr k a) -> (repr (a, h)) b) -> 110 | repr h (a -> b) 111 | lam f = hoas (\x -> f $ conv x) 112 | 113 | lam2 :: forall repr a b c h. DBI repr => 114 | ((forall k. NT repr (a, h) k => repr k a) -> 115 | (forall k. NT repr (b, (a, h)) k => repr k b) -> 116 | (repr (b, (a, h))) c) -> 117 | repr h (a -> b -> c) 118 | lam2 f = lam $ \x -> lam $ \y -> f x y 119 | 120 | lam3 f = lam2 $ \a b -> lam $ \c -> f a b c 121 | 122 | lam4 f = lam3 $ \a b c -> lam $ \d -> f a b c d 123 | 124 | app1 = app 125 | 126 | app2 f a = app (app1 f a) 127 | 128 | app3 f a b = app (app2 f a b) 129 | 130 | app4 f a b c = app (app3 f a b c) 131 | 132 | app5 f a b c d = app (app4 f a b c d) 133 | 134 | plus2 = app2 plus 135 | 136 | noEnv :: repr () x -> repr () x 137 | noEnv x = x 138 | 139 | scomb2 = app2 scomb 140 | plus1 = app plus 141 | dup1 = app dup 142 | -------------------------------------------------------------------------------- /DDF/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | ExplicitForAll, 4 | InstanceSigs, 5 | ScopedTypeVariables, 6 | TypeApplications, 7 | FlexibleContexts, 8 | UndecidableInstances, 9 | TypeFamilies, 10 | MultiParamTypeClasses, 11 | TypeOperators, 12 | DataKinds, 13 | FlexibleInstances, 14 | UndecidableSuperClasses 15 | #-} 16 | 17 | module DDF.Diff where 18 | 19 | import DDF.Lang 20 | import qualified Prelude as M 21 | import qualified Data.Map as M 22 | import qualified DDF.Map as Map 23 | import qualified Data.Bimap as M 24 | import qualified DDF.Meta.Dual as M 25 | import qualified DDF.VectorTF as VTF 26 | import qualified DDF.Meta.DiffWrapper as M.DW 27 | import qualified Data.Functor.Foldable as M 28 | import qualified DDF.Meta.FreeVector as M 29 | import qualified DDF.Meta.VectorTF as M.VTF 30 | import DDF.Vector 31 | 32 | type instance OrdC (Diff r v) = DiffOrdC r v 33 | 34 | class Ord r (DiffType v x) => DiffOrdC r v x 35 | instance Ord r (DiffType v x) => DiffOrdC r v x 36 | 37 | type instance DiffType v (l -> r) = DiffType v l -> DiffType v r 38 | instance DBI r => DBI (Diff r v) where 39 | z = Diff z 40 | s (Diff x) = Diff $ s x 41 | abs (Diff f) = Diff $ abs f 42 | app (Diff f) (Diff x) = Diff $ app f x 43 | hoas f = Diff $ hoas (\x -> runDiff $ f $ Diff x) 44 | 45 | type instance DiffType v M.Bool = M.Bool 46 | instance Bool r => Bool (Diff r v) where 47 | bool x = Diff $ bool x 48 | ite = Diff ite 49 | 50 | type instance DiffType v M.Char = M.Char 51 | instance Char r => Char (Diff r v) where 52 | char = Diff . char 53 | 54 | type instance DiffType v (l, r) = (DiffType v l, DiffType v r) 55 | instance Prod r => Prod (Diff r v) where 56 | mkProd = Diff mkProd 57 | zro = Diff zro 58 | fst = Diff fst 59 | 60 | type instance DiffType v (M.Dual l r) = M.Dual (DiffType v l) (DiffType v r) 61 | instance Dual r => Dual (Diff r v) where 62 | dual = Diff $ dual 63 | runDual = Diff $ runDual 64 | dualGetOrdC :: forall x y. Ord (Diff r v) x :- OrdC (Diff r v) (M.Dual x y) 65 | dualGetOrdC = Sub (withDict (getOrdC @(Diff r v) @x Proxy) Dict) 66 | 67 | type instance DiffType v M.Double = M.Dual M.Double v 68 | instance (Vector r v, Lang r) => Double (Diff r v) where 69 | double x = Diff $ mkDual2 (double x) zero 70 | doublePlus = Diff $ lam2 $ \l r -> 71 | mkDual2 (plus2 (dualOrig1 l) (dualOrig1 r)) (plus2 (dualDiff1 l) (dualDiff1 r)) 72 | doubleMinus = Diff $ lam2 $ \l r -> 73 | mkDual2 (minus2 (dualOrig1 l) (dualOrig1 r)) (minus2 (dualDiff1 l) (dualDiff1 r)) 74 | doubleMult = Diff $ lam2 $ \l r -> 75 | mkDual2 (mult2 (dualOrig1 l) (dualOrig1 r)) 76 | (plus2 (mult2 (dualOrig1 l) (dualDiff1 r)) (mult2 (dualOrig1 r) (dualDiff1 l))) 77 | doubleDivide = Diff $ lam2 $ \l r -> 78 | mkDual2 (divide2 (dualOrig1 l) (dualOrig1 r)) 79 | (divide2 (minus2 (mult2 (dualOrig1 r) (dualDiff1 l)) (mult2 (dualOrig1 l) (dualDiff1 r))) 80 | (mult2 (dualOrig1 r) (dualOrig1 r))) 81 | doubleExp = Diff $ lam $ \x -> let_2 (doubleExp1 (dualOrig1 x)) (lam $ \e -> mkDual2 e (mult2 e (dualDiff1 x))) 82 | doubleCmp = Diff $ lam2 $ \l r -> cmp2 (dualOrig1 l) (dualOrig1 r) 83 | 84 | type instance DiffType v M.Float = M.Dual M.Float v 85 | instance (Vector r v, Lang r) => Float (Diff r v) where 86 | float x = Diff $ mkDual2 (float x) zero 87 | floatPlus = Diff $ lam2 $ \l r -> 88 | mkDual2 (plus2 (dualOrig1 l) (dualOrig1 r)) (plus2 (dualDiff1 l) (dualDiff1 r)) 89 | floatMinus = Diff $ lam2 $ \l r -> 90 | mkDual2 (minus2 (dualOrig1 l) (dualOrig1 r)) (minus2 (dualDiff1 l) (dualDiff1 r)) 91 | floatMult = Diff $ lam2 $ \l r -> 92 | mkDual2 (mult2 (float2Double1 (dualOrig1 l)) (dualOrig1 r)) 93 | (plus2 (mult2 (float2Double1 (dualOrig1 l)) (dualDiff1 r)) (mult2 (float2Double1 (dualOrig1 r)) (dualDiff1 l))) 94 | floatDivide = Diff $ lam2 $ \l r -> 95 | mkDual2 (divide2 (dualOrig1 l) (float2Double1 (dualOrig1 r))) 96 | (divide2 (minus2 (mult2 (float2Double1 (dualOrig1 r)) (dualDiff1 l)) (mult2 (float2Double1 (dualOrig1 l)) (dualDiff1 r))) 97 | (float2Double1 (mult2 (float2Double1 (dualOrig1 r)) (dualOrig1 r)))) 98 | floatExp = Diff (lam $ \x -> let_2 (floatExp1 (dualOrig1 x)) (lam $ \e -> mkDual2 e (mult2 (float2Double1 e) (dualDiff1 x)))) 99 | 100 | type instance DiffType v (Maybe l) = Maybe (DiffType v l) 101 | instance Option r => Option (Diff r v) where 102 | nothing = Diff nothing 103 | just = Diff just 104 | optionMatch = Diff optionMatch 105 | 106 | type instance DiffType v (M.Map k val) = M.Map (DiffType v k) (DiffType v val) 107 | instance Map.Map r => Map.Map (Diff r v) where 108 | empty = Diff Map.empty 109 | singleton' = Diff Map.singleton 110 | mapMap = Diff Map.mapMap 111 | lookup' = Diff Map.lookup 112 | alter' = Diff Map.alter 113 | unionWithKey' = Diff Map.unionWithKey 114 | 115 | type instance DiffType v (M.Bimap a b) = M.Bimap (DiffType v a) (DiffType v b) 116 | instance Bimap r => Bimap (Diff r v) where 117 | size = Diff size 118 | toMapL = Diff toMapL 119 | toMapR = Diff toMapR 120 | empty = Diff empty 121 | singleton = Diff singleton 122 | lookupL' = Diff lookupL 123 | lookupR' = Diff lookupR 124 | insert' = Diff insert 125 | updateL' = Diff updateL 126 | updateR' = Diff updateR 127 | 128 | type instance DiffType v () = () 129 | instance Unit r => Unit (Diff r v) where 130 | unit = Diff unit 131 | 132 | type instance DiffType v (M.Either l r) = M.Either (DiffType v l) (DiffType v r) 133 | instance Sum r => Sum (Diff r v) where 134 | left = Diff left 135 | right = Diff right 136 | sumMatch = Diff sumMatch 137 | 138 | instance Int r => Int (Diff r v) where 139 | int = Diff . int 140 | pred = Diff pred 141 | intCmp = Diff intCmp 142 | 143 | instance Y r => Y (Diff r v) where 144 | y = Diff y 145 | 146 | type instance DiffType v (M.IO l) = M.IO (DiffType v l) 147 | instance IO r => IO (Diff r v) where 148 | putStrLn = Diff putStrLn 149 | ioMap = Diff ioMap 150 | ioPure = Diff ioPure 151 | ioAP = Diff ioAP 152 | ioBind = Diff ioBind 153 | ioJoin = Diff ioJoin 154 | 155 | type instance DiffType v [l] = [DiffType v l] 156 | instance List r => List (Diff r v) where 157 | nil = Diff nil 158 | cons = Diff cons 159 | listMatch = Diff listMatch 160 | 161 | instance (Vector r v, Lang r) => VTF.VectorTF (Diff r v) where 162 | zero = Diff VTF.zero 163 | basis = Diff VTF.basis 164 | plus = Diff VTF.plus 165 | mult = Diff $ VTF.mult `com2` dualOrig 166 | vtfMatch = Diff $ lam4 $ \ze b p m -> VTF.vtfMatch4 ze b p $ lam $ \x -> app m (mkDual2 x zero) 167 | vtfCmp = Diff VTF.vtfCmp 168 | vtfGetOrdC :: forall t f. (Ord (Diff r v) t, Ord (Diff r v) f) :- OrdC (Diff r v) (M.VTF.VectorTF t f) 169 | vtfGetOrdC = Sub (withDict (getOrdC @(Diff r v) @t Proxy) (withDict (getOrdC @(Diff r v) @f Proxy) Dict)) 170 | 171 | type instance DiffType v (M.DW.DiffWrapper a x) = M.DW.DiffWrapper (v ': a) x 172 | instance DiffWrapper r => DiffWrapper (Diff r v) where 173 | diffWrapper = Diff diffWrapper 174 | runDiffWrapper = Diff runDiffWrapper 175 | 176 | type instance DiffType v (M.Fix f) = M.DW.DiffWrapper '[v] (f (M.Fix f)) 177 | instance DiffWrapper r => Fix (Diff r v) where 178 | fix = Diff diffWrapper 179 | runFix = Diff runDiffWrapper 180 | 181 | type instance DiffType v (M.FreeVector a b) = M.FreeVector (DiffType v a) (DiffType v b) 182 | instance FreeVector r => FreeVector (Diff r v) where 183 | freeVector = Diff freeVector 184 | runFreeVector = Diff runFreeVector 185 | 186 | type instance DiffType v Void = Void 187 | type instance DiffType v (Writer l r) = Writer (DiffType v l) (DiffType v r) 188 | type instance DiffType v (State l r) = State (DiffType v l) (DiffType v r) 189 | instance (Vector r v, Lang r) => Lang (Diff r v) where 190 | exfalso = Diff exfalso 191 | writer = Diff writer 192 | runWriter = Diff runWriter 193 | float2Double = Diff $ bimap2 float2Double id 194 | double2Float = Diff $ bimap2 double2Float id 195 | state = Diff state 196 | runState = Diff runState 197 | 198 | type instance DiffType v M.Ordering = M.Ordering 199 | 200 | instance Ordering r => Ordering (Diff r v) where 201 | ordering = Diff . ordering 202 | sel = Diff sel 203 | -------------------------------------------------------------------------------- /DDF/DiffWrapper.hs: -------------------------------------------------------------------------------- 1 | module DDF.DiffWrapper (module DDF.DiffWrapper, module DDF.DBI) where 2 | 3 | import DDF.DBI 4 | import DDF.Meta.DiffWrapper as DW 5 | 6 | class DBI r => DiffWrapper r where 7 | diffWrapper :: r h (DW.FDiffType a x -> DW.DiffWrapper a x) 8 | runDiffWrapper :: r h (DW.DiffWrapper a x -> DW.FDiffType a x) -------------------------------------------------------------------------------- /DDF/Double.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | FlexibleInstances, 5 | MultiParamTypeClasses, 6 | UndecidableInstances, 7 | UndecidableSuperClasses 8 | #-} 9 | 10 | module DDF.Double (module DDF.Double, module DDF.Ordering) where 11 | 12 | import DDF.Ordering 13 | import qualified Prelude as M 14 | 15 | class (OrdC r M.Double, Ordering r) => Double r where 16 | double :: M.Double -> r h M.Double 17 | doubleZero :: r h M.Double 18 | doubleZero = double 0 19 | doubleOne :: r h M.Double 20 | doubleOne = double 1 21 | doublePlus :: r h (M.Double -> M.Double -> M.Double) 22 | doubleMinus :: r h (M.Double -> M.Double -> M.Double) 23 | doubleMult :: r h (M.Double -> M.Double -> M.Double) 24 | doubleDivide :: r h (M.Double -> M.Double -> M.Double) 25 | doubleExp :: r h (M.Double -> M.Double) 26 | doubleCmp :: r h (M.Double -> M.Double -> M.Ordering) 27 | 28 | instance Double r => Ord r M.Double where 29 | cmp = doubleCmp 30 | getOrdC _ = Dict 31 | 32 | doublePlus1 = app doublePlus 33 | doublePlus2 = app2 doublePlus 34 | doubleMinus2 = app2 doubleMinus 35 | doubleMult2 = app2 doubleMult 36 | doubleDivide2 = app2 doubleDivide 37 | doubleExp1 = app doubleExp 38 | -------------------------------------------------------------------------------- /DDF/Dual.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | FlexibleInstances, 5 | MultiParamTypeClasses, 6 | TypeOperators, 7 | TypeApplications, 8 | ScopedTypeVariables 9 | #-} 10 | 11 | module DDF.Dual (module DDF.Dual, module DDF.Prod) where 12 | 13 | import DDF.Prod 14 | import qualified DDF.Meta.Dual as M 15 | 16 | class Prod r => Dual r where 17 | dual :: r h ((x, y) -> M.Dual x y) 18 | runDual :: r h (M.Dual x y -> (x, y)) 19 | mkDual :: r h (x -> y -> M.Dual x y) 20 | mkDual = curry1 dual 21 | dualOrig :: r h (M.Dual x y -> x) 22 | dualOrig = zro `com2` runDual 23 | dualDiff :: r h (M.Dual x y -> y) 24 | dualDiff = fst `com2` runDual 25 | dualCmp :: r h (Cmp x -> Cmp (M.Dual x y)) 26 | dualCmp = cmpMap1 dualOrig 27 | dualGetOrdC :: Ord r x :- OrdC r (M.Dual x y) 28 | 29 | dual1 = app dual 30 | mkDual2 = app2 mkDual 31 | dualOrig1 = app dualOrig 32 | dualDiff1 = app dualDiff 33 | runDual1 = app1 runDual 34 | 35 | instance (Ord r x, Dual r) => Ord r (M.Dual x y) where 36 | cmp = app dualCmp cmp 37 | getOrdC _ = Dict \\ dualGetOrdC @r @x @y 38 | -------------------------------------------------------------------------------- /DDF/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | LambdaCase, 4 | TypeFamilies, 5 | FlexibleContexts, 6 | MultiParamTypeClasses, 7 | FlexibleInstances 8 | #-} 9 | 10 | module DDF.Eval where 11 | 12 | import DDF.Lang 13 | import qualified Prelude as M 14 | import qualified Control.Monad.Writer as M (WriterT(WriterT), runWriter) 15 | import qualified Control.Monad.State as M 16 | import qualified GHC.Float as M 17 | import qualified Data.Functor.Identity as M 18 | import qualified Data.Bool as M 19 | import qualified Data.Map as M.Map 20 | import qualified DDF.Meta.Dual as M 21 | import qualified DDF.Map as Map 22 | import qualified DDF.Meta.VectorTF as M.VTF 23 | import qualified Data.Bimap as M.Bimap 24 | import qualified DDF.VectorTF as VTF 25 | import qualified DDF.Meta.DiffWrapper as M.DW 26 | import qualified Data.Functor.Foldable as M 27 | import qualified DDF.Meta.FreeVector as M 28 | import qualified DDF.Meta.Util as M 29 | 30 | newtype Eval h x = Eval {runEval :: h -> x} 31 | 32 | comb = Eval . M.const 33 | 34 | type instance OrdC Eval = NoOrdC 35 | 36 | instance DBI Eval where 37 | z = Eval M.fst 38 | s (Eval a) = Eval $ a . M.snd 39 | abs (Eval f) = Eval $ \h a -> f (a, h) 40 | app (Eval f) (Eval x) = Eval $ \h -> f h $ x h 41 | 42 | instance Bool Eval where 43 | bool = comb 44 | ite = comb M.bool 45 | 46 | instance Char Eval where 47 | char = comb 48 | 49 | instance Prod Eval where 50 | mkProd = comb (,) 51 | zro = comb M.fst 52 | fst = comb M.snd 53 | 54 | instance Double Eval where 55 | double = comb 56 | doublePlus = comb (+) 57 | doubleMinus = comb (-) 58 | doubleMult = comb (*) 59 | doubleDivide = comb (/) 60 | doubleExp = comb M.exp 61 | doubleCmp = comb M.compare 62 | 63 | instance Float Eval where 64 | float = comb 65 | floatPlus = comb (+) 66 | floatMinus = comb (-) 67 | floatMult = comb (*) 68 | floatDivide = comb (/) 69 | floatExp = comb M.exp 70 | 71 | instance Option Eval where 72 | nothing = comb M.Nothing 73 | just = comb M.Just 74 | optionMatch = comb $ \l r -> \case 75 | M.Nothing -> l 76 | M.Just x -> r x 77 | 78 | instance Map.Map Eval where 79 | empty = comb M.Map.empty 80 | singleton = comb M.Map.singleton 81 | lookup' = flip1 $ comb M.Map.lookup 82 | alter' = comb M.Map.alter 83 | mapMap = comb M.fmap 84 | unionWithKey' = comb M.Map.unionWithKey 85 | 86 | instance Bimap Eval where 87 | size = comb M.Bimap.size 88 | lookupL' = flip1 $ comb M.Bimap.lookup 89 | lookupR' = flip1 $ comb M.Bimap.lookupR 90 | toMapL = comb M.Bimap.toMap 91 | toMapR = comb M.Bimap.toMapR 92 | empty = comb M.Bimap.empty 93 | singleton = comb $ \(a, b) -> M.Bimap.singleton a b 94 | insert' = comb $ \(a, b) -> M.Bimap.insert a b 95 | updateL' = comb M.Bimap.update 96 | updateR' = comb M.Bimap.updateR 97 | 98 | instance Dual Eval where 99 | dual = comb M.Dual 100 | runDual = comb M.runDual 101 | dualGetOrdC = Sub Dict 102 | 103 | instance Unit Eval where 104 | unit = comb () 105 | 106 | instance Sum Eval where 107 | left = comb M.Left 108 | right = comb M.Right 109 | sumMatch = comb $ \l r -> \case 110 | M.Left x -> l x 111 | M.Right x -> r x 112 | 113 | instance Int Eval where 114 | int = comb 115 | pred = comb ((-) 1) 116 | intCmp = comb M.compare 117 | 118 | instance Y Eval where 119 | y = comb loop 120 | where loop x = x $ loop x 121 | 122 | instance List Eval where 123 | nil = comb [] 124 | cons = comb (:) 125 | listMatch = comb $ \l r -> \case 126 | [] -> l 127 | x:xs -> r x xs 128 | 129 | instance IO Eval where 130 | putStrLn = comb M.putStrLn 131 | ioMap = comb M.fmap 132 | ioPure = comb M.pure 133 | ioAP = comb M.ap 134 | ioBind = comb (>>=) 135 | ioJoin = comb M.join 136 | 137 | instance VTF.VectorTF Eval where 138 | zero = comb M.VTF.Zero 139 | basis = comb M.VTF.Basis 140 | plus = comb M.VTF.Plus 141 | mult = comb M.VTF.Mult 142 | vtfMatch = 143 | comb $ \zr b p m -> \case 144 | M.VTF.Zero -> zr 145 | M.VTF.Basis t -> b t 146 | M.VTF.Plus l r -> p l r 147 | M.VTF.Mult l r -> m l r 148 | vtfCmp = 149 | comb $ x where 150 | x t f = c where 151 | c M.VTF.Zero M.VTF.Zero = M.EQ 152 | c M.VTF.Zero _ = M.LT 153 | c _ M.VTF.Zero = M.GT 154 | c (M.VTF.Basis l) (M.VTF.Basis r) = t l r 155 | c (M.VTF.Basis _) _ = M.LT 156 | c _ (M.VTF.Basis _) = M.GT 157 | c (M.VTF.Plus ll lr) (M.VTF.Plus rl rr) = M.chainOrd (f ll rl) (f lr rr) 158 | c (M.VTF.Plus _ _) _ = M.LT 159 | c _ (M.VTF.Plus _ _) = M.GT 160 | c (M.VTF.Mult ll lr) (M.VTF.Mult rl rr) = M.chainOrd (runEval cmp () ll rl) (f lr rr) 161 | vtfGetOrdC = Sub Dict 162 | 163 | instance DiffWrapper Eval where 164 | diffWrapper = comb M.DW.DiffWrapper 165 | runDiffWrapper = comb M.DW.runDiffWrapper 166 | 167 | instance Fix Eval where 168 | fix = comb M.Fix 169 | runFix = comb M.unfix 170 | 171 | instance FreeVector Eval where 172 | freeVector = comb M.FreeVector 173 | runFreeVector = comb M.runFreeVector 174 | 175 | instance Lang Eval where 176 | exfalso = comb absurd 177 | writer = comb (M.WriterT . M.Identity) 178 | runWriter = comb M.runWriter 179 | float2Double = comb M.float2Double 180 | double2Float = comb M.double2Float 181 | state = comb M.state 182 | runState = comb M.runState 183 | 184 | instance Ordering Eval where 185 | ordering = comb 186 | sel = comb f where 187 | f x _ _ M.LT = x 188 | f _ x _ M.EQ = x 189 | f _ _ x M.GT = x 190 | -------------------------------------------------------------------------------- /DDF/Fix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, NoImplicitPrelude #-} 2 | 3 | module DDF.Fix (module DDF.Fix, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | import qualified Data.Functor.Foldable as M 7 | 8 | class DBI r => Fix r where 9 | fix :: r h (f (M.Fix f) -> M.Fix f) 10 | runFix :: r h (M.Fix f -> f (M.Fix f)) 11 | 12 | fix1 = app fix 13 | runFix1 = app runFix -------------------------------------------------------------------------------- /DDF/Float.hs: -------------------------------------------------------------------------------- 1 | {-# Language NoMonomorphismRestriction #-} 2 | 3 | module DDF.Float (module DDF.Float, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | import qualified GHC.Float as M 7 | 8 | class DBI r => Float r where 9 | float :: M.Float -> r h M.Float 10 | floatZero :: r h M.Float 11 | floatZero = float 0 12 | floatOne :: r h M.Float 13 | floatOne = float 1 14 | floatPlus :: r h (M.Float -> M.Float -> M.Float) 15 | floatMinus :: r h (M.Float -> M.Float -> M.Float) 16 | floatMult :: r h (M.Float -> M.Float -> M.Float) 17 | floatDivide :: r h (M.Float -> M.Float -> M.Float) 18 | floatExp :: r h (M.Float -> M.Float) 19 | 20 | floatPlus1 = app1 floatPlus 21 | floatPlus2 = app2 floatPlus 22 | floatMinus1 = app1 floatMinus 23 | floatMinus2 = app2 floatMinus 24 | floatMult1 = app1 floatMult 25 | floatMult2 = app2 floatMult 26 | floatDivide1 = app1 floatDivide 27 | floatDivide2 = app2 floatDivide 28 | floatExp1 = app1 floatExp -------------------------------------------------------------------------------- /DDF/FreeVector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module DDF.FreeVector (module DDF.FreeVector, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | import qualified DDF.Meta.FreeVector as M 7 | 8 | class DBI r => FreeVector r where 9 | freeVector :: r h ((b -> d) -> M.FreeVector b d) 10 | runFreeVector :: r h (M.FreeVector b d -> (b -> d)) 11 | 12 | freeVector1 = app freeVector 13 | runFreeVector1 = app runFreeVector 14 | runFreeVector2 = app2 runFreeVector -------------------------------------------------------------------------------- /DDF/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | FlexibleContexts, 4 | NoMonomorphismRestriction, 5 | FlexibleInstances, 6 | MultiParamTypeClasses 7 | #-} 8 | 9 | module DDF.IO (module DDF.IO, module DDF.List, module DDF.Char, module DDF.Unit) where 10 | 11 | import DDF.List 12 | import DDF.Char 13 | import DDF.Unit 14 | import qualified Prelude as M 15 | 16 | string [] = nil 17 | string (c:str) = cons2 (char c) (string str) 18 | 19 | class (List r, Unit r, Char r) => IO r where 20 | putStrLn :: r h (String -> M.IO ()) 21 | ioMap :: r h ((a -> b) -> M.IO a -> M.IO b) 22 | ioPure :: r h (a -> M.IO a) 23 | ioAP :: r h (M.IO (a -> b) -> M.IO a -> M.IO b) 24 | ioBind :: r h (M.IO a -> (a -> M.IO b) -> M.IO b) 25 | ioBind = lam2 $ \m f -> join1 (map2 f m) 26 | ioJoin :: r h (M.IO (M.IO a) -> M.IO a) 27 | ioJoin = lam $ \m -> bind2 m id 28 | {-# MINIMAL putStrLn, ioMap, ioPure, ioAP, (ioBind | ioJoin) #-} 29 | 30 | instance IO r => Functor r M.IO where 31 | map = ioMap 32 | 33 | instance IO r => Applicative r M.IO where 34 | pure = ioPure 35 | ap = ioAP 36 | 37 | instance IO r => Monad r M.IO where 38 | join = ioJoin 39 | bind = ioBind 40 | 41 | putStrLn1 = app putStrLn 42 | -------------------------------------------------------------------------------- /DDF/ImpW.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | RankNTypes, 4 | InstanceSigs, 5 | ScopedTypeVariables, 6 | ExistentialQuantification, 7 | TypeFamilies, 8 | TypeApplications, 9 | FlexibleInstances, 10 | MultiParamTypeClasses, 11 | TypeOperators 12 | #-} 13 | 14 | module DDF.ImpW where 15 | 16 | import DDF.Lang 17 | import DDF.WithDiff 18 | import qualified DDF.Map as Map 19 | import qualified DDF.VectorTF as VTF 20 | import qualified Prelude as M 21 | import DDF.Meta.Util 22 | import DDF.Vector 23 | import DDF.Meta.VectorTF as M.VTF 24 | 25 | type instance OrdC (ImpW r) = Ord r 26 | 27 | class ProdCon con l r where 28 | prodCon :: (con l, con r) :- con (l, r) 29 | 30 | instance ProdCon Random l r where prodCon = Sub Dict 31 | 32 | instance ProdCon RandRange l r where prodCon = Sub Dict 33 | 34 | instance ProdCon M.Show l r where prodCon = Sub Dict 35 | 36 | instance Lang repr => ProdCon (Monoid repr) l r where prodCon = Sub Dict 37 | 38 | instance Lang repr => ProdCon (Reify repr) l r where prodCon = Sub Dict 39 | 40 | instance Lang repr => ProdCon (Vector repr) l r where prodCon = Sub Dict 41 | 42 | instance Lang repr => ProdCon (WithDiff repr) l r where prodCon = Sub Dict 43 | 44 | class Weight w where 45 | weightCon :: (con (), con M.Float, con M.Double, ForallV (ProdCon con)) :- con w 46 | 47 | instance Weight () where weightCon = Sub Dict 48 | 49 | instance Weight M.Double where weightCon = Sub Dict 50 | 51 | instance Weight M.Float where weightCon = Sub Dict 52 | 53 | instance (Weight l, Weight r) => Weight (l, r) where 54 | weightCon :: forall con. (con (), con M.Float, con M.Double, ForallV (ProdCon con)) :- con (l, r) 55 | weightCon = Sub (mapDict (prodCon \\ (instV :: (ForallV (ProdCon con) :- ProdCon con l r))) (Dict \\ weightCon @l @con \\ weightCon @r @con)) 56 | 57 | runImpW :: forall r h x. Unit r => ImpW r h x -> RunImpW r h x 58 | runImpW (ImpW x) = RunImpW x 59 | runImpW (NoImpW x) = RunImpW (const1 x :: r h (() -> x)) 60 | 61 | data RunImpW repr h x = forall w. Weight w => RunImpW (repr h (w -> x)) 62 | data ImpW repr h x = NoImpW (repr h x) | forall w. Weight w => ImpW (repr h (w -> x)) 63 | type RunImpWR repr h x = forall r. (forall w. Weight w => repr h (w -> x) -> r) -> r 64 | 65 | runImpW2RunImpWR :: RunImpW repr h x -> RunImpWR repr h x 66 | runImpW2RunImpWR (RunImpW x) = \f -> f x 67 | 68 | runImpWR2RunImpW :: RunImpWR repr h x -> RunImpW repr h x 69 | runImpWR2RunImpW f = f RunImpW 70 | 71 | instance Prod r => DBI (ImpW r) where 72 | z = NoImpW z 73 | s :: forall a h b. ImpW r h b -> ImpW r (a, h) b 74 | s (ImpW w) = ImpW (s w) 75 | s (NoImpW x) = NoImpW (s x) 76 | app (ImpW f) (ImpW x) = ImpW (lam $ \p -> app (app (conv f) (zro1 p)) (app (conv x) (fst1 p))) 77 | app (NoImpW f) (NoImpW x) = NoImpW (app f x) 78 | app (ImpW f) (NoImpW x) = ImpW (lam $ \w -> app2 (conv f) w (conv x)) 79 | app (NoImpW f) (ImpW x) = ImpW (lam $ \w -> app (conv f) (app (conv x) w)) 80 | abs (ImpW f) = ImpW (flip1 $ abs f) 81 | abs (NoImpW x) = NoImpW (abs x) 82 | 83 | instance (Prod r, Bool r) => Bool (ImpW r) where 84 | bool = NoImpW . bool 85 | ite = NoImpW ite 86 | 87 | instance (Prod r, Char r) => Char (ImpW r) where 88 | char = NoImpW . char 89 | 90 | instance Prod r => Prod (ImpW r) where 91 | mkProd = NoImpW mkProd 92 | zro = NoImpW zro 93 | fst = NoImpW fst 94 | 95 | instance (Prod r, Double r) => Double (ImpW r) where 96 | double = NoImpW . double 97 | doubleExp = NoImpW doubleExp 98 | doublePlus = NoImpW doublePlus 99 | doubleMinus = NoImpW doubleMinus 100 | doubleMult = NoImpW doubleMult 101 | doubleDivide = NoImpW doubleDivide 102 | doubleCmp = NoImpW doubleCmp 103 | 104 | instance (Prod r, Float r) => Float (ImpW r) where 105 | float = NoImpW . float 106 | floatExp = NoImpW floatExp 107 | floatPlus = NoImpW floatPlus 108 | floatMinus = NoImpW floatMinus 109 | floatMult = NoImpW floatMult 110 | floatDivide = NoImpW floatDivide 111 | 112 | instance (Prod r, Option r) => Option (ImpW r) where 113 | nothing = NoImpW nothing 114 | just = NoImpW just 115 | optionMatch = NoImpW optionMatch 116 | 117 | instance Map.Map r => Map.Map (ImpW r) where 118 | empty = NoImpW Map.empty 119 | singleton' = NoImpW Map.singleton 120 | lookup' = NoImpW Map.lookup 121 | alter' = NoImpW Map.alter 122 | mapMap = NoImpW Map.mapMap 123 | unionWithKey' = NoImpW Map.unionWithKey 124 | 125 | instance Bimap r => Bimap (ImpW r) where 126 | size = NoImpW size 127 | lookupL' = NoImpW lookupL 128 | lookupR' = NoImpW lookupR 129 | singleton = NoImpW singleton 130 | empty = NoImpW empty 131 | insert' = NoImpW insert 132 | toMapL = NoImpW toMapL 133 | toMapR = NoImpW toMapR 134 | updateL' = NoImpW updateL 135 | updateR' = NoImpW updateR 136 | 137 | instance Dual r => Dual (ImpW r) where 138 | dual = NoImpW dual 139 | runDual = NoImpW runDual 140 | dualGetOrdC = Sub (getOrdC @(ImpW r) Proxy) 141 | 142 | instance (Prod r, Unit r) => Unit (ImpW r) where 143 | unit = NoImpW unit 144 | 145 | instance (Prod r, Sum r) => Sum (ImpW r) where 146 | left = NoImpW left 147 | right = NoImpW right 148 | sumMatch = NoImpW sumMatch 149 | 150 | instance (Prod r, Int r) => Int (ImpW r) where 151 | int = NoImpW . int 152 | pred = NoImpW pred 153 | intCmp = NoImpW cmp 154 | 155 | instance (Prod r, IO r) => IO (ImpW r) where 156 | putStrLn = NoImpW putStrLn 157 | ioMap = NoImpW map 158 | ioAP = NoImpW ap 159 | ioPure = NoImpW pure 160 | ioJoin = NoImpW join 161 | ioBind = NoImpW bind 162 | 163 | instance (Prod r, List r) => List (ImpW r) where 164 | nil = NoImpW nil 165 | cons = NoImpW cons 166 | listMatch = NoImpW listMatch 167 | 168 | instance (Prod r, Y r) => Y (ImpW r) where 169 | y = NoImpW y 170 | 171 | instance (Prod r, VTF.VectorTF r) => VTF.VectorTF (ImpW r) where 172 | zero = NoImpW VTF.zero 173 | basis = NoImpW VTF.basis 174 | plus = NoImpW VTF.plus 175 | mult = NoImpW VTF.mult 176 | vtfMatch = NoImpW VTF.vtfMatch 177 | vtfCmp = NoImpW VTF.vtfCmp 178 | vtfGetOrdC :: forall t f. (Ord (ImpW r) t, Ord (ImpW r) f) :- Ord r (M.VTF.VectorTF t f) 179 | vtfGetOrdC = Sub (withDict (getOrdC @(ImpW r) @t Proxy) $ withDict (getOrdC @(ImpW r) @f Proxy) Dict) 180 | 181 | instance (Prod r, DiffWrapper r) => DiffWrapper (ImpW r) where 182 | diffWrapper = NoImpW diffWrapper 183 | runDiffWrapper = NoImpW runDiffWrapper 184 | 185 | instance (Prod r, Fix r) => Fix (ImpW r) where 186 | fix = NoImpW fix 187 | runFix = NoImpW runFix 188 | 189 | instance (Prod r, FreeVector r) => FreeVector (ImpW r) where 190 | freeVector = NoImpW freeVector 191 | runFreeVector = NoImpW runFreeVector 192 | 193 | instance (Prod r, Ordering r) => Ordering (ImpW r) where 194 | sel = NoImpW sel 195 | ordering = NoImpW . ordering 196 | 197 | instance Lang r => Lang (ImpW r) where 198 | exfalso = NoImpW exfalso 199 | writer = NoImpW writer 200 | runWriter = NoImpW runWriter 201 | float2Double = NoImpW float2Double 202 | double2Float = NoImpW double2Float 203 | state = NoImpW state 204 | runState = NoImpW runState 205 | -------------------------------------------------------------------------------- /DDF/ImportMeta.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module DDF.ImportMeta ( 4 | module Prelude, 5 | module Data.Void, 6 | module Control.Monad.Writer, 7 | module Control.Monad.State, 8 | module Data.Constraint, 9 | module Data.Constraint.Forall, 10 | module Data.Proxy) where 11 | 12 | import Prelude ( 13 | ($), show, (+), (-), (*), (/), (.), (++), (>>=), (<=), (<), (==), compare, print, Maybe(Just, Nothing), String, (||), Either(Left, Right)) 14 | import Data.Void (Void, absurd) 15 | import Control.Monad.Writer (Writer) 16 | import Control.Monad.State (State) 17 | import Data.Constraint 18 | import Data.Constraint.Forall 19 | import Data.Proxy 20 | -------------------------------------------------------------------------------- /DDF/Int.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | FlexibleContexts, 5 | UndecidableSuperClasses, 6 | FlexibleInstances, 7 | MultiParamTypeClasses, 8 | UndecidableInstances 9 | #-} 10 | 11 | module DDF.Int (module DDF.Int, module DDF.Ordering) where 12 | 13 | import DDF.Ordering 14 | import qualified Prelude as M 15 | 16 | class (OrdC r M.Int, Ordering r) => Int r where 17 | int :: M.Int -> r h M.Int 18 | pred :: r h (M.Int -> M.Int) 19 | intCmp :: r h (M.Int -> M.Int -> M.Ordering) 20 | 21 | instance Int r => Ord r M.Int where 22 | cmp = intCmp 23 | getOrdC _ = Dict 24 | 25 | pred1 = app pred 26 | -------------------------------------------------------------------------------- /DDF/Lang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | MultiParamTypeClasses, 5 | FlexibleInstances, 6 | TypeFamilies, 7 | ScopedTypeVariables, 8 | FlexibleContexts, 9 | UndecidableInstances, 10 | TypeApplications, 11 | PartialTypeSignatures, 12 | UndecidableSuperClasses 13 | #-} 14 | 15 | module DDF.Lang ( 16 | module DDF.Lang, 17 | module DDF.Bimap, 18 | module DDF.Bool, 19 | module DDF.Char, 20 | module DDF.Double, 21 | module DDF.Dual, 22 | module DDF.Float, 23 | module DDF.Meta.Diff, 24 | module DDF.Ordering, 25 | module DDF.Unit, 26 | module DDF.Sum, 27 | module DDF.Int, 28 | module DDF.IO, 29 | module DDF.DiffWrapper, 30 | module DDF.Fix, 31 | module DDF.FreeVector 32 | ) where 33 | 34 | import DDF.Bool 35 | import DDF.Char 36 | import DDF.Double 37 | import DDF.Float 38 | import DDF.Bimap 39 | import DDF.Dual 40 | import DDF.Vector 41 | import DDF.Meta.Diff 42 | import DDF.Unit 43 | import DDF.Sum 44 | import DDF.Int 45 | import DDF.IO 46 | import DDF.DiffWrapper 47 | import DDF.Fix 48 | import DDF.FreeVector 49 | import DDF.Ordering 50 | 51 | import qualified DDF.VectorTF as VTF 52 | import qualified DDF.Meta.VectorTF as M.VTF 53 | import qualified DDF.Meta.Dual as M 54 | import qualified Control.Monad.Writer as M (Writer) 55 | import qualified GHC.Float as M 56 | import qualified Prelude as M 57 | import qualified Data.Map as M 58 | import qualified DDF.Map as Map 59 | import qualified Data.Map as M.Map 60 | import qualified Data.Functor.Foldable as M 61 | import qualified Data.Bimap as M.Bimap 62 | import qualified DDF.Meta.FreeVector as M 63 | 64 | type FreeVectorBuilder b = M.Map.Map b M.Double 65 | type SVTFBuilder b = State (M.Bimap.Bimap (M.VTF.VectorTF b M.Int) M.Int) M.Int 66 | class (Ordering r, Char r, Double r, Float r, Bimap r, Dual r, Unit r, Sum r, Int r, IO r, VTF.VectorTF r, DiffWrapper r, Fix r, FreeVector r) => Lang r where 67 | exfalso :: r h (Void -> a) 68 | writer :: r h ((a, w) -> M.Writer w a) 69 | runWriter :: r h (M.Writer w a -> (a, w)) 70 | float2Double :: r h (M.Float -> M.Double) 71 | double2Float :: r h (M.Double -> M.Float) 72 | state :: r h ((x -> (y, x)) -> State x y) 73 | runState :: r h (State x y -> (x -> (y, x))) 74 | iterate :: r h ((x -> x) -> x -> [x]) 75 | iterate = lam $ \f -> y1 $ lam2 $ \fi x -> cons2 x (app fi (app f x)) 76 | buildFreeVector :: Ord r b => r h (FreeVectorBuilder b -> M.FreeVector b M.Double) 77 | buildFreeVector = lam $ \fb -> freeVector1 $ lam $ \b -> optionMatch3 (double 0) id (Map.lookup2 fb b) 78 | toSVTFBuilder :: forall h b. Ord r b => r h (M.VTF.VectorTF b M.Int -> SVTFBuilder b) 79 | toSVTFBuilder = 80 | lam $ \x -> state1 $ lam $ \m -> 81 | optionMatch3 82 | (let_2 (size1 m) (lam $ \si -> mkProd2 si (insert2 (mkProd2 x si) m))) 83 | (lam $ \xid -> mkProd2 xid m) 84 | (lookupL2 m x) 85 | get :: r h (Maybe a -> a) 86 | get = optionMatch2 undefined id 87 | getVar :: r h (State x x) 88 | getVar = state1 (dup1 mkProd) 89 | update :: r h ((x -> x) -> State x ()) 90 | update = lam $ \f -> state1 $ lam $ \x -> mkProd2 unit (app f x) 91 | updateWengert :: r h (M.Int -> M.Double -> M.Map.Map M.Int M.Double -> M.Map M.Int M.Double) 92 | updateWengert = lam2 $ \i d -> Map.alter2 (optionMatch2 (just1 d) (just `com2` (plus1 d))) i 93 | vtfCata :: r h ((M.VTF.VectorTF a b -> b) -> M.Fix (M.VTF.VectorTF a) -> b) 94 | vtfCata = lam $ \f -> y1 $ lam $ \fx -> 95 | VTF.vtfMatch4 96 | (app f VTF.zero) 97 | (f `com2` VTF.basis) 98 | (lam2 $ \l r -> app f (VTF.plus2 (app fx l) (app fx r))) 99 | (lam2 $ \d v -> app f (VTF.mult2 d (app fx v))) `com2` runFix 100 | 101 | class Reify r x where 102 | reify :: x -> r h x 103 | 104 | instance Lang r => Reify r () where 105 | reify _ = unit 106 | 107 | instance Lang r => Reify r M.Double where 108 | reify = double 109 | 110 | instance (Lang repr, Reify repr l, Reify repr r) => Reify repr (l, r) where 111 | reify (l, r) = mkProd2 (reify l) (reify r) 112 | 113 | instance Lang r => Monoid r () where 114 | zero = unit 115 | plus = const1 $ const1 unit 116 | 117 | instance Lang r => Group r () where 118 | invert = const1 unit 119 | minus = const1 $ const1 unit 120 | 121 | instance Lang r => Vector r () where 122 | type Basis () = Void 123 | toFreeVector = const1 $ freeVector1 exfalso 124 | mult = const1 $ const1 unit 125 | divide = const1 $ const1 unit 126 | 127 | instance Float r => Monoid r M.Float where 128 | zero = floatZero 129 | plus = floatPlus 130 | 131 | instance Float r => Group r M.Float where 132 | minus = floatMinus 133 | 134 | instance Lang r => Vector r M.Float where 135 | type Basis M.Float = () 136 | toFreeVector = freeVector `com2` const `com2` float2Double 137 | mult = com2 floatMult double2Float 138 | divide = com2 (flip2 com double2Float) floatDivide 139 | 140 | instance Lang r => Functor r (M.VTF.VectorTF b) where 141 | map = lam $ \f -> VTF.vtfMatch4 VTF.zero VTF.basis (lam2 $ \l r -> app f l `VTF.plus2` app f r) (lam2 $ \d x -> d `VTF.mult2` app f x) 142 | 143 | instance (Prod repr, Monoid repr l, Monoid repr r) => Monoid repr (l, r) where 144 | zero = mkProd2 zero zero 145 | plus = lam2 $ \l r -> mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r)) 146 | 147 | instance (Prod repr, Group repr l, Group repr r) => Group repr (l, r) where 148 | invert = bimap2 invert invert 149 | 150 | instance (Prod repr, Double repr, Sum repr, FreeVector repr, Vector repr l, Vector repr r) => Vector repr (l, r) where 151 | type Basis (l, r) = M.Either (Basis l) (Basis r) 152 | toFreeVector = lam $ \p -> let_2 (toFreeVector1 $ zro1 p) $ lam $ \lfv -> let_2 (toFreeVector1 $ fst1 p) $ lam $ \rfv -> 153 | freeVector1 $ sumMatch2 (runFreeVector1 lfv) (runFreeVector1 rfv) 154 | mult = lam $ \x -> bimap2 (mult1 x) (mult1 x) 155 | 156 | instance (Double r, Monoid r v) => Monoid r (M.Double -> v) where 157 | zero = const1 zero 158 | plus = lam3 $ \l r x -> plus2 (app l x) (app r x) 159 | 160 | instance (Lang r, Group r v) => Group r (M.Double -> v) where 161 | invert = lam2 $ \l x -> app l (invert1 x) 162 | 163 | instance (Lang r, Vector r v) => Vector r (M.Double -> v) where 164 | type Basis (M.Double -> v) = Basis v 165 | toFreeVector = lam $ \f -> toFreeVector1 $ app f (double 1) 166 | mult = lam3 $ \l r x -> app r (mult2 l x) 167 | 168 | instance Lang r => Monoid r [a] where 169 | zero = nil 170 | plus = listAppend 171 | 172 | instance {-# INCOHERENT #-} Lang r => Functor r [] where 173 | map = lam $ \f -> y1 $ lam $ \self -> listMatch2 nil (lam2 $ \x xs -> cons2 (app f x) $ app self xs) 174 | 175 | instance Lang r => BiFunctor r M.Either where 176 | bimap = lam2 $ \l r -> sumMatch2 (com2 left l) (com2 right r) 177 | 178 | instance Prod r => BiFunctor r (,) where 179 | bimap = lam3 $ \l r p -> mkProd2 (app l (zro1 p)) (app r (fst1 p)) 180 | 181 | instance Dual r => BiFunctor r M.Dual where 182 | bimap = lam2 $ \l r -> dual `com2` bimap2 l r `com2` runDual 183 | 184 | instance Lang r => Functor r (Writer w) where 185 | map = lam $ \f -> com2 writer (com2 (bimap2 f id) runWriter) 186 | 187 | instance Lang r => Functor r (M.Map k) where 188 | map = Map.mapMap 189 | 190 | instance (Lang r, Monoid r w) => Applicative r (Writer w) where 191 | pure = com2 writer (flip2 mkProd zero) 192 | ap = lam2 $ \f x -> writer1 (mkProd2 (app (zro1 (runWriter1 f)) (zro1 (runWriter1 x))) (plus2 (fst1 (runWriter1 f)) (fst1 (runWriter1 x)))) 193 | 194 | instance (Lang r, Monoid r w) => Monad r (Writer w) where 195 | join = lam $ \x -> writer1 $ mkProd2 (zro1 $ runWriter1 $ zro1 $ runWriter1 x) (plus2 (fst1 $ runWriter1 $ zro1 $ runWriter1 x) (fst1 $ runWriter1 x)) 196 | 197 | instance Lang r => Functor r (State l) where 198 | map = lam2 $ \f st -> state1 (com2 (bimap2 f id) (runState1 st)) 199 | 200 | instance Lang r => Applicative r (State l) where 201 | pure = lam $ \x -> state1 (mkProd1 x) 202 | ap = lam2 $ \f x -> state1 $ lam $ \st -> let_2 (runState2 f st) (lam $ \p -> bimap3 (zro1 p) id (runState2 x (fst1 p))) 203 | 204 | instance Lang r => Monad r (State l) where 205 | join = lam $ \x -> state1 $ lam $ \st -> let_2 (runState2 x st) (uncurry1 runState) 206 | 207 | instance Lang r => Functor r M.Maybe where 208 | map = lam $ \func -> optionMatch2 nothing (com2 just func) 209 | 210 | instance Lang r => Applicative r M.Maybe where 211 | pure = just 212 | ap = optionMatch2 (const1 nothing) map 213 | 214 | instance Lang r => Monad r M.Maybe where 215 | bind = lam2 $ \x func -> optionMatch3 nothing func x 216 | 217 | instance Lang r => Monoid r (M.FreeVector b M.Double) where 218 | zero = freeVector1 $ const1 (double 0) 219 | plus = lam2 $ \l r -> freeVector1 $ lam $ \x -> runFreeVector2 l x `plus2` runFreeVector2 r x 220 | 221 | instance Lang r => Group r (M.FreeVector b M.Double) where 222 | invert = lam $ \f -> freeVector1 $ lam $ \x -> invert1 (runFreeVector2 f x) 223 | minus = lam2 $ \l r -> freeVector1 $ lam $ \x -> runFreeVector2 l x `minus2` runFreeVector2 r x 224 | 225 | instance Lang r => Vector r (M.FreeVector b M.Double) where 226 | type Basis (M.FreeVector b M.Double) = b 227 | toFreeVector = id 228 | mult = lam2 $ \d l -> freeVector1 $ lam $ \x -> d `mult2` runFreeVector2 l x 229 | divide = lam2 $ \l d -> freeVector1 $ lam $ \x -> runFreeVector2 l x `divide2` d 230 | 231 | instance (Ord r b, Lang r) => Monoid r (FreeVectorBuilder b) where 232 | zero = Map.empty 233 | plus = Map.unionWithKey1 (const1 plus) 234 | 235 | instance (Ord r b, Lang r) => Group r (FreeVectorBuilder b) where 236 | invert = Map.mapMap1 invert 237 | 238 | instance (Ord r b, Lang r) => Vector r (FreeVectorBuilder b) where 239 | type Basis (FreeVectorBuilder b) = b 240 | toFreeVector = buildFreeVector 241 | mult = Map.mapMap `com2` mult 242 | divide = lam2 $ \m d -> Map.mapMap2 (lam $ \x -> divide2 x d) m 243 | 244 | instance Lang r => Monoid r (M.Fix (M.VTF.VectorTF b)) where 245 | zero = fix1 VTF.zero 246 | plus = lam2 $ \l r -> fix1 $ l `VTF.plus2` r 247 | 248 | instance (Ord r b, Lang r) => Group r (M.Fix (M.VTF.VectorTF b)) where 249 | invert = mult1 (double (-1)) 250 | 251 | instance (Ord r b, Lang r) => Vector r (M.Fix (M.VTF.VectorTF b)) where 252 | type Basis (M.Fix (M.VTF.VectorTF b)) = b 253 | toFreeVector = buildFreeVector `com2` vtfCata1 (VTF.vtfMatch4 zero (flip2 Map.singleton (double 1)) plus mult) 254 | mult = lam $ \d -> fix `com2` VTF.mult1 d 255 | 256 | instance (Ord r b, Lang r) => Monoid r (SVTFBuilder b) where 257 | zero = toSVTFBuilder1 VTF.zero 258 | plus = lam2 $ \l r -> l `bind2` (lam $ \lid -> r `bind2` (lam $ \rid -> toSVTFBuilder1 (VTF.plus2 lid rid))) 259 | 260 | instance (Ord r b, Lang r) => Group r (SVTFBuilder b) where 261 | invert = mult1 (double (-1)) 262 | 263 | instance (Ord r b, Lang r) => Vector r (SVTFBuilder b) where 264 | type Basis (SVTFBuilder b) = b 265 | toFreeVector = 266 | buildFreeVector `com2` flip2 id Map.empty `com2` 267 | (lam $ \x -> zro `com2` (runState1 $ y2 (lam2 $ \fx i -> 268 | map2 (lam $ \m -> mkProd2 (get1 $ Map.lookup2 (fst1 x) i) (get1 $ Map.lookup2 m i)) getVar `bind2` 269 | (lam $ \p -> VTF.vtfMatch5 270 | (return1 zero) 271 | (lam $ \b -> return1 (Map.singleton2 b (fst1 p))) 272 | (lam2 $ \lid rid -> map2 (const1 zero) (update1 (updateWengert2 lid (fst1 p) `com2` updateWengert2 rid (fst1 p)))) 273 | (lam2 $ \d xid -> map2 (const1 zero) (update1 (let_2 (d `mult2` (fst1 p)) (updateWengert1 xid)))) 274 | (zro1 p) `bind2` (lam $ \fvb -> ite3 (return1 fvb) (map2 (plus1 fvb) $ app fx (pred1 i)) (eq2 i (int 0))))) (zro1 x)) 275 | `com2` Map.insert2 (zro1 x) (double 0)) `com2` bimap2 id toMapR `com2` flip2 runState empty 276 | mult = lam2 $ \d x -> x `bind2` (lam $ \xid -> toSVTFBuilder1 (VTF.mult2 d xid)) 277 | 278 | type instance DiffType v (M.VTF.VectorTF t f) = M.VTF.VectorTF (DiffType v t) (DiffType v f) 279 | type instance DiffType v M.Int = M.Int 280 | 281 | instance Double r => Monoid r M.Double where 282 | zero = doubleZero 283 | plus = doublePlus 284 | 285 | instance Double r => Group r M.Double where 286 | minus = doubleMinus 287 | 288 | instance Lang r => Vector r M.Double where 289 | type Basis M.Double = () 290 | toFreeVector = freeVector `com2` const 291 | mult = doubleMult 292 | divide = doubleDivide 293 | 294 | optionMatch2 = app2 optionMatch 295 | optionMatch3 = app3 optionMatch 296 | writer1 = app writer 297 | runWriter1 = app runWriter 298 | float2Double1 = app float2Double 299 | state1 = app state 300 | runState1 = app runState 301 | runState2 = app2 runState 302 | toSVTFBuilder1 = app toSVTFBuilder 303 | double2Float1 = app double2Float 304 | get1 = app get 305 | return1 = app return 306 | update1 = app update 307 | updateWengert1 = app updateWengert 308 | updateWengert2 = app2 updateWengert 309 | vtfCata1 = app vtfCata 310 | -------------------------------------------------------------------------------- /DDF/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module DDF.List (module DDF.List, module DDF.Y) where 4 | 5 | import DDF.Y 6 | 7 | class Y r => List r where 8 | nil :: r h [a] 9 | cons :: r h (a -> [a] -> [a]) 10 | listMatch :: r h (b -> (a -> [a] -> b) -> [a] -> b) 11 | listAppend :: r h ([a] -> [a] -> [a]) 12 | listAppend = lam2 $ \l r -> y2 (lam $ \self -> listMatch2 r (lam2 $ \a as -> cons2 a (app self as))) l 13 | 14 | cons2 = app2 cons 15 | listMatch2 = app2 listMatch 16 | listMatch3 = app3 listMatch 17 | listAppend2 = app2 listAppend 18 | -------------------------------------------------------------------------------- /DDF/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | ScopedTypeVariables, 4 | TypeApplications, 5 | FlexibleInstances, 6 | NoMonomorphismRestriction, 7 | MultiParamTypeClasses 8 | #-} 9 | 10 | module DDF.Map (module DDF.Map, module DDF.Prod, module DDF.Option, module DDF.Ordering) where 11 | 12 | import DDF.Prod 13 | import DDF.Option 14 | import DDF.Ordering 15 | import qualified Data.Map as M 16 | 17 | class (Prod r, Option r) => Map r where 18 | empty :: r h (M.Map k a) 19 | lookup :: forall h k a. Ord r k => r h (M.Map k a -> k -> Maybe a) 20 | lookup = withDict (getOrdC @r @k Proxy) lookup' 21 | lookup' :: OrdWC r k => r h (M.Map k a -> k -> Maybe a) 22 | alter :: forall h k a. Ord r k => r h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a) 23 | alter = withDict (getOrdC @r @k Proxy) alter' 24 | alter' :: OrdWC r k => r h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a) 25 | mapMap :: r h ((a -> b) -> M.Map k a -> M.Map k b) 26 | unionWithKey :: forall h k a. Ord r k => r h ((k -> a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a) 27 | unionWithKey = withDict (getOrdC @r @k Proxy) unionWithKey' 28 | unionWithKey' :: OrdWC r k => r h ((k -> a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a) 29 | insert :: forall h k a. Ord r k => r h (k -> a -> M.Map k a -> M.Map k a) 30 | insert = withDict (getOrdC @r @k Proxy) insert' 31 | insert' :: OrdWC r k => r h (k -> a -> M.Map k a -> M.Map k a) 32 | insert' = lam2 $ \k a -> alter2 (const1 $ just1 a) k 33 | delete :: forall h k a. Ord r k => r h (k -> M.Map k a -> M.Map k a) 34 | delete = withDict (getOrdC @r @k Proxy) delete' 35 | delete' :: OrdWC r k => r h (k -> M.Map k a -> M.Map k a) 36 | delete' = lam $ \k -> alter2 (const1 nothing) k 37 | -- | While singleton doesnt need the ord instance in Data.Map, 38 | -- doing so will improve difficulty of writing all sort of interpreter, 39 | -- and I dont know any use of singleton (without Ord). 40 | singleton :: forall h k a. Ord r k => r h (k -> a -> M.Map k a) 41 | singleton = withDict (getOrdC @r @k Proxy) singleton' 42 | singleton' :: OrdWC r k => r h (k -> a -> M.Map k a) 43 | singleton' = lam2 $ \k a -> insert3 k a empty 44 | 45 | lookup2 = app2 lookup 46 | unionWithKey1 = app1 unionWithKey 47 | unionWithKey2 = app2 unionWithKey 48 | unionWithKey3 = app3 unionWithKey 49 | mapMap1 = app1 mapMap 50 | mapMap2 = app2 mapMap 51 | insert1 = app1 insert 52 | insert2 = app2 insert 53 | insert3 = app3 insert 54 | alter1 = app1 alter 55 | alter2 = app2 alter 56 | alter3 = app3 alter 57 | delete1 = app1 delete 58 | delete2 = app2 delete 59 | singleton1 = app1 singleton 60 | singleton2 = app2 singleton -------------------------------------------------------------------------------- /DDF/Meta/Diff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RankNTypes, 3 | ScopedTypeVariables, 4 | TypeApplications, 5 | TypeFamilies, 6 | KindSignatures, 7 | MultiParamTypeClasses, 8 | FlexibleInstances, 9 | NoMonomorphismRestriction, 10 | ConstraintKinds, 11 | DataKinds, 12 | FlexibleContexts 13 | #-} 14 | 15 | module DDF.Meta.Diff where 16 | 17 | type family DiffType (v :: *) (x :: *) 18 | 19 | newtype Diff r v h x = Diff {runDiff :: r (DiffType v h) (DiffType v x)} 20 | -------------------------------------------------------------------------------- /DDF/Meta/DiffWrapper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures, DataKinds, TypeFamilies, TypeOperators, UndecidableInstances #-} 2 | 3 | module DDF.Meta.DiffWrapper (module DDF.Meta.DiffWrapper, module DDF.Meta.Diff) where 4 | 5 | import DDF.Meta.Diff 6 | 7 | type family FDiffType (a :: [*]) x 8 | type instance FDiffType '[] x = x 9 | type instance FDiffType (a ': as) x = DiffType a (FDiffType as x) 10 | 11 | newtype DiffWrapper (a :: [*]) x = DiffWrapper {runDiffWrapper :: FDiffType a x} -------------------------------------------------------------------------------- /DDF/Meta/Dual.hs: -------------------------------------------------------------------------------- 1 | module DDF.Meta.Dual where 2 | 3 | newtype Dual l r = Dual {runDual :: (l, r)} 4 | 5 | instance Eq l => Eq (Dual l r) where 6 | (Dual (l, _)) == (Dual (r, _)) = l == r 7 | 8 | instance Ord l => Ord (Dual l r) where 9 | (Dual (l, _)) `compare` (Dual (r, _)) = l `compare` r 10 | 11 | dualOrig (Dual (l, _)) = l 12 | 13 | dualDiff (Dual (_, r)) = r 14 | 15 | mkDual l r = Dual (l, r) -------------------------------------------------------------------------------- /DDF/Meta/FreeVector.hs: -------------------------------------------------------------------------------- 1 | module DDF.Meta.FreeVector where 2 | 3 | newtype FreeVector b d = FreeVector {runFreeVector :: b -> d} -------------------------------------------------------------------------------- /DDF/Meta/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module DDF.Meta.Util (module DDF.Meta.Util, module System.Random) where 4 | 5 | import System.Random 6 | import GHC.Float 7 | 8 | isSquare n = sq * sq == n 9 | where sq = floor $ sqrt (fromIntegral n::Double) 10 | 11 | instance Random () where 12 | random = ((),) 13 | randomR _ = random 14 | 15 | instance (Random l, Random r) => Random (l, r) where 16 | random g0 = ((l, r), g2) 17 | where 18 | (l, g1) = random g0 19 | (r, g2) = random g1 20 | randomR ((llo, rlo), (lhi, rhi)) g0 = ((l, r), g2) 21 | where 22 | (l, g1) = randomR (llo, lhi) g0 23 | (r, g2) = randomR (rlo, rhi) g1 24 | 25 | class RandRange w where 26 | randRange :: (Double, Double) -> (w, w) 27 | 28 | instance RandRange () where 29 | randRange _ = ((), ()) 30 | 31 | instance RandRange Double where 32 | randRange (lo, hi) = (lo, hi) 33 | 34 | instance RandRange Float where 35 | randRange (lo, hi) = (double2Float lo, double2Float hi) 36 | 37 | instance (RandRange l, RandRange r) => RandRange (l, r) where 38 | randRange (lo, hi) = ((llo, rlo), (lhi, rhi)) 39 | where 40 | (llo, lhi) = randRange (lo, hi) 41 | (rlo, rhi) = randRange (lo, hi) 42 | 43 | chainOrd EQ x = x 44 | chainOrd x _ = x 45 | -------------------------------------------------------------------------------- /DDF/Meta/VectorTF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module DDF.Meta.VectorTF where 4 | 5 | -- | F algebra of a Term Vector Spaces 6 | data VectorTF t f = Zero | Basis t | Plus f f | Mult Double f deriving (Eq, Ord, Functor) -------------------------------------------------------------------------------- /DDF/Option.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module DDF.Option (module DDF.Option, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | 7 | class DBI r => Option r where 8 | nothing :: r h (Maybe a) 9 | just :: r h (a -> Maybe a) 10 | optionMatch :: r h (b -> (a -> b) -> Maybe a -> b) 11 | 12 | just1 = app just -------------------------------------------------------------------------------- /DDF/Ordering.hs: -------------------------------------------------------------------------------- 1 | {-# Language 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | MultiParamTypeClasses, 5 | ConstraintKinds, 6 | FlexibleInstances, 7 | UndecidableInstances, 8 | KindSignatures, 9 | ConstraintKinds, 10 | TypeFamilies, 11 | UndecidableSuperClasses 12 | #-} 13 | 14 | module DDF.Ordering (module DDF.Ordering, module DDF.Bool) where 15 | 16 | import DDF.Bool 17 | import qualified Prelude as M 18 | 19 | class Bool r => Ordering r where 20 | sel :: r h (a -> a -> a -> M.Ordering -> a) 21 | ordering :: M.Ordering -> r h M.Ordering 22 | ltOrd :: r h M.Ordering 23 | ltOrd = ordering M.LT 24 | eqOrd :: r h M.Ordering 25 | eqOrd = ordering M.EQ 26 | gtOrd :: r h M.Ordering 27 | gtOrd = ordering M.GT 28 | isLT :: r h (M.Ordering -> M.Bool) 29 | isLT = sel3 true false false 30 | isEQ :: r h (M.Ordering -> M.Bool) 31 | isEQ = sel3 false true false 32 | isGT :: r h (M.Ordering -> M.Bool) 33 | isGT = sel3 false false true 34 | chainOrd :: r h (M.Ordering -> M.Ordering -> M.Ordering) 35 | chainOrd = lam2 $ \l r -> sel4 ltOrd r gtOrd l 36 | cmpMap :: r h ((b -> a) -> Cmp a -> Cmp b) 37 | cmpMap = lam4 $ \f c l r -> app2 c (app f l) (app f r) 38 | 39 | sel1 = app1 sel 40 | sel2 = app2 sel 41 | sel3 = app3 sel 42 | sel4 = app4 sel 43 | 44 | isLT1 = app1 isLT 45 | isEQ1 = app1 isEQ 46 | isGT1 = app1 isGT 47 | 48 | chainOrd1 = app1 chainOrd 49 | chainOrd2 = app2 chainOrd 50 | 51 | type family OrdC (r :: * -> * -> *) :: * -> Constraint 52 | 53 | class (Ordering r, M.Ord x) => Ord r x where 54 | cmp :: r h (x -> x -> M.Ordering) 55 | eq :: r h (x -> x -> M.Bool) 56 | eq = lam2 $ \l r -> isEQ1 $ cmp2 l r 57 | getOrdC :: Proxy r -> Dict (OrdC r x) 58 | 59 | class (Ord r x, OrdC r x) => OrdWC r x 60 | instance (Ord r x, OrdC r x) => OrdWC r x 61 | 62 | eq1 = app1 eq 63 | eq2 = app2 eq 64 | 65 | cmp1 = app1 cmp 66 | cmp2 = app2 cmp 67 | 68 | cmpMap1 = app1 cmpMap 69 | cmpMap2 = app2 cmpMap 70 | cmpMap3 = app3 cmpMap 71 | cmpMap4 = app4 cmpMap 72 | 73 | type Cmp a = a -> a -> M.Ordering 74 | 75 | class NoOrdC x 76 | instance NoOrdC x 77 | -------------------------------------------------------------------------------- /DDF/PE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RankNTypes, 3 | NoImplicitPrelude, 4 | GADTs, 5 | ExplicitForAll, 6 | ScopedTypeVariables, 7 | NoMonomorphismRestriction, 8 | IncoherentInstances, 9 | InstanceSigs, 10 | LambdaCase, 11 | FlexibleContexts, 12 | KindSignatures, 13 | TypeFamilies, 14 | TypeApplications, 15 | MultiParamTypeClasses, 16 | FlexibleInstances, 17 | TypeOperators 18 | #-} 19 | 20 | module DDF.PE where 21 | 22 | import DDF.Lang 23 | import qualified Prelude as M 24 | import qualified DDF.Meta.Dual as M 25 | 26 | type instance OrdC (P repr) = Ord repr 27 | 28 | data P repr h a where 29 | Open :: (forall hout. EnvT repr h hout -> P repr hout a) -> P repr h a 30 | Unk :: repr h a -> P repr h a 31 | Known :: 32 | K repr h a -> 33 | repr h a -> 34 | (forall hout. EnvT repr h hout -> P repr hout a) -> 35 | (forall any. P repr (any, h) a) -> 36 | (forall hh ht. (hh, ht) ~ h => P repr ht (hh -> a)) -> 37 | P repr h a 38 | 39 | know :: DBI repr => 40 | K repr h a -> 41 | repr h a -> 42 | (forall hout. EnvT repr h hout -> P repr hout a) -> 43 | (forall any. P repr (any, h) a) -> 44 | P repr h a 45 | know a b c d = Known a b c d (mkFun c) 46 | 47 | static :: forall repr h a. DBI repr => (forall h'. (K repr h' a, repr h' a)) -> P repr h a 48 | static x = know (M.fst $ x @h) (M.snd x) (\_ -> static x) (static x) 49 | 50 | isOpen (Open _) = M.True 51 | isOpen _ = M.False 52 | 53 | type family K (repr :: * -> * -> *) h a 54 | 55 | mkFun :: DBI repr => (forall hout. EnvT repr (a, h) hout -> P repr hout b) -> P repr h (a -> b) 56 | mkFun f = Known (Fun f) (abs $ dynamic (f Dyn)) (\h -> abs $ f $ Next h) (abs $ f $ Next Weak) (mkFun $ app_open (mkFun f)) 57 | 58 | data EnvT repr hin hout where 59 | Dyn :: EnvT repr hin hin 60 | Arg :: P repr hout a -> EnvT repr (a, hout) hout 61 | Weak :: EnvT repr h (a, h) 62 | Next :: EnvT repr hin hout -> EnvT repr (a, hin) (a, hout) 63 | 64 | dynamic:: DBI repr => P repr h a -> repr h a 65 | dynamic (Unk x) = x 66 | dynamic (Open f) = dynamic (f Dyn) 67 | dynamic (Known _ d _ _ _) = d 68 | 69 | app_open :: DBI repr => P repr hin r -> EnvT repr hin hout -> P repr hout r 70 | app_open (Open fs) h = fs h 71 | app_open (Unk e) Dyn = Unk e 72 | app_open (Unk e) (Arg p) = Unk (app (abs e) (dynamic p)) 73 | app_open (Unk e) (Next h) = app (s (app_open (Unk (abs e)) h)) z 74 | app_open (Unk e) Weak = Unk (s e) 75 | app_open (Known _ _ x _ _) h = x h 76 | 77 | type instance K repr h (a -> b) = Fun repr h a b 78 | newtype Fun repr h a b = Fun {runFun :: forall hout. EnvT repr (a, h) hout -> P repr hout b} 79 | 80 | instance DBI r => DBI (P r) where 81 | z = Open f where 82 | f :: EnvT r (a,h) hout -> P r hout a 83 | f Dyn = Unk z 84 | f (Arg x) = x 85 | f (Next _) = z 86 | f Weak = s z 87 | 88 | s :: forall h a any. P r h a -> P r (any, h) a 89 | s (Unk x) = Unk (s x) 90 | s (Known _ _ _ x _) = x 91 | s p@(Open _) = Open f where 92 | f :: EnvT r (any, h) hout -> P r hout a 93 | f Dyn = Unk (s (dynamic p)) 94 | f (Arg _) = p 95 | f (Next h) = s (app_open p h) 96 | f Weak = s (s p) 97 | 98 | abs (Unk f) = Unk (abs f) 99 | abs (Open o) = mkFun o 100 | abs (Known _ _ _ _ x) = x 101 | 102 | app (Known (Fun fs) _ _ _ _) p = fs (Arg p) 103 | app e1 e2 | isOpen e1 || isOpen e2 = Open (\h -> app (app_open e1 h) (app_open e2 h)) 104 | app f x = Unk (app (dynamic f) (dynamic x)) 105 | 106 | type instance K repr h M.Bool = M.Bool 107 | instance Bool r => Bool (P r) where 108 | bool x = static (x, bool x) 109 | ite = lam3 (\l r b -> app2 (f b) l r) 110 | where 111 | f :: P r h M.Bool -> P r h (a -> a -> a) 112 | f (Known M.True _ _ _ _) = const 113 | f (Known M.False _ _ _ _) = const1 id 114 | f (Open x) = Open $ f . x 115 | f (Unk x) = Unk (lam2 (\l r -> ite3 l r (s (s x)))) 116 | 117 | type instance K repr h M.Double = M.Double 118 | instance Double r => Double (P r) where 119 | double x = static (x, double x) 120 | doublePlus = abs (abs (f (s z) z)) 121 | where 122 | f :: P r h M.Double -> P r h M.Double -> P r h M.Double 123 | f (Known l _ _ _ _) (Known r _ _ _ _) = double (l + r) 124 | f (Known 0 _ _ _ _) r = r 125 | f l (Known 0 _ _ _ _) = l 126 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 127 | f l r = Unk (doublePlus2 (dynamic l) (dynamic r)) 128 | doubleMult = abs (abs (f (s z) z)) 129 | where 130 | f :: P r h M.Double -> P r h M.Double -> P r h M.Double 131 | f (Known l _ _ _ _) (Known r _ _ _ _) = double (l * r) 132 | f (Known 0 _ _ _ _) _ = double 0 133 | f _ (Known 0 _ _ _ _) = double 0 134 | f l (Known 1 _ _ _ _) = l 135 | f (Known 1 _ _ _ _) r = r 136 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 137 | f l r = Unk (doubleMult2 (dynamic l) (dynamic r)) 138 | doubleMinus = abs (abs (f (s z) z)) 139 | where 140 | f :: P r h M.Double -> P r h M.Double -> P r h M.Double 141 | f (Known l _ _ _ _) (Known r _ _ _ _) = double (l - r) 142 | f l (Known 0 _ _ _ _) = l 143 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 144 | f l r = Unk $ doubleMinus2 (dynamic l) (dynamic r) 145 | doubleDivide = abs (abs (f (s z) z)) 146 | where 147 | f :: P r h M.Double -> P r h M.Double -> P r h M.Double 148 | f (Known l _ _ _ _) (Known r _ _ _ _) = double (l / r) 149 | f (Known 0 _ _ _ _) _ = double 0 150 | f l (Known 1 _ _ _ _) = l 151 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 152 | f l r = Unk $ doubleDivide2 (dynamic l) (dynamic r) 153 | doubleExp = abs (f z) 154 | where 155 | f :: P r h M.Double -> P r h M.Double 156 | f (Known l _ _ _ _) = double (M.exp l) 157 | f (Open x) = Open $ f . x 158 | f (Unk l) = Unk $ doubleExp1 l 159 | doubleCmp = abs $ abs $ f (s z) z where 160 | f :: P r h M.Double -> P r h M.Double -> P r h M.Ordering 161 | f (Known l _ _ _ _) (Known r _ _ _ _) = ordering (M.compare l r) 162 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 163 | f l r = Unk (cmp2 (dynamic l) (dynamic r)) 164 | 165 | type instance K repr h M.Float = M.Float 166 | instance Float r => Float (P r) where 167 | float x = static (x, float x) 168 | floatPlus = abs (abs (f (s z) z)) 169 | where 170 | f :: P r h M.Float -> P r h M.Float -> P r h M.Float 171 | f (Known l _ _ _ _) (Known r _ _ _ _) = float (l + r) 172 | f (Known 0 _ _ _ _) r = r 173 | f l (Known 0 _ _ _ _) = l 174 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 175 | f l r = Unk (floatPlus2 (dynamic l) (dynamic r)) 176 | floatMult = abs (abs (f (s z) z)) 177 | where 178 | f :: P r h M.Float -> P r h M.Float -> P r h M.Float 179 | f (Known l _ _ _ _) (Known r _ _ _ _) = float (l * r) 180 | f (Known 0 _ _ _ _) _ = float 0 181 | f _ (Known 0 _ _ _ _) = float 0 182 | f l (Known 1 _ _ _ _) = l 183 | f (Known 1 _ _ _ _) r = r 184 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 185 | f l r = Unk (floatMult2 (dynamic l) (dynamic r)) 186 | floatMinus = abs (abs (f (s z) z)) 187 | where 188 | f :: P r h M.Float -> P r h M.Float -> P r h M.Float 189 | f (Known l _ _ _ _) (Known r _ _ _ _) = float (l - r) 190 | f l (Known 0 _ _ _ _) = l 191 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 192 | f l r = Unk (floatMinus2 (dynamic l) (dynamic r)) 193 | floatDivide = abs (abs (f (s z) z)) 194 | where 195 | f :: P r h M.Float -> P r h M.Float -> P r h M.Float 196 | f (Known l _ _ _ _) (Known r _ _ _ _) = float (l / r) 197 | f (Known 0 _ _ _ _) _ = float 0 198 | f l (Known 1 _ _ _ _) = l 199 | f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h)) 200 | f l r = Unk (floatDivide2 (dynamic l) (dynamic r)) 201 | floatExp = abs (f z) 202 | where 203 | f :: P r h M.Float -> P r h M.Float 204 | f (Known l _ _ _ _) = float (M.exp l) 205 | f (Open x) = Open $ f . x 206 | f (Unk l) = Unk (floatExp1 l) 207 | 208 | type instance K repr h (a, b) = (P repr h a, P repr h b) 209 | instance Prod r => Prod (P r) where 210 | mkProd = abs (abs (f (s z) z)) 211 | where 212 | f :: P r h a -> P r h b -> P r h (a, b) 213 | f l r = know (l, r) 214 | (mkProd2 (dynamic l) (dynamic r)) 215 | (\h -> mkProd2 (app_open l h) (app_open r h)) 216 | (mkProd2 (s l) (s r)) 217 | zro = abs (f z) 218 | where 219 | f :: P r h (a, b) -> P r h a 220 | f (Known (l, _) _ _ _ _) = l 221 | f (Open x) = Open $ f . x 222 | f (Unk p) = Unk (zro1 p) 223 | fst = abs (f z) 224 | where 225 | f :: P r h (a, b) -> P r h b 226 | f (Known (_, r) _ _ _ _) = r 227 | f (Open x) = Open $ f . x 228 | f (Unk p) = Unk (fst1 p) 229 | 230 | type instance K repr h (M.Either a b) = M.Either (P repr h a) (P repr h b) 231 | instance Sum r => Sum (P r) where 232 | left = abs (f z) 233 | where 234 | f :: P r h a -> P r h (M.Either a b) 235 | f x = know (Left x) 236 | (left1 $ dynamic x) 237 | (\h -> left1 $ app_open x h) 238 | (left1 $ s x) 239 | right = abs (f z) 240 | where 241 | f :: P r h b -> P r h (M.Either a b) 242 | f x = know (Right x) 243 | (right1 $ dynamic x) 244 | (\h -> right1 $ app_open x h) 245 | (right1 $ s x) 246 | sumMatch = abs $ abs $ abs (f (s (s z)) (s z) z) 247 | where 248 | f :: P r h (a -> c) -> P r h (b -> c) -> P r h (M.Either a b) -> P r h c 249 | f l _ (Known (M.Left x) _ _ _ _) = app l x 250 | f _ r (Known (M.Right x) _ _ _ _) = app r x 251 | f l r (Open x) = Open $ \h -> f (app_open l h) (app_open r h) (x h) 252 | f l r (Unk x) = Unk $ sumMatch3 (dynamic l) (dynamic r) x 253 | 254 | instance Y r => Y (P r) where 255 | y = Unk y -- naive strategy to avoid infinite loop in PE. Later might do infinite PE thx to laziness. 256 | 257 | type instance K repr h [a] = Maybe (P repr h a, P repr h [a]) 258 | instance List repr => List (P repr) where 259 | nil = static (Nothing, nil) 260 | cons = abs $ abs (f (s z) z) 261 | where 262 | f :: P repr h a -> P repr h [a] -> P repr h [a] 263 | f h t = know (Just (h, t)) 264 | (cons2 (dynamic h) (dynamic t)) 265 | (\env -> cons2 (app_open h env) (app_open t env)) 266 | (cons2 (s h) (s t)) 267 | listMatch = abs $ abs $ abs (f (s $ s z) (s z) z) 268 | where 269 | f :: P repr h b -> P repr h (a -> [a] -> b) -> P repr h [a] -> P repr h b 270 | f l _ (Known Nothing _ _ _ _) = l -- You know nothing, Jon Snow. 271 | f _ r (Known (Just (h, t)) _ _ _ _) = app2 r h t 272 | f l r (Open x) = Open $ \h -> f (app_open l h) (app_open r h) (x h) 273 | f l r (Unk x) = Unk $ listMatch3 (dynamic l) (dynamic r) x 274 | listAppend = abs $ abs (f (s z) z) 275 | where 276 | f :: P repr h [a] -> P repr h [a] -> P repr h [a] 277 | f (Known Nothing _ _ _ _) r = r 278 | f (Known (Just (h, t)) _ _ _ _) r = cons2 h (listAppend2 t r) 279 | f l (Known Nothing _ _ _ _) = l 280 | f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h) 281 | f l r = Unk (listAppend2 (dynamic l) (dynamic r)) 282 | 283 | type instance K repr h (Maybe a) = Maybe (P repr h a) 284 | instance Option repr => Option (P repr) where 285 | nothing = static (Nothing, nothing) 286 | just = abs (f z) 287 | where 288 | f :: P repr h a -> P repr h (Maybe a) 289 | f x = know (Just x) 290 | (just1 $ dynamic x) 291 | (\h -> just1 $ app_open x h) 292 | (just1 $ s x) 293 | optionMatch = abs $ abs $ abs (f (s (s z)) (s z) z) 294 | where 295 | f :: P repr h b -> P repr h (a -> b) -> P repr h (Maybe a) -> P repr h b 296 | f l _ (Known Nothing _ _ _ _) = l 297 | f _ r (Known (Just x) _ _ _ _) = app r x 298 | f l r (Open x) = Open $ \h -> f (app_open l h) (app_open r h) (x h) 299 | f l r (Unk x) = Unk $ optionMatch3 (dynamic l) (dynamic r) x 300 | 301 | type instance K repr h M.Char = M.Char 302 | instance Char repr => Char (P repr) where 303 | char x = static (x, char x) 304 | 305 | type instance K repr h M.Ordering = M.Ordering 306 | instance Ordering repr => Ordering (P repr) where 307 | ordering x = static (x, ordering x) 308 | sel = abs $ abs $ abs $ abs $ f (s (s (s z))) (s (s z)) (s z) z where 309 | f :: P repr h a -> P repr h a -> P repr h a -> P repr h M.Ordering -> P repr h a 310 | f a _ _ (Known M.LT _ _ _ _) = a 311 | f _ b _ (Known M.EQ _ _ _ _) = b 312 | f _ _ c (Known M.GT _ _ _ _) = c 313 | f a b c (Open x) = Open $ \h -> f (app_open a h) (app_open b h) (app_open c h) (x h) 314 | f a b c (Unk x) = Unk $ sel4 (dynamic a) (dynamic b) (dynamic c) x 315 | 316 | type instance K repr h M.Int = M.Int 317 | instance Int repr => Int (P repr) where 318 | int x = static (x, int x) 319 | pred = abs (f z) where 320 | f :: P repr h M.Int -> P repr h M.Int 321 | f (Known i _ _ _ _) = int $ i - 1 322 | f (Open x) = Open $ f . x 323 | f (Unk x) = Unk $ pred1 x 324 | intCmp = abs $ abs $ f (s z) z where 325 | f :: P repr h M.Int -> P repr h M.Int -> P repr h M.Ordering 326 | f (Known l _ _ _ _) (Known r _ _ _ _) = ordering $ M.compare l r 327 | f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h) 328 | f l r = Unk $ cmp2 (dynamic l) (dynamic r) 329 | 330 | type instance K repr h (M.Dual l r) = (P repr h l, P repr h r) 331 | instance Dual repr => Dual (P repr) where 332 | dual = abs $ f z 333 | where 334 | f :: P repr h (a, b) -> P repr h (M.Dual a b) 335 | f (Known (l, r) _ _ _ _) = 336 | know (l, r) 337 | (mkDual2 (dynamic l) (dynamic r)) 338 | (\h -> mkDual2 (app_open l h) (app_open r h)) 339 | (s $ mkDual2 l r) 340 | f (Open x) = Open $ f . x 341 | f (Unk x) = Unk $ dual1 x 342 | runDual = abs (f z) 343 | where 344 | f :: P repr h (M.Dual a b) -> P repr h (a, b) 345 | f (Known (l, r) _ _ _ _) = 346 | know (l, r) 347 | (mkProd2 (dynamic l) (dynamic r)) 348 | (\h -> mkProd2 (app_open l h) (app_open r h)) 349 | (mkProd2 (s l) (s r)) 350 | f (Open x) = Open $ f . x 351 | f (Unk x) = Unk $ runDual1 x 352 | dualGetOrdC :: forall x y. Ord (P repr) x :- OrdC (P repr) (M.Dual x y) 353 | dualGetOrdC = Sub (withDict (getOrdC @(P repr) @x Proxy) Dict) 354 | 355 | type instance K r h () = () 356 | instance Unit r => Unit (P r) where 357 | unit = static ((), unit) 358 | 359 | type instance K r h (M.IO a) = P r h a 360 | instance IO r => IO (P r) where 361 | putStrLn = Unk putStrLn 362 | ioJoin = abs $ f z where 363 | f :: P r h (M.IO (M.IO a)) -> P r h (M.IO a) 364 | f (Known l _ _ _ _) = l 365 | f (Open x) = Open $ f . x 366 | f (Unk x) = Unk $ join1 x 367 | ioMap = abs $ abs $ f (s z) z where 368 | f :: P r h (a -> b) -> P r h (M.IO a) -> P r h (M.IO b) 369 | f l (Known a _ _ _ _) = pure1 $ app l a 370 | f l (Open x) = Open $ \h -> f (app_open l h) (x h) 371 | f l (Unk x) = Unk $ map2 (dynamic l) x 372 | ioPure = abs $ f z where 373 | f :: P r h a -> P r h (M.IO a) 374 | f x = know x (pure1 $ dynamic x) (\h -> pure1 $ app_open x h) (pure1 $ s x) 375 | ioAP = abs $ abs $ f (s z) z where 376 | f :: P r h (M.IO (a -> b)) -> P r h (M.IO a) -> P r h (M.IO b) 377 | f (Known l _ _ _ _) (Known r _ _ _ _) = pure1 $ app l r 378 | f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h) 379 | f l r = Unk $ ap2 (dynamic l) (dynamic r) 380 | 381 | pe :: DBI repr => P repr () a -> repr () a 382 | pe = dynamic 383 | -------------------------------------------------------------------------------- /DDF/Prod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | ScopedTypeVariables 5 | #-} 6 | 7 | module DDF.Prod (module DDF.Prod, module DDF.Ordering) where 8 | 9 | import DDF.Ordering 10 | 11 | class Ordering r => Prod r where 12 | mkProd :: r h (a -> b -> (a, b)) 13 | zro :: r h ((a, b) -> a) 14 | fst :: r h ((a, b) -> b) 15 | swap :: r h ((x, y) -> (y, x)) 16 | swap = lam $ \p -> mkProd2 (fst1 p) (zro1 p) 17 | curry :: r h (((a, b) -> c) -> (a -> b -> c)) 18 | curry = lam3 $ \f a b -> app f (mkProd2 a b) 19 | uncurry :: r h ((a -> b -> c) -> ((a, b) -> c)) 20 | uncurry = lam2 $ \f p -> app2 f (zro1 p) (fst1 p) 21 | prodCmp :: forall h a b. r h (Cmp a -> Cmp b -> Cmp (a, b)) 22 | prodCmp = 23 | lam2 $ \l r -> 24 | uncurry1 (lam2 $ \ll lr -> 25 | uncurry1 (lam2 $ \rl rr -> 26 | chainOrd2 (app2 l ll rl) (app2 r lr rr))) 27 | 28 | zro1 = app1 zro 29 | fst1 = app1 fst 30 | mkProd1 = app1 mkProd 31 | mkProd2 = app2 mkProd 32 | curry1 = app curry 33 | uncurry1 = app1 uncurry 34 | -------------------------------------------------------------------------------- /DDF/Sam/Hello.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE 2 | > NoImplicitPrelude, 3 | > ExplicitForAll, 4 | > KindSignatures, 5 | > NoMonomorphismRestriction 6 | > #-} 7 | 8 | > module DDF.Sam.Hello where 9 | > import DDF.Lang 10 | > import DDF.Eval 11 | > import DDF.Show 12 | > import qualified Prelude as M 13 | 14 | DDF is a language embedded in Haskell, written using Finally Tagless Style. 15 | Being an embedded language mean it is a piece of cake to write DDF macro - they are just Haskell function! 16 | Another benefit is that DDF code is typed check when GHC compile, so you can do type driven developement. 17 | 18 | > hello :: forall (int :: * -> * -> *) (h :: *). Lang int => int h String 19 | > hello = string "Hello" 20 | 21 | Let's get to action! 22 | The code above define a literal in hello. 23 | Note that it has strange type: it take an (int :: * -> * -> *), and (h :: *), and return int h String. 24 | Well, h is an enviroment of variable, and int h is an interpreter which interpret term in enviroment h. 25 | int h String mean the final result is an int, so we had constrained the term to be scope-correct and type safe at Haskell compile time. 26 | Lang int is simply the constraint that int can interpret anything inside Lang. 27 | 28 | > world :: (List int, Char int) => int () String 29 | > world = string "world" 30 | 31 | Well, we are just defining string literal, so it don't need the full power of Lang. 32 | Since string is list of char, using List and Char should be enough. 33 | This is better since maybe some interpreter (int) doesnt support the full Lang! 34 | Also note that we had manually select an enviromnet, instead of letting it be anything. 35 | The enviroment is simply (), which mean there's no free variable. 36 | 37 | > space :: (List int, Char int) => int h (String -> String -> String) 38 | > space = lam2 $ \l r -> listAppend2 l (cons2 (char ' ') r) 39 | 40 | And now we should play with lambda a bit. 41 | Lambda abstraction is just Haskell Lambda abstraction (with some magic), so it is relatively easy to use. 42 | Also, note how everything is scope safe again: it is impossible to append x to z, because variable z doesnt exist. 43 | It is assumed that every interpreter know how to deal with lambda, so we dont need another constraint (it is implied by both List and Char). 44 | 45 | > addTail :: (List int, Char int) => int h String -> M.Char -> int h String 46 | > addTail l r = listAppend2 l (cons2 (char r) nil) 47 | 48 | Now this is some macro: just ordinary Haskell function that generate AST. 49 | They can take both Haskell term, DDF term as input, and notice that the macro is type safe. 50 | 51 | > str = addTail (app2 space hello world) '!' 52 | 53 | Finally, notice that, under NoMonomorphismRestriction, GHC will infer the most general type automatically. 54 | Unfortunately, since we specify Lang, and use () as env in the component, it's type are more restrictive than we hope. 55 | 56 | > main :: M.IO () 57 | > main = do 58 | > print $ runEval str () 59 | > print $ showAST str 60 | > M.return () 61 | 62 | Now we show two interpreter: the evaluator and the pretty printer. 63 | One output the final result and one output the AST. 64 | The () floating around is the enviroment we feed into the evaluator. 65 | -------------------------------------------------------------------------------- /DDF/Sam/Poly.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE 2 | > NoImplicitPrelude, 3 | > MultiParamTypeClasses, 4 | > RankNTypes, 5 | > ScopedTypeVariables, 6 | > FlexibleInstances, 7 | > FlexibleContexts, 8 | > UndecidableInstances, 9 | > IncoherentInstances, 10 | > PolyKinds, 11 | > LambdaCase, 12 | > NoMonomorphismRestriction, 13 | > TypeFamilies, 14 | > LiberalTypeSynonyms, 15 | > EmptyCase 16 | > #-} 17 | 18 | > module DDF.Sam.Poly where 19 | > import Control.Monad (when) 20 | > import DDF.Meta.Util 21 | > import DDF.Lang 22 | > import DDF.Show 23 | > import DDF.Diff () 24 | > import qualified Control.Monad as M 25 | > import Prelude (Integer) 26 | > import qualified Prelude as M 27 | > import qualified DDF.Meta.Dual as M 28 | > import DDF.Eval 29 | > import DDF.Vector 30 | 31 | Our goal is to find x, where x * x + 2 * x + 3 = 27. 32 | To do so, we try to minimize their difference squared (l2 norm). 33 | 34 | > poly :: forall repr h. Lang repr => repr h (M.Double -> M.Double) 35 | > poly = lam $ \x -> plus2 (mult2 x x) (plus2 (mult2 (double 2.0) x) (double 3.0)) 36 | 37 | poly x = x * x + (2 * x + 3) 38 | 39 | > l2 = lam $ \x -> mult2 (minus2 x (double 27)) (minus2 x (double 27)) 40 | 41 | l2 x = (x - 27) * (x - 27) 42 | l2 measure how far is the input from 27 43 | 44 | > comp = com2 l2 poly 45 | 46 | By composing the two, we can measure how far is x * x + 2 * x + 3 from 27. 47 | We want to minimize this distance. 48 | 49 | Now write a generic function that calculate x and return it. 50 | 51 | > solve :: forall m. M.Monad m => (AST -> m ()) -> (Integer -> M.Double -> m ()) -> m M.Double 52 | > solve doAST doIter = do 53 | 54 | Let's begin by trying to print poly 55 | 56 | > doAST $ runShow poly vars 0 57 | > go 0 0 58 | > where 59 | 60 | The main loop. i is step and w is weight (our current estimate of x). 61 | We start by assuming x = 0 is the solution, 62 | and minimize (comp x) by taking derivative of x, and decrease it whenever it is positive (and vice versa). 63 | 64 | > go :: Integer -> M.Double -> m M.Double 65 | > go i w | i < 200 = do 66 | > doIter i w 67 | > go (1 + i) $ w - 0.001 * M.dualDiff (runEval (runDiff $ noEnv comp) () $ M.Dual (w, 1)) 68 | 69 | noEnv comp assume the term (which is a De Brujin Index term) need no environment (is free) 70 | and it is a finally tagless term, with WDiff interpreter being implicitly applied, 71 | which return another finally tagless term, but taking derivative of x. 72 | it is then applied to Eval interpreter (which eval it in the meta language, haskell). 73 | similar to runWDiff, we use runEval to take out the term from a newtype 74 | now we apply the environment (remember it has no environment? so just stick a unit) 75 | and a pair, the zeroth being x, the first being derivative of x, which is 1. 76 | the whole computation return a pair of (x * x + (2 * x + 3) - 27)^2, and it's derivative. 77 | we modify w using the derivative. 78 | 79 | > go _ w = M.return w 80 | 81 | By running the program, you shall see 82 | (\a -> (plus (mult a a) (plus (mult 2.0 a) 3.0))) 83 | since we pretty print poly 84 | followed by something like 85 | 0.0 86 | 9.6e-2 87 | 0.43573084645674215 88 | 1.1890033104995505 89 | 2.498644212525056 90 | 3.652210805402036 91 | 3.9662181049468925 92 | 3.9981203814732154 93 | 3.9999338218043157 94 | 3.999998509763363 95 | 3.9999999785234146 96 | 3.9999999998019136 97 | 3.9999999999988307 98 | 3.9999999999999956 99 | 3.999999999999999 100 | which mean we found 4 as a soultion. 101 | plugging it back to the equation, we can verify that (4 * 4) + 2 * 4 + 3 is indeed 27! 102 | 103 | Now the main function: 104 | 105 | > main :: M.IO () 106 | > main = do 107 | > d <- solve print printSquare 108 | > M.putStrLn $ "x is: " ++ (show d) 109 | > M.return () 110 | > where 111 | > printSquare i x = when (isSquare i) (print x) 112 | 113 | the only thing worth noting is that we print the weight in increasing interval, 114 | so initially more weight is printed 115 | -------------------------------------------------------------------------------- /DDF/Sam/Xor.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE 2 | > ScopedTypeVariables, 3 | > NoMonomorphismRestriction, 4 | > TypeApplications, 5 | > RankNTypes, 6 | > NoImplicitPrelude, 7 | > ScopedTypeVariables 8 | > #-} 9 | 10 | This is the classical example of using sigmoid NN to approximate Xor. 11 | You should already read DDF.Poly before this. 12 | 13 | > module DDF.Sam.Xor where 14 | > import qualified Prelude as M 15 | > import System.Random 16 | > import Control.Monad (when) 17 | > import Data.Constraint 18 | > import DDF.Meta.Util 19 | > import DDF.Lang 20 | > import DDF.Show 21 | > import DDF.Eval () 22 | > import DDF.Term 23 | > import DDF.ImpW 24 | > import DDF.WithDiff 25 | > import DDF.Eval 26 | > import qualified DDF.Meta.Dual as M 27 | > import DDF.Vector 28 | 29 | Recall in poly, we constructed a function Double -> Double, 30 | with argument being the weight, and do gradient descend to found a solution. 31 | 32 | However, most of the time, there wil be more than one weight (or no weight at all). 33 | Also, when we are composing a Neural Network to approximate a value, we dont really care how much weight it use. 34 | So, we use existential type to hide the actual weight. 35 | 36 | data ImpW repr h x = forall w. Weight w => ImpW (repr h (w -> x)) 37 | 38 | ImpW stands for implicit weights. 39 | The existential w is weight, and a Neural Network of type x is just a function from w to x! 40 | We require that the weight can be constructed randomly, so we have random initialization. 41 | Weight also form a Vector so we can combine weights (update it), scale it (to control the learning rate). 42 | 43 | Let's start by constructing a weight. 44 | 45 | > doubleWeight :: Lang repr => ImpW repr h M.Double 46 | > doubleWeight = ImpW id 47 | 48 | Note that we are just manipulating AST. 49 | If you wanna do weight sharing, you need to use let(in DDF) yourself. 50 | 51 | Obviously, we just need to take the implicit argument. 52 | 53 | We have the weight, now we need the activation function, sigmoid. 54 | 55 | > sigmoid = lam $ \x -> recip1 (plus2 doubleOne (doubleExp1 (invert1 x))) 56 | > sigmoid1 = app sigmoid 57 | 58 | With weight and sigmoid we can construct a neuron of type ((M.Double, M.Double) -> M.Double) 59 | The weight should be a pair of M.Double, each as a scale on the actual input, with a bias. 60 | We then add the two scaled input, with the bias, and pass them into sigmoid. 61 | 62 | > scaleAdd :: Lang repr => ImpW repr h ((M.Double, M.Double) -> M.Double) 63 | > scaleAdd = ImpW $ lam2 $ \w p -> plus2 (mult2 (zro1 w) (zro1 p)) (plus2 (fst1 w) (fst1 p)) 64 | 65 | > withBias :: Lang repr => ImpW repr h (M.Double -> M.Double) 66 | > withBias = ImpW $ plus 67 | 68 | > neuron :: Lang repr => ImpW repr h ((M.Double, M.Double) -> M.Double) 69 | > neuron = com2 (com2 sigmoid withBias) scaleAdd 70 | > neuron1 = app neuron 71 | 72 | Now, the hidden layer of type (M.Double, M.Double) -> ((M.Double, M.Double), (M.Double, M.Double)) 73 | 74 | > hidden = lam $ \p -> mkProd2 (mkProd2 (neuron1 p) (neuron1 p)) (mkProd2 (neuron1 p) (neuron1 p)) 75 | 76 | And finally, the whole NN: 77 | 78 | > type XOR = (M.Double, M.Double) -> M.Double 79 | > xorNet :: Lang repr => ImpW repr h XOR 80 | > xorNet = neuron `com2` (bimap2 scaleAdd scaleAdd) `com2` hidden 81 | 82 | But before we can train it, we need to define the dataset and the loss function. 83 | 84 | > l2 :: Lang repr => repr h (M.Double -> M.Double -> M.Double) 85 | > l2 = lam2 $ \l r -> (mult2 (minus2 l r) (minus2 l r)) 86 | > l22 = app2 l2 87 | 88 | > eval :: Lang repr => repr h (XOR -> ((M.Double, M.Double), M.Double) -> M.Double) 89 | > eval = lam2 $ \xor p -> l22 (app xor (zro1 p)) (fst1 p) 90 | 91 | > dataset :: Lang repr => repr h [((M.Double, M.Double), M.Double)] 92 | > dataset = cons2 (build 0 0 0) (cons2 (build 0 1 1) (cons2 (build 1 0 1) (cons2 (build 1 1 0) nil))) 93 | > where build l r ret = mkProd2 (mkProd2 (double l) (double r)) (double ret) 94 | 95 | However, unlike Poly, there are more than one datapoint, so we need to use a list, and map xor onto it. 96 | 97 | > loss :: Lang repr => repr h (XOR -> M.Double) 98 | > loss = lam $ \xor -> y2 (lam $ \self -> listMatch2 doubleZero (lam2 $ \x xs -> plus2 x (app self xs))) (map2 (app eval xor) dataset) 99 | 100 | Now we are good to implement the train function! 101 | 102 | > findXor :: forall g m. (RandomGen g, M.Monad m) => g -> (AST -> m ()) -> (M.Int -> M.Double -> M.String -> m ()) -> m XOR 103 | > findXor rand doAST doIter = case runImpW $ noEnv xorNet of 104 | > RunImpW ((Term net) :: Weight w => Term Lang () (w -> XOR)) -> do 105 | > doAST $ runShow net vars 0 106 | 107 | printing weights. now you will see a list of gibberish 108 | 109 | > let initWeight :: w = M.fst $ ((randomR (randRange (-0.01, 0.01)) \\ weightCon @w @Random) \\ weightCon @w @RandRange) rand 110 | 111 | Getting random weights... 112 | 113 | > (go (diff net) initWeight (runEval selfWithDiff () \\ weightCon @w @(WithDiff Eval)) (diff loss) 114 | > ((runEval (lam3 $ \d o n -> minus2 o (mult2 d n)) ()) \\ weightCon @w @(Vector Eval)) 0 (runEval net ())) \\ weightCon @w @M.Show 115 | > where 116 | > diff :: forall x. Term Lang () x -> DiffType w x 117 | > diff (Term x) = runEval (runDiff @_ @w (noEnv x)) () \\ weightCon @w @(Vector Eval) 118 | > go :: M.Show w => (DiffType w (w -> XOR)) -> w -> (w -> DiffType w w) -> (DiffType w (XOR -> M.Double)) -> (M.Double -> w -> w -> w) -> M.Int -> (w -> XOR) -> m XOR 119 | > go xor weight reifyE lossE updateW i orig | i <= 2500 = do 120 | > doIter i lossVal (M.show weight) 121 | > go xor (updateW 0.3 weight lossDiff) reifyE lossE updateW (1 + i) orig 122 | > where 123 | > M.Dual (lossVal, lossDiff) = lossE $ xor (reifyE weight) 124 | > go _ weight _ _ _ _ orig = M.return $ orig weight 125 | 126 | > main :: M.IO () 127 | > main = do 128 | > g <- getStdGen 129 | > xorTrained <- findXor g print (\i d w -> when (isSquare i) $ do 130 | > print d 131 | > M.putStrLn w 132 | > M.putStrLn "") 133 | > let doXor :: M.Double -> M.Double -> M.IO () 134 | > doXor l r = M.putStrLn $ M.show l ++ " xor " ++ M.show r ++ " is " ++ (M.show $ xorTrained (l, r)) 135 | > doXor 0 0 136 | > doXor 0 1 137 | > doXor 1 0 138 | > doXor 1 1 139 | > M.return () 140 | -------------------------------------------------------------------------------- /DDF/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module DDF.Show where 4 | 5 | import DDF.Lang 6 | import qualified Prelude as M 7 | import qualified DDF.Map as Map 8 | import qualified DDF.VectorTF as VTF 9 | 10 | type instance OrdC Show = NoOrdC 11 | 12 | data Name = Prefix M.String | Infix M.String 13 | 14 | data AST = Node [M.String] Name [AST] 15 | 16 | appAST (Node [] n rest) x = Node [] n (rest ++ [x]) 17 | appAST f x = Node [] (Prefix (show f)) [x] 18 | 19 | lamAST str (Node abst n rest) = Node (str:abst) n rest 20 | 21 | vars = [pre : suf | suf <- "":M.map show [0..], pre <- ['a'..'z']] 22 | 23 | leaf x = Node [] x [] 24 | 25 | paren :: M.String -> M.String 26 | paren str = "(" ++ str ++ ")" 27 | 28 | apps :: Name -> [AST] -> M.String 29 | apps (Prefix n) rest = M.unwords (n:(M.map show rest)) 30 | apps (Infix n) [] = n 31 | apps (Infix n) [l] = (n ++ " " ++ show l) 32 | apps (Infix n) [l, r] = show l ++ " " ++ n ++ " " ++ show r 33 | apps (Infix n) (l:r:rest) = apps (Prefix (paren (show l ++ " " ++ n ++ " " ++ show r))) rest 34 | 35 | instance M.Show AST where 36 | show (Node [] n []) = apps n [] 37 | show (Node [] n rest) = paren $ apps n rest 38 | show (Node abst n rest) = paren ("\\" ++ M.unwords abst ++ " -> " ++ apps n rest) 39 | 40 | newtype Show h a = Show {runShow :: [M.String] -> M.Int -> AST} 41 | 42 | cname = Show . M.const . M.const . leaf 43 | name = cname . Prefix 44 | iname = cname . Infix 45 | 46 | showAST (Show sh) = sh vars 0 47 | 48 | instance DBI Show where 49 | z = Show $ M.const $ leaf . Prefix . show . M.flip (-) 1 50 | s (Show v) = Show $ \va -> v va . M.flip (-) 1 51 | abs (Show f) = Show $ \va x -> lamAST (show x) (f va (x + 1)) 52 | app (Show f) (Show x) = Show $ \va h -> appAST (f va h) (x va h) 53 | hoas f = Show $ \(v:va) h -> 54 | lamAST v (runShow (f $ Show $ M.const $ M.const $ leaf $ Prefix v) va (h + 1)) 55 | 56 | instance Bool Show where 57 | bool = name . show 58 | ite = name "ite" 59 | 60 | instance Char Show where 61 | char = name . show 62 | 63 | instance Prod Show where 64 | mkProd = name "mkProd" 65 | zro = name "zro" 66 | fst = name "fst" 67 | 68 | instance Double Show where 69 | double = name . show 70 | doublePlus = name "plus" 71 | doubleMinus = name "minus" 72 | doubleMult = name "mult" 73 | doubleDivide = name "divide" 74 | doubleExp = name "exp" 75 | doubleCmp = name "cmp" 76 | 77 | instance Float Show where 78 | float = name . show 79 | floatPlus = name "plus" 80 | floatMinus = name "minus" 81 | floatMult = name "mult" 82 | floatDivide = name "divide" 83 | floatExp = name "exp" 84 | 85 | instance Option Show where 86 | nothing = name "nothing" 87 | just = name "just" 88 | optionMatch = name "optionMatch" 89 | 90 | instance Map.Map Show where 91 | empty = name "Map.empty" 92 | singleton = name "Map.singleton" 93 | lookup' = name "Map.lookup" 94 | alter' = name "Map.alter" 95 | mapMap = name "Map.mapMap" 96 | unionWithKey' = name "Map.unionWithKey" 97 | 98 | instance Bimap Show where 99 | size = name "size" 100 | lookupL' = name "lookupL" 101 | lookupR' = name "lookupR" 102 | toMapL = name "toMapL" 103 | toMapR = name "toMapR" 104 | updateL' = name "updateL" 105 | updateR' = name "updateR" 106 | empty = name "empty" 107 | singleton = name "singleton" 108 | insert' = name "insert" 109 | 110 | instance Dual Show where 111 | dual = name "dual" 112 | runDual = name "runDual" 113 | dualGetOrdC = Sub Dict 114 | 115 | instance Unit Show where 116 | unit = name "unit" 117 | 118 | instance Sum Show where 119 | left = name "left" 120 | right = name "right" 121 | sumMatch = name "sumMatch" 122 | 123 | instance Int Show where 124 | int = name . show 125 | pred = name "pred" 126 | intCmp = name "compare" 127 | 128 | instance List Show where 129 | nil = name "[]" 130 | cons = iname ":" 131 | listMatch = name "listMatch" 132 | listAppend = iname "++" 133 | 134 | instance Y Show where 135 | y = name "Y" 136 | 137 | instance IO Show where 138 | putStrLn = name "putStrLn" 139 | ioMap = name "map" 140 | ioPure = name "pure" 141 | ioAP = name "ap" 142 | ioBind = name "bind" 143 | ioJoin = name "join" 144 | 145 | instance VTF.VectorTF Show where 146 | zero = name "VTF.zero" 147 | basis = name "VTF.basis" 148 | plus = name "VTF.plus" 149 | mult = name "VTF.mult" 150 | vtfMatch = name "VTF.vtfMatch" 151 | vtfCmp = name "vtfCompare" 152 | vtfGetOrdC = Sub Dict 153 | 154 | instance DiffWrapper Show where 155 | diffWrapper = name "diffWrapper" 156 | runDiffWrapper = name "runDiffWrapper" 157 | 158 | instance Fix Show where 159 | fix = name "fix" 160 | runFix = name "runFix" 161 | 162 | instance FreeVector Show where 163 | freeVector = name "freeVector" 164 | runFreeVector = name "runFreeVector" 165 | 166 | instance Lang Show where 167 | exfalso = name "exfalso" 168 | writer = name "writer" 169 | runWriter = name "runWriter" 170 | float2Double = name "float2Double" 171 | double2Float = name "double2Float" 172 | state = name "state" 173 | runState = name "runState" 174 | 175 | instance Ordering Show where 176 | ordering = name . show 177 | sel = name "sel" 178 | -------------------------------------------------------------------------------- /DDF/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-} 2 | 3 | module DDF.Size where 4 | 5 | import DDF.Lang 6 | import qualified Prelude as M 7 | import qualified DDF.Map as Map 8 | import qualified DDF.VectorTF as VTF 9 | 10 | type instance OrdC Size = NoOrdC 11 | 12 | newtype Size h x = Size {runSize :: M.Int} 13 | 14 | one = Size 1 15 | 16 | instance DBI Size where 17 | z = one 18 | s (Size x) = Size x 19 | app (Size l) (Size r) = Size (l + r) 20 | abs (Size x) = Size x 21 | 22 | instance Bool Size where 23 | bool _ = one 24 | ite = one 25 | 26 | instance Char Size where 27 | char _ = one 28 | 29 | instance Option Size where 30 | nothing = one 31 | just = one 32 | optionMatch = one 33 | 34 | instance Double Size where 35 | double _ = one 36 | doublePlus = one 37 | doubleMinus = one 38 | doubleMult = one 39 | doubleDivide = one 40 | doubleExp = one 41 | doubleCmp = one 42 | 43 | instance Float Size where 44 | float _ = one 45 | floatPlus = one 46 | floatMinus = one 47 | floatMult = one 48 | floatDivide = one 49 | floatExp = one 50 | 51 | instance Map.Map Size where 52 | mapMap = one 53 | alter' = one 54 | empty = one 55 | singleton = one 56 | lookup' = one 57 | unionWithKey' = one 58 | 59 | instance Prod Size where 60 | mkProd = one 61 | zro = one 62 | fst = one 63 | 64 | instance Dual Size where 65 | dual = one 66 | runDual = one 67 | dualGetOrdC = Sub Dict 68 | 69 | instance Bimap Size where 70 | updateL' = one 71 | updateR' = one 72 | singleton = one 73 | empty = one 74 | insert' = one 75 | lookupL' = one 76 | lookupR' = one 77 | size = one 78 | toMapL = one 79 | toMapR = one 80 | 81 | instance Unit Size where 82 | unit = one 83 | 84 | instance Sum Size where 85 | left = one 86 | right = one 87 | sumMatch = one 88 | 89 | instance Int Size where 90 | int _ = one 91 | pred = one 92 | intCmp = one 93 | 94 | instance IO Size where 95 | putStrLn = one 96 | ioJoin = one 97 | ioBind = one 98 | ioMap = one 99 | ioPure = one 100 | ioAP = one 101 | 102 | instance Y Size where 103 | y = one 104 | 105 | instance List Size where 106 | nil = one 107 | cons = one 108 | listMatch = one 109 | 110 | instance VTF.VectorTF Size where 111 | zero = one 112 | basis = one 113 | plus = one 114 | mult = one 115 | vtfMatch = one 116 | vtfCmp = one 117 | vtfGetOrdC = Sub Dict 118 | 119 | instance DiffWrapper Size where 120 | diffWrapper = one 121 | runDiffWrapper = one 122 | 123 | instance Fix Size where 124 | fix = one 125 | runFix = one 126 | 127 | instance FreeVector Size where 128 | freeVector = one 129 | runFreeVector = one 130 | 131 | instance Lang Size where 132 | exfalso = one 133 | writer = one 134 | runWriter = one 135 | float2Double = one 136 | double2Float = one 137 | state = one 138 | runState = one 139 | 140 | instance Ordering Size where 141 | sel = one 142 | ordering _ = one 143 | -------------------------------------------------------------------------------- /DDF/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module DDF.Sum (module DDF.Sum, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | 7 | class DBI r => Sum r where 8 | left :: r h (a -> Either a b) 9 | right :: r h (b -> Either a b) 10 | sumMatch :: r h ((a -> c) -> (b -> c) -> Either a b -> c) 11 | 12 | sumMatch1 = app1 sumMatch 13 | sumMatch2 = app2 sumMatch 14 | sumMatch3 = app3 sumMatch 15 | left1 = app left 16 | right1 = app right -------------------------------------------------------------------------------- /DDF/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | TemplateHaskell, 4 | MultiParamTypeClasses 5 | #-} 6 | 7 | module DDF.Term (module DDF.TermGen) where 8 | import DDF.TermGen 9 | 10 | $genInstance 11 | -------------------------------------------------------------------------------- /DDF/TermGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | RankNTypes, 3 | ConstraintKinds, 4 | NoImplicitPrelude, 5 | KindSignatures, 6 | TypeOperators, 7 | MultiParamTypeClasses, 8 | FlexibleContexts, 9 | UndecidableInstances, 10 | FlexibleInstances, 11 | TypeFamilies, 12 | UndecidableSuperClasses, 13 | TemplateHaskell, 14 | TypeApplications, 15 | ScopedTypeVariables, 16 | PartialTypeSignatures, 17 | AllowAmbiguousTypes, 18 | InstanceSigs 19 | #-} 20 | 21 | module DDF.TermGen (module DDF.TermGen, module DDF.Lang) where 22 | 23 | import DDF.Lang 24 | import qualified DDF.Map as Map 25 | import qualified DDF.VectorTF as VTF 26 | import qualified Prelude as M 27 | import Language.Haskell.TH 28 | import qualified DDF.Meta.Dual as M 29 | import qualified Data.Bimap as M 30 | import qualified DDF.Meta.VectorTF as M.VTF 31 | import qualified Data.Map as M 32 | 33 | type instance OrdC (Term c) = TermOrd c 34 | class TermOrd (c :: (* -> * -> *) -> Constraint) x where 35 | termOrdDict :: c r => Dict (Ord r x) 36 | 37 | instance SubL c Int => TermOrd c M.Int where 38 | termOrdDict :: forall r. c r => Dict (Ord r M.Int) 39 | termOrdDict = Dict \\ sub @c @Int @r 40 | 41 | instance SubL c Double => TermOrd c M.Double where 42 | termOrdDict :: forall r. c r => Dict (Ord r M.Double) 43 | termOrdDict = Dict \\ sub @c @Double @r 44 | 45 | instance (SubL c Dual, TermOrd c x) => TermOrd c (M.Dual x y) where 46 | termOrdDict :: forall r. c r => Dict (Ord r (M.Dual x y)) 47 | termOrdDict = withDict (termOrdDict @c @x @r) Dict \\ sub @c @Dual @r 48 | 49 | instance (SubL c VTF.VectorTF, TermOrd c t, TermOrd c f) => TermOrd c (M.VTF.VectorTF t f) where 50 | termOrdDict :: forall r. c r => Dict (Ord r (M.VTF.VectorTF t f)) 51 | termOrdDict = (withDict (termOrdDict @c @t @r) $ withDict (termOrdDict @c @f @r) Dict) \\ sub @c @VTF.VectorTF @r 52 | 53 | type family SubLC (l :: (* -> * -> *) -> Constraint) (r :: (* -> * -> *) -> Constraint) :: Constraint 54 | 55 | class SubLC l r => SubL l r where 56 | sub :: forall repr. l repr :- r repr 57 | 58 | newtype Term c h s = Term { runTerm :: forall r. c r => r h s } 59 | 60 | mkT :: forall r l h s. (SubL l r) => 61 | (forall (repr :: * -> * -> *). (l repr, r repr) => repr h s) -> 62 | Term l h s 63 | 64 | mkT f = Term k 65 | where 66 | k :: forall repr. l repr => repr h s 67 | k = f @repr \\ sub @l @r @repr 68 | 69 | mkT1 :: forall r a l h s. (SubL l r, OrdWC (Term l) a) => 70 | (forall (repr :: * -> * -> *). (l repr, r repr, Ord repr a) => repr h s) -> 71 | Term l h s 72 | 73 | mkT1 f = Term k 74 | where 75 | k :: forall repr. l repr => repr h s 76 | k = withDict (termOrdDict @l @a @repr) (f @repr \\ sub @l @r @repr) 77 | 78 | mkT2 :: forall r a b l h s. (SubL l r, OrdWC (Term l) a, OrdWC (Term l) b) => 79 | (forall (repr :: * -> * -> *). (l repr, r repr, Ord repr a, Ord repr b) => repr h s) -> 80 | Term l h s 81 | 82 | mkT2 f = Term k 83 | where 84 | k :: forall repr. l repr => repr h s 85 | k = withDict (termOrdDict @l @a @repr) $ withDict (termOrdDict @l @b @repr) (f @repr \\ sub @l @r @repr) 86 | 87 | type instance SubLC c DBI = () 88 | 89 | instance SubL c DBI => DBI (Term c) where 90 | z = mkT @DBI z 91 | s (Term x) = mkT @DBI (s x) 92 | abs (Term x) = mkT @DBI (abs x) 93 | app (Term f) (Term x) = mkT @DBI (app f x) 94 | 95 | type instance SubLC c Bool = SubL c DBI 96 | 97 | instance SubL c Bool => Bool (Term c) where 98 | ite = mkT @Bool ite 99 | bool x = mkT @Bool (bool x) 100 | 101 | type instance SubLC c Int = SubL c Ordering 102 | 103 | instance SubL c Int => Int (Term c) where 104 | pred = mkT @Int pred 105 | int x = mkT @Int (int x) 106 | intCmp = mkT @Int cmp 107 | 108 | type instance SubLC c Fix = SubL c DBI 109 | 110 | instance SubL c Fix => Fix (Term c) where 111 | fix = mkT @Fix fix 112 | runFix = mkT @Fix runFix 113 | 114 | type instance SubLC c FreeVector = SubL c DBI 115 | 116 | instance SubL c FreeVector => FreeVector (Term c) where 117 | freeVector = mkT @FreeVector freeVector 118 | runFreeVector = mkT @FreeVector runFreeVector 119 | 120 | type instance SubLC c DiffWrapper = SubL c DBI 121 | 122 | instance SubL c DiffWrapper => DiffWrapper (Term c) where 123 | diffWrapper = mkT @DiffWrapper diffWrapper 124 | runDiffWrapper = mkT @DiffWrapper runDiffWrapper 125 | 126 | type instance SubLC c Char = SubL c DBI 127 | 128 | instance SubL c Char => Char (Term c) where 129 | char x = mkT @Char (char x) 130 | 131 | termOrd :: forall c a r. (Ord (Term c) a, c r) => Dict (Ord r a) 132 | termOrd = withDict (getOrdC @(Term c) @a Proxy) (termOrdDict @c @a @r) 133 | 134 | termOrd2 :: forall c a b r. (Ord (Term c) a, Ord (Term c) b, c r) => Dict (Ord r a, Ord r b) 135 | termOrd2 = withDict (termOrd @c @a @r) $ withDict (termOrd @c @b @r) Dict 136 | 137 | type instance SubLC c Bimap = (SubL c Int, SubL c Map.Map) 138 | instance SubL c Bimap => Bimap (Term c) where 139 | size = mkT @Bimap size 140 | empty = mkT @Bimap empty 141 | toMapL = mkT @Bimap toMapL 142 | toMapR = mkT @Bimap toMapR 143 | singleton = mkT @Bimap singleton 144 | lookupL' :: forall h a b. (OrdWC (Term c) a, OrdWC (Term c) b) => Term c h (M.Bimap a b -> a -> Maybe b) 145 | lookupL' = mkT2 @Bimap @a @b lookupL 146 | lookupR' :: forall h a b. (OrdWC (Term c) a, OrdWC (Term c) b) => Term c h (M.Bimap a b -> b -> Maybe a) 147 | lookupR' = mkT2 @Bimap @a @b lookupR 148 | updateL' :: forall h a b. (OrdWC (Term c) a, OrdWC (Term c) b) => Term c h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b) 149 | updateL' = mkT2 @Bimap @a @b updateL 150 | updateR' :: forall h a b. (OrdWC (Term c) a, OrdWC (Term c) b) => Term c h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b) 151 | updateR' = mkT2 @Bimap @a @b updateR 152 | insert' :: forall h a b. (OrdWC (Term c) a, OrdWC (Term c) b) => Term c h ((a, b) -> M.Bimap a b -> M.Bimap a b) 153 | insert' = mkT2 @Bimap @a @b insert 154 | 155 | type instance SubLC c Float = SubL c DBI 156 | instance SubL c Float => Float (Term c) where 157 | float x = mkT @Float (float x) 158 | floatExp = mkT @Float floatExp 159 | floatPlus = mkT @Float floatPlus 160 | floatMult = mkT @Float floatMult 161 | floatMinus = mkT @Float floatMinus 162 | floatDivide = mkT @Float floatDivide 163 | 164 | type instance SubLC c Double = SubL c Ordering 165 | instance SubL c Double => Double (Term c) where 166 | double x = mkT @Double (double x) 167 | doubleCmp = mkT @Double doubleCmp 168 | doubleExp = mkT @Double doubleExp 169 | doublePlus = mkT @Double doublePlus 170 | doubleMult = mkT @Double doubleMult 171 | doubleMinus = mkT @Double doubleMinus 172 | doubleDivide = mkT @Double doubleDivide 173 | 174 | type instance SubLC c Dual = SubL c Prod 175 | 176 | instance SubL c Dual => Dual (Term c) where 177 | dual = mkT @Dual dual 178 | runDual = mkT @Dual runDual 179 | dualGetOrdC :: forall x y. Ord (Term c) x :- TermOrd c (M.Dual x y) 180 | dualGetOrdC = Sub (withDict (getOrdC @(Term c) @x Proxy) Dict) 181 | 182 | type instance SubLC c Unit = SubL c DBI 183 | 184 | instance SubL c Unit => Unit (Term c) where 185 | unit = mkT @Unit unit 186 | 187 | type instance SubLC c Sum = SubL c DBI 188 | 189 | instance SubL c Sum => Sum (Term c) where 190 | left = mkT @Sum left 191 | right = mkT @Sum right 192 | sumMatch = mkT @Sum sumMatch 193 | 194 | type instance SubLC c IO = (SubL c Unit, SubL c Char, SubL c List) 195 | 196 | instance SubL c IO => IO (Term c) where 197 | putStrLn = mkT @IO putStrLn 198 | ioMap = mkT @IO map 199 | ioAP = mkT @IO ap 200 | ioPure = mkT @IO pure 201 | ioJoin = mkT @IO join 202 | ioBind = mkT @IO bind 203 | 204 | type instance SubLC c List = SubL c Y 205 | instance SubL c List => List (Term c) where 206 | nil = mkT @List nil 207 | cons = mkT @List cons 208 | listMatch = mkT @List listMatch 209 | 210 | type instance SubLC c Prod = SubL c Ordering 211 | instance SubL c Prod => Prod (Term c) where 212 | zro = mkT @Prod zro 213 | fst = mkT @Prod fst 214 | mkProd = mkT @Prod mkProd 215 | 216 | type instance SubLC c Y = SubL c DBI 217 | 218 | instance SubL c Y => Y (Term c) where 219 | y = mkT @Y y 220 | 221 | type instance SubLC c Map.Map = (SubL c Prod, SubL c Option) 222 | instance SubL c Map.Map => Map.Map (Term c) where 223 | empty = mkT @Map.Map Map.empty 224 | mapMap = mkT @Map.Map Map.mapMap 225 | alter' :: forall h k a. OrdWC (Term c) k => Term c h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a) 226 | alter' = mkT1 @Map.Map @k Map.alter 227 | unionWithKey' :: forall h k a. OrdWC (Term c) k => Term c h ((k -> a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a) 228 | unionWithKey' = mkT1 @Map.Map @k Map.unionWithKey 229 | lookup' :: forall h k a. OrdWC (Term c) k => Term c h (M.Map k a -> k -> Maybe a) 230 | lookup' = mkT1 @Map.Map @k Map.lookup 231 | 232 | type instance SubLC c VTF.VectorTF = (SubL c Ordering, SubL c Double) 233 | instance SubL c VTF.VectorTF => VTF.VectorTF (Term c) where 234 | zero = mkT @VTF.VectorTF VTF.zero 235 | plus = mkT @VTF.VectorTF VTF.plus 236 | mult = mkT @VTF.VectorTF VTF.mult 237 | basis = mkT @VTF.VectorTF VTF.basis 238 | vtfMatch = mkT @VTF.VectorTF VTF.vtfMatch 239 | vtfCmp = mkT @VTF.VectorTF VTF.vtfCmp 240 | vtfGetOrdC :: forall t f. (Ord (Term c) t, Ord (Term c) f) :- TermOrd c (M.VTF.VectorTF t f) 241 | vtfGetOrdC = Sub (withDict (getOrdC @(Term c) @t Proxy) $ withDict (getOrdC @(Term c) @f Proxy) Dict) 242 | 243 | type instance SubLC c Option = SubL c DBI 244 | instance SubL c Option => Option (Term c) where 245 | just = mkT @Option just 246 | nothing = mkT @Option nothing 247 | optionMatch = mkT @Option optionMatch 248 | 249 | type instance SubLC c Ordering = SubL c Bool 250 | instance SubL c Ordering => Ordering (Term c) where 251 | sel = mkT @Ordering sel 252 | ordering x = mkT @Ordering (ordering x) 253 | 254 | genInstance :: Q [Dec] 255 | genInstance = 256 | M.mapM gen [ 257 | ''DBI, 258 | ''Double, 259 | ''Bool, 260 | ''Lang, 261 | ''Fix, 262 | ''Int, 263 | ''Char, 264 | ''Float, 265 | ''VTF.VectorTF, 266 | ''Map.Map, 267 | ''Bimap, 268 | ''Prod, 269 | ''IO, 270 | ''Unit, 271 | ''Option, 272 | ''Sum, 273 | ''List, 274 | ''Y, 275 | ''Dual, 276 | ''DiffWrapper, 277 | ''FreeVector, 278 | ''Ordering] 279 | where 280 | gen n = M.return $ 281 | InstanceD 282 | M.Nothing 283 | [] 284 | (AppT (AppT (ConT ''SubL) (ConT ''Lang)) (ConT n)) 285 | [ValD (VarP 'sub) (NormalB (AppE (ConE 'Sub) (ConE 'Dict))) []] 286 | 287 | type instance SubLC c Lang = ( 288 | SubL c Fix, 289 | SubL c Int, 290 | SubL c Float, 291 | SubL c Double, 292 | SubL c Bimap, 293 | SubL c IO, 294 | SubL c Sum, 295 | SubL c Dual, 296 | SubL c DiffWrapper, 297 | SubL c FreeVector, 298 | SubL c VTF.VectorTF, 299 | SubL c Ordering) 300 | 301 | instance SubL c Lang => Lang (Term c) where 302 | state = mkT @Lang state 303 | writer = mkT @Lang writer 304 | exfalso = mkT @Lang exfalso 305 | runState = mkT @Lang runState 306 | runWriter = mkT @Lang runWriter 307 | float2Double = mkT @Lang float2Double 308 | double2Float = mkT @Lang double2Float 309 | -------------------------------------------------------------------------------- /DDF/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module DDF.Unit (module DDF.DBI, module DDF.Unit) where 4 | 5 | import DDF.DBI 6 | 7 | class DBI r => Unit r where 8 | unit :: r h () 9 | -------------------------------------------------------------------------------- /DDF/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | DefaultSignatures, 4 | MultiParamTypeClasses, 5 | NoMonomorphismRestriction, 6 | FlexibleContexts, 7 | FlexibleInstances, 8 | TypeFamilies 9 | #-} 10 | 11 | module DDF.Vector where 12 | import DDF.Double 13 | import qualified Prelude as M 14 | import DDF.Meta.FreeVector 15 | 16 | class Monoid r g => Group r g where 17 | invert :: r h (g -> g) 18 | minus :: r h (g -> g -> g) 19 | default invert :: DBI r => r h (g -> g) 20 | invert = minus1 zero 21 | default minus :: DBI r => r h (g -> g -> g) 22 | minus = lam2 $ \x y -> plus2 x (invert1 y) 23 | {-# MINIMAL (invert | minus) #-} 24 | 25 | class Group r v => Vector r v where 26 | type Basis v :: * 27 | mult :: r h (M.Double -> v -> v) 28 | divide :: r h (v -> M.Double -> v) 29 | default mult :: Double r => r h (M.Double -> v -> v) 30 | mult = lam2 $ \x y -> divide2 y (app2 doubleDivide doubleOne x) 31 | default divide :: Double r => r h (v -> M.Double -> v) 32 | divide = lam2 $ \x y -> mult2 (app2 doubleDivide doubleOne y) x 33 | toFreeVector :: r h (v -> FreeVector (Basis v) M.Double) 34 | {-# MINIMAL (mult | divide), toFreeVector #-} 35 | 36 | minus2 = app2 minus 37 | mult1 = app mult 38 | mult2 = app2 mult 39 | divide2 = app2 divide 40 | invert1 = app invert 41 | minus1 = app minus 42 | divide1 = app divide 43 | recip = divide1 doubleOne 44 | recip1 = app recip 45 | toFreeVector1 = app toFreeVector -------------------------------------------------------------------------------- /DDF/VectorTF.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | FlexibleContexts, 5 | UndecidableSuperClasses, 6 | UndecidableInstances, 7 | FlexibleInstances, 8 | MultiParamTypeClasses, 9 | TypeOperators, 10 | TypeApplications, 11 | ScopedTypeVariables 12 | #-} 13 | 14 | module DDF.VectorTF where 15 | 16 | import DDF.ImportMeta 17 | import qualified DDF.Double as Double 18 | import qualified DDF.Meta.VectorTF as M 19 | import qualified Prelude as M 20 | import qualified DDF.Ordering as Ord 21 | 22 | class Double.Double r => VectorTF r where 23 | zero :: r h (M.VectorTF t f) 24 | basis :: r h (t -> M.VectorTF t f) 25 | plus :: r h (f -> f -> M.VectorTF t f) 26 | mult :: r h (M.Double -> f -> M.VectorTF t f) 27 | vtfMatch :: r h (a -> (t -> a) -> (f -> f -> a) -> (M.Double -> f -> a) -> M.VectorTF t f -> a) 28 | vtfCmp :: r h (Ord.Cmp t -> Ord.Cmp f -> Ord.Cmp (M.VectorTF t f)) 29 | vtfGetOrdC :: (Ord.Ord r t, Ord.Ord r f) :- (Ord.OrdC r (M.VectorTF t f)) 30 | 31 | instance (Ord.Ord r t, Ord.Ord r f, VectorTF r) => Ord.Ord r (M.VectorTF t f) where 32 | cmp = Double.app2 vtfCmp Ord.cmp Ord.cmp 33 | getOrdC _ = Ord.Dict \\ vtfGetOrdC @r @t @f 34 | 35 | vtfMatch4 = Double.app4 vtfMatch 36 | vtfMatch5 = Double.app5 vtfMatch 37 | plus2 = Double.app2 plus 38 | mult1 = Double.app mult 39 | mult2 = Double.app2 mult 40 | -------------------------------------------------------------------------------- /DDF/WithDiff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | NoMonomorphismRestriction 6 | #-} 7 | 8 | module DDF.WithDiff where 9 | import DDF.Lang 10 | import qualified Prelude as M 11 | import DDF.Diff () 12 | 13 | class Monoid r w => WithDiff r w where 14 | withDiff :: r h ((w -> x) -> w -> DiffType x w) 15 | 16 | withDiff1 = app withDiff 17 | selfWithDiff :: (DBI r, WithDiff r w) => r h (w -> DiffType w w) 18 | selfWithDiff = withDiff1 id 19 | 20 | instance Lang r => WithDiff r () where 21 | withDiff = const1 id 22 | 23 | instance Lang r => WithDiff r M.Double where 24 | withDiff = lam2 $ \con d -> dual1 $ mkProd2 d (app con doubleOne) 25 | 26 | instance Lang r => WithDiff r M.Float where 27 | withDiff = lam2 $ \con d -> dual1 $ mkProd2 d (app con floatOne) 28 | 29 | instance (Lang repr, WithDiff repr l, WithDiff repr r) => WithDiff repr (l, r) where 30 | withDiff = lam $ \con -> bimap2 (withDiff1 (lam $ \l -> app con (mkProd2 l zero))) (withDiff1 (lam $ \r -> app con (mkProd2 zero r))) 31 | -------------------------------------------------------------------------------- /DDF/Y.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-} 2 | 3 | module DDF.Y (module DDF.Y, module DDF.DBI) where 4 | 5 | import DDF.DBI 6 | 7 | class DBI r => Y r where 8 | y :: r h ((a -> a) -> a) 9 | undefined :: r h a 10 | undefined = y1 id 11 | 12 | y1 = app y 13 | y2 = app2 y 14 | -------------------------------------------------------------------------------- /DeepDarkFantasy.cabal: -------------------------------------------------------------------------------- 1 | name: DeepDarkFantasy 2 | version: 0.2017.8.19 3 | cabal-version: 1.12 4 | build-type: Simple 5 | license: Apache 6 | tested-with: GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1 7 | maintainer: lolisa@marisa.moe 8 | category: DSL 9 | description: Deep Dark Fantasy(DDF) is a domain specific language that allow one to automatically derive derivative of program in DDF. Hence, one can write neural network in DDF and use the derivative program for gradient descend. 10 | synopsis: A DSL for creating neural network. 11 | license-file: LICENSE 12 | 13 | Flag WError 14 | Description: make warning error 15 | Manual: True 16 | Default: False 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/ThoughtWorksInc/DeepDarkFantasy 21 | 22 | library 23 | exposed-modules: DDF.Bimap 24 | DDF.Bool 25 | DDF.Char 26 | DDF.DBI 27 | DDF.Diff 28 | DDF.DiffWrapper 29 | DDF.Double 30 | DDF.Dual 31 | DDF.Eval 32 | DDF.Fix 33 | DDF.Float 34 | DDF.FreeVector 35 | DDF.ImportMeta 36 | DDF.ImpW 37 | DDF.Int 38 | DDF.IO 39 | DDF.Lang 40 | DDF.List 41 | DDF.Map 42 | DDF.Meta.Diff 43 | DDF.Meta.DiffWrapper 44 | DDF.Meta.Dual 45 | DDF.Meta.FreeVector 46 | DDF.Meta.Util 47 | DDF.Meta.VectorTF 48 | DDF.Option 49 | DDF.Ordering 50 | DDF.PE 51 | DDF.Prod 52 | DDF.Sam.Hello 53 | DDF.Sam.Poly 54 | DDF.Sam.Xor 55 | DDF.Show 56 | DDF.Size 57 | DDF.Sum 58 | DDF.Term 59 | DDF.TermGen 60 | DDF.Unit 61 | DDF.Vector 62 | DDF.VectorTF 63 | DDF.WithDiff 64 | DDF.Y 65 | build-depends: base >= 4.9.0.0 && < 5, 66 | mtl -any, 67 | random -any, 68 | constraints -any, 69 | containers -any, 70 | bimap -any, 71 | recursion-schemes -any, 72 | template-haskell -any 73 | ghc-options: -Wall -Wno-type-defaults -Wno-missing-signatures -Wno-orphans -fwarn-tabs -ferror-spans -Wno-partial-type-signatures 74 | if flag(WError) 75 | ghc-options: -Werror 76 | default-language: Haskell2010 77 | 78 | test-Suite TestPoly 79 | type: exitcode-stdio-1.0 80 | default-language: Haskell2010 81 | hs-source-dirs: test 82 | main-is: TestPoly.hs 83 | build-depends: 84 | base >= 4.9.0.0 && < 5, 85 | mtl -any, 86 | random -any, 87 | constraints -any, 88 | DeepDarkFantasy -any 89 | 90 | test-Suite TestXor 91 | type: exitcode-stdio-1.0 92 | default-language: Haskell2010 93 | hs-source-dirs: test 94 | main-is: TestXor.hs 95 | build-depends: 96 | base >= 4.9.0.0 && < 5, 97 | mtl -any, 98 | random -any, 99 | constraints -any, 100 | DeepDarkFantasy -any 101 | 102 | test-Suite TestPE 103 | type: exitcode-stdio-1.0 104 | default-language: Haskell2010 105 | hs-source-dirs: test 106 | main-is: TestPE.hs 107 | build-depends: 108 | base >= 4.9.0.0 && < 5, 109 | mtl -any, 110 | random -any, 111 | constraints -any, 112 | QuickCheck -any, 113 | DeepDarkFantasy -any 114 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2016 ThoughtWorks, Marisa Kirisame 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DEPRECATED. 2 | 3 | # DeepDarkFantasy 4 | 5 | [![Hackage](https://img.shields.io/hackage/v/DeepDarkFantasy.svg)](http://hackage.haskell.org/package/DeepDarkFantasy) 6 | [![Join the chat at https://gitter.im/ThoughtWorksInc/DeepDarkFantasy](https://badges.gitter.im/ThoughtWorksInc/DeepDarkFantasy.svg)](https://gitter.im/ThoughtWorksInc/DeepDarkFantasy?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) 7 | [![Build Status](https://travis-ci.org/ThoughtWorksInc/DeepDarkFantasy.svg?branch=master)](https://travis-ci.org/ThoughtWorksInc/DeepDarkFantasy) 8 | [![Coverage Status](https://coveralls.io/repos/github/ThoughtWorksInc/DeepDarkFantasy/badge.svg?branch=master)](https://coveralls.io/github/ThoughtWorksInc/DeepDarkFantasy?branch=master) 9 | 10 | ### What if we combine Functional Programming and Deep Learning? 11 | 12 | As we all know, a neural network is just a computable math expression (and hence a program). 13 | 14 | **Can we add 'ordinary' programming construct to a 'neural network', like branch, loop, pair, sum, list, and function?** 15 | 16 | Of course, I must still be able to train the network. 17 | 18 | **Yes! I had add all the above construct, and I am planning to add more.** 19 | 20 | They all had their own special gradient structure to propagate loss accordingly. 21 | 22 | However, in the end of the day, what is updated is only container of double (or other representation of real). 23 | Having those construct only make you write networks easier, but does not offer fundamentally different learning capability. 24 | 25 | ---------- 26 | 27 | Can we make the language typed so we can detect error before we train the network? 28 | 29 | **Sort of.** I am able to type most stuff, but I am having trouble adding higher kinded type/generic type. However, they can be written as Haskell function (macro in DDF). 30 | 31 | ---------- 32 | 33 | Can we make the language modular and extensible so all people can write all sorts of Chuck Norris move into the language? 34 | 35 | **Yes Yes Yes!** The whole language is structured in [finally tagless style](http://okmij.org/ftp/tagless-final/JFP.pdf), so, it is possible to add new operation/constructor, and still retain type safety. 36 | 37 | In fact, there isn't even a core language! All feature(function, double, back propagation, pretty printing) is added as ordinary plugin so you can extend/subset the language as you can wish. 38 | 39 | # Patchouli Go! 40 | 41 | You should read the [blog](http://marisa.moe/2017/DLPL/) before anything. 42 | 43 | We have a few example on using DDF: 44 | 45 | [Hello world](DDF/Sam/Hello.lhs) 46 | 47 | [Solving polynomial equation](DDF/Sam/Poly.lhs) 48 | 49 | [Training XOR Network](DDF/Sam/Xor.lhs) 50 | 51 | If you want to look into the code base, it is necessary to understand [Finally Tagless](http://www.cs.cornell.edu/info/projects/nuprl/PRLSeminar/PRLSeminar2011/Chung-chiehShan-FinallyTaglessPartiallyEevaluated.pdf). 52 | 53 | # FA Q 54 | 55 | Q: How is the speed? 56 | 57 | A: Unoptimized. This is more of a proof of concept that we can use function in neural network, than something that can get you good kaggle score right off the shelf. We are working on Partial Evaluation. 58 | 59 | Q: Why does this work theoretically? 60 | 61 | A: See [DDFADC](https://github.com/MarisaKirisame/DDFADC) 62 | 63 | Q: What does this have to do with [Yang Bo](https://github.com/Atry)'s [DeepLearning.scala](https://github.com/ThoughtWorksInc/DeepLearning.scala/)? 64 | 65 | A: We work on a prototype for 2-3 months, and split apart. 66 | 67 | Q: You seems to have a space in FAQ. 68 | 69 | A: I like it that way. 70 | 71 | Q: What are you currently working on? 72 | 73 | A: I am trying to add a neural network demo. 74 | 75 | # Thank You Sir 76 | 77 | This is heavily inspired by [Neural Networks, Types, and Functional Programming](http://colah.github.io/posts/2015-09-NN-Types-FP/), and my colleague, [Yang Bo](https://github.com/Atry). 78 | 79 | Also, I'd like to thanks [dram](https://github.com/dramforever) for getting it to work without Incoherent Instances, and fixing it on stack, cabal & travis. 80 | 81 | And [izgzhen](https://github.com/izgzhen) helps with the initial version of Partial Evaluation. 82 | 83 | You can be the next contributor! 84 | 85 | ![I Want You](img/I_Want_You.png "Baka!") 86 | [image courtesy of Milk Mage](http://www.pixiv.net/member_illust.php?id=461351) 87 | [aquired here](img/I_Want_You_Image_Courtesy.png) 88 | 89 | Please look at [This Issue](https://github.com/ThoughtWorksInc/DeepDarkFantasy/issues/174) and help solve it. 90 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Talk/Talk.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ThoughtWorksInc/DeepDarkFantasy/4c569aefc03a2bcfb6113b65367201d30077f2b6/Talk/Talk.pdf -------------------------------------------------------------------------------- /Talk/Talk.pptx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ThoughtWorksInc/DeepDarkFantasy/4c569aefc03a2bcfb6113b65367201d30077f2b6/Talk/Talk.pptx -------------------------------------------------------------------------------- /img/I_Want_You.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ThoughtWorksInc/DeepDarkFantasy/4c569aefc03a2bcfb6113b65367201d30077f2b6/img/I_Want_You.png -------------------------------------------------------------------------------- /img/I_Want_You_Image_Courtesy.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ThoughtWorksInc/DeepDarkFantasy/4c569aefc03a2bcfb6113b65367201d30077f2b6/img/I_Want_You_Image_Courtesy.png -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: [] 7 | 8 | flags: 9 | DeepDarkFantasy: 10 | WError: true 11 | 12 | extra-package-dbs: [] -------------------------------------------------------------------------------- /test/TestPE.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | NoImplicitPrelude, 3 | NoMonomorphismRestriction, 4 | RankNTypes, 5 | FlexibleInstances, 6 | AllowAmbiguousTypes, 7 | TypeApplications 8 | #-} 9 | 10 | module Main where 11 | 12 | import DDF.PE 13 | import DDF.Double 14 | import DDF.Size 15 | import qualified Prelude as M 16 | import Prelude ((>), (>=)) 17 | import System.Exit (exitFailure) 18 | import Control.Monad 19 | import Test.QuickCheck 20 | import DDF.Eval 21 | 22 | class TestEqual x where 23 | testEqual :: x -> x -> M.IO () 24 | 25 | instance TestEqual M.Double where 26 | testEqual l r = quickCheck (l == r) 27 | 28 | instance TestEqual (M.Double -> M.Double) where 29 | testEqual l r = quickCheck (\x -> l x == r x) 30 | 31 | instance TestEqual (M.Double -> M.Double -> M.Double) where 32 | testEqual l r = quickCheck (\x y -> l x y == r x y) 33 | 34 | test :: TestEqual x => (forall r. Double r => r () x) -> (M.Int -> M.Int -> M.Bool) -> M.IO () 35 | test x c = do 36 | quickCheck (c (runSize x) (runSize (pe x))) 37 | testEqual (runEval x ()) (runEval (pe x) ()) 38 | 39 | optimized x y = quickCheck (runSize x > runSize y) 40 | 41 | main :: M.IO () 42 | main = do 43 | test @M.Double (doublePlus2 (double 1.0) (double 1.0)) (>) 44 | test @(M.Double -> M.Double) (doublePlus1 (double 1.0)) n 45 | test @(M.Double -> M.Double) (abs (doublePlus2 z (double 1.0))) n 46 | test @(M.Double -> M.Double) (doublePlus1 (double 0.0)) (>) 47 | test @(M.Double -> M.Double) (abs (doublePlus2 z (double 0.0))) (>) 48 | test @M.Double (doubleExp1 (double 1.0)) (>) 49 | test @(M.Double -> M.Double) (abs (doubleExp1 z)) n 50 | test @(M.Double -> M.Double -> M.Double) (abs $ abs $ (app2 (s doublePlus) z (s z))) n 51 | where 52 | n _ _ = M.True 53 | -------------------------------------------------------------------------------- /test/TestPoly.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import DDF.Sam.Poly hiding (main) 4 | import Control.Monad 5 | import System.Exit (exitFailure) 6 | 7 | main :: IO () 8 | main = do 9 | x <- solve (const $ return ()) (const . const $ return ()) 10 | unless (x - 4 < 0.1) exitFailure 11 | return () 12 | -------------------------------------------------------------------------------- /test/TestXor.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import DDF.Sam.Xor hiding (main) 4 | import Control.Monad 5 | import System.Exit (exitFailure) 6 | import System.Random 7 | 8 | main :: IO () 9 | main = do 10 | g <- getStdGen 11 | xor <- findXor g (const $ return ()) (const . const . const $ return ()) 12 | let doXor :: Double -> Double -> Double -> IO () 13 | doXor l r ret = unless (xor (l, r) - ret < 0.2) exitFailure 14 | doXor 0 0 0 15 | doXor 0 1 1 16 | doXor 1 0 1 17 | doXor 1 1 0 18 | return () 19 | --------------------------------------------------------------------------------