DeepDarkFantasy (empty) → 0.0.1
raw patch · 9 files changed
+767/−0 lines, 9 filesdep +basedep +mtlsetup-changed
Dependencies added: base, mtl
Files
- DeepDarkFantasy.cabal +31/−0
- LICENSE +202/−0
- Setup.hs +2/−0
- src/Comb.hs +47/−0
- src/DBI.hs +332/−0
- src/HOAS.hs +35/−0
- src/Main.hs +19/−0
- src/Poly.lhs +96/−0
- src/Util.hs +3/−0
+ DeepDarkFantasy.cabal view
@@ -0,0 +1,31 @@+name: DeepDarkFantasy+version: 0.0.1+cabal-version: 1.12+build-type: Simple+license: Apache+tested-with: GHC == 8.0.2+maintainer: lolisa@marisa.moe+category: DSL+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. +synopsis: A DSL for creating neural network.+license-file: LICENSE++source-repository head+ type: git+ location: https://github.com/ThoughtWorksInc/DeepDarkFantasy++library+ exposed-modules:+ Comb+ DBI+ HOAS+ Main+ Poly+ Util+ build-depends:+ base >= 4.9.0.0 && <= 4.9.1.0,+ mtl -any+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -ferror-spans+
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Comb.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances, + IncoherentInstances, + PolyKinds, + LambdaCase, + MonomorphismRestriction #-} + +module Comb where + +class Comb repr where + app :: repr (a -> b) -> repr a -> repr b + s :: repr ((a -> b -> c) -> (a -> b) -> (a -> c)) + k :: repr (a -> b -> a) + i :: repr (a -> a) + b :: repr ((b -> c) -> (a -> b) -> (a -> c)) + c :: repr ((a -> b -> c) -> (b -> a -> c)) + w :: repr ((a -> a -> b) -> (a -> b)) + +newtype Eval x = Eval {unEval :: x} + +instance Comb Eval where + app (Eval f) (Eval x) = Eval (f x) + s = Eval (\f x arg -> f arg $ x arg) + k = Eval const + i = Eval id + b = Eval (.) + c = Eval flip + w = Eval (\f x -> f x x) + +newtype SShow x = SShow {unSShow :: String} + +instance Comb SShow where + app (SShow f) (SShow x) = SShow $ "(" ++ f ++ " " ++ x ++ ")" + s = SShow "s" + k = SShow "k" + i = SShow "i" + b = SShow "b" + c = SShow "c" + w = SShow "w" + +main :: IO () +main = return ()
+ src/DBI.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances, + PolyKinds, + LambdaCase, + NoMonomorphismRestriction, + TypeFamilies, + LiberalTypeSynonyms, + EmptyCase, + FunctionalDependencies, + AllowAmbiguousTypes, + ExistentialQuantification #-} + +module DBI where +import qualified Prelude as P +import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), undefined) +import Util +import Data.Void +import Control.Monad (when) +import qualified Control.Monad.Writer as P +import qualified Data.Functor.Identity as P +import qualified Data.Tuple as P + +class DBI repr where + z :: repr (a, h) a + s :: repr h b -> repr (a, h) b + lam :: repr (a, h) b -> repr h (a -> b) + app :: repr h (a -> b) -> repr h a -> repr h b + mkProd :: repr h (a -> b -> (a, b)) + zro :: repr h ((a, b) -> a) + fst :: repr h ((a, b) -> b) + lit :: P.Double -> repr h P.Double + litZro :: repr h P.Double + litZro = lit 0 + litOne :: repr h P.Double + litOne = lit 1 + plus :: repr h (P.Double -> P.Double -> P.Double) + minus :: repr h (P.Double -> P.Double -> P.Double) + mult :: repr h (P.Double -> P.Double -> P.Double) + divide :: repr h (P.Double -> P.Double -> P.Double) + hoas :: (repr (a, h) a -> repr (a, h) b) -> repr h (a -> b) + hoas f = lam $ f z + fix :: repr h ((a -> a) -> a) + left :: repr h (a -> P.Either a b) + right :: repr h (b -> P.Either a b) + sumMatch :: repr h ((a -> c) -> (b -> c) -> P.Either a b -> c) + unit :: repr h () + exfalso :: repr h (Void -> a) + nothing :: repr h (P.Maybe a) + just :: repr h (a -> P.Maybe a) + optionMatch :: repr h (b -> (a -> b) -> P.Maybe a -> b) + ioRet :: repr h (a -> P.IO a) + ioBind :: repr h (P.IO a -> (a -> P.IO b) -> P.IO b) + ioMap :: repr h ((a -> b) -> P.IO a -> P.IO b) + nil :: repr h [a] + cons :: repr h (a -> [a] -> [a]) + listMatch :: repr h (b -> (a -> [a] -> b) -> [a] -> b) + com :: repr h ((b -> c) -> (a -> b) -> (a -> c)) + com = hlam $ \f -> hlam $ \g -> hlam $ \x -> app f (app g x) + append :: repr h ([a] -> [a] -> [a]) + append = hlam $ \l -> hlam $ \r -> fix2 (hlam $ \self -> listMatch2 r (hlam $ \a -> hlam $ \as -> cons2 a (app self as))) l + writer :: repr h ((a, w) -> P.Writer w a) + runWriter :: repr h (P.Writer w a -> (a, w)) + swap :: repr h ((l, r) -> (r, l)) + swap = hlam $ \p -> mkProd2 (fst1 p) (zro1 p) + flip :: repr h ((a -> b -> c) -> (b -> a -> c)) + flip = hlam $ \f -> hlam $ \b -> hlam $ \a -> app2 f a b + id :: repr h (a -> a) + id = hlam $ \x -> x + const :: repr h (a -> b -> a) + const = hlam $ \x -> hlam $ \_ -> x + +const1 = app const +cons2 = app2 cons +listMatch2 = app2 listMatch +fix2 = app2 fix + +class DBI r => Monoid r m where + mzero :: r h m + mappend :: r h (m -> m -> m) + +instance DBI r => Monoid r [a] where + mzero = nil + mappend = append + +class DBI r => Functor r f where + map :: r h ((a -> b) -> (f a -> f b)) + +class Functor r a => Applicative r a where + pure :: r h (x -> a x) + ap :: r h (a (x -> y) -> a x -> a y) + +return = pure + +class Applicative r m => Monad r m where + bind :: r h (m a -> (a -> m b) -> m b) + join :: r h (m (m a) -> m a) + join = hlam $ \m -> bind2 m id + bind = hlam $ \m -> hlam $ \f -> join1 (app2 map f m) + {-# MINIMAL (join | bind) #-} + +bind2 = app2 bind +map1 = app map +join1 = app join +bimap2 = app2 bimap +flip1 = app flip +flip2 = app2 flip + +class DBI r => BiFunctor r p where + bimap :: r h ((a -> b) -> (c -> d) -> p a c -> p b d) + +instance DBI r => BiFunctor r (,) where + bimap = hlam $ \l -> hlam $ \r -> hlam $ \p -> mkProd2 (app l (zro1 p)) (app r (fst1 p)) + +instance DBI r => Functor r (P.Writer w) where + map = hlam $ \f -> com2 writer (com2 (bimap2 f id) runWriter) + +writer1 = app writer +runWriter1 = app runWriter +mappend2 = app2 mappend + +instance (DBI r, Monoid r w) => Applicative r (P.Writer w) where + pure = com2 writer (flip2 mkProd mzero) + ap = hlam $ \f -> hlam $ \x -> writer1 (mkProd2 (app (zro1 (runWriter1 f)) (zro1 (runWriter1 x))) (mappend2 (fst1 (runWriter1 f)) (fst1 (runWriter1 x)))) + +instance (DBI r, Monoid r w) => Monad r (P.Writer w) where + join = hlam $ \x -> writer1 $ mkProd2 (zro1 $ runWriter1 $ zro1 $ runWriter1 x) (mappend2 (fst1 $ runWriter1 $ zro1 $ runWriter1 x) (fst1 $ runWriter1 x)) + +instance DBI r => Functor r P.IO where + map = ioMap + +ioBind2 = app2 ioBind + +instance DBI r => Applicative r P.IO where + pure = ioRet + ap = hlam $ \f -> hlam $ \x -> ioBind2 f (flip2 ioMap x) + +instance DBI r => Monad r P.IO where + bind = ioBind + +app3 f x y z = app (app2 f x y) z + +optionMatch3 = app3 optionMatch +optionMatch2 = app2 optionMatch +com2 = app2 com + +instance DBI r => Functor r P.Maybe where + map = hlam $ \func -> optionMatch2 nothing (com2 just func) + +instance DBI r => Applicative r P.Maybe where + pure = just + ap = optionMatch2 (const1 nothing) map + +instance DBI r => Monad r P.Maybe where + bind = hlam $ \x -> hlam $ \func -> optionMatch3 nothing func x + +newtype Eval h x = Eval {runEval :: h -> x} + +comb = Eval . P.const + +instance DBI Eval where + z = Eval P.fst + s (Eval a) = Eval $ a . P.snd + lam (Eval f) = Eval $ \a h -> f (h, a) + app (Eval f) (Eval x) = Eval $ \h -> f h $ x h + zro = comb P.fst + fst = comb P.snd + mkProd = comb (,) + lit = comb + plus = comb (+) + minus = comb (-) + mult = comb (*) + divide = comb (/) + fix = comb loop + where loop x = x $ loop x + left = comb P.Left + right = comb P.Right + sumMatch = comb $ \l r -> \case + P.Left x -> l x + P.Right x -> r x + unit = comb () + exfalso = comb absurd + nothing = comb P.Nothing + just = comb P.Just + ioRet = comb P.return + ioBind = comb (>>=) + nil = comb [] + cons = comb (:) + listMatch = comb $ \l r -> \case + [] -> l + x:xs -> r x xs + optionMatch = comb $ \l r -> \case + P.Nothing -> l + P.Just x -> r x + ioMap = comb P.fmap + writer = comb (P.WriterT . P.Identity) + runWriter = comb P.runWriter + +data AST = Leaf P.String | App P.String AST [AST] | Lam P.String [P.String] AST + +appAST (Leaf f) x = App f x [] +appAST (App f x l) r = App f x (l ++ [r]) +appAST lam r = appAST (Leaf $ show lam) r + +lamAST str (Lam s l t) = Lam str (s:l) t +lamAST str r = Lam str [] r + +instance P.Show AST where + show (Leaf f) = f + show (App f x l) = "(" ++ f ++ " " ++ show x ++ P.concatMap ((" " ++) . show) l ++ ")" + show (Lam s l t) = "(\\" ++ s ++ P.concatMap (" " ++) l ++ " -> " ++ show t ++ ")" +newtype Show h a = Show {runShow :: [P.String] -> P.Int -> AST} +name = Show . P.const . P.const . Leaf + +instance DBI Show where + z = Show $ P.const $ Leaf . show . P.flip (-) 1 + s (Show v) = Show $ \vars -> v vars . P.flip (-) 1 + lam (Show f) = Show $ \vars x -> lamAST (show x) (f vars (x + 1)) + app (Show f) (Show x) = Show $ \vars h -> appAST (f vars h) (x vars h) + hoas f = Show $ \(v:vars) h -> + lamAST v (runShow (f $ Show $ P.const $ P.const $ Leaf v) vars h) + mkProd = name "mkProd" + zro = name "zro" + fst = name "fst" + lit x = name $ show x + plus = name "plus" + minus = name "minus" + mult = name "mult" + divide = name "divide" + fix = name "fix" + left = name "left" + right = name "right" + sumMatch = name "sumMatch" + unit = name "unit" + exfalso = name "exfalso" + nothing = name "nothing" + just = name "just" + ioRet = name "ioRet" + ioBind = name "ioBind" + nil = name "nil" + cons = name "cons" + listMatch = name "listMatch" + optionMatch = name "optionMatch" + ioMap = name "ioMap" + writer = name "writer" + runWriter = name "runWriter" + +class NT repr l r where + conv :: repr l t -> repr r t + +instance {-# INCOHERENT #-} (DBI repr, NT repr l r) => NT repr l (a, r) where + conv = s . conv + +instance NT repr x x where + conv = P.id + +hlam :: forall repr a b h. DBI repr => + ((forall k. NT repr ((a, h)) k => repr k a) -> (repr (a, h)) b) -> repr h (a -> b) +hlam f = hoas (\x -> f $ conv x) + +type family Diff x +type instance Diff P.Double = (P.Double, P.Double) +type instance Diff () = () +type instance Diff (a, b) = (Diff a, Diff b) +type instance Diff (a -> b) = Diff a -> Diff b +type instance Diff (P.Either a b) = P.Either (Diff a) (Diff b) +type instance Diff Void = Void +type instance Diff (P.Maybe a) = P.Maybe (Diff a) +type instance Diff (P.IO a) = P.IO (Diff a) +type instance Diff [a] = [Diff a] +type instance Diff (P.Writer w a) = P.Writer (Diff w) (Diff a) + +newtype WDiff repr h x = WDiff {runWDiff :: repr (Diff h) (Diff x)} + +app2 f a = app (app f a) + +mkProd1 = app mkProd +mkProd2 = app2 mkProd +plus2 = app2 plus +zro1 = app zro +fst1 = app fst +minus2 = app2 minus +mult2 = app2 mult +divide2 = app2 divide + +instance DBI repr => DBI (WDiff repr) where + z = WDiff z + s (WDiff x) = WDiff $ s x + lam (WDiff f) = WDiff $ lam f + app (WDiff f) (WDiff x) = WDiff $ app f x + mkProd = WDiff mkProd + zro = WDiff zro + fst = WDiff fst + lit x = WDiff $ app (mkProd1 (lit x)) (lit 0) + plus = WDiff $ hlam $ \l -> hlam $ \r -> + mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r)) + minus = WDiff $ hlam $ \l -> hlam $ \r -> + mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r)) + mult = WDiff $ hlam $ \l -> hlam $ \r -> + mkProd2 (mult2 (zro1 l) (zro1 r)) + (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l))) + divide = WDiff $ hlam $ \l -> hlam $ \r -> + mkProd2 (divide2 (zro1 l) (zro1 r)) + (divide2 (minus2 (mult2 (zro1 r) (fst1 l)) (mult2 (zro1 l) (fst1 r))) + (mult2 (zro1 r) (zro1 r))) + hoas f = WDiff $ hoas (runWDiff . f . WDiff) + fix = WDiff fix + left = WDiff left + right = WDiff right + sumMatch = WDiff sumMatch + unit = WDiff unit + exfalso = WDiff exfalso + nothing = WDiff nothing + just = WDiff just + ioRet = WDiff ioRet + ioBind = WDiff ioBind + nil = WDiff nil + cons = WDiff cons + listMatch = WDiff listMatch + optionMatch = WDiff optionMatch + ioMap = WDiff ioMap + writer = WDiff writer + runWriter = WDiff runWriter + +scomb = hlam $ \f -> hlam $ \x -> hlam $ \arg -> app (app f arg) (app x arg) + +noEnv :: repr () x -> repr () x +noEnv = P.id
+ src/HOAS.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances, + IncoherentInstances, + PolyKinds, + LambdaCase, + MonomorphismRestriction #-} + +module HOAS where +import Util + +class HOAS repr where + app :: repr (a -> b) -> repr a -> repr b + lam :: (repr a -> repr b) -> repr (a -> b) + +newtype Eval x = Eval {unEval :: x} + +instance HOAS Eval where + app (Eval f) (Eval x) = Eval (f x) + lam f = Eval (unEval . f . Eval) + +newtype HShow x = HShow {unHShow :: [String] -> String} + +instance HOAS HShow where + app (HShow f) (HShow x) = HShow (\vars -> "(" ++ f vars ++ " " ++ x vars ++ ")") + lam f = HShow (\(v:vars) -> "(\\" ++ v ++ " -> " ++ (unHShow $ f $ HShow $ const v) vars ++ ")") + +s = lam (\f -> lam (\x -> lam (\arg -> app (app f arg) (app x arg)))) + +main :: IO () +main = putStrLn ((unHShow s) $ vars)
+ src/Main.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE + MultiParamTypeClasses, + RankNTypes, + ScopedTypeVariables, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances, + IncoherentInstances, + PolyKinds, + LambdaCase, + NoMonomorphismRestriction #-} + +module Main (main) where +import qualified HOAS +import qualified Comb +import qualified DBI +import qualified Poly + +main = Poly.main
+ src/Poly.lhs view
@@ -0,0 +1,96 @@+> {-# LANGUAGE +> MultiParamTypeClasses, +> RankNTypes, +> ScopedTypeVariables, +> FlexibleInstances, +> FlexibleContexts, +> UndecidableInstances, +> IncoherentInstances, +> PolyKinds, +> LambdaCase, +> NoMonomorphismRestriction, +> TypeFamilies, +> LiberalTypeSynonyms, +> EmptyCase #-} + +> module Poly where +> import Control.Monad (when) +> import Util +> import DBI hiding (main, return) + +Importting files and opening language extension... +So, our goal is to find x, where x * x + 2 * x + 3 = 27. +To do so, we try to minimize their difference squared (l2 norm). + +> poly :: forall repr h. DBI repr => repr h (Double -> Double) +> poly = hlam $ \x -> plus2 (mult2 x x) (plus2 (mult2 (lit 2.0) x) (lit 3.0)) + +poly x = x * x + (2 * x + 3) + +> l2 = hlam $ \x -> mult2 (minus2 x (lit 27)) (minus2 x (lit 27)) + +l2 x = (x - 27) * (x - 27) +l2 measure how far is the input from 27 + +> comp = com2 l2 poly + +By composing the two, we can measure how far is x * x + 2 * x + 3 from 27. +We want to minimize this distance. + +> main :: IO () +> main = do + +Let's begin by trying to print poly + +> print $ runShow poly vars 0 +> go 0 0 +> where + +The main loop. i is step and w is weight (our current estimate of x). +We start by assuming x = 0 is the solution, +and minimize (comp x) by taking derivative of x, and decrease it whenever it is positive (and vice versa). + +> go :: Integer -> Double -> IO () +> go i w | i < 200 = do +> when (isSquare i) $ print w + +print the weight in increasing interval, so initially more weight can be printed + +> go (1 + i) $ w - 0.001 * snd (runEval (runWDiff $ noEnv comp) () (w, 1)) + +noEnv comp assume the term (which is a De Brujin Index term) need no enviroment (is free) +and it is a finally tagless term, with WDiff interpreter being implicitly applied, +which return another finally tagless term, but taking derivative of x. +it is then applied to Eval interpreter (which eval it in the meta language, haskell). +similar to unWDiff, we use unEval to take out the term from a newtype +now we apply the enviroment (remember it has no enviroment? so just stick a unit) +and a pair, the zeroth being x, the first being derivative of x, which is 1. +the whole computation return a pair of (x * x + (2 * x + 3) - 27)^2, and it's derivative. +we modify w using the derivative. + +> go i w = return () + +By running the program, you shall see +(\a -> (plus (mult a a) (plus (mult 2.0 a) 3.0))) +since we pretty print poly +followed by something like +0.0 +9.6e-2 +0.43573084645674215 +1.1890033104995505 +2.498644212525056 +3.652210805402036 +3.9662181049468925 +3.9981203814732154 +3.9999338218043157 +3.999998509763363 +3.9999999785234146 +3.9999999998019136 +3.9999999999988307 +3.9999999999999956 +3.999999999999999 +which mean we found 4 as a soultion. +plugging it back to the equation, we can verify that (4 * 4) + 2 * 4 + 3 is indeed 27! + +> isSquare n = sq * sq == n +> where sq = floor $ sqrt (fromIntegral n::Double)
+ src/Util.hs view
@@ -0,0 +1,3 @@+module Util where + +vars = [pre : suf | suf <- "":map show [0..], pre <- ['a'..'z']]