packages feed

DeepDarkFantasy 0.2017.3.28 → 0.2017.3.30

raw patch · 13 files changed

+1131/−1002 lines, 13 filesdep +DeepDarkFantasyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: DeepDarkFantasy

API changes (from Hackage documentation)

+ DBI: let_ :: DBI repr => repr h (a -> (a -> b) -> b)
+ DBI: runImpW2RunImpWR :: RunImpW repr h x -> RunImpWR repr h x
+ DBI: runImpWR2RunImpW :: RunImpWR repr h x -> RunImpW repr h x
+ DBI: type RunImpWR repr h x = forall r. (forall w. Weight w => repr h (w -> x) -> r) -> r
+ Lang: UnHOAS :: repr h x -> UnHOAS repr h x
+ Lang: [runUnHOAS] :: UnHOAS repr h x -> repr h x
+ Lang: instance DBI.DBI repr => DBI.DBI (Lang.UnHOAS repr)
+ Lang: instance Lang.Lang repr => Lang.Lang (Lang.UnHOAS repr)
+ Lang: newtype UnHOAS repr h x
+ Poly: solve :: forall m. Monad m => (AST -> m ()) -> (Integer -> Double -> m ()) -> m Double
+ Xor: findXor :: forall g m. (RandomGen g, Monad m) => g -> (AST -> m ()) -> (Int -> Double -> String -> m ()) -> m XOR
- DBI: class DBI repr where hoas f = abs $ f z com = lam3 $ \ f g x -> app f (app g x) flip = lam3 $ \ f b a -> app2 f a b id = lam $ \ x -> x const = lam2 $ \ x _ -> x scomb = lam3 $ \ f x arg -> app2 f arg (app x arg) dup = lam2 $ \ f x -> app2 f x x
+ DBI: class DBI repr where hoas f = abs $ f z com = lam3 $ \ f g x -> app f (app g x) flip = lam3 $ \ f b a -> app2 f a b id = lam $ \ x -> x const = lam2 $ \ x _ -> x scomb = lam3 $ \ f x arg -> app2 f arg (app x arg) dup = lam2 $ \ f x -> app2 f x x let_ = flip1 id

Files

