DeepDarkFantasy 0.2017.3.30 → 0.2017.4.1

raw patch · 20 files changed

+1265/−1083 lines, 20 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DDF/Bool.hs +9/−0
• DDF/Combine.hs +57/−0
• DDF/DBI.hs +185/−0
• DDF/Eval.hs +72/−0
• DDF/GWDiff.hs +70/−0
• DDF/ImportMeta.hs +6/−0
• DDF/Lang.hs +442/−0
• DDF/Poly.lhs +108/−0
• DDF/Show.hs +74/−0
• DDF/UnHOAS.hs +55/−0
• DDF/Util.hs +43/−0
• DDF/Xor.lhs +129/−0
• DeepDarkFantasy.cabal +13/−7
• lib/DBI.hs +0/−246
• lib/Lang.hs +0/−587
• lib/Poly.lhs +0/−107
• lib/Util.hs +0/−6
• lib/Xor.lhs +0/−127
• test/TestPoly.hs +1/−1
• test/TestXor.hs +1/−2

@@ -0,0 +1,9 @@+{-# LANGUAGE NoImplicitPrelude #-}+module DDF.Bool (module DDF.Bool, module DDF.DBI) where++import DDF.DBI+import qualified Prelude as M++class DBI r => Bool r where+  bool :: M.Bool -> r h M.Bool+  ite :: r h (a -> a -> M.Bool -> a)

@@ -0,0 +1,57 @@+{-# LANGUAGE NoImplicitPrelude #-}++module DDF.Combine where++import DDF.Lang+import DDF.ImportMeta++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)++instance (Bool l, Bool r) => Bool (Combine l r) where+  bool x = Combine (bool x) (bool x)+  ite = Combine ite ite++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+  state = Combine state state+  runState = Combine runState runState

@@ -0,0 +1,185 @@+{-# LANGUAGE
+    MultiParamTypeClasses,
+    RankNTypes,
+    ScopedTypeVariables,
+    FlexibleInstances,
+    FlexibleContexts,
+    UndecidableInstances,
+    PolyKinds,
+    LambdaCase,
+    NoMonomorphismRestriction,
+    TypeFamilies,
+    LiberalTypeSynonyms,
+    FunctionalDependencies,
+    ExistentialQuantification,
+    InstanceSigs,
+    ConstraintKinds,
+    DefaultSignatures,
+    TypeOperators,
+    TypeApplications,
+    PartialTypeSignatures #-}
+
+module DDF.DBI (module DDF.DBI, module DDF.ImportMeta) where
+import qualified Prelude as P
+import DDF.Util
+import Control.Monad (when)
+import System.Random
+import Data.Proxy
+import Data.Constraint
+import Data.Constraint.Forall
+import DDF.ImportMeta
+
+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)
+
+class DBI repr => ConvDiff repr w where
+  toDiff :: forall h x. Monoid repr x => Proxy x -> repr h (w -> Diff x w)
+  toDiff _ = toDiffBy1 @repr @w @x zero
+  toDiffBy :: forall h x. repr h (x -> w -> Diff x w)
+  fromDiff :: forall h x. Monoid repr x => Proxy x -> repr h (Diff x w -> w)
+  fromDiff _ = fromDiffBy1 @repr @w @x zero
+  fromDiffBy :: repr h (x -> Diff x w -> w)
+
+withDiff1 = app withDiff
+toDiffBy1 :: forall repr w x h. ConvDiff repr w => repr h x -> repr h (w -> Diff x w)
+toDiffBy1 = app toDiffBy
+fromDiffBy1 :: forall repr w x h. ConvDiff repr w => repr h x -> repr h (Diff x w -> w)
+fromDiffBy1 = app fromDiffBy
+
+selfWithDiff :: (DBI repr, WithDiff repr w) => repr h (w -> Diff w w)
+selfWithDiff = withDiff1 id
+
+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
+bimap3 = app3 bimap
+flip1 = app flip
+flip2 = app2 flip
+let_2 = app2 let_
+
+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
+
+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 (l, r) = (Diff v l, Diff v r)
+type instance Diff v (l -> r) = Diff v l -> Diff v r
+
+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
+
+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.Float, 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.Float, 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

@@ -0,0 +1,72 @@+{-# LANGUAGE NoImplicitPrelude,+  LambdaCase #-}++module DDF.Eval where++import DDF.ImportMeta+import DDF.Lang+import qualified Prelude as M+import qualified Control.Monad.Writer as M+import qualified Control.Monad.State as M+import qualified GHC.Float as M+import qualified Data.Functor.Identity as M+import qualified Data.Bool as M++newtype Eval h x = Eval {runEval :: h -> x}++comb = Eval . M.const++instance DBI Eval where+  z = Eval M.fst+  s (Eval a) = Eval $ a . M.snd+  abs (Eval f) = Eval $ \a h -> f (h, a)+  app (Eval f) (Eval x) = Eval $ \h -> f h $ x h++instance Bool Eval where+  bool = comb+  ite = comb M.bool++instance Lang Eval where+  zro = comb M.fst+  fst = comb M.snd+  mkProd = comb (,)+  double = comb+  doublePlus = comb (+)+  doubleMinus = comb (-)+  doubleMult = comb (*)+  doubleDivide = comb (/)+  fix = comb loop+    where loop x = x $ loop x+  left = comb M.Left+  right = comb M.Right+  sumMatch = comb $ \l r -> \case+                             M.Left x -> l x+                             M.Right x -> r x+  unit = comb ()+  exfalso = comb absurd+  nothing = comb M.Nothing+  just = comb M.Just+  ioRet = comb M.return+  ioBind = comb (>>=)+  nil = comb []+  cons = comb (:)+  listMatch = comb $ \l r -> \case+                            [] -> l+                            x:xs -> r x xs+  optionMatch = comb $ \l r -> \case+                              M.Nothing -> l+                              M.Just x -> r x+  ioMap = comb M.fmap+  writer = comb (M.WriterT . M.Identity)+  runWriter = comb M.runWriter+  doubleExp = comb M.exp+  float = comb+  floatPlus = comb (+)+  floatMinus = comb (-)+  floatMult = comb (*)+  floatDivide = comb (/)+  floatExp = comb M.exp+  float2Double = comb M.float2Double+  double2Float = comb M.double2Float+  state = comb M.state+  runState = comb M.runState

@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude, RankNTypes #-}++module DDF.GWDiff where+import DDF.Lang+import qualified Prelude as M+import Data.Proxy++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 (M.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)++instance Bool r => Bool (GWDiff r) where+  bool x = GWDiff $ M.const $ bool x+  ite = GWDiff $ M.const ite++instance Lang repr => Lang (GWDiff repr) where+  mkProd = GWDiff (M.const mkProd)+  zro = GWDiff $ M.const zro+  fst = GWDiff $ M.const fst+  double x = GWDiff $ M.const $ mkProd2 (double x) zero+  doublePlus = GWDiff $ M.const $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  doubleMinus = GWDiff $ M.const $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  doubleMult = GWDiff $ M.const $ lam2 $ \l r ->+    mkProd2 (mult2 (zro1 l) (zro1 r))+      (plus2 (mult2 (zro1 l) (fst1 r)) (mult2 (zro1 r) (fst1 l)))+  doubleDivide = GWDiff $ M.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 $ M.const $ lam $ \x -> mkProd2 (doubleExp1 (zro1 x)) (mult2 (doubleExp1 (zro1 x)) (fst1 x))+  fix = GWDiff $ M.const fix+  left = GWDiff $ M.const left+  right = GWDiff $ M.const right+  sumMatch = GWDiff $ M.const sumMatch+  unit = GWDiff $ M.const unit+  exfalso = GWDiff $ M.const exfalso+  nothing = GWDiff $ M.const nothing+  just = GWDiff $ M.const just+  ioRet = GWDiff $ M.const ioRet+  ioBind = GWDiff $ M.const ioBind+  nil = GWDiff $ M.const nil+  cons = GWDiff $ M.const cons+  listMatch = GWDiff $ M.const listMatch+  optionMatch = GWDiff $ M.const optionMatch+  ioMap = GWDiff $ M.const ioMap+  writer = GWDiff $ M.const writer+  runWriter = GWDiff $ M.const runWriter+  float x = GWDiff $ M.const $ mkProd2 (float x) zero+  floatPlus = GWDiff $ M.const $ lam2 $ \l r ->+    mkProd2 (plus2 (zro1 l) (zro1 r)) (plus2 (fst1 l) (fst1 r))+  floatMinus = GWDiff $ M.const $ lam2 $ \l r ->+    mkProd2 (minus2 (zro1 l) (zro1 r)) (minus2 (fst1 l) (fst1 r))+  floatMult = GWDiff $ M.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 $ M.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 $ M.const $ lam $ \x -> mkProd2 (floatExp1 (zro1 x)) (mult2 (float2Double1 (floatExp1 (zro1 x))) (fst1 x))+  float2Double = GWDiff $ M.const $ bimap2 float2Double id+  double2Float = GWDiff $ M.const $ bimap2 double2Float id+  state = GWDiff $ M.const state+  runState = GWDiff $ M.const runState

@@ -0,0 +1,6 @@+{-# LANGUAGE NoImplicitPrelude #-}++module DDF.ImportMeta (module Prelude, module Data.Void) where++import Prelude (($), show, (+), (-), (*), (/), (.), (++), (>>=), Double, IO, Int, (<=), print)+import Data.Void (absurd)

@@ -0,0 +1,442 @@+{-# LANGUAGE+    MultiParamTypeClasses,+    RankNTypes,+    ScopedTypeVariables,+    FlexibleInstances,+    FlexibleContexts,+    UndecidableInstances,+    PolyKinds,+    LambdaCase,+    NoMonomorphismRestriction,+    TypeFamilies,+    LiberalTypeSynonyms,+    FunctionalDependencies,+    ExistentialQuantification,+    InstanceSigs,+    TupleSections,+    ConstraintKinds,+    DefaultSignatures,+    TypeOperators,+    TypeApplications,+    PartialTypeSignatures #-}++module DDF.Lang (module DDF.Lang, module DDF.Bool) where+import DDF.DBI+import qualified Prelude as P+import Prelude (($), (.), (+), (-), (++), show, (>>=), (*), (/), Double, Either, IO, Maybe)+import qualified Control.Monad.Writer as P+import Control.Monad.Writer (Writer, WriterT)+import qualified Control.Monad.State as P+import Control.Monad.State (State)+import qualified GHC.Float as P+import GHC.Float (Float)+import qualified Data.Tuple as P+import Data.Void+import Data.Proxy+import Data.Proxy+import Data.Constraint+import Data.Constraint.Forall+import qualified Data.Bool as P+import DDF.Bool++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 (Writer l r) = Writer (Diff v l) (Diff v r)+type instance Diff v (IO l) = IO (Diff v l)+type instance Diff v (Maybe l) = Maybe (Diff v l)+type instance Diff v [l] = [Diff v l]+type instance Diff v (Either l r) = Either (Diff v l) (Diff v r)+type instance Diff v (State l r) = State (Diff v l) (Diff v r)+type instance Diff v P.Bool = P.Bool++class Bool 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)+  undefined :: repr h a+  undefined = fix1 id+  state :: repr h ((l -> (r, l)) -> State l r)+  runState :: repr h (State l r -> (l -> (r, l)))++instance Lang repr => ConvDiff repr () where+  toDiffBy = const1 id+  fromDiffBy = const1 id++instance Lang repr => ConvDiff repr Double where+  toDiffBy = flip1 mkProd+  fromDiffBy = const1 zro++instance Lang repr => ConvDiff repr Float where+  toDiffBy = flip1 mkProd+  fromDiffBy = const1 zro++instance (Lang repr, ConvDiff repr l, ConvDiff repr r) => ConvDiff repr (l, r) where+  toDiffBy = lam $ \x -> bimap2 (toDiffBy1 x) (toDiffBy1 x)+  fromDiffBy = lam $ \x -> bimap2 (fromDiffBy1 x) (fromDiffBy1 x)++instance (Lang repr, ConvDiff repr l, ConvDiff repr r) => ConvDiff repr (Either l r) where+  toDiffBy = lam $ \x -> bimap2 (toDiffBy1 x) (toDiffBy1 x)+  fromDiffBy = lam $ \x -> bimap2 (fromDiffBy1 x) (fromDiffBy1 x)++instance (Lang repr, ConvDiff repr l, ConvDiff repr r) => ConvDiff repr (l -> r) where+  toDiffBy = lam2 $ \x f -> (toDiffBy1 x) `com2` f `com2` (fromDiffBy1 x)+  fromDiffBy = lam2 $ \x f -> (fromDiffBy1 x) `com2` f `com2` (toDiffBy1 x)++instance (Lang repr, ConvDiff repr l) => ConvDiff repr [l] where+  toDiffBy = lam $ \x -> map1 (toDiffBy1 x)+  fromDiffBy = lam $ \x -> map1 (fromDiffBy1 x)++class Reify repr x where+  reify :: x -> repr h x++instance Lang repr => Reify repr () where+  reify _ = unit++instance Lang repr => Reify repr 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 (Bool r, Vector r v) => Bool (WDiff r v) where+  bool = WDiff . bool+  ite = WDiff ite++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+  state = WDiff state+  runState = WDiff runState++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+  state = NoImpW state+  runState = NoImpW runState++instance Lang r => Bool (ImpW r) where+  bool = NoImpW . bool+  ite = NoImpW ite++instance Lang repr => WithDiff repr () where+  withDiff = const1 id++instance Lang repr => WithDiff repr Double where+  withDiff = lam2 $ \conv d -> mkProd2 d (app conv doubleOne)++instance Lang repr => WithDiff repr P.Float where+  withDiff = lam2 $ \conv d -> mkProd2 d (app conv floatOne)++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 (Double -> v -> v)+  divide :: r h (v -> Double -> v)+  default mult :: Lang r => r h (Double -> v -> v)+  mult = lam2 $ \x y -> divide2 y (recip1 x)+  default divide :: Lang r => r h (v -> 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 Double where+  zero = doubleZero+  plus = doublePlus++instance Lang r => Group r Double where+  minus = doubleMinus++instance Lang r => Vector r 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 v) => Monoid repr (Double -> v) where+  zero = const1 zero+  plus = lam3 $ \l r x -> plus2 (app l x) (app r x)++instance (Lang repr, Group repr v) => Group repr (Double -> v) where+  invert = lam2 $ \l x -> app l (invert1 x)++instance (Lang repr, Vector repr v) => Vector repr (Double -> v) 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 Either where+  bimap = lam2 $ \l r -> sumMatch2 (com2 left l) (com2 right r)++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 (Writer w) where+  map = lam $ \f -> com2 writer (com2 (bimap2 f id) runWriter)++instance (Lang r, Monoid r w) => Applicative r (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 (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 (State l) where+  map = lam2 $ \f s -> state1 (com2 (bimap2 f id) (runState1 s))++instance Lang r => Applicative r (State l) where+  pure = lam $ \x -> state1 (mkProd1 x)+  ap = lam2 $ \f x -> state1 $ lam $ \s -> let_2 (runState2 f s) (lam $ \p -> bimap3 (zro1 p) id (runState2 x (fst1 p)))++instance Lang r => Monad r (State l) where+  join = lam $ \x -> state1 $ lam $ \s -> let_2 (runState2 x s) (uncurry1 runState)++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))++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)++++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+sumMatch2 = app2 sumMatch+state1 = app state+runState1 = app runState+runState2 = app2 runState

@@ -0,0 +1,108 @@+> {-# LANGUAGE
+>     MultiParamTypeClasses,
+>     RankNTypes,
+>     ScopedTypeVariables,
+>     FlexibleInstances,
+>     FlexibleContexts,
+>     UndecidableInstances,
+>     IncoherentInstances,
+>     PolyKinds,
+>     LambdaCase,
+>     NoMonomorphismRestriction,
+>     TypeFamilies,
+>     LiberalTypeSynonyms,
+>     EmptyCase #-}
+
+> module DDF.Poly where
+> import Control.Monad (when)
+> import DDF.Util
+> import DDF.Lang
+> import DDF.Show
+> import DDF.Eval
+> import qualified Control.Monad as M
+
+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. M.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 = M.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)
+>   M.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

@@ -0,0 +1,74 @@+{-# LANGUAGE NoImplicitPrelude #-}++module DDF.Show (module DDF.Show) where++import DDF.Lang+import qualified Prelude as M+import DDF.ImportMeta++data AST = Leaf M.String | App M.String AST [AST] | Lam M.String [M.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 M.Show AST where+  show (Leaf f) = f+  show (App f x l) = "(" ++ f ++ " " ++ show x ++ M.concatMap ((" " ++) . show) l ++ ")"+  show (Lam s l t) = "(\\" ++ s ++ M.concatMap (" " ++) l ++ " -> " ++ show t ++ ")"++newtype Show h a = Show {runShow :: [M.String] -> M.Int -> AST}+name = Show . M.const . M.const . Leaf++instance DBI Show where+  z = Show $ M.const $ Leaf . show . M.flip (-) 1+  s (Show v) = Show $ \vars -> v vars . M.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 $ M.const $ M.const $ Leaf v) vars (h + 1))++instance Bool Show where+  bool = name . show+  ite = name "ite"++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"+  state = name "state"+  runState = name "runState"

@@ -0,0 +1,55 @@+{-# LANGUAGE NoImplicitPrelude #-}++module DDF.UnHOAS where++import DDF.Lang++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 Bool r => Bool (UnHOAS r) where+  bool = UnHOAS . bool+  ite = UnHOAS ite++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+  state = UnHOAS state+  runState = UnHOAS runState

@@ -0,0 +1,43 @@+{-# LANGUAGE TupleSections #-}
+
+module DDF.Util where
+
+import System.Random
+import GHC.Float
+
+vars = [pre : suf | suf <- "":map show [0..], pre <- ['a'..'z']]
+
+isSquare n = sq * sq == n
+  where sq = floor $ sqrt (fromIntegral n::Double)
+
+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 RandRange w where
+  randRange :: (Double, Double) -> (w, w)
+
+instance RandRange () where
+  randRange _ = ((), ())
+
+instance RandRange Double where
+  randRange (lo, hi) = (lo, hi)
+
+instance RandRange Float where
+  randRange (lo, hi) = (double2Float lo, double2Float 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)

@@ -0,0 +1,129 @@+> {-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction, TypeApplications, RankNTypes #-}++This is the classical example of using sigmoid NN to approximate Xor.++> module DDF.Xor where+> import qualified DDF.Poly as YouShouldAlreadyReadThis+> import qualified Prelude as M+> import System.Random+> import Control.Monad (when)+> import Data.Proxy+> import Data.Constraint+> import DDF.Util+> import DDF.Lang+> import DDF.Show+> import DDF.Combine+> import DDF.Eval+> import DDF.GWDiff++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, M.Monad m) => g -> (AST -> m ()) -> (Int -> Double -> M.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 = M.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 @M.Show+>     where+>       diff :: GWDiff Eval () x -> Diff w x+>       diff x = (runEval (runGWDiff x (Proxy :: Proxy w)) ()) \\ weightCon @w @(Vector Eval)+>       go :: M.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 (M.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 = M.return $ orig weight++> main :: IO ()+> main = do+>   g <- getStdGen+>   xor <- findXor g print (\i d w -> when (isSquare i) $ do+>     print d+>     M.putStrLn w+>     M.putStrLn "")+>   let doXor :: Double -> Double -> IO ()+>       doXor l r = M.putStrLn $ M.show l ++ " xor " ++ M.show r ++ " is " ++ (M.show $ xor (l, r))+>   doXor 0 0+>   doXor 0 1+>   doXor 1 0+>   doXor 1 1+>   M.return ()

@@ -1,5 +1,5 @@ name: DeepDarkFantasy-version: 0.2017.3.30+version: 0.2017.4.1 cabal-version: 1.12 build-type: Simple license: Apache@@ -16,17 +16,23 @@  library   exposed-modules:-    DBI-    Poly-    Xor-    Util-    Lang+    DDF.Bool+    DDF.Combine+    DDF.DBI+    DDF.Eval+    DDF.GWDiff+    DDF.ImportMeta+    DDF.Lang+    DDF.Poly+    DDF.Show+    DDF.UnHOAS+    DDF.Util+    DDF.Xor   build-depends:     base >= 4.9.0.0 && <= 4.9.1.0,     mtl -any,     random -any,     constraints -any -  hs-source-dirs: lib   ghc-options: -ferror-spans    default-language: Haskell2010 

@@ -1,246 +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
-  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)

@@ -1,587 +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--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)

@@ -1,107 +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
-> 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

@@ -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)

@@ -1,127 +0,0 @@-> {-# 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 ()

@@ -1,6 +1,6 @@ module Main where -import Poly hiding (main)+import DDF.Poly hiding (main) import Control.Monad import System.Exit (exitFailure) 

@@ -1,7 +1,6 @@ module Main where -import Poly hiding (main)-import Xor hiding (main)+import DDF.Xor hiding (main) import Control.Monad import System.Exit (exitFailure) import System.Random