diff --git a/DDF/Bool.hs b/DDF/Bool.hs new file mode 100644 --- /dev/null +++ b/DDF/Bool.hs @@ -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) diff --git a/DDF/Combine.hs b/DDF/Combine.hs new file mode 100644 --- /dev/null +++ b/DDF/Combine.hs @@ -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 diff --git a/DDF/DBI.hs b/DDF/DBI.hs new file mode 100644 --- /dev/null +++ b/DDF/DBI.hs @@ -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 diff --git a/DDF/Eval.hs b/DDF/Eval.hs new file mode 100644 --- /dev/null +++ b/DDF/Eval.hs @@ -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 diff --git a/DDF/GWDiff.hs b/DDF/GWDiff.hs new file mode 100644 --- /dev/null +++ b/DDF/GWDiff.hs @@ -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 diff --git a/DDF/ImportMeta.hs b/DDF/ImportMeta.hs new file mode 100644 --- /dev/null +++ b/DDF/ImportMeta.hs @@ -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) diff --git a/DDF/Lang.hs b/DDF/Lang.hs new file mode 100644 --- /dev/null +++ b/DDF/Lang.hs @@ -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 diff --git a/DDF/Poly.lhs b/DDF/Poly.lhs new file mode 100644 --- /dev/null +++ b/DDF/Poly.lhs @@ -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 diff --git a/DDF/Show.hs b/DDF/Show.hs new file mode 100644 --- /dev/null +++ b/DDF/Show.hs @@ -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" diff --git a/DDF/UnHOAS.hs b/DDF/UnHOAS.hs new file mode 100644 --- /dev/null +++ b/DDF/UnHOAS.hs @@ -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 diff --git a/DDF/Util.hs b/DDF/Util.hs new file mode 100644 --- /dev/null +++ b/DDF/Util.hs @@ -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) diff --git a/DDF/Xor.lhs b/DDF/Xor.lhs new file mode 100644 --- /dev/null +++ b/DDF/Xor.lhs @@ -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 () diff --git a/DeepDarkFantasy.cabal b/DeepDarkFantasy.cabal --- a/DeepDarkFantasy.cabal +++ b/DeepDarkFantasy.cabal @@ -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 diff --git a/lib/DBI.hs b/lib/DBI.hs deleted file mode 100644 --- a/lib/DBI.hs +++ /dev/null @@ -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) diff --git a/lib/Lang.hs b/lib/Lang.hs deleted file mode 100644 --- a/lib/Lang.hs +++ /dev/null @@ -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) diff --git a/lib/Poly.lhs b/lib/Poly.lhs deleted file mode 100644 --- a/lib/Poly.lhs +++ /dev/null @@ -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 diff --git a/lib/Util.hs b/lib/Util.hs deleted file mode 100644 --- a/lib/Util.hs +++ /dev/null @@ -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) diff --git a/lib/Xor.lhs b/lib/Xor.lhs deleted file mode 100644 --- a/lib/Xor.lhs +++ /dev/null @@ -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 () diff --git a/test/TestPoly.hs b/test/TestPoly.hs --- a/test/TestPoly.hs +++ b/test/TestPoly.hs @@ -1,6 +1,6 @@ module Main where -import Poly hiding (main) +import DDF.Poly hiding (main) import Control.Monad import System.Exit (exitFailure) diff --git a/test/TestXor.hs b/test/TestXor.hs --- a/test/TestXor.hs +++ b/test/TestXor.hs @@ -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