DeepDarkFantasy.cabal view
@@ -1,5 +1,5 @@ name: DeepDarkFantasy-version: 0.2017.3.28+version: 0.2017.3.30 cabal-version: 1.12 build-type: Simple license: Apache@@ -25,7 +25,31 @@     base >= 4.9.0.0 && <= 4.9.1.0,     mtl -any,     random -any,-    constraints -any-  default-language: Haskell2010-  hs-source-dirs: src+    constraints -any +  hs-source-dirs: lib   ghc-options: -ferror-spans +  default-language: Haskell2010++Test-Suite TestPoly+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs: test+  main-is: TestPoly.hs+  build-depends:+    base >= 4.9.0.0 && <= 4.9.1.0,+    mtl -any,+    random -any,+    constraints -any,+    DeepDarkFantasy++Test-Suite TestXor+  type: exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs: test+  main-is: TestXor.hs+  build-depends:+    base >= 4.9.0.0 && <= 4.9.1.0,+    mtl -any,+    random -any,+    constraints -any,+    DeepDarkFantasy
+ lib/DBI.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE
+    MultiParamTypeClasses,
+    RankNTypes,
+    ScopedTypeVariables,
+    FlexibleInstances,
+    FlexibleContexts,
+    UndecidableInstances,
+    PolyKinds,
+    LambdaCase,
+    NoMonomorphismRestriction,
+    TypeFamilies,
+    LiberalTypeSynonyms,
+    FunctionalDependencies,
+    ExistentialQuantification,
+    InstanceSigs,
+    TupleSections,
+    ConstraintKinds,
+    DefaultSignatures,
+    UndecidableSuperClasses,
+    TypeOperators,
+    TypeApplications,
+    PartialTypeSignatures #-}
+
+module DBI where
+import qualified Prelude as P
+import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), undefined)
+import Util
+import Control.Monad (when)
+import System.Random
+import Data.Proxy
+import Data.Constraint
+import Data.Constraint.Forall
+
+class Monoid r m where
+  zero :: r h m
+  plus :: r h (m -> m -> m)
+
+class Monoid repr w => WithDiff repr w where
+  withDiff :: repr h ((w -> x) -> w -> Diff x w)
+
+withDiff1 = app withDiff
+
+selfWithDiff :: (DBI repr, WithDiff repr w) => repr h (w -> Diff w w)
+selfWithDiff = withDiff1 id
+
+instance Random () where
+  random = ((),)
+  randomR _ = random
+
+instance (Random l, Random r) => Random (l, r) where
+  random g0 = ((l, r), g2)
+    where
+      (l, g1) = random g0
+      (r, g2) = random g1
+  randomR ((llo, rlo), (lhi, rhi)) g0 = ((l, r), g2)
+    where
+      (l, g1) = randomR (llo, lhi) g0
+      (r, g2) = randomR (rlo, rhi) g1
+
+class DBI repr where
+  z :: repr (a, h) a
+  s :: repr h b -> repr (a, h) b
+  abs :: repr (a, h) b -> repr h (a -> b)
+  app :: repr h (a -> b) -> repr h a -> repr h b
+  hoas :: (repr (a, h) a -> repr (a, h) b) -> repr h (a -> b)
+  hoas f = abs $ f z
+  com :: repr h ((b -> c) -> (a -> b) -> (a -> c))
+  com = lam3 $ \f g x -> app f (app g x)
+  flip :: repr h ((a -> b -> c) -> (b -> a -> c))
+  flip = lam3 $ \f b a -> app2 f a b
+  id :: repr h (a -> a)
+  id = lam $ \x -> x
+  const :: repr h (a -> b -> a)
+  const = lam2 $ \x _ -> x
+  scomb :: repr h ((a -> b -> c) -> (a -> b) -> (a -> c))
+  scomb = lam3 $ \f x arg -> app2 f arg (app x arg)
+  dup :: repr h ((a -> a -> b) -> (a -> b))
+  dup = lam2 $ \f x -> app2 f x x
+  let_ :: repr h (a -> (a -> b) -> b)
+  let_ = flip1 id
+
+const1 = app const
+map2 = app2 map
+return = pure
+bind2 = app2 bind
+map1 = app map
+join1 = app join
+bimap2 = app2 bimap
+flip1 = app flip
+flip2 = app2 flip
+
+class 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)
+
+class (DBI r, 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 = lam $ \m -> bind2 m id
+  bind = lam2 $ \m f -> join1 (app2 map f m)
+  {-# MINIMAL (join | bind) #-}
+
+class BiFunctor r p where
+  bimap :: r h ((a -> b) -> (c -> d) -> p a c -> p b d)
+
+app3 f x y z = app (app2 f x y) z
+com2 = app2 com
+
+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
+  abs (Eval f) = Eval $ \a h -> f (h, a)
+  app (Eval f) (Eval x) = Eval $ \h -> f h $ x h
+
+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
+  abs (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 + 1))
+
+class NT repr l r where
+    conv :: repr l t -> repr r t
+
+class NTS repr l r where
+    convS :: repr l t -> repr r t
+
+instance (DBI repr, NT repr l r) => NTS repr l (a, r) where
+    convS = s . conv
+
+instance {-# OVERLAPPABLE #-} NTS repr l r => NT repr l r where
+    conv = convS
+
+instance {-# OVERLAPPING #-} NT repr x x where
+    conv = P.id
+
+lam :: 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)
+lam f = hoas (\x -> f $ conv x)
+
+lam2 :: forall repr a b c h. DBI repr =>
+  ((forall k. NT repr (a, h) k => repr k a) -> (forall k. NT repr (b, (a, h)) k => repr k b) -> (repr (b, (a, h))) c) -> repr h (a -> b -> c)
+lam2 f = lam $ \x -> lam $ \y -> f x y
+
+lam3 f = lam2 $ \x y -> lam $ \z -> f x y z
+
+type family Diff v x
+type instance Diff v () = ()
+type instance Diff v (a -> b) = Diff v a -> Diff v b
+type instance Diff v (a, b) = (Diff v a, Diff v b)
+
+newtype WDiff repr v h x = WDiff {runWDiff :: repr (Diff v h) (Diff v x)}
+
+app2 f a = app (app f a)
+
+plus2 = app2 plus
+
+instance DBI repr => DBI (WDiff repr v) where
+  z = WDiff z
+  s (WDiff x) = WDiff $ s x
+  abs (WDiff f) = WDiff $ abs f
+  app (WDiff f) (WDiff x) = WDiff $ app f x
+  hoas f = WDiff $ hoas (runWDiff . f . WDiff)
+
+noEnv :: repr () x -> repr () x
+noEnv = P.id
+
+class RandRange w where
+  randRange :: (P.Double, P.Double) -> (w, w)
+
+instance RandRange () where
+  randRange _ = ((), ())
+
+instance RandRange P.Double where
+  randRange (lo, hi) = (lo, hi)
+
+instance (RandRange l, RandRange r) => RandRange (l, r) where
+  randRange (lo, hi) = ((llo, rlo), (lhi, rhi))
+    where
+      (llo, lhi) = randRange (lo, hi)
+      (rlo, rhi) = randRange (lo, hi)
+
+instance Weight () where weightCon = Sub Dict
+
+instance Weight P.Double where weightCon = Sub Dict
+
+instance (Weight l, Weight r) => Weight (l, r) where
+  weightCon :: forall con. (con (), con P.Double, ForallV (ProdCon con)) :- con (l, r)
+  weightCon = Sub (mapDict (prodCon \\ (instV :: (ForallV (ProdCon con) :- ProdCon con l r))) (Dict \\ weightCon @l @con \\ weightCon @r @con))
+
+class ProdCon con l r where
+  prodCon :: (con l, con r) :- con (l, r)
+
+instance ProdCon Random l r where prodCon = Sub Dict
+
+instance ProdCon RandRange l r where prodCon = Sub Dict
+
+instance ProdCon P.Show l r where prodCon = Sub Dict
+
+class Weight w where
+  weightCon :: (con (), con P.Double, ForallV (ProdCon con)) :- con w
+
+data RunImpW repr h x = forall w. Weight w => RunImpW (repr h (w -> x))
+data ImpW repr h x = NoImpW (repr h x) | forall w. Weight w => ImpW (repr h (w -> x))
+
+type RunImpWR repr h x = forall r. (forall w. Weight w => repr h (w -> x) -> r) -> r
+
+runImpW2RunImpWR :: RunImpW repr h x -> RunImpWR repr h x
+runImpW2RunImpWR (RunImpW x) = \f -> f x
+
+runImpWR2RunImpW :: RunImpWR repr h x -> RunImpW repr h x
+runImpWR2RunImpW f = f RunImpW
+
+data Combine l r h x = Combine (l h x) (r h x)
+
+instance (DBI l, DBI r) => DBI (Combine l r) where
+  z = Combine z z
+  s (Combine l r) = Combine (s l) (s r)
+  app (Combine fl fr) (Combine xl xr) = Combine (app fl xl) (app fr xr)
+  abs (Combine l r) = Combine (abs l) (abs r)
+  hoas f = Combine (hoas $ \x -> case f (Combine x z) of Combine l r -> l) (hoas $ \x -> case f (Combine z x) of Combine l r -> r)
+ lib/Lang.hs view
@@ -0,0 +1,587 @@+{-# LANGUAGE+    MultiParamTypeClasses,+    RankNTypes,+    ScopedTypeVariables,+    FlexibleInstances,+    FlexibleContexts,+    UndecidableInstances,+    PolyKinds,+    LambdaCase,+    NoMonomorphismRestriction,+    TypeFamilies,+    LiberalTypeSynonyms,+    FunctionalDependencies,+    ExistentialQuantification,+    InstanceSigs,+    TupleSections,+    ConstraintKinds,+    DefaultSignatures,+    UndecidableSuperClasses,+    TypeOperators,+    TypeApplications,+    PartialTypeSignatures #-}++module Lang where+import DBI+import qualified Prelude as P+import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), undefined)+import qualified Control.Monad.Writer as P+import qualified Data.Functor.Identity as P+import qualified GHC.Float as P+import qualified Data.Tuple as P+import Data.Void+import Data.Proxy+import Data.Proxy+import Data.Constraint+import Data.Constraint.Forall++type instance Diff v (P.Writer w a) = P.Writer (Diff v w) (Diff v a)+type instance Diff v Void = Void+type instance Diff v P.Double = (P.Double, v)+type instance Diff v P.Float = (P.Float, v)+type instance Diff v (P.Either a b) = P.Either (Diff v a) (Diff v b)+type instance Diff v (P.Maybe a) = P.Maybe (Diff v a)+type instance Diff v (P.IO a) = P.IO (Diff v a)+type instance Diff v [a] = [Diff v a]++class DBI repr => Lang repr where+  mkProd :: repr h (a -> b -> (a, b))+  zro :: repr h ((a, b) -> a)+  fst :: repr h ((a, b) -> b)+  double :: P.Double -> repr h P.Double+  doubleZero :: repr h P.Double+  doubleZero = double 0+  doubleOne :: repr h P.Double+  doubleOne = double 1+  doublePlus :: repr h (P.Double -> P.Double -> P.Double)+  doubleMinus :: repr h (P.Double -> P.Double -> P.Double)+  doubleMult :: repr h (P.Double -> P.Double -> P.Double)+  doubleDivide :: repr h (P.Double -> P.Double -> P.Double)+  doubleExp :: repr h (P.Double -> P.Double)+  float :: P.Float -> repr h P.Float+  floatZero :: repr h P.Float+  floatZero = float 0+  floatOne :: repr h P.Float+  floatOne = float 1+  floatPlus :: repr h (P.Float -> P.Float -> P.Float)+  floatMinus :: repr h (P.Float -> P.Float -> P.Float)+  floatMult :: repr h (P.Float -> P.Float -> P.Float)+  floatDivide :: repr h (P.Float -> P.Float -> P.Float)+  floatExp :: repr h (P.Float -> P.Float)+  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)+  listAppend :: repr h ([a] -> [a] -> [a])+  listAppend = lam2 $ \l r -> fix2 (lam $ \self -> listMatch2 r (lam2 $ \a 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 = lam $ \p -> mkProd2 (fst1 p) (zro1 p)+  curry :: repr h (((a, b) -> c) -> (a -> b -> c))+  uncurry :: repr h ((a -> b -> c) -> ((a, b) -> c))+  curry = lam3 $ \f a b -> app f (mkProd2 a b)+  uncurry = lam2 $ \f p -> app2 f (zro1 p) (fst1 p)+  float2Double :: repr h (P.Float -> P.Double)+  double2Float :: repr h (P.Double -> P.Float)++class Reify repr x where+  reify :: x -> repr h x++instance Lang repr => Reify repr () where+  reify _ = unit++instance Lang repr => Reify repr P.Double where+  reify = double++instance (Lang repr, Reify repr l, Reify repr r) => Reify repr (l, r) where+  reify (l, r) = mkProd2 (reify l) (reify r)++instance Lang Eval where+  zro = comb P.fst+  fst = comb P.snd+  mkProd = comb (,)+  double = comb+  doublePlus = comb (+)+  doubleMinus = comb (-)+  doubleMult = comb (*)+  doubleDivide = 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+  doubleExp = comb P.exp+  float = comb+  floatPlus = comb (+)+  floatMinus = comb (-)+  floatMult = comb (*)+  floatDivide = comb (/)+  floatExp = comb P.exp+  float2Double = comb P.float2Double+  double2Float = comb P.double2Float++newtype UnHOAS repr h x = UnHOAS {runUnHOAS :: repr h x}++instance DBI repr => DBI (UnHOAS repr) where+  z = UnHOAS z+  s (UnHOAS x) = UnHOAS $ s x+  abs (UnHOAS x) = UnHOAS $ abs x+  app (UnHOAS f) (UnHOAS x) = UnHOAS $ app f x++instance Lang repr => Lang (UnHOAS repr) where+  mkProd = UnHOAS mkProd+  zro = UnHOAS zro+  fst = UnHOAS fst+  double = UnHOAS . double+  doublePlus = UnHOAS doublePlus+  doubleMinus = UnHOAS doubleMinus+  doubleMult = UnHOAS doubleMult+  doubleDivide = UnHOAS doubleDivide+  doubleExp = UnHOAS doubleExp+  fix = UnHOAS fix+  left = UnHOAS left+  right = UnHOAS right+  sumMatch = UnHOAS sumMatch+  unit = UnHOAS unit+  exfalso = UnHOAS exfalso+  nothing = UnHOAS nothing+  just = UnHOAS just+  ioRet = UnHOAS ioRet+  ioBind = UnHOAS ioBind+  nil = UnHOAS nil+  cons = UnHOAS cons+  listMatch = UnHOAS listMatch+  optionMatch = UnHOAS optionMatch+  ioMap = UnHOAS ioMap+  writer = UnHOAS writer+  runWriter = UnHOAS runWriter+  float = UnHOAS . float+  floatPlus = UnHOAS floatPlus+  floatMinus = UnHOAS floatMinus+  floatMult = UnHOAS floatMult+  floatDivide = UnHOAS floatDivide+  floatExp = UnHOAS floatExp+  float2Double = UnHOAS float2Double+  double2Float = UnHOAS double2Float++instance Lang Show where+  mkProd = name "mkProd"+  zro = name "zro"+  fst = name "fst"+  double = name . show+  doublePlus = name "plus"+  doubleMinus = name "minus"+  doubleMult = name "mult"+  doubleDivide = name "divide"+  doubleExp = name "exp"+  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"+  float = name . show+  floatPlus = name "plus"+  floatMinus = name "minus"+  floatMult = name "mult"+  floatDivide = name "divide"+  floatExp = name "exp"+  float2Double = name "float2Double"+  double2Float = name "double2Float"++instance Lang repr => Lang (GWDiff repr) where+  mkProd = GWDiff (P.const mkProd)+  zro = GWDiff $ P.const $ zro+  fst = GWDiff $ P.const $ fst+  double x = GWDiff $ P.const $ mkProd2 (double x) zero+  doublePlus = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  doubleMinus = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  doubleMult = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (mult2 (zro1 l) (zro1 r))+      (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l)))+  doubleDivide = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (divide2 (zro1 l) (zro1 r))+      (divide2 (minus2 (mult2 (zro1 r) (fst1 l)) (mult2 (zro1 l) (fst1 r)))+        (mult2 (zro1 r) (zro1 r)))+  doubleExp = GWDiff $ P.const $ lam $ \x -> mkProd2 (doubleExp1 (zro1 x)) (mult2 (doubleExp1 (zro1 x)) (fst1 x))+  fix = GWDiff $ P.const fix+  left = GWDiff $ P.const left+  right = GWDiff $ P.const right+  sumMatch = GWDiff $ P.const sumMatch+  unit = GWDiff $ P.const unit+  exfalso = GWDiff $ P.const exfalso+  nothing = GWDiff $ P.const nothing+  just = GWDiff $ P.const just+  ioRet = GWDiff $ P.const ioRet+  ioBind = GWDiff $ P.const ioBind+  nil = GWDiff $ P.const nil+  cons = GWDiff $ P.const cons+  listMatch = GWDiff $ P.const listMatch+  optionMatch = GWDiff $ P.const optionMatch+  ioMap = GWDiff $ P.const ioMap+  writer = GWDiff $ P.const writer+  runWriter = GWDiff $ P.const runWriter+  float x = GWDiff $ P.const $ mkProd2 (float x) zero+  floatPlus = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  floatMinus = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  floatMult = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (mult2 (float2Double1 (zro1 l)) (zro1 r))+      (plus2 (mult2 (float2Double1 (zro1 l)) (fst1 r)) (mult2 (float2Double1 (zro1 r)) (fst1 l)))+  floatDivide = GWDiff $ P.const $ lam2 $ \l r ->+    mkProd2 (divide2 (zro1 l) (float2Double1 (zro1 r)))+      (divide2 (minus2 (mult2 (float2Double1 (zro1 r)) (fst1 l)) (mult2 (float2Double1 (zro1 l)) (fst1 r)))+        (float2Double1 (mult2 (float2Double1 (zro1 r)) (zro1 r))))+  floatExp = GWDiff $ P.const $ lam $ \x -> mkProd2 (floatExp1 (zro1 x)) (mult2 (float2Double1 (floatExp1 (zro1 x))) (fst1 x))+  float2Double = GWDiff $ P.const $ bimap2 float2Double id+  double2Float = GWDiff $ P.const $ bimap2 double2Float id++instance (Vector repr v, Lang repr) => Lang (WDiff repr v) where+  mkProd = WDiff mkProd+  zro = WDiff zro+  fst = WDiff fst+  double x = WDiff $ mkProd2 (double x) zero+  doublePlus = WDiff $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  doubleMinus = WDiff $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  doubleMult = WDiff $ lam2 $ \l r ->+    mkProd2 (mult2 (zro1 l) (zro1 r))+      (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l)))+  doubleDivide = WDiff $ lam2 $ \l r ->+    mkProd2 (divide2 (zro1 l) (zro1 r))+      (divide2 (minus2 (mult2 (zro1 r) (fst1 l)) (mult2 (zro1 l) (fst1 r)))+        (mult2 (zro1 r) (zro1 r)))+  doubleExp = WDiff $ lam $ \x -> mkProd2 (doubleExp1 (zro1 x)) (mult2 (doubleExp1 (zro1 x)) (fst1 x))+  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+  float x = WDiff $ mkProd2 (float x) zero+  floatPlus = WDiff $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  floatMinus = WDiff $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  floatMult = WDiff $ lam2 $ \l r ->+    mkProd2 (mult2 (float2Double1 (zro1 l)) (zro1 r))+      (plus2 (mult2 (float2Double1 (zro1 l)) (fst1 r)) (mult2 (float2Double1 (zro1 r)) (fst1 l)))+  floatDivide = WDiff $ lam2 $ \l r ->+    mkProd2 (divide2 (zro1 l) (float2Double1 (zro1 r)))+      (divide2 (minus2 (mult2 (float2Double1 (zro1 r)) (fst1 l)) (mult2 (float2Double1 (zro1 l)) (fst1 r)))+        (float2Double1 (mult2 (float2Double1 (zro1 r)) (zro1 r))))+  floatExp = WDiff $ lam $ \x -> mkProd2 (floatExp1 (zro1 x)) (mult2 (float2Double1 (floatExp1 (zro1 x))) (fst1 x))+  float2Double = WDiff $ bimap2 float2Double id+  double2Float = WDiff $ bimap2 double2Float id++instance Lang repr => ProdCon (Monoid repr) l r where prodCon = Sub Dict++instance Lang repr => ProdCon (WithDiff repr) l r where prodCon = Sub Dict++instance Lang repr => ProdCon (Reify repr) l r where prodCon = Sub Dict++instance Lang repr => ProdCon (Vector repr) l r where prodCon = Sub Dict++instance Lang repr => Lang (ImpW repr) where+  nil = NoImpW nil+  cons = NoImpW cons+  listMatch = NoImpW listMatch+  zro = NoImpW zro+  fst = NoImpW fst+  mkProd = NoImpW mkProd+  ioRet = NoImpW ioRet+  ioMap = NoImpW ioMap+  ioBind = NoImpW ioBind+  unit = NoImpW unit+  nothing = NoImpW nothing+  just = NoImpW just+  optionMatch = NoImpW optionMatch+  exfalso = NoImpW exfalso+  fix = NoImpW fix+  left = NoImpW left+  right = NoImpW right+  sumMatch = NoImpW sumMatch+  writer = NoImpW writer+  runWriter = NoImpW runWriter+  double = NoImpW . double+  doubleExp = NoImpW doubleExp+  doublePlus = NoImpW doublePlus+  doubleMinus = NoImpW doubleMinus+  doubleMult = NoImpW doubleMult+  doubleDivide = NoImpW doubleDivide+  float = NoImpW . float+  floatExp = NoImpW floatExp+  floatPlus = NoImpW floatPlus+  floatMinus = NoImpW floatMinus+  floatMult = NoImpW floatMult+  floatDivide = NoImpW floatDivide+  float2Double = NoImpW float2Double+  double2Float = NoImpW double2Float++instance (Lang l, Lang r) => Lang (Combine l r) where+  mkProd = Combine mkProd mkProd+  zro = Combine zro zro+  fst = Combine fst fst+  double x = Combine (double x) (double x)+  doublePlus = Combine doublePlus doublePlus+  doubleMinus = Combine doubleMinus doubleMinus+  doubleMult = Combine doubleMult doubleMult+  doubleDivide = Combine doubleDivide doubleDivide+  doubleExp = Combine doubleExp doubleExp+  float x = Combine (float x) (float x)+  floatPlus = Combine floatPlus floatPlus+  floatMinus = Combine floatMinus floatMinus+  floatMult = Combine floatMult floatMult+  floatDivide = Combine floatDivide floatDivide+  floatExp = Combine floatExp floatExp+  fix = Combine fix fix+  left = Combine left left+  right = Combine right right+  sumMatch = Combine sumMatch sumMatch+  unit = Combine unit unit+  exfalso = Combine exfalso exfalso+  nothing = Combine nothing nothing+  just = Combine just just+  optionMatch = Combine optionMatch optionMatch+  ioRet = Combine ioRet ioRet+  ioBind = Combine ioBind ioBind+  ioMap = Combine ioMap ioMap+  nil = Combine nil nil+  cons = Combine cons cons+  listMatch = Combine listMatch listMatch+  runWriter = Combine runWriter runWriter+  writer = Combine writer writer+  double2Float = Combine double2Float double2Float+  float2Double = Combine float2Double float2Double++instance Lang repr => WithDiff repr () where+  withDiff = const1 id++instance Lang repr => WithDiff repr P.Double where+  withDiff = lam2 $ \conv d -> mkProd2 d (app conv doubleOne)++instance (Lang repr, WithDiff repr l, WithDiff repr r) => WithDiff repr (l, r) where+  withDiff = lam $ \conv -> bimap2 (withDiff1 (lam $ \l -> app conv (mkProd2 l zero))) (withDiff1 (lam $ \r -> app conv (mkProd2 zero r)))++class Monoid r g => Group r g where+  invert :: r h (g -> g)+  minus :: r h (g -> g -> g)+  default invert :: Lang r => r h (g -> g)+  invert = minus1 zero+  default minus :: Lang r => r h (g -> g -> g)+  minus = lam2 $ \x y -> plus2 x (invert1 y)+  {-# MINIMAL (invert | minus) #-}++class Group r v => Vector r v where+  mult :: r h (P.Double -> v -> v)+  divide :: r h (v -> P.Double -> v)+  default mult :: Lang r => r h (P.Double -> v -> v)+  mult = lam2 $ \x y -> divide2 y (recip1 x)+  default divide :: Lang r => r h (v -> P.Double -> v)+  divide = lam2 $ \x y -> mult2 (recip1 y) x+  {-# MINIMAL (mult | divide) #-}++instance Lang r => Monoid r () where+  zero = unit+  plus = const1 $ const1 unit++instance Lang r => Group r () where+  invert = const1 unit+  minus = const1 $ const1 unit++instance Lang r => Vector r () where+  mult = const1 $ const1 unit+  divide = const1 $ const1 unit++instance Lang r => Monoid r P.Double where+  zero = doubleZero+  plus = doublePlus++instance Lang r => Group r P.Double where+  minus = doubleMinus++instance Lang r => Vector r P.Double where+  mult = doubleMult+  divide = doubleDivide++instance Lang r => Monoid r P.Float where+  zero = floatZero+  plus = floatPlus++instance Lang r => Group r P.Float where+  minus = floatMinus++instance Lang r => Vector r P.Float where+  mult = com2 floatMult double2Float+  divide = com2 (flip2 com double2Float) floatDivide++instance (Lang repr, Monoid repr l, Monoid repr r) => Monoid repr (l, r) where+  zero = mkProd2 zero zero+  plus = lam2 $ \l r -> mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))++instance (Lang repr, Group repr l, Group repr r) => Group repr (l, r) where+  invert = bimap2 invert invert++instance (Lang repr, Vector repr l, Vector repr r) => Vector repr (l, r) where+  mult = lam $ \x -> bimap2 (mult1 x) (mult1 x)++instance (Lang repr, Monoid repr l, Monoid repr r) => Monoid repr (l -> r) where+  zero = const1 zero+  plus = lam3 $ \l r x -> plus2 (app l x) (app r x)++instance (Lang repr, Group repr l, Group repr r) => Group repr (l -> r) where+  invert = lam2 $ \l x -> app l (invert1 x)++instance (Lang repr, Vector repr l, Vector repr r) => Vector repr (l -> r) where+  mult = lam3 $ \l r x -> app r (mult2 l x)++instance Lang r => Monoid r [a] where+  zero = nil+  plus = listAppend++instance Lang r => Functor r [] where+  map = lam $ \f -> fix1 $ lam $ \self -> listMatch2 nil (lam2 $ \x xs -> cons2 (app f x) $ app self xs)++instance Lang r => BiFunctor r (,) where+  bimap = lam3 $ \l r p -> mkProd2 (app l (zro1 p)) (app r (fst1 p))++instance Lang r => Functor r (P.Writer w) where+  map = lam $ \f -> com2 writer (com2 (bimap2 f id) runWriter)++instance (Lang r, Monoid r w) => Applicative r (P.Writer w) where+  pure = com2 writer (flip2 mkProd zero)+  ap = lam2 $ \f x -> writer1 (mkProd2 (app (zro1 (runWriter1 f)) (zro1 (runWriter1 x))) (plus2 (fst1 (runWriter1 f)) (fst1 (runWriter1 x))))++instance (Lang r, Monoid r w) => Monad r (P.Writer w) where+  join = lam $ \x -> writer1 $ mkProd2 (zro1 $ runWriter1 $ zro1 $ runWriter1 x) (plus2 (fst1 $ runWriter1 $ zro1 $ runWriter1 x) (fst1 $ runWriter1 x))++instance Lang r => Functor r P.IO where+  map = ioMap++instance Lang r => Applicative r P.IO where+  pure = ioRet+  ap = lam2 $ \f x -> ioBind2 f (flip2 ioMap x)++instance Lang r => Monad r P.IO where+  bind = ioBind++instance Lang r => Functor r P.Maybe where+  map = lam $ \func -> optionMatch2 nothing (com2 just func)++instance Lang r => Applicative r P.Maybe where+  pure = just+  ap = optionMatch2 (const1 nothing) map++instance Lang r => Monad r P.Maybe where+  bind = lam2 $ \x func -> optionMatch3 nothing func x++runImpW :: forall repr h x. Lang repr => ImpW repr h x -> RunImpW repr h x+runImpW (ImpW x) = RunImpW x+runImpW (NoImpW x) = RunImpW (const1 x :: repr h (() -> x))++newtype GWDiff repr h x = GWDiff {runGWDiff :: forall v. Vector repr v => Proxy v -> repr (Diff v h) (Diff v x)}++instance DBI repr => DBI (GWDiff repr) where+  z = GWDiff (P.const z)+  s (GWDiff x) = GWDiff (\p -> s $ x p)+  app (GWDiff f) (GWDiff x) = GWDiff (\p -> app (f p) (x p))+  abs (GWDiff x) = GWDiff (\p -> abs $ x p)++cons2 = app2 cons+listMatch2 = app2 listMatch+fix1 = app fix+fix2 = app2 fix+uncurry1 = app uncurry+optionMatch2 = app2 optionMatch+optionMatch3 = app3 optionMatch+zro1 = app zro+fst1 = app fst+mult1 = app mult+mult2 = app2 mult+divide2 = app2 divide+invert1 = app invert+mkProd1 = app mkProd+mkProd2 = app2 mkProd+minus1 = app minus+divide1 = app divide+recip = divide1 doubleOne+recip1 = app recip+writer1 = app writer+runWriter1 = app runWriter+ioBind2 = app2 ioBind+minus2 = app2 minus+float2Double1 = app float2Double+doubleExp1 = app doubleExp+floatExp1 = app floatExp++instance Lang repr => DBI (ImpW repr) where+  z = NoImpW z+  s :: forall a h b. ImpW repr h b -> ImpW repr (a, h) b+  s (ImpW x) = work x+    where+      work :: Weight w => repr h (w -> b) -> ImpW repr (a, h) b+      work x = ImpW (s x)+  s (NoImpW x) = NoImpW (s x)+  app (ImpW f) (ImpW x) = ImpW (lam $ \p -> app (app (conv f) (zro1 p)) (app (conv x) (fst1 p)))+  app (NoImpW f) (NoImpW x) = NoImpW (app f x)+  app (ImpW f) (NoImpW x) = ImpW (lam $ \w -> app2 (conv f) w (conv x))+  app (NoImpW f) (ImpW x) = ImpW (lam $ \w -> app (conv f) (app (conv x) w))+  abs (ImpW f) = ImpW (flip1 $ abs f)+  abs (NoImpW x) = NoImpW (abs x)
+ lib/Poly.lhs view
@@ -0,0 +1,107 @@+> {-# 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 (return)
+> import Lang
+> import qualified Control.Monad as P
+
+Importing 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. Lang repr => repr h (Double -> Double)
+> poly = lam $ \x -> plus2 (mult2 x x) (plus2 (mult2 (double 2.0) x) (double 3.0))
+
+poly x = x * x + (2 * x + 3)
+
+> l2 = lam $ \x -> mult2 (minus2 x (double 27)) (minus2 x (double 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.
+
+Now write a generic function that calculate x and return it.
+
+> solve :: forall m. P.Monad m => (AST -> m ()) -> (Integer -> Double -> m ()) -> m Double
+> solve doAST doIter = do
+
+Let's begin by trying to print poly
+
+>   doAST $ 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 -> m Double
+>     go i w | i < 200 = do
+>       doIter i w
+>       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 environment (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 runWDiff, we use runEval to take out the term from a newtype
+now we apply the environment (remember it has no environment? 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 w
+
+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!
+
+Now the main function:
+
+> main :: IO ()
+> main = do
+>   d <- solve print printSquare
+>   putStrLn $ "x is: " ++ (show d)
+>   return ()
+>   where
+>     printSquare i x = when (isSquare i) (print x)
+
+the only thing worth noting is that we print the weight in increasing interval,
+so initially more weight is printed
+ lib/Util.hs view
@@ -0,0 +1,6 @@+module Util where
+
+vars = [pre : suf | suf <- "":map show [0..], pre <- ['a'..'z']]
+
+isSquare n = sq * sq == n
+  where sq = floor $ sqrt (fromIntegral n::Double)
+ lib/Xor.lhs view
@@ -0,0 +1,127 @@+> {-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction, TypeApplications, RankNTypes #-}++This is the classical example of using sigmoid NN to approximate Xor.++> module Xor where+> import DBI hiding (return)+> import qualified Poly as YouShouldAlreadyReadThis+> import qualified Prelude as P+> import Prelude (Double, IO, return, ($), print, undefined, Int, (<=), (<), (+), (-), (*), (/), (++), fromIntegral, putStr)+> import Util+> import System.Random+> import Control.Monad (when)+> import Data.Proxy+> import Data.Constraint+> import Lang++Recall in poly, we constructed a function Double -> Double,+with argument being the weight, and do gradient descend to found a solution.++However, most of the time, there wil be more than one weight (or no weight at all).+Also, when we are composing a Neural Network to approximate a value, we dont really care how much weight it use.+So, we use existential type to hide the actual weight.++data ImpW repr h x = forall w. Weight w => ImpW (repr h (w -> x))++ImpW stands for implicit weights.+The existential w is weight, and a Neural Network of type x is just a function from w to x!+We require that the weight can be constructed randomly, so we have random initialization.+Weight also form a Vector so we can combine weights (update it), scale it (to control the learning rate).++Let's start by constructing a weight.++> weight :: Lang repr => ImpW repr h Double+> weight = ImpW id++Note that we are just manipulating AST.+If you wanna do weight sharing, you need to use let(in DDF) yourself.++Obviously, we just need to take the implicit argument.++We have the weight, now we need the activation function, sigmoid.++> sigmoid = lam $ \x -> recip1 (plus2 doubleOne (doubleExp1 (invert1 x)))+> sigmoid1 = app sigmoid++With weight and sigmoid we can construct a neuron of type ((Double, Double) -> Double)+The weight should be a pair of Double, each as a scale on the actual input, with a bias.+We then add the two scaled input, with the bias, and pass them into sigmoid.++> scaleAdd :: Lang repr => ImpW repr h ((Double, Double) -> Double)+> scaleAdd = ImpW $ lam2 $ \w p -> plus2 (mult2 (zro1 w) (zro1 p)) (plus2 (fst1 w) (fst1 p))++> withBias :: Lang repr => ImpW repr h (Double -> Double)+> withBias = ImpW $ plus++> neuron :: Lang repr => ImpW repr h ((Double, Double) -> Double)+> neuron = com2 (com2 sigmoid withBias) scaleAdd+> neuron1 = app neuron++Now, the hidden layer of type (Double, Double) -> ((Double, Double), (Double, Double))++> hidden = lam $ \p -> mkProd2 (mkProd2 (neuron1 p) (neuron1 p)) (mkProd2 (neuron1 p) (neuron1 p))++And finally, the whole NN:++> type XOR = (Double, Double) -> Double+> xor :: Lang repr => ImpW repr h XOR+> xor = neuron `com2` (bimap2 scaleAdd scaleAdd) `com2` hidden++But before we can train it, we need to define the dataset and the loss function.++> l2 :: Lang repr => repr h (Double -> Double -> Double)+> l2 = lam2 $ \l r -> (mult2 (minus2 l r) (minus2 l r))+> l22 = app2 l2++> eval :: Lang repr => repr h (XOR -> ((Double, Double), Double) -> Double)+> eval = lam2 $ \xor p -> l22 (app xor (zro1 p)) (fst1 p)++> dataset :: Lang repr => repr h [((Double, Double), Double)]+> dataset = cons2 (build 0 0 0) (cons2 (build 0 1 1) (cons2 (build 1 0 1) (cons2 (build 1 1 0) nil)))+>   where build l r ret = mkProd2 (mkProd2 (double l) (double r)) (double ret)++However, unlike Poly, there are more than one datapoint, so we need to use a list, and map xor onto it.++> loss :: Lang repr => repr h (XOR -> Double)+> loss = lam $ \xor -> fix2 (lam $ \self -> listMatch2 doubleZero (lam2 $ \x xs -> plus2 x (app self xs))) (map2 (app eval xor) dataset)++Now we are good to implement the train function!++> findXor :: forall g m. (RandomGen g, P.Monad m) => g -> (AST -> m ()) -> (Int -> Double -> P.String -> m ()) -> m XOR+> findXor rand doAST doIter = case runImpW $ noEnv xor of+>   RunImpW ((Combine (Show xorS) (Combine (Eval xorEv) xorE)) :: Weight w => Combine Show (Combine Eval (GWDiff Eval)) () (w -> XOR)) -> do+>     doAST $ xorS vars 0++printing weights. now you will see a list of gibberish++>     let initWeight :: w = P.fst $ ((randomR (randRange (-0.01, 0.01)) \\ weightCon @w @Random) \\ weightCon @w @RandRange) rand++Getting random weights...++>     (go (diff xorE) initWeight (runEval selfWithDiff () \\ weightCon @w @(WithDiff Eval)) (diff loss)+>         ((runEval (lam3 $ \d o n -> minus2 o (mult2 d n)) ()) \\ weightCon @w @(Vector Eval)) 0 (xorEv ())) \\ weightCon @w @P.Show+>     where+>       diff :: GWDiff Eval () x -> Diff w x+>       diff x = (runEval (runGWDiff x (Proxy :: Proxy w)) ()) \\ weightCon @w @(Vector Eval)+>       go :: P.Show w => (Diff w (w -> XOR)) -> w -> (w -> Diff w w) -> (Diff w (XOR -> Double)) -> (Double -> w -> w -> w) -> Int -> (w -> XOR) -> m XOR+>       go xor weight reify loss update i orig | i <= 2500 = do+>         doIter i lossVal (P.show weight)+>         go xor (update 0.3 weight lossDiff) reify loss update (1 + i) orig+>           where+>             (lossVal, lossDiff) = loss $ xor (reify weight)+>       go xor weight _ _ _ _ orig = return $ orig weight++> main :: IO ()+> main = do+>   g <- getStdGen+>   xor <- findXor g print (\i d w -> when (isSquare i) $ do+>     print d+>     P.putStrLn w+>     P.putStrLn "")+>   let doXor :: Double -> Double -> IO ()+>       doXor l r = P.putStrLn $ P.show l ++ " xor " ++ P.show r ++ " is " ++ (P.show $ xor (l, r))+>   doXor 0 0+>   doXor 0 1+>   doXor 1 0+>   doXor 1 1+>   return ()
− src/DBI.hs 
@@ -1,236 +0,0 @@-{-# LANGUAGE
-    MultiParamTypeClasses,
-    RankNTypes,
-    ScopedTypeVariables,
-    FlexibleInstances,
-    FlexibleContexts,
-    UndecidableInstances,
-    PolyKinds,
-    LambdaCase,
-    NoMonomorphismRestriction,
-    TypeFamilies,
-    LiberalTypeSynonyms,
-    FunctionalDependencies,
-    ExistentialQuantification,
-    InstanceSigs,
-    TupleSections,
-    ConstraintKinds,
-    DefaultSignatures,
-    UndecidableSuperClasses,
-    TypeOperators,
-    TypeApplications,
-    PartialTypeSignatures #-}
-
-module DBI where
-import qualified Prelude as P
-import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), undefined)
-import Util
-import Control.Monad (when)
-import System.Random
-import Data.Proxy
-import Data.Constraint
-import Data.Constraint.Forall
-
-class Monoid r m where
-  zero :: r h m
-  plus :: r h (m -> m -> m)
-
-class Monoid repr w => WithDiff repr w where
-  withDiff :: repr h ((w -> x) -> w -> Diff x w)
-
-withDiff1 = app withDiff
-
-selfWithDiff :: (DBI repr, WithDiff repr w) => repr h (w -> Diff w w)
-selfWithDiff = withDiff1 id
-
-instance Random () where
-  random = ((),)
-  randomR _ = random
-
-instance (Random l, Random r) => Random (l, r) where
-  random g0 = ((l, r), g2)
-    where
-      (l, g1) = random g0
-      (r, g2) = random g1
-  randomR ((llo, rlo), (lhi, rhi)) g0 = ((l, r), g2)
-    where
-      (l, g1) = randomR (llo, lhi) g0
-      (r, g2) = randomR (rlo, rhi) g1
-
-class DBI repr where
-  z :: repr (a, h) a
-  s :: repr h b -> repr (a, h) b
-  abs :: repr (a, h) b -> repr h (a -> b)
-  app :: repr h (a -> b) -> repr h a -> repr h b
-  hoas :: (repr (a, h) a -> repr (a, h) b) -> repr h (a -> b)
-  hoas f = abs $ f z
-  com :: repr h ((b -> c) -> (a -> b) -> (a -> c))
-  com = lam3 $ \f g x -> app f (app g x)
-  flip :: repr h ((a -> b -> c) -> (b -> a -> c))
-  flip = lam3 $ \f b a -> app2 f a b
-  id :: repr h (a -> a)
-  id = lam $ \x -> x
-  const :: repr h (a -> b -> a)
-  const = lam2 $ \x _ -> x
-  scomb :: repr h ((a -> b -> c) -> (a -> b) -> (a -> c))
-  scomb = lam3 $ \f x arg -> app2 f arg (app x arg)
-  dup :: repr h ((a -> a -> b) -> (a -> b))
-  dup = lam2 $ \f x -> app2 f x x
-
-const1 = app const
-map2 = app2 map
-return = pure
-bind2 = app2 bind
-map1 = app map
-join1 = app join
-bimap2 = app2 bimap
-flip1 = app flip
-flip2 = app2 flip
-
-class 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)
-
-class (DBI r, 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 = lam $ \m -> bind2 m id
-  bind = lam2 $ \m f -> join1 (app2 map f m)
-  {-# MINIMAL (join | bind) #-}
-
-class BiFunctor r p where
-  bimap :: r h ((a -> b) -> (c -> d) -> p a c -> p b d)
-
-app3 f x y z = app (app2 f x y) z
-com2 = app2 com
-
-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
-  abs (Eval f) = Eval $ \a h -> f (h, a)
-  app (Eval f) (Eval x) = Eval $ \h -> f h $ x h
-
-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
-  abs (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 + 1))
-
-class NT repr l r where
-    conv :: repr l t -> repr r t
-
-class NTS repr l r where
-    convS :: repr l t -> repr r t
-
-instance (DBI repr, NT repr l r) => NTS repr l (a, r) where
-    convS = s . conv
-
-instance {-# OVERLAPPABLE #-} NTS repr l r => NT repr l r where
-    conv = convS
-
-instance {-# OVERLAPPING #-} NT repr x x where
-    conv = P.id
-
-lam :: 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)
-lam f = hoas (\x -> f $ conv x)
-
-lam2 :: forall repr a b c h. DBI repr =>
-  ((forall k. NT repr (a, h) k => repr k a) -> (forall k. NT repr (b, (a, h)) k => repr k b) -> (repr (b, (a, h))) c) -> repr h (a -> b -> c)
-lam2 f = lam $ \x -> lam $ \y -> f x y
-
-lam3 f = lam2 $ \x y -> lam $ \z -> f x y z
-
-type family Diff v x
-type instance Diff v () = ()
-type instance Diff v (a -> b) = Diff v a -> Diff v b
-type instance Diff v (a, b) = (Diff v a, Diff v b)
-
-newtype WDiff repr v h x = WDiff {runWDiff :: repr (Diff v h) (Diff v x)}
-
-app2 f a = app (app f a)
-
-plus2 = app2 plus
-
-instance DBI repr => DBI (WDiff repr v) where
-  z = WDiff z
-  s (WDiff x) = WDiff $ s x
-  abs (WDiff f) = WDiff $ abs f
-  app (WDiff f) (WDiff x) = WDiff $ app f x
-  hoas f = WDiff $ hoas (runWDiff . f . WDiff)
-
-noEnv :: repr () x -> repr () x
-noEnv = P.id
-
-class RandRange w where
-  randRange :: (P.Double, P.Double) -> (w, w)
-
-instance RandRange () where
-  randRange _ = ((), ())
-
-instance RandRange P.Double where
-  randRange (lo, hi) = (lo, hi)
-
-instance (RandRange l, RandRange r) => RandRange (l, r) where
-  randRange (lo, hi) = ((llo, rlo), (lhi, rhi))
-    where
-      (llo, lhi) = randRange (lo, hi)
-      (rlo, rhi) = randRange (lo, hi)
-
-instance Weight () where weightCon = Sub Dict
-
-instance Weight P.Double where weightCon = Sub Dict
-
-instance (Weight l, Weight r) => Weight (l, r) where
-  weightCon :: forall con. (con (), con P.Double, ForallV (ProdCon con)) :- con (l, r)
-  weightCon = Sub (mapDict (prodCon \\ (instV :: (ForallV (ProdCon con) :- ProdCon con l r))) (Dict \\ weightCon @l @con \\ weightCon @r @con))
-
-class ProdCon con l r where
-  prodCon :: (con l, con r) :- con (l, r)
-
-instance ProdCon Random l r where prodCon = Sub Dict
-
-instance ProdCon RandRange l r where prodCon = Sub Dict
-
-instance ProdCon P.Show l r where prodCon = Sub Dict
-
-class Weight w where
-  weightCon :: (con (), con P.Double, ForallV (ProdCon con)) :- con w
-
-data RunImpW repr h x = forall w. Weight w => RunImpW (repr h (w -> x))
-data ImpW repr h x = NoImpW (repr h x) | forall w. Weight w => ImpW (repr h (w -> x))
-
-data Combine l r h x = Combine (l h x) (r h x)
-
-instance (DBI l, DBI r) => DBI (Combine l r) where
-  z = Combine z z
-  s (Combine l r) = Combine (s l) (s r)
-  app (Combine fl fr) (Combine xl xr) = Combine (app fl xl) (app fr xr)
-  abs (Combine l r) = Combine (abs l) (abs r)
-  hoas f = Combine (hoas $ \x -> case f (Combine x z) of Combine l r -> l) (hoas $ \x -> case f (Combine z x) of Combine l r -> r)
− src/Lang.hs 
@@ -1,543 +0,0 @@-{-# LANGUAGE-    MultiParamTypeClasses,-    RankNTypes,-    ScopedTypeVariables,-    FlexibleInstances,-    FlexibleContexts,-    UndecidableInstances,-    PolyKinds,-    LambdaCase,-    NoMonomorphismRestriction,-    TypeFamilies,-    LiberalTypeSynonyms,-    FunctionalDependencies,-    ExistentialQuantification,-    InstanceSigs,-    TupleSections,-    ConstraintKinds,-    DefaultSignatures,-    UndecidableSuperClasses,-    TypeOperators,-    TypeApplications,-    PartialTypeSignatures #-}--module Lang where-import DBI-import qualified Prelude as P-import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), undefined)-import qualified Control.Monad.Writer as P-import qualified Data.Functor.Identity as P-import qualified GHC.Float as P-import qualified Data.Tuple as P-import Data.Void-import Data.Proxy-import Data.Proxy-import Data.Constraint-import Data.Constraint.Forall--type instance Diff v (P.Writer w a) = P.Writer (Diff v w) (Diff v a)-type instance Diff v Void = Void-type instance Diff v P.Double = (P.Double, v)-type instance Diff v P.Float = (P.Float, v)-type instance Diff v (P.Either a b) = P.Either (Diff v a) (Diff v b)-type instance Diff v (P.Maybe a) = P.Maybe (Diff v a)-type instance Diff v (P.IO a) = P.IO (Diff v a)-type instance Diff v [a] = [Diff v a]--class DBI repr => Lang repr where-  mkProd :: repr h (a -> b -> (a, b))-  zro :: repr h ((a, b) -> a)-  fst :: repr h ((a, b) -> b)-  double :: P.Double -> repr h P.Double-  doubleZero :: repr h P.Double-  doubleZero = double 0-  doubleOne :: repr h P.Double-  doubleOne = double 1-  doublePlus :: repr h (P.Double -> P.Double -> P.Double)-  doubleMinus :: repr h (P.Double -> P.Double -> P.Double)-  doubleMult :: repr h (P.Double -> P.Double -> P.Double)-  doubleDivide :: repr h (P.Double -> P.Double -> P.Double)-  doubleExp :: repr h (P.Double -> P.Double)-  float :: P.Float -> repr h P.Float-  floatZero :: repr h P.Float-  floatZero = float 0-  floatOne :: repr h P.Float-  floatOne = float 1-  floatPlus :: repr h (P.Float -> P.Float -> P.Float)-  floatMinus :: repr h (P.Float -> P.Float -> P.Float)-  floatMult :: repr h (P.Float -> P.Float -> P.Float)-  floatDivide :: repr h (P.Float -> P.Float -> P.Float)-  floatExp :: repr h (P.Float -> P.Float)-  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)-  listAppend :: repr h ([a] -> [a] -> [a])-  listAppend = lam2 $ \l r -> fix2 (lam $ \self -> listMatch2 r (lam2 $ \a 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 = lam $ \p -> mkProd2 (fst1 p) (zro1 p)-  curry :: repr h (((a, b) -> c) -> (a -> b -> c))-  uncurry :: repr h ((a -> b -> c) -> ((a, b) -> c))-  curry = lam3 $ \f a b -> app f (mkProd2 a b)-  uncurry = lam2 $ \f p -> app2 f (zro1 p) (fst1 p)-  float2Double :: repr h (P.Float -> P.Double)-  double2Float :: repr h (P.Double -> P.Float)--class Reify repr x where-  reify :: x -> repr h x--instance Lang repr => Reify repr () where-  reify _ = unit--instance Lang repr => Reify repr P.Double where-  reify = double--instance (Lang repr, Reify repr l, Reify repr r) => Reify repr (l, r) where-  reify (l, r) = mkProd2 (reify l) (reify r)--instance Lang Eval where-  zro = comb P.fst-  fst = comb P.snd-  mkProd = comb (,)-  double = comb-  doublePlus = comb (+)-  doubleMinus = comb (-)-  doubleMult = comb (*)-  doubleDivide = 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-  doubleExp = comb P.exp-  float = comb-  floatPlus = comb (+)-  floatMinus = comb (-)-  floatMult = comb (*)-  floatDivide = comb (/)-  floatExp = comb P.exp-  float2Double = comb P.float2Double-  double2Float = comb P.double2Float--instance Lang Show where-  mkProd = name "mkProd"-  zro = name "zro"-  fst = name "fst"-  double = name . show-  doublePlus = name "plus"-  doubleMinus = name "minus"-  doubleMult = name "mult"-  doubleDivide = name "divide"-  doubleExp = name "exp"-  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"-  float = name . show-  floatPlus = name "plus"-  floatMinus = name "minus"-  floatMult = name "mult"-  floatDivide = name "divide"-  floatExp = name "exp"-  float2Double = name "float2Double"-  double2Float = name "double2Float"--instance Lang repr => Lang (GWDiff repr) where-  mkProd = GWDiff (P.const mkProd)-  zro = GWDiff $ P.const $ zro-  fst = GWDiff $ P.const $ fst-  double x = GWDiff $ P.const $ mkProd2 (double x) zero-  doublePlus = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))-  doubleMinus = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))-  doubleMult = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (mult2 (zro1 l) (zro1 r))-      (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l)))-  doubleDivide = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (divide2 (zro1 l) (zro1 r))-      (divide2 (minus2 (mult2 (zro1 r) (fst1 l)) (mult2 (zro1 l) (fst1 r)))-        (mult2 (zro1 r) (zro1 r)))-  doubleExp = GWDiff $ P.const $ lam $ \x -> mkProd2 (doubleExp1 (zro1 x)) (mult2 (doubleExp1 (zro1 x)) (fst1 x))-  fix = GWDiff $ P.const fix-  left = GWDiff $ P.const left-  right = GWDiff $ P.const right-  sumMatch = GWDiff $ P.const sumMatch-  unit = GWDiff $ P.const unit-  exfalso = GWDiff $ P.const exfalso-  nothing = GWDiff $ P.const nothing-  just = GWDiff $ P.const just-  ioRet = GWDiff $ P.const ioRet-  ioBind = GWDiff $ P.const ioBind-  nil = GWDiff $ P.const nil-  cons = GWDiff $ P.const cons-  listMatch = GWDiff $ P.const listMatch-  optionMatch = GWDiff $ P.const optionMatch-  ioMap = GWDiff $ P.const ioMap-  writer = GWDiff $ P.const writer-  runWriter = GWDiff $ P.const runWriter-  float x = GWDiff $ P.const $ mkProd2 (float x) zero-  floatPlus = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))-  floatMinus = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))-  floatMult = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (mult2 (float2Double1 (zro1 l)) (zro1 r))-      (plus2 (mult2 (float2Double1 (zro1 l)) (fst1 r)) (mult2 (float2Double1 (zro1 r)) (fst1 l)))-  floatDivide = GWDiff $ P.const $ lam2 $ \l r ->-    mkProd2 (divide2 (zro1 l) (float2Double1 (zro1 r)))-      (divide2 (minus2 (mult2 (float2Double1 (zro1 r)) (fst1 l)) (mult2 (float2Double1 (zro1 l)) (fst1 r)))-        (float2Double1 (mult2 (float2Double1 (zro1 r)) (zro1 r))))-  floatExp = GWDiff $ P.const $ lam $ \x -> mkProd2 (floatExp1 (zro1 x)) (mult2 (float2Double1 (floatExp1 (zro1 x))) (fst1 x))-  float2Double = GWDiff $ P.const $ bimap2 float2Double id-  double2Float = GWDiff $ P.const $ bimap2 double2Float id--instance (Vector repr v, Lang repr) => Lang (WDiff repr v) where-  mkProd = WDiff mkProd-  zro = WDiff zro-  fst = WDiff fst-  double x = WDiff $ mkProd2 (double x) zero-  doublePlus = WDiff $ lam2 $ \l r ->-    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))-  doubleMinus = WDiff $ lam2 $ \l r ->-    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))-  doubleMult = WDiff $ lam2 $ \l r ->-    mkProd2 (mult2 (zro1 l) (zro1 r))-      (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l)))-  doubleDivide = WDiff $ lam2 $ \l r ->-    mkProd2 (divide2 (zro1 l) (zro1 r))-      (divide2 (minus2 (mult2 (zro1 r) (fst1 l)) (mult2 (zro1 l) (fst1 r)))-        (mult2 (zro1 r) (zro1 r)))-  doubleExp = WDiff $ lam $ \x -> mkProd2 (doubleExp1 (zro1 x)) (mult2 (doubleExp1 (zro1 x)) (fst1 x))-  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-  float x = WDiff $ mkProd2 (float x) zero-  floatPlus = WDiff $ lam2 $ \l r ->-    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))-  floatMinus = WDiff $ lam2 $ \l r ->-    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))-  floatMult = WDiff $ lam2 $ \l r ->-    mkProd2 (mult2 (float2Double1 (zro1 l)) (zro1 r))-      (plus2 (mult2 (float2Double1 (zro1 l)) (fst1 r)) (mult2 (float2Double1 (zro1 r)) (fst1 l)))-  floatDivide = WDiff $ lam2 $ \l r ->-    mkProd2 (divide2 (zro1 l) (float2Double1 (zro1 r)))-      (divide2 (minus2 (mult2 (float2Double1 (zro1 r)) (fst1 l)) (mult2 (float2Double1 (zro1 l)) (fst1 r)))-        (float2Double1 (mult2 (float2Double1 (zro1 r)) (zro1 r))))-  floatExp = WDiff $ lam $ \x -> mkProd2 (floatExp1 (zro1 x)) (mult2 (float2Double1 (floatExp1 (zro1 x))) (fst1 x))-  float2Double = WDiff $ bimap2 float2Double id-  double2Float = WDiff $ bimap2 double2Float id--instance Lang repr => ProdCon (Monoid repr) l r where prodCon = Sub Dict--instance Lang repr => ProdCon (WithDiff repr) l r where prodCon = Sub Dict--instance Lang repr => ProdCon (Reify repr) l r where prodCon = Sub Dict--instance Lang repr => ProdCon (Vector repr) l r where prodCon = Sub Dict--instance Lang repr => Lang (ImpW repr) where-  nil = NoImpW nil-  cons = NoImpW cons-  listMatch = NoImpW listMatch-  zro = NoImpW zro-  fst = NoImpW fst-  mkProd = NoImpW mkProd-  ioRet = NoImpW ioRet-  ioMap = NoImpW ioMap-  ioBind = NoImpW ioBind-  unit = NoImpW unit-  nothing = NoImpW nothing-  just = NoImpW just-  optionMatch = NoImpW optionMatch-  exfalso = NoImpW exfalso-  fix = NoImpW fix-  left = NoImpW left-  right = NoImpW right-  sumMatch = NoImpW sumMatch-  writer = NoImpW writer-  runWriter = NoImpW runWriter-  double = NoImpW . double-  doubleExp = NoImpW doubleExp-  doublePlus = NoImpW doublePlus-  doubleMinus = NoImpW doubleMinus-  doubleMult = NoImpW doubleMult-  doubleDivide = NoImpW doubleDivide-  float = NoImpW . float-  floatExp = NoImpW floatExp-  floatPlus = NoImpW floatPlus-  floatMinus = NoImpW floatMinus-  floatMult = NoImpW floatMult-  floatDivide = NoImpW floatDivide-  float2Double = NoImpW float2Double-  double2Float = NoImpW double2Float--instance (Lang l, Lang r) => Lang (Combine l r) where-  mkProd = Combine mkProd mkProd-  zro = Combine zro zro-  fst = Combine fst fst-  double x = Combine (double x) (double x)-  doublePlus = Combine doublePlus doublePlus-  doubleMinus = Combine doubleMinus doubleMinus-  doubleMult = Combine doubleMult doubleMult-  doubleDivide = Combine doubleDivide doubleDivide-  doubleExp = Combine doubleExp doubleExp-  float x = Combine (float x) (float x)-  floatPlus = Combine floatPlus floatPlus-  floatMinus = Combine floatMinus floatMinus-  floatMult = Combine floatMult floatMult-  floatDivide = Combine floatDivide floatDivide-  floatExp = Combine floatExp floatExp-  fix = Combine fix fix-  left = Combine left left-  right = Combine right right-  sumMatch = Combine sumMatch sumMatch-  unit = Combine unit unit-  exfalso = Combine exfalso exfalso-  nothing = Combine nothing nothing-  just = Combine just just-  optionMatch = Combine optionMatch optionMatch-  ioRet = Combine ioRet ioRet-  ioBind = Combine ioBind ioBind-  ioMap = Combine ioMap ioMap-  nil = Combine nil nil-  cons = Combine cons cons-  listMatch = Combine listMatch listMatch-  runWriter = Combine runWriter runWriter-  writer = Combine writer writer-  double2Float = Combine double2Float double2Float-  float2Double = Combine float2Double float2Double--instance Lang repr => WithDiff repr () where-  withDiff = const1 id--instance Lang repr => WithDiff repr P.Double where-  withDiff = lam2 $ \conv d -> mkProd2 d (app conv doubleOne)--instance (Lang repr, WithDiff repr l, WithDiff repr r) => WithDiff repr (l, r) where-  withDiff = lam $ \conv -> bimap2 (withDiff1 (lam $ \l -> app conv (mkProd2 l zero))) (withDiff1 (lam $ \r -> app conv (mkProd2 zero r)))--class Monoid r g => Group r g where-  invert :: r h (g -> g)-  minus :: r h (g -> g -> g)-  default invert :: Lang r => r h (g -> g)-  invert = minus1 zero-  default minus :: Lang r => r h (g -> g -> g)-  minus = lam2 $ \x y -> plus2 x (invert1 y)-  {-# MINIMAL (invert | minus) #-}--class Group r v => Vector r v where-  mult :: r h (P.Double -> v -> v)-  divide :: r h (v -> P.Double -> v)-  default mult :: Lang r => r h (P.Double -> v -> v)-  mult = lam2 $ \x y -> divide2 y (recip1 x)-  default divide :: Lang r => r h (v -> P.Double -> v)-  divide = lam2 $ \x y -> mult2 (recip1 y) x-  {-# MINIMAL (mult | divide) #-}--instance Lang r => Monoid r () where-  zero = unit-  plus = const1 $ const1 unit--instance Lang r => Group r () where-  invert = const1 unit-  minus = const1 $ const1 unit--instance Lang r => Vector r () where-  mult = const1 $ const1 unit-  divide = const1 $ const1 unit--instance Lang r => Monoid r P.Double where-  zero = doubleZero-  plus = doublePlus--instance Lang r => Group r P.Double where-  minus = doubleMinus--instance Lang r => Vector r P.Double where-  mult = doubleMult-  divide = doubleDivide--instance Lang r => Monoid r P.Float where-  zero = floatZero-  plus = floatPlus--instance Lang r => Group r P.Float where-  minus = floatMinus--instance Lang r => Vector r P.Float where-  mult = com2 floatMult double2Float-  divide = com2 (flip2 com double2Float) floatDivide--instance (Lang repr, Monoid repr l, Monoid repr r) => Monoid repr (l, r) where-  zero = mkProd2 zero zero-  plus = lam2 $ \l r -> mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))--instance (Lang repr, Group repr l, Group repr r) => Group repr (l, r) where-  invert = bimap2 invert invert--instance (Lang repr, Vector repr l, Vector repr r) => Vector repr (l, r) where-  mult = lam $ \x -> bimap2 (mult1 x) (mult1 x)--instance (Lang repr, Monoid repr l, Monoid repr r) => Monoid repr (l -> r) where-  zero = const1 zero-  plus = lam3 $ \l r x -> plus2 (app l x) (app r x)--instance (Lang repr, Group repr l, Group repr r) => Group repr (l -> r) where-  invert = lam2 $ \l x -> app l (invert1 x)--instance (Lang repr, Vector repr l, Vector repr r) => Vector repr (l -> r) where-  mult = lam3 $ \l r x -> app r (mult2 l x)--instance Lang r => Monoid r [a] where-  zero = nil-  plus = listAppend--instance Lang r => Functor r [] where-  map = lam $ \f -> fix1 $ lam $ \self -> listMatch2 nil (lam2 $ \x xs -> cons2 (app f x) $ app self xs)--instance Lang r => BiFunctor r (,) where-  bimap = lam3 $ \l r p -> mkProd2 (app l (zro1 p)) (app r (fst1 p))--instance Lang r => Functor r (P.Writer w) where-  map = lam $ \f -> com2 writer (com2 (bimap2 f id) runWriter)--instance (Lang r, Monoid r w) => Applicative r (P.Writer w) where-  pure = com2 writer (flip2 mkProd zero)-  ap = lam2 $ \f x -> writer1 (mkProd2 (app (zro1 (runWriter1 f)) (zro1 (runWriter1 x))) (plus2 (fst1 (runWriter1 f)) (fst1 (runWriter1 x))))--instance (Lang r, Monoid r w) => Monad r (P.Writer w) where-  join = lam $ \x -> writer1 $ mkProd2 (zro1 $ runWriter1 $ zro1 $ runWriter1 x) (plus2 (fst1 $ runWriter1 $ zro1 $ runWriter1 x) (fst1 $ runWriter1 x))--instance Lang r => Functor r P.IO where-  map = ioMap--instance Lang r => Applicative r P.IO where-  pure = ioRet-  ap = lam2 $ \f x -> ioBind2 f (flip2 ioMap x)--instance Lang r => Monad r P.IO where-  bind = ioBind--instance Lang r => Functor r P.Maybe where-  map = lam $ \func -> optionMatch2 nothing (com2 just func)--instance Lang r => Applicative r P.Maybe where-  pure = just-  ap = optionMatch2 (const1 nothing) map--instance Lang r => Monad r P.Maybe where-  bind = lam2 $ \x func -> optionMatch3 nothing func x--runImpW :: forall repr h x. Lang repr => ImpW repr h x -> RunImpW repr h x-runImpW (ImpW x) = RunImpW x-runImpW (NoImpW x) = RunImpW (const1 x :: repr h (() -> x))--newtype GWDiff repr h x = GWDiff {runGWDiff :: forall v. Vector repr v => Proxy v -> repr (Diff v h) (Diff v x)}--instance DBI repr => DBI (GWDiff repr) where-  z = GWDiff (P.const z)-  s (GWDiff x) = GWDiff (\p -> s $ x p)-  app (GWDiff f) (GWDiff x) = GWDiff (\p -> app (f p) (x p))-  abs (GWDiff x) = GWDiff (\p -> abs $ x p)--cons2 = app2 cons-listMatch2 = app2 listMatch-fix1 = app fix-fix2 = app2 fix-uncurry1 = app uncurry-optionMatch2 = app2 optionMatch-optionMatch3 = app3 optionMatch-zro1 = app zro-fst1 = app fst-mult1 = app mult-mult2 = app2 mult-divide2 = app2 divide-invert1 = app invert-mkProd1 = app mkProd-mkProd2 = app2 mkProd-minus1 = app minus-divide1 = app divide-recip = divide1 doubleOne-recip1 = app recip-writer1 = app writer-runWriter1 = app runWriter-ioBind2 = app2 ioBind-minus2 = app2 minus-float2Double1 = app float2Double-doubleExp1 = app doubleExp-floatExp1 = app floatExp--instance Lang repr => DBI (ImpW repr) where-  z = NoImpW z-  s :: forall a h b. ImpW repr h b -> ImpW repr (a, h) b-  s (ImpW x) = work x-    where-      work :: Weight w => repr h (w -> b) -> ImpW repr (a, h) b-      work x = ImpW (s x)-  s (NoImpW x) = NoImpW (s x)-  app (ImpW f) (ImpW x) = ImpW (lam $ \p -> app (app (conv f) (zro1 p)) (app (conv x) (fst1 p)))-  app (NoImpW f) (NoImpW x) = NoImpW (app f x)-  app (ImpW f) (NoImpW x) = ImpW (lam $ \w -> app2 (conv f) w (conv x))-  app (NoImpW f) (ImpW x) = ImpW (lam $ \w -> app (conv f) (app (conv x) w))-  abs (ImpW f) = ImpW (flip1 $ abs f)-  abs (NoImpW x) = NoImpW (abs x)
− src/Poly.lhs 
@@ -1,94 +0,0 @@-> {-# 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 (return)
-> import Lang
-
-Importing 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. Lang repr => repr h (Double -> Double)
-> poly = lam $ \x -> plus2 (mult2 x x) (plus2 (mult2 (double 2.0) x) (double 3.0))
-
-poly x = x * x + (2 * x + 3)
-
-> l2 = lam $ \x -> mult2 (minus2 x (double 27)) (minus2 x (double 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 environment (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 runWDiff, we use runEval to take out the term from a newtype
-now we apply the environment (remember it has no environment? 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!
− src/Util.hs 
@@ -1,6 +0,0 @@-module Util where
-
-vars = [pre : suf | suf <- "":map show [0..], pre <- ['a'..'z']]
-
-isSquare n = sq * sq == n
-  where sq = floor $ sqrt (fromIntegral n::Double)
− src/Xor.lhs 
@@ -1,119 +0,0 @@-> {-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction, TypeApplications #-}--This is the classical example of using sigmoid NN to approximate Xor.--> module Xor where-> import DBI hiding (return)-> import qualified Poly as YouShouldAlreadyReadThis-> import qualified Prelude as P-> import Prelude (Double, IO, return, ($), print, undefined, Int, (<=), (<), (+), (-), (*), (/), fromIntegral, putStr)-> import Util-> import System.Random-> import Control.Monad (when)-> import Data.Proxy-> import Data.Constraint-> import Lang--Recall in poly, we constructed a function Double -> Double,-with argument being the weight, and do gradient descend to found a solution.--However, most of the time, there wil be more than one weight (or no weight at all).-Also, when we are composing a Neural Network to approximate a value, we dont really care how much weight it use.-So, we use existential type to hide the actual weight.--data ImpW repr h x = forall w. Weight w => ImpW (repr h (w -> x))--ImpW stands for implicit weights.-The existential w is weight, and a Neural Network of type x is just a function from w to x!-We require that the weight can be constructed randomly, so we have random initialization.-Weight also form a Vector so we can combine weights (update it), scale it (to control the learning rate).--Let's start by constructing a weight.--> weight :: Lang repr => ImpW repr h Double-> weight = ImpW id--Note that we are just manipulating AST.-If you wanna do weight sharing, you need to use let(in DDF) yourself.--Obviously, we just need to take the implicit argument.--We have the weight, now we need the activation function, sigmoid.--> sigmoid = lam $ \x -> recip1 (plus2 doubleOne (doubleExp1 (invert1 x)))-> sigmoid1 = app sigmoid--With weight and sigmoid we can construct a neuron of type ((Double, Double) -> Double)-The weight should be a pair of Double, each as a scale on the actual input, with a bias.-We then add the two scaled input, with the bias, and pass them into sigmoid.--> scaleAdd :: Lang repr => ImpW repr h ((Double, Double) -> Double)-> scaleAdd = ImpW $ lam2 $ \w p -> plus2 (mult2 (zro1 w) (zro1 p)) (plus2 (fst1 w) (fst1 p))--> withBias :: Lang repr => ImpW repr h (Double -> Double)-> withBias = ImpW $ plus--> neuron :: Lang repr => ImpW repr h ((Double, Double) -> Double)-> neuron = com2 (com2 sigmoid withBias) scaleAdd-> neuron1 = app neuron--Now, the hidden layer of type (Double, Double) -> ((Double, Double), (Double, Double))--> hidden = lam $ \p -> mkProd2 (mkProd2 (neuron1 p) (neuron1 p)) (mkProd2 (neuron1 p) (neuron1 p))--And finally, the whole NN:--> type XOR = (Double, Double) -> Double-> xor :: Lang repr => ImpW repr h XOR-> xor = neuron `com2` (bimap2 scaleAdd scaleAdd) `com2` hidden--But before we can train it, we need to define the dataset and the loss function.--> l2 :: Lang repr => repr h (Double -> Double -> Double)-> l2 = lam2 $ \l r -> (mult2 (minus2 l r) (minus2 l r))-> l22 = app2 l2--> eval :: Lang repr => repr h (XOR -> ((Double, Double), Double) -> Double)-> eval = lam2 $ \xor p -> l22 (app xor (zro1 p)) (fst1 p)--> dataset :: Lang repr => repr h [((Double, Double), Double)]-> dataset = cons2 (build 0 0 0) (cons2 (build 0 1 1) (cons2 (build 1 0 1) (cons2 (build 1 1 0) nil)))->   where build l r ret = mkProd2 (mkProd2 (double l) (double r)) (double ret)--However, unlike Poly, there are more than one datapoint, so we need to use a list, and map xor onto it.--> loss :: Lang repr => repr h (XOR -> Double)-> loss = lam $ \xor -> fix2 (lam $ \self -> listMatch2 doubleZero (lam2 $ \x xs -> plus2 x (app self xs))) (map2 (app eval xor) dataset)--Let's try to print the thing.--> main :: IO ()-> main = case runImpW $ noEnv xor of RunImpW xor -> inner xor->   where->     inner :: forall w. Weight w => Combine Show (GWDiff Eval) () (w -> (Double, Double) -> Double) -> IO ()->     inner (Combine xorS xorE) = do->       print $ runShow xorS vars 0--now you will see a list of gibberish-->       initWeight :: w <- ((randomRIO (randRange (-0.01, 0.01)) \\ weightCon @w @Random) \\ weightCon @w @RandRange)--Getting random weights...-->       (go (diff xorE) initWeight (runEval selfWithDiff () \\ weightCon @w @(WithDiff Eval)) (diff loss)->           ((runEval (lam3 $ \d o n -> minus2 o (mult2 d n)) ()) \\ weightCon @w @(Vector Eval)) 0) \\ weightCon @w @P.Show->         where->           diff :: GWDiff Eval () x -> Diff w x->           diff x = (runEval (runGWDiff x (Proxy :: Proxy w)) ()) \\ weightCon @w @(Vector Eval)->     go :: P.Show w => (Diff w (w -> XOR)) -> w -> (w -> Diff w w) -> (Diff w (XOR -> Double)) -> (Double -> w -> w -> w) -> Int -> IO ()->     go xor weight reify loss update i | i <= 2500 = do->       when (isSquare i) $ do->         print weight->         print lossVal->         putStr "\n"->       go xor (update 0.3 weight lossDiff) reify loss update (1 + i)->       where->         (lossVal, lossDiff) = loss $ xor (reify weight)->     go _ _ _ _ _ _ = return ()--And the main loop. Basically we take the derivative of stuff, eval them, and use the derivative of loss to update the weights.
+ test/TestPoly.hs view
@@ -0,0 +1,11 @@+module Main where++import Poly hiding (main)+import Control.Monad+import System.Exit (exitFailure)++main :: IO ()+main = do+  x <- solve (const $ return ()) (const . const $ return ())+  unless (x - 4 < 0.1) exitFailure+  return ()
+ test/TestXor.hs view
@@ -0,0 +1,19 @@+module Main where++import Poly hiding (main)+import Xor hiding (main)+import Control.Monad+import System.Exit (exitFailure)+import System.Random++main :: IO ()+main = do+  g <- getStdGen+  xor <- findXor g (const $ return ()) (const . const . const $ return ())+  let doXor :: Double -> Double -> Double -> IO ()+      doXor l r ret = unless (xor (l, r) - ret < 0.2) exitFailure+  doXor 0 0 0+  doXor 0 1 1+  doXor 1 0 1+  doXor 1 1 0+  return ()