DeepDarkFantasy 0.2017.8.18 → 0.2017.8.19

raw patch · 25 files changed

+402/−302 lines, 25 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• DDF/Bimap.hs +11/−6
• DDF/Diff.hs +36/−38
• DDF/Double.hs +10/−6
• DDF/Eval.hs +30/−21
• DDF/IO.hs +27/−2
• DDF/ImpW.hs +9/−13
• DDF/ImportMeta.hs +1/−3
• DDF/Int.hs +15/−6
• DDF/Lang.hs +26/−21
• DDF/Map.hs +8/−10
• DDF/Meta/Diff.hs +4/−0
• DDF/Meta/Util.hs +44/−0
• DDF/Ordering.hs +46/−12
• DDF/PE.hs +53/−50
• DDF/Prod.hs +18/−7
• DDF/Sam/Poly.lhs +1/−1
• DDF/Sam/Xor.lhs +1/−1
• DDF/Show.hs +11/−12
• DDF/Size.hs +8/−13
• DDF/TermGen.hs +15/−20
• DDF/UnHOAS.hs +11/−3
• DDF/UnLiftEnv.hs +8/−13
• DDF/Util.hs +0/−41
• DDF/VectorTF.hs +7/−1
• DeepDarkFantasy.cabal +2/−2

@@ -1,4 +1,8 @@-{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-}+{-# LANGUAGE+  NoImplicitPrelude,+  NoMonomorphismRestriction,+  UndecidableSuperClasses+#-}  module DDF.Bimap (module DDF.Bimap, module DDF.Prod, module DDF.Option) where @@ -9,18 +13,19 @@ import qualified Data.Bimap as M import qualified Prelude as M import qualified Data.Map as M+import DDF.Meta.Diff  class (Int r, Map.Map r) => Bimap r where   size :: r h (M.Bimap a b -> M.Int)-  lookupL :: (Map.Ord a, Map.Ord b) => r h (M.Bimap a b -> a -> Maybe b)-  lookupR :: (Map.Ord a, Map.Ord b) => r h (M.Bimap a b -> b -> Maybe a)+  lookupL :: (MetaOrd  a, MetaOrd b) => r h (M.Bimap a b -> a -> Maybe b)+  lookupR :: (MetaOrd a, MetaOrd b) => r h (M.Bimap a b -> b -> Maybe a)   empty :: r h (M.Bimap a b)   singleton :: r h ((a, b) -> M.Bimap a b)   toMapL :: r h (M.Bimap a b -> M.Map a b)   toMapR :: r h (M.Bimap a b -> M.Map b a)-  insert :: (Map.Ord a, Map.Ord b) => r h ((a, b) -> M.Bimap a b -> M.Bimap a b) -  updateL :: (Map.Ord a, Map.Ord b) => r h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b)-  updateR :: (Map.Ord a, Map.Ord b) => r h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b)+  insert :: (MetaOrd a, MetaOrd b) => r h ((a, b) -> M.Bimap a b -> M.Bimap a b) +  updateL :: (MetaOrd a, MetaOrd b) => r h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b)+  updateR :: (MetaOrd a, MetaOrd b) => r h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b)  lookupL2 = app2 lookupL size1 = app size

@@ -9,7 +9,9 @@   TypeFamilies,   MultiParamTypeClasses,   TypeOperators,-  DataKinds+  DataKinds,+  FlexibleInstances,+  UndecidableSuperClasses #-}  module DDF.Diff where@@ -68,7 +70,7 @@       (divide2 (minus2 (mult2 (dualOrig1 r) (dualDiff1 l)) (mult2 (dualOrig1 l) (dualDiff1 r)))         (mult2 (dualOrig1 r) (dualOrig1 r)))   doubleExp = Diff $ lam $ \x -> let_2 (doubleExp1 (dualOrig1 x)) (lam $ \e -> mkDual2 e (mult2 e (dualDiff1 x)))-  doubleEq = Diff $ lam2 $ \l r -> doubleEq2 (dualOrig1 l) (dualOrig1 r)+  doubleCmp = Diff $ lam2 $ \l r -> cmp2 (dualOrig1 l) (dualOrig1 r)  type instance DiffType v M.Float = M.Dual M.Float v instance (Vector r v, Lang r) => Float (Diff r v) where@@ -96,31 +98,31 @@ instance Map.Map r => Map.Map (Diff r v) where   empty = Diff Map.empty   singleton = Diff Map.singleton-  lookup :: forall h k a. Map.Ord k => Diff r v h (M.Map k a -> k -> Maybe a)-  lookup = withDict (Map.diffOrd (Proxy :: Proxy (v, k))) (Diff Map.lookup)-  alter :: forall h k a. Map.Ord k => Diff r v h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a)-  alter = withDict (Map.diffOrd (Proxy :: Proxy (v, k))) (Diff Map.alter)+  lookup :: forall h k a. MetaOrd k => Diff r v h (M.Map k a -> k -> Maybe a)+  lookup = withDict (diffOrd (Proxy :: Proxy (v, k))) (Diff Map.lookup)+  alter :: forall h k a. MetaOrd k => Diff r v h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a)+  alter = withDict (diffOrd (Proxy :: Proxy (v, k))) (Diff Map.alter)   mapMap = Diff Map.mapMap-  unionWith :: forall h k a. Map.Ord k => Diff r v h ((a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a)-  unionWith = withDict (Map.diffOrd (Proxy :: Proxy (v, k))) (Diff Map.unionWith)+  unionWith :: forall h k a. MetaOrd k => Diff r v h ((a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a)+  unionWith = withDict (diffOrd (Proxy :: Proxy (v, k))) (Diff Map.unionWith)  type instance DiffType v (M.Bimap a b) = M.Bimap (DiffType v a) (DiffType v b) instance Bimap r => Bimap (Diff r v) where   size = Diff size   toMapL = Diff toMapL   toMapR = Diff toMapR-  lookupL :: forall h a b. (Map.Ord a, Map.Ord b) => Diff r v h (M.Bimap a b -> a -> Maybe b)-  lookupL = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) (withDict (Map.diffOrd (Proxy :: Proxy (v, b))) (Diff lookupL))-  lookupR :: forall h a b. (Map.Ord a, Map.Ord b) => Diff r v h (M.Bimap a b -> b -> Maybe a)-  lookupR = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) (withDict (Map.diffOrd (Proxy :: Proxy (v, b))) (Diff lookupR))+  lookupL :: forall h a b. (MetaOrd a, MetaOrd b) => Diff r v h (M.Bimap a b -> a -> Maybe b)+  lookupL = withDict (diffOrd (Proxy :: Proxy (v, a))) (withDict (diffOrd (Proxy :: Proxy (v, b))) (Diff lookupL))+  lookupR :: forall h a b. (MetaOrd a, MetaOrd b) => Diff r v h (M.Bimap a b -> b -> Maybe a)+  lookupR = withDict (diffOrd (Proxy :: Proxy (v, a))) (withDict (diffOrd (Proxy :: Proxy (v, b))) (Diff lookupR))   empty = Diff empty   singleton = Diff singleton-  insert :: forall h a b. (Map.Ord a, Map.Ord b) => Diff r v h ((a, b) -> M.Bimap a b -> M.Bimap a b)-  insert = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) (withDict (Map.diffOrd (Proxy :: Proxy (v, b))) (Diff insert))-  updateL :: forall h a b. (Map.Ord a, Map.Ord b) => Diff r v h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b)-  updateL = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) (withDict (Map.diffOrd (Proxy :: Proxy (v, b))) (Diff updateL))-  updateR :: forall h a b. (Map.Ord a, Map.Ord b) => Diff r v h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b)-  updateR = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) (withDict (Map.diffOrd (Proxy :: Proxy (v, b))) (Diff updateR))+  insert :: forall h a b. (MetaOrd a, MetaOrd b) => Diff r v h ((a, b) -> M.Bimap a b -> M.Bimap a b)+  insert = withDict (diffOrd (Proxy :: Proxy (v, a))) (withDict (diffOrd (Proxy :: Proxy (v, b))) (Diff insert))+  updateL :: forall h a b. (MetaOrd a, MetaOrd b) => Diff r v h ((b -> Maybe b) -> a -> M.Bimap a b -> M.Bimap a b)+  updateL = withDict (diffOrd (Proxy :: Proxy (v, a))) (withDict (diffOrd (Proxy :: Proxy (v, b))) (Diff updateL))+  updateR :: forall h a b. (MetaOrd a, MetaOrd b) => Diff r v h ((a -> Maybe a) -> b -> M.Bimap a b -> M.Bimap a b)+  updateR = withDict (diffOrd (Proxy :: Proxy (v, a))) (withDict (diffOrd (Proxy :: Proxy (v, b))) (Diff updateR))  type instance DiffType v () = () instance Unit r => Unit (Diff r v) where@@ -135,7 +137,7 @@ instance Int r => Int (Diff r v) where   int = Diff . int   pred = Diff pred-  isZero = Diff isZero+  intCmp = Diff intCmp  instance Y r => Y (Diff r v) where   y = Diff y@@ -143,6 +145,11 @@ type instance DiffType v (M.IO l) = M.IO (DiffType v l) instance IO r => IO (Diff r v) where   putStrLn = Diff putStrLn+  ioMap = Diff ioMap+  ioPure = Diff ioPure+  ioAP = Diff ioAP+  ioBind = Diff ioBind+  ioJoin = Diff ioJoin  type instance DiffType v [l] = [DiffType v l] instance List r => List (Diff r v) where@@ -150,23 +157,13 @@   cons = Diff cons   listMatch = Diff listMatch -instance Functor r M.IO => Functor (Diff r v) M.IO where-  map = Diff map--instance Applicative r M.IO => Applicative (Diff r v) M.IO where-  pure = Diff pure-  ap = Diff ap--instance Monad r M.IO => Monad (Diff r v) M.IO where-  bind = Diff bind-  join = Diff join- instance (Vector r v, Lang r) => VTF.VectorTF (Diff r v) where   zero = Diff VTF.zero   basis = Diff VTF.basis   plus = Diff VTF.plus   mult = Diff $ VTF.mult `com2` dualOrig   vtfMatch = Diff $ lam4 $ \ze b p m -> VTF.vtfMatch4 ze b p $ lam $ \x -> app m (mkDual2 x zero)+  vtfCmp = Diff VTF.vtfCmp  type instance DiffType v (M.DW.DiffWrapper a x) = M.DW.DiffWrapper (v ': a) x instance DiffWrapper r => DiffWrapper (Diff r v) where@@ -195,22 +192,23 @@   state = Diff state   runState = Diff runState -instance Map.Ord () where+instance MetaOrd () where   diffOrd _ = Dict -instance Map.Ord a => Map.Ord [a] where-  diffOrd (_ :: Proxy (v, [a])) = withDict (Map.diffOrd (Proxy :: Proxy (v, a))) Dict+instance MetaOrd a => MetaOrd [a] where+  diffOrd (_ :: Proxy (v, [a])) = withDict (diffOrd (Proxy :: Proxy (v, a))) Dict -instance Map.Ord l => Map.Ord (M.Dual l r) where-  diffOrd (_ :: Proxy (v, M.Dual l r)) = withDict (Map.diffOrd (Proxy :: Proxy (v, l))) Dict+instance MetaOrd l => MetaOrd (M.Dual l r) where+  diffOrd (_ :: Proxy (v, M.Dual l r)) = withDict (diffOrd (Proxy :: Proxy (v, l))) Dict -instance Map.Ord M.Double where+instance MetaOrd M.Double where   diffOrd _ = Dict -instance Map.Ord M.Float where+instance MetaOrd M.Float where   diffOrd _ = Dict  type instance DiffType v M.Ordering = M.Ordering-instance (Vector r v, Ordering r) => Ordering (Diff r v) where++instance Ordering r => Ordering (Diff r v) where   ordering = Diff . ordering   sel = Diff sel

@@ -1,14 +1,16 @@ {-# LANGUAGE   NoImplicitPrelude,-  NoMonomorphismRestriction+  NoMonomorphismRestriction,+  FlexibleInstances,+  MultiParamTypeClasses #-} -module DDF.Double (module DDF.Double, module DDF.Bool) where+module DDF.Double (module DDF.Double, module DDF.Ordering) where -import DDF.Bool+import DDF.Ordering import qualified Prelude as M -class Bool r => Double r where+class Ordering r => Double r where   double :: M.Double -> r h M.Double   doubleZero :: r h M.Double   doubleZero = double 0@@ -19,12 +21,14 @@   doubleMult :: r h (M.Double -> M.Double -> M.Double)   doubleDivide :: r h (M.Double -> M.Double -> M.Double)   doubleExp :: r h (M.Double -> M.Double)-  doubleEq :: r h (M.Double -> M.Double -> M.Bool)+  doubleCmp :: r h (M.Double -> M.Double -> M.Ordering) +instance Double r => ObjOrd r M.Double where+  cmp = doubleCmp+ doublePlus1 = app doublePlus doublePlus2 = app2 doublePlus doubleMinus2 = app2 doubleMinus doubleMult2 = app2 doubleMult doubleDivide2 = app2 doubleDivide doubleExp1 = app doubleExp-doubleEq2 = app2 doubleEq

@@ -3,12 +3,13 @@   LambdaCase,   TypeFamilies,   FlexibleContexts,-  MultiParamTypeClasses+  MultiParamTypeClasses,+  FlexibleInstances #-}  module DDF.Eval where -import DDF.ImportMeta+import DDF.Lang import qualified Prelude as M import qualified Control.Monad.Writer as M (WriterT(WriterT), runWriter) import qualified Control.Monad.State as M@@ -24,7 +25,7 @@ import qualified DDF.Meta.DiffWrapper as M.DW import qualified Data.Functor.Foldable as M import qualified DDF.Meta.FreeVector as M-import DDF.Lang+import qualified DDF.Meta.Util as M  newtype Eval h x = Eval {runEval :: h -> x} @@ -55,7 +56,7 @@   doubleMult = comb (*)   doubleDivide = comb (/)   doubleExp = comb M.exp-  doubleEq = comb (==)+  doubleCmp = comb M.compare  instance Float Eval where   float = comb@@ -109,7 +110,7 @@ instance Int Eval where   int = comb   pred = comb ((-) 1)-  isZero = comb (== 0)+  intCmp = comb M.compare  instance Y Eval where   y = comb loop@@ -122,30 +123,38 @@                             [] -> l                             x:xs -> r x xs -instance Functor Eval M.IO where-  map = comb M.fmap--instance Applicative Eval M.IO where-  pure = comb M.pure-  ap = comb M.ap--instance Monad Eval M.IO where-  join = comb M.join-  bind = comb (>>=)- instance IO Eval where   putStrLn = comb M.putStrLn+  ioMap = comb M.fmap+  ioPure = comb M.pure+  ioAP = comb M.ap+  ioBind = comb (>>=)+  ioJoin = comb M.join  instance VTF.VectorTF Eval where   zero = comb M.VTF.Zero   basis = comb M.VTF.Basis   plus = comb M.VTF.Plus   mult = comb M.VTF.Mult-  vtfMatch = comb $ \zr b p m -> \case-                                 M.VTF.Zero -> zr-                                 M.VTF.Basis t -> b t-                                 M.VTF.Plus l r -> p l r-                                 M.VTF.Mult l r -> m l r+  vtfMatch =+      comb $ \zr b p m -> \case+                          M.VTF.Zero -> zr+                          M.VTF.Basis t -> b t+                          M.VTF.Plus l r -> p l r+                          M.VTF.Mult l r -> m l r+  vtfCmp =+      comb $ x where+        x t f = c where+          c M.VTF.Zero M.VTF.Zero = M.EQ+          c M.VTF.Zero _ = M.LT+          c _ M.VTF.Zero = M.GT+          c (M.VTF.Basis l) (M.VTF.Basis r) = t l r+          c (M.VTF.Basis _) _ = M.LT+          c _ (M.VTF.Basis _) = M.GT+          c (M.VTF.Plus ll lr) (M.VTF.Plus rl rr) = M.chainOrd (f ll rl) (f lr rr)+          c (M.VTF.Plus _ _) _ = M.LT+          c _ (M.VTF.Plus _ _) = M.GT+          c (M.VTF.Mult ll lr) (M.VTF.Mult rl rr) = M.chainOrd (runEval cmp () ll rl) (f lr rr)  instance DiffWrapper Eval where   diffWrapper = comb M.DW.DiffWrapper

@@ -1,4 +1,10 @@-{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, NoMonomorphismRestriction #-}+{-# LANGUAGE +  NoImplicitPrelude,+  FlexibleContexts,+  NoMonomorphismRestriction,+  FlexibleInstances,+  MultiParamTypeClasses+#-}  module DDF.IO (module DDF.IO, module DDF.List, module DDF.Char, module DDF.Unit) where @@ -10,7 +16,26 @@ string [] = nil string (c:str) = cons2 (char c) (string str) -class (List r, Unit r, Char r, Monad r M.IO) => IO r where+class (List r, Unit r, Char r) => IO r where   putStrLn :: r h (String -> M.IO ())+  ioMap :: r h ((a -> b) -> M.IO a -> M.IO b)+  ioPure :: r h (a -> M.IO a)+  ioAP :: r h (M.IO (a -> b) -> M.IO a -> M.IO b)+  ioBind :: r h (M.IO a -> (a -> M.IO b) -> M.IO b)+  ioBind = lam2 $ \m f -> join1 (map2 f m)+  ioJoin :: r h (M.IO (M.IO a) -> M.IO a)+  ioJoin = lam $ \m -> bind2 m id+  {-# MINIMAL putStrLn, ioMap, ioPure, ioAP, (ioBind | ioJoin) #-}++instance IO r => Functor r M.IO where+  map = ioMap++instance IO r => Applicative r M.IO where+  pure = ioPure+  ap = ioAP++instance IO r => Monad r M.IO where+  join = ioJoin+  bind = ioBind  putStrLn1 = app putStrLn

@@ -18,6 +18,7 @@ import qualified DDF.Map as Map import qualified DDF.VectorTF as VTF import qualified Prelude as M+import DDF.Meta.Util  class ProdCon con l r where   prodCon :: (con l, con r) :- con (l, r)@@ -94,7 +95,7 @@   doubleMinus = NoImpW doubleMinus   doubleMult = NoImpW doubleMult   doubleDivide = NoImpW doubleDivide-  doubleEq = NoImpW doubleEq+  doubleCmp = NoImpW doubleCmp  instance (Prod r, Float r) => Float (ImpW r) where   float = NoImpW . float@@ -144,10 +145,15 @@ instance (Prod r, Int r) => Int (ImpW r) where   int = NoImpW . int   pred = NoImpW pred-  isZero = NoImpW isZero+  intCmp = NoImpW cmp  instance (Prod r, IO r) => IO (ImpW r) where   putStrLn = NoImpW putStrLn+  ioMap = NoImpW map+  ioAP = NoImpW ap+  ioPure = NoImpW pure+  ioJoin = NoImpW join+  ioBind = NoImpW bind  instance (Prod r, List r) => List (ImpW r) where   nil = NoImpW nil@@ -157,23 +163,13 @@ instance (Prod r, Y r) => Y (ImpW r) where   y = NoImpW y -instance (Prod r, Functor r x) => Functor (ImpW r) x where-  map = NoImpW map--instance (Prod r, Applicative r x) => Applicative (ImpW r) x where-  ap = NoImpW ap-  pure = NoImpW pure--instance (Prod r, Monad r x) => Monad (ImpW r) x where-  join = NoImpW join-  bind = NoImpW bind- instance (Prod r, VTF.VectorTF r) => VTF.VectorTF (ImpW r) where   zero = NoImpW VTF.zero   basis = NoImpW VTF.basis   plus = NoImpW VTF.plus   mult = NoImpW VTF.mult   vtfMatch = NoImpW VTF.vtfMatch+  vtfCmp = NoImpW VTF.vtfCmp  instance (Prod r, DiffWrapper r) => DiffWrapper (ImpW r) where   diffWrapper = NoImpW diffWrapper

@@ -7,8 +7,7 @@   module Control.Monad.State,   module Data.Constraint,   module Data.Constraint.Forall,-  module Data.Proxy,-  module DDF.Util) where+  module Data.Proxy) where  import Prelude (   ($), show, (+), (-), (*), (/), (.), (++), (>>=), (<=), (<), (==), compare, print, Maybe(Just, Nothing), String, (||), Either(Left, Right))@@ -18,4 +17,3 @@ import Data.Constraint import Data.Constraint.Forall import Data.Proxy-import DDF.Util

@@ -1,14 +1,23 @@-{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-}+{-# LANGUAGE+  NoImplicitPrelude,+  NoMonomorphismRestriction,+  FlexibleContexts,+  UndecidableSuperClasses,+  FlexibleInstances,+  MultiParamTypeClasses+#-} -module DDF.Int (module DDF.Int, module DDF.Bool) where+module DDF.Int (module DDF.Int, module DDF.Ordering) where -import DDF.Bool+import DDF.Ordering import qualified Prelude as M -class Bool r => Int r where+class Ordering r => Int r where   int :: M.Int -> r h M.Int   pred :: r h (M.Int -> M.Int)-  isZero :: r h (M.Int -> M.Bool)+  intCmp :: r h (M.Int -> M.Int -> M.Ordering) +instance Int r => ObjOrd r M.Int where+  cmp = intCmp+ pred1 = app pred-isZero1 = app isZero

@@ -4,7 +4,12 @@   MultiParamTypeClasses,   FlexibleInstances,   TypeFamilies,-  ScopedTypeVariables+  ScopedTypeVariables,+  FlexibleContexts,+  UndecidableInstances,+  TypeApplications,+  PartialTypeSignatures,+  UndecidableSuperClasses #-}  module DDF.Lang (@@ -68,14 +73,15 @@   runState :: r h (State x y -> (x -> (y, x)))   iterate :: r h ((x -> x) -> x -> [x])   iterate = lam $ \f -> y1 $ lam2 $ \fi x -> cons2 x (app fi (app f x))-  buildFreeVector :: Map.Ord b => r h (FreeVectorBuilder b -> M.FreeVector b M.Double)+  buildFreeVector :: MetaOrd b => r h (FreeVectorBuilder b -> M.FreeVector b M.Double)   buildFreeVector = lam $ \fb -> freeVector1 $ lam $ \b -> optionMatch3 (double 0) id (Map.lookup2 fb b)-  toSVTFBuilder :: Map.Ord b => r h (M.VTF.VectorTF b M.Int -> SVTFBuilder b)-  toSVTFBuilder = lam $ \x -> state1 $ lam $ \m ->-    optionMatch3-      (let_2 (size1 m) (lam $ \si -> mkProd2 si (insert2 (mkProd2 x si) m)))-      (lam $ \xid -> mkProd2 xid m)-      (lookupL2 m x)+  toSVTFBuilder :: forall h b. MetaOrd b => r h (M.VTF.VectorTF b M.Int -> SVTFBuilder b)+  toSVTFBuilder =+    lam $ \x -> state1 $ lam $ \m ->+      optionMatch3+        (let_2 (size1 m) (lam $ \si -> mkProd2 si (insert2 (mkProd2 x si) m)))+        (lam $ \xid -> mkProd2 xid m)+        (lookupL2 m x)   get :: r h (Maybe a -> a)   get = optionMatch2 undefined id   getVar :: r h (State x x)@@ -222,14 +228,14 @@   mult = lam2 $ \d l -> freeVector1 $ lam $ \x -> d `mult2` runFreeVector2 l x   divide = lam2 $ \l d -> freeVector1 $ lam $ \x -> runFreeVector2 l x `divide2` d -instance (Map.Ord b, Lang r) => Monoid r (FreeVectorBuilder b) where+instance (MetaOrd b, Lang r) => Monoid r (FreeVectorBuilder b) where   zero = Map.empty   plus = Map.unionWith1 plus -instance (Map.Ord b, Lang r) => Group r (FreeVectorBuilder b) where+instance (MetaOrd b, Lang r) => Group r (FreeVectorBuilder b) where   invert = Map.mapMap1 invert -instance (Map.Ord b, Lang r) => Vector r (FreeVectorBuilder b) where+instance (MetaOrd b, Lang r) => Vector r (FreeVectorBuilder b) where   type Basis (FreeVectorBuilder b) = b   toFreeVector = buildFreeVector   mult = Map.mapMap `com2` mult@@ -239,22 +245,22 @@   zero = fix1 VTF.zero   plus = lam2 $ \l r -> fix1 $ l `VTF.plus2` r -instance (Map.Ord b, Lang r) => Group r (M.Fix (M.VTF.VectorTF b)) where+instance (MetaOrd b, Lang r) => Group r (M.Fix (M.VTF.VectorTF b)) where   invert = mult1 (double (-1)) -instance (Map.Ord b, Lang r) => Vector r (M.Fix (M.VTF.VectorTF b)) where+instance (MetaOrd b, Lang r) => Vector r (M.Fix (M.VTF.VectorTF b)) where   type Basis (M.Fix (M.VTF.VectorTF b)) = b   toFreeVector = buildFreeVector `com2` vtfCata1 (VTF.vtfMatch4 zero (flip2 Map.singleton (double 1)) plus mult)   mult = lam $ \d -> fix `com2` VTF.mult1 d -instance (Map.Ord b, Lang r) => Monoid r (SVTFBuilder b) where+instance (MetaOrd b, Lang r) => Monoid r (SVTFBuilder b) where   zero = toSVTFBuilder1 VTF.zero   plus = lam2 $ \l r -> l `bind2` (lam $ \lid -> r `bind2` (lam $ \rid -> toSVTFBuilder1 (VTF.plus2 lid rid))) -instance (Map.Ord b, Lang r) => Group r (SVTFBuilder b) where+instance (MetaOrd b, Lang r) => Group r (SVTFBuilder b) where   invert = mult1 (double (-1)) -instance (Map.Ord b, Lang r) => Vector r (SVTFBuilder b) where+instance (MetaOrd b, Lang r) => Vector r (SVTFBuilder b) where   type Basis (SVTFBuilder b) = b   toFreeVector =     buildFreeVector `com2` flip2 id Map.empty `com2`@@ -265,16 +271,16 @@         (lam $ \b -> return1 (Map.singleton2 b (fst1 p)))         (lam2 $ \lid rid -> map2 (const1 zero) (update1 (updateWengert2 lid (fst1 p) `com2` updateWengert2 rid (fst1 p))))         (lam2 $ \d xid -> map2 (const1 zero) (update1 (let_2 (d `mult2` (fst1 p)) (updateWengert1 xid))))-        (zro1 p) `bind2` (lam $ \fvb -> ite3 (return1 fvb) (map2 (plus1 fvb) $ app fx (pred1 i)) (isZero1 i)))) (zro1 x))+        (zro1 p) `bind2` (lam $ \fvb -> ite3 (return1 fvb) (map2 (plus1 fvb) $ app fx (pred1 i)) (eq2 i (int 0))))) (zro1 x))     `com2` Map.insert2 (zro1 x) (double 0)) `com2` bimap2 id toMapR `com2` flip2 runState empty   mult = lam2 $ \d x -> x `bind2` (lam $ \xid -> toSVTFBuilder1 (VTF.mult2 d xid))  type instance DiffType v (M.VTF.VectorTF t f) = M.VTF.VectorTF (DiffType v t) (DiffType v f)-instance (Map.Ord b, Map.Ord f) => Map.Ord (M.VTF.VectorTF b f) where-  diffOrd (_ :: Proxy (v, M.VTF.VectorTF b f)) = withDict (Map.diffOrd (Proxy :: Proxy (v, b))) $ withDict (Map.diffOrd (Proxy :: Proxy (v, f))) Dict+instance (MetaOrd t, MetaOrd f) => MetaOrd (M.VTF.VectorTF t f) where+  diffOrd (_ :: Proxy (v, _)) = withDict (diffOrd $ Proxy @(v, t)) $ withDict (diffOrd $ Proxy @(v, f)) Dict  type instance DiffType v M.Int = M.Int-instance Map.Ord M.Int where+instance MetaOrd M.Int where   diffOrd _ = Dict  instance Double r => Monoid r M.Double where@@ -290,7 +296,6 @@   mult = doubleMult   divide = doubleDivide -uncurry1 = app uncurry optionMatch2 = app2 optionMatch optionMatch3 = app3 optionMatch writer1 = app writer

@@ -3,28 +3,26 @@   ScopedTypeVariables,   TypeApplications,   FlexibleInstances,-  NoMonomorphismRestriction+  NoMonomorphismRestriction,+  MultiParamTypeClasses #-} -module DDF.Map (module DDF.Map, module DDF.Prod, module DDF.Option) where+module DDF.Map (module DDF.Map, module DDF.Prod, module DDF.Option, module DDF.Ordering) where  import DDF.Prod-import qualified Prelude as M import qualified Data.Map as M import DDF.Option+import DDF.Ordering import DDF.Meta.Diff -class M.Ord x => Ord x where-  diffOrd :: Proxy (v, x) -> Dict (Ord (DiffType v x))- class (Prod r, Option r) => Map r where   empty :: r h (M.Map k a)   singleton :: r h (k -> a -> M.Map k a)-  lookup :: Ord k => r h (M.Map k a -> k -> Maybe a)-  alter :: Ord k => r h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a)+  lookup :: MetaOrd k => r h (M.Map k a -> k -> Maybe a)+  alter :: MetaOrd k => r h ((Maybe a -> Maybe a) -> k -> M.Map k a -> M.Map k a)   mapMap :: r h ((a -> b) -> M.Map k a -> M.Map k b)-  unionWith :: Ord k => r h ((a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a)-  insert :: Ord k => r h (k -> a -> M.Map k a -> M.Map k a)+  unionWith :: MetaOrd k => r h ((a -> a -> a) -> M.Map k a -> M.Map k a -> M.Map k a)+  insert :: MetaOrd k => r h (k -> a -> M.Map k a -> M.Map k a)   insert = lam2 $ \k a -> alter2 (const1 (just1 a)) k  lookup2 = app2 lookup

@@ -15,7 +15,11 @@ module DDF.Meta.Diff (module DDF.Meta.Diff, module DDF.Vector) where  import DDF.Vector+import DDF.ImportMeta  type family DiffType (v :: *) (x :: *)  newtype Diff r v h x = Diff {runDiff :: r (DiffType v h) (DiffType v x)}++class Ord x => MetaOrd x where+  diffOrd :: Proxy (v, x) -> Dict (MetaOrd (DiffType v x))

@@ -0,0 +1,44 @@+{-# LANGUAGE TupleSections #-}
+
+module DDF.Meta.Util (module DDF.Meta.Util, module System.Random) where
+
+import System.Random
+import GHC.Float
+
+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)
+
+chainOrd EQ x = x
+chainOrd x _ = x

@@ -1,26 +1,60 @@-{-# Language NoImplicitPrelude, NoMonomorphismRestriction #-}+{-# Language+  NoImplicitPrelude,+  NoMonomorphismRestriction,+  MultiParamTypeClasses,+  ConstraintKinds,+  FlexibleInstances,+  UndecidableInstances,+  KindSignatures,+  ConstraintKinds,+  TypeFamilies,+  UndecidableSuperClasses+#-} -module DDF.Ordering (module DDF.Ordering, module DDF.DBI) where+module DDF.Ordering (module DDF.Ordering, module DDF.Bool) where -import DDF.DBI import DDF.Bool import qualified Prelude as M -class DBI repr => Ordering repr where-  sel :: repr h (a -> a -> a -> M.Ordering -> a)-  ordering :: M.Ordering -> repr h M.Ordering-  ltOrd :: repr h M.Ordering+class Bool r => Ordering r where+  sel :: r h (a -> a -> a -> M.Ordering -> a)+  ordering :: M.Ordering -> r h M.Ordering+  ltOrd :: r h M.Ordering   ltOrd = ordering M.LT-  eqOrd :: repr h M.Ordering+  eqOrd :: r h M.Ordering   eqOrd = ordering M.EQ-  gtOrd :: repr h M.Ordering+  gtOrd :: r h M.Ordering   gtOrd = ordering M.GT+  isLT :: r h (M.Ordering -> M.Bool)+  isLT = sel3 true  false false+  isEQ :: r h (M.Ordering -> M.Bool)+  isEQ = sel3 false true  false+  isGT :: r h (M.Ordering -> M.Bool)+  isGT = sel3 false false true+  chainOrd :: r h (M.Ordering -> M.Ordering -> M.Ordering)+  chainOrd = lam2 $ \l r -> sel4 ltOrd r gtOrd l  sel1 = app1 sel sel2 = app2 sel sel3 = app3 sel sel4 = app4 sel -isLT = sel3 true  false false-isEQ = sel3 false true  false-isGT = sel3 false false true+isLT1 = app1 isLT+isEQ1 = app1 isEQ+isGT1 = app1 isGT++chainOrd1 = app1 chainOrd+chainOrd2 = app2 chainOrd++class Ordering r => ObjOrd r x where+  cmp :: r h (x -> x -> M.Ordering)+  eq :: r h (x -> x -> M.Bool)+  eq = lam2 $ \l r -> isEQ1 $ cmp2 l r++eq1 = app1 eq+eq2 = app2 eq++cmp1 = app1 cmp+cmp2 = app2 cmp++type Cmp a = a -> a -> M.Ordering

@@ -12,7 +12,8 @@   KindSignatures,   TypeFamilies,   TypeApplications,-  MultiParamTypeClasses+  MultiParamTypeClasses,+  FlexibleInstances #-}  module DDF.PE where@@ -154,11 +155,11 @@       f (Known l _ _ _ _) = double (M.exp l)        f (Open x) = Open $ f . x       f (Unk l) = Unk $ doubleExp1 l-  doubleEq = abs (abs (f (s z) z)) where-    f :: P r h M.Double -> P r h M.Double -> P r h M.Bool-    f (Known l _ _ _ _) (Known r _ _ _ _) = bool (l == r)+  doubleCmp = abs $ abs $ f (s z) z where+    f :: P r h M.Double -> P r h M.Double -> P r h M.Ordering+    f (Known l _ _ _ _) (Known r _ _ _ _) = ordering (M.compare l r)     f l r | isOpen l || isOpen r = Open (\h -> f (app_open l h) (app_open r h))-    f l r = Unk (doubleEq2 (dynamic l) (dynamic r))+    f l r = Unk (cmp2 (dynamic l) (dynamic r))  type instance K repr h M.Float = M.Float instance Float r => Float (P r) where@@ -300,25 +301,37 @@ instance Char repr => Char (P repr) where   char x = static (x, char x) +type instance K repr h M.Ordering = M.Ordering+instance Ordering repr => Ordering (P repr) where+  ordering x = static (x, ordering x)+  sel = abs $ abs $ abs $ abs $ f (s (s (s z))) (s (s z)) (s z) z where+    f :: P repr h a -> P repr h a -> P repr h a -> P repr h M.Ordering -> P repr h a+    f a _ _ (Known M.LT _ _ _ _) = a+    f _ b _ (Known M.EQ _ _ _ _) = b+    f _ _ c (Known M.GT _ _ _ _) = c+    f a b c (Open x) = Open $ \h -> f (app_open a h) (app_open b h) (app_open c h) (x h)+    f a b c (Unk x) = Unk $ sel4 (dynamic a) (dynamic b) (dynamic c) x+ type instance K repr h M.Int = M.Int+instance Int repr => ObjOrd (P repr) M.Int where+  cmp = intCmp+ instance Int repr => Int (P repr) where   int x = static (x, int x)-  pred = abs (f z)-    where-      f :: P repr h M.Int -> P repr h M.Int-      f (Known i _ _ _ _) = int $ i - 1-      f (Open x) = Open $ f . x-      f (Unk x) = Unk $ pred1 x-  isZero = abs (f z)-    where-      f :: P repr h M.Int -> P repr h M.Bool-      f (Known i _ _ _ _) = bool $ i == 0-      f (Open x) = Open $ f . x-      f (Unk x) = Unk $ isZero1 x+  pred = abs (f z) where+    f :: P repr h M.Int -> P repr h M.Int+    f (Known i _ _ _ _) = int $ i - 1+    f (Open x) = Open $ f . x+    f (Unk x) = Unk $ pred1 x+  intCmp = abs $ abs $ f (s z) z where+    f :: P repr h M.Int -> P repr h M.Int -> P repr h M.Ordering+    f (Known l _ _ _ _) (Known r _ _ _ _) = ordering $ M.compare l r+    f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h)+    f l r = Unk $ cmp2 (dynamic l) (dynamic r)  type instance K repr h (M.Dual l r) = (P repr h l, P repr h r) instance Dual repr => Dual (P repr) where-  dual = abs (f z)+  dual = abs $ f z     where       f :: P repr h (a, b) -> P repr h (M.Dual a b)       f (Known (l, r) _ _ _ _) =@@ -339,41 +352,31 @@       f (Open x) = Open $ f . x       f (Unk x) = Unk $ runDual1 x -type instance K repr h () = ()-instance Unit repr => Unit (P repr) where+type instance K r h () = ()+instance Unit r => Unit (P r) where   unit = static ((), unit) -type instance K repr h (M.IO a) = P repr h a-instance IO repr => Functor (P repr) M.IO where-  map = abs $ abs (f (s z) z)-    where-      f :: P repr h (a -> b) -> P repr h (M.IO a) -> P repr h (M.IO b)-      f l (Known a _ _ _ _) = pure1 $ app l a-      f l (Open x) = Open $ \h -> f (app_open l h) (x h)-      f l (Unk x) = Unk $ map2 (dynamic l) x--instance IO repr => Applicative (P repr) M.IO where-  pure = abs $ f z-    where-      f :: P repr h a -> P repr h (M.IO a)-      f x = know x (pure1 $ dynamic x) (\h -> pure1 $ app_open x h) (pure1 $ s x)-  ap = abs $ abs $ f (s z) z-    where-      f :: P repr h (M.IO (a -> b)) -> P repr h (M.IO a) -> P repr h (M.IO b)-      f (Known l _ _ _ _) (Known r _ _ _ _) = pure1 $ app l r-      f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h)-      f l r = Unk $ ap2 (dynamic l) (dynamic r)--instance IO repr => Monad (P repr) M.IO where-  join = abs $ f z-    where-      f :: P repr h (M.IO (M.IO a)) -> P repr h (M.IO a)-      f (Known l _ _ _ _) = l-      f (Open x) = Open $ f . x-      f (Unk x) = Unk $ join1 x--instance IO repr => IO (P repr) where+type instance K r h (M.IO a) = P r h a+instance IO r => IO (P r) where   putStrLn = Unk putStrLn+  ioJoin = abs $ f z where+    f :: P r h (M.IO (M.IO a)) -> P r h (M.IO a)+    f (Known l _ _ _ _) = l+    f (Open x) = Open $ f . x+    f (Unk x) = Unk $ join1 x+  ioMap = abs $ abs $ f (s z) z where+    f :: P r h (a -> b) -> P r h (M.IO a) -> P r h (M.IO b)+    f l (Known a _ _ _ _) = pure1 $ app l a+    f l (Open x) = Open $ \h -> f (app_open l h) (x h)+    f l (Unk x) = Unk $ map2 (dynamic l) x+  ioPure = abs $ f z where+    f :: P r h a -> P r h (M.IO a)+    f x = know x (pure1 $ dynamic x) (\h -> pure1 $ app_open x h) (pure1 $ s x)+  ioAP = abs $ abs $ f (s z) z where+    f :: P r h (M.IO (a -> b)) -> P r h (M.IO a) -> P r h (M.IO b)+    f (Known l _ _ _ _) (Known r _ _ _ _) = pure1 $ app l r+    f l r | isOpen l || isOpen r = Open $ \h -> f (app_open l h) (app_open r h)+    f l r = Unk $ ap2 (dynamic l) (dynamic r)  data MapPE (repr :: * -> * -> *) h k a :: * where   EmptyMap :: MapPE repr h k a

@@ -1,10 +1,14 @@-{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-}+{-# LANGUAGE+  NoImplicitPrelude,+  NoMonomorphismRestriction,+  ScopedTypeVariables+#-} -module DDF.Prod (module DDF.Prod, module DDF.DBI) where+module DDF.Prod (module DDF.Prod, module DDF.Ordering) where -import DDF.DBI+import DDF.Ordering -class DBI r => Prod r where+class Ordering r => Prod r where   mkProd :: r h (a -> b -> (a, b))   zro :: r h ((a, b) -> a)   fst :: r h ((a, b) -> b)@@ -14,9 +18,16 @@   curry = lam3 $ \f a b -> app f (mkProd2 a b)   uncurry :: r h ((a -> b -> c) -> ((a, b) -> c))   uncurry = lam2 $ \f p -> app2 f (zro1 p) (fst1 p)+  prodCmp :: forall h a b. r h (Cmp a -> Cmp b -> Cmp (a, b))+  prodCmp =+    lam2 $ \l r ->+      uncurry1 (lam2 $ \ll lr ->+        uncurry1 (lam2 $ \rl rr ->+          chainOrd2 (app2 l ll rl) (app2 r lr rr))) -zro1 = app zro-fst1 = app fst-mkProd1 = app mkProd+zro1 = app1 zro+fst1 = app1 fst+mkProd1 = app1 mkProd mkProd2 = app2 mkProd curry1 = app curry+uncurry1 = app1 uncurry

@@ -17,7 +17,7 @@ 
 > module DDF.Sam.Poly where
 > import Control.Monad (when)
-> import DDF.Util
+> import DDF.Meta.Util
 > import DDF.Lang
 > import DDF.Show
 > import DDF.Diff ()

@@ -15,7 +15,7 @@ > import System.Random > import Control.Monad (when) > import Data.Constraint-> import DDF.Util+> import DDF.Meta.Util > import DDF.Lang > import DDF.Show > import DDF.Eval ()

@@ -6,6 +6,7 @@ import qualified Prelude as M import qualified DDF.Map as Map import qualified DDF.VectorTF as VTF+import qualified DDF.Meta.VectorTF as M.VTF  data Name = Prefix M.String | Infix M.String @@ -70,7 +71,7 @@   doubleMult = name "mult"   doubleDivide = name "divide"   doubleExp = name "exp"-  doubleEq = name "eq"+  doubleCmp = name "cmp"  instance Float Show where   float = name . show@@ -120,7 +121,7 @@ instance Int Show where   int = name . show   pred = name "pred"-  isZero = name "isZero"+  intCmp = name "compare"  instance List Show where   nil = name "[]"@@ -133,17 +134,14 @@  instance IO Show where   putStrLn = name "putStrLn"--instance Functor Show x where-  map = name "map"--instance Applicative Show x where-  pure = name "pure"-  ap = name "ap"+  ioMap = name "map"+  ioPure = name "pure"+  ioAP = name "ap"+  ioBind = name "bind"+  ioJoin = name "join" -instance Monad Show x where-  join = name "join"-  bind = name "bind"+instance ObjOrd Show (M.VTF.VectorTF a b) where+  cmp = name "cmp"  instance VTF.VectorTF Show where   zero = name "VTF.zero"@@ -151,6 +149,7 @@   plus = name "VTF.plus"   mult = name "VTF.mult"   vtfMatch = name "VTF.vtfMatch"+  vtfCmp = name "vtfCompare"  instance DiffWrapper Show where   diffWrapper = name "diffWrapper"

@@ -36,7 +36,7 @@   doubleMult = one   doubleDivide = one   doubleExp = one-  doubleEq = one+  doubleCmp = one  instance Float Size where   float _ = one@@ -86,10 +86,15 @@ instance Int Size where   int _ = one   pred = one-  isZero = one+  intCmp = one  instance IO Size where   putStrLn = one+  ioJoin = one+  ioBind = one+  ioMap = one+  ioPure = one+  ioAP = one  instance Y Size where   y = one@@ -99,23 +104,13 @@   cons = one   listMatch = one -instance Functor Size x where-  map = one--instance Applicative Size x where-  pure = one-  ap = one--instance Monad Size x where-  bind = one-  join = one- instance VTF.VectorTF Size where   zero = one   basis = one   plus = one   mult = one   vtfMatch = one+  vtfCmp = one  instance DiffWrapper Size where   diffWrapper = one

@@ -14,7 +14,8 @@   TypeApplications,   ScopedTypeVariables,   PartialTypeSignatures,-  AllowAmbiguousTypes+  AllowAmbiguousTypes,+  InstanceSigs #-}  module DDF.TermGen (module DDF.TermGen, module DDF.Lang) where@@ -22,7 +23,6 @@ import DDF.Lang import qualified DDF.Map as Map import qualified DDF.VectorTF as VTF- import qualified Prelude as M import Language.Haskell.TH @@ -56,12 +56,12 @@   ite = mkT @Bool ite   bool x = mkT @Bool (bool x) -type instance SubLC c Int = SubL c Bool+type instance SubLC c Int = SubL c Ordering  instance SubL c Int => Int (Term c) where   pred = mkT @Int pred   int x = mkT @Int (int x)-  isZero = mkT @Int isZero+  intCmp = mkT @Int cmp  type instance SubLC c Fix = SubL c DBI @@ -108,10 +108,10 @@   floatMinus = mkT @Float floatMinus   floatDivide = mkT @Float floatDivide -type instance SubLC c Double = SubL c Bool+type instance SubLC c Double = SubL c Ordering instance SubL c Double => Double (Term c) where-  doubleEq = mkT @Double doubleEq   double x = mkT @Double (double x)+  doubleCmp = mkT @Double doubleCmp   doubleExp = mkT @Double doubleExp   doublePlus = mkT @Double doublePlus     doubleMult = mkT @Double doubleMult@@ -140,17 +140,11 @@  instance SubL c IO => IO (Term c) where   putStrLn = mkT @IO putStrLn--instance SubL c IO => Functor (Term c) M.IO where-  map = mkT @IO map--instance SubL c IO => Applicative (Term c) M.IO where-  ap = mkT @IO ap-  pure = mkT @IO pure--instance SubL c IO => Monad (Term c) M.IO where-  join = mkT @IO join-  bind = mkT @IO bind+  ioMap = mkT @IO map+  ioAP = mkT @IO ap+  ioPure = mkT @IO pure+  ioJoin = mkT @IO join+  ioBind = mkT @IO bind  type instance SubLC c List = SubL c Y instance SubL c List => List (Term c) where@@ -158,7 +152,7 @@   cons = mkT @List cons   listMatch = mkT @List listMatch -type instance SubLC c Prod = SubL c DBI+type instance SubLC c Prod = SubL c Ordering instance SubL c Prod => Prod (Term c) where   zro = mkT @Prod zro   fst = mkT @Prod fst@@ -178,13 +172,14 @@   singleton = mkT @Map.Map Map.singleton   unionWith = mkT @Map.Map Map.unionWith -type instance SubLC c VTF.VectorTF = SubL c Double+type instance SubLC c VTF.VectorTF = (SubL c Ordering, SubL c Double) instance SubL c VTF.VectorTF => VTF.VectorTF (Term c) where   zero = mkT @VTF.VectorTF VTF.zero   plus = mkT @VTF.VectorTF VTF.plus   mult = mkT @VTF.VectorTF VTF.mult   basis = mkT @VTF.VectorTF VTF.basis   vtfMatch = mkT @VTF.VectorTF VTF.vtfMatch+  vtfCmp = mkT @VTF.VectorTF VTF.vtfCmp  type instance SubLC c Option = SubL c DBI instance SubL c Option => Option (Term c) where@@ -192,7 +187,7 @@   nothing = mkT @Option nothing   optionMatch = mkT @Option optionMatch -type instance SubLC c Ordering = SubL c DBI+type instance SubLC c Ordering = SubL c Bool instance SubL c Ordering => Ordering (Term c) where   sel = mkT @Ordering sel   ordering x = mkT @Ordering (ordering x)

@@ -4,7 +4,9 @@   TypeApplications,   ScopedTypeVariables,   FlexibleInstances,-  MultiParamTypeClasses+  MultiParamTypeClasses,+  FlexibleContexts,+  UndecidableInstances #-}  module DDF.UnHOAS where@@ -40,7 +42,7 @@   doubleMult = UnHOAS doubleMult   doubleDivide = UnHOAS doubleDivide   doubleExp = UnHOAS doubleExp-  doubleEq = UnHOAS doubleEq+  doubleCmp = UnHOAS cmp  instance Float r => Float (UnHOAS r) where   float = UnHOAS . float@@ -90,7 +92,7 @@ instance Int r => Int (UnHOAS r) where   int = UnHOAS . int   pred = UnHOAS pred-  isZero = UnHOAS isZero+  intCmp = UnHOAS cmp  instance Y r => Y (UnHOAS r) where   y = UnHOAS y@@ -108,6 +110,11 @@  instance IO r => IO (UnHOAS r) where   putStrLn = UnHOAS putStrLn+  ioMap = UnHOAS map+  ioBind = UnHOAS bind+  ioJoin = UnHOAS join+  ioPure = UnHOAS pure+  ioAP = UnHOAS ap  instance List r => List (UnHOAS r) where   nil = UnHOAS nil@@ -120,6 +127,7 @@   plus = UnHOAS VTF.plus   mult = UnHOAS VTF.mult   vtfMatch = UnHOAS VTF.vtfMatch+  vtfCmp = UnHOAS VTF.vtfCmp  instance DiffWrapper r => DiffWrapper (UnHOAS r) where   diffWrapper = UnHOAS diffWrapper

@@ -40,7 +40,7 @@   doubleMult = unLiftEnv doubleMult   doubleDivide = unLiftEnv doubleDivide   doubleExp = unLiftEnv doubleExp-  doubleEq = unLiftEnv doubleEq+  doubleCmp = unLiftEnv doubleCmp  instance (Prod r, Char r) => Char (UnLiftEnv r) where   char = unLiftEnv . char@@ -89,37 +89,32 @@  instance (Prod r, Int r) => Int (UnLiftEnv r) where   int = unLiftEnv . int-  isZero = unLiftEnv isZero   pred = unLiftEnv pred+  intCmp = unLiftEnv cmp  instance (Prod r, Y r) => Y (UnLiftEnv r) where   y = unLiftEnv y  instance (Prod r, IO r) => IO (UnLiftEnv r) where   putStrLn = unLiftEnv putStrLn+  ioMap = unLiftEnv map+  ioPure = unLiftEnv pure+  ioAP = unLiftEnv ap+  ioBind = unLiftEnv bind+  ioJoin = unLiftEnv join  instance (Unit r, Prod r, List r) => List (UnLiftEnv r) where   nil = unLiftEnv nil   cons = unLiftEnv cons   listMatch = unLiftEnv listMatch -instance (Prod r, Functor r m) => Functor (UnLiftEnv r) m where-  map = unLiftEnv map--instance (Prod r, Applicative r m) => Applicative (UnLiftEnv r) m where-  pure = unLiftEnv pure-  ap = unLiftEnv ap--instance (Prod r, Monad r m) => Monad (UnLiftEnv r) m where-  bind = unLiftEnv bind-  join = unLiftEnv join- instance (Prod r, VTF.VectorTF r) => VTF.VectorTF (UnLiftEnv r) where   zero = unLiftEnv VTF.zero   basis = unLiftEnv VTF.basis   plus = unLiftEnv VTF.plus   mult = unLiftEnv VTF.mult   vtfMatch = unLiftEnv VTF.vtfMatch+  vtfCmp = unLiftEnv VTF.vtfCmp  instance (Prod r, DiffWrapper r) => DiffWrapper (UnLiftEnv r) where   diffWrapper = unLiftEnv diffWrapper

@@ -1,41 +0,0 @@-{-# LANGUAGE TupleSections #-}
-
-module DDF.Util (module DDF.Util, module System.Random) where
-
-import System.Random
-import GHC.Float
-
-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)

@@ -1,10 +1,15 @@-{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction #-}+{-# LANGUAGE+  NoImplicitPrelude,+  NoMonomorphismRestriction,+  FlexibleContexts+#-}  module DDF.VectorTF where  import qualified DDF.Double as Double import qualified DDF.Meta.VectorTF as M import qualified Prelude as M+import qualified DDF.Ordering as Ord  class Double.Double r => VectorTF r where   zero :: r h (M.VectorTF t f)@@ -12,6 +17,7 @@   plus :: r h (f -> f -> M.VectorTF t f)   mult :: r h (M.Double -> f -> M.VectorTF t f)   vtfMatch :: r h (a -> (t -> a) -> (f -> f -> a) -> (M.Double -> f -> a) -> M.VectorTF t f -> a)+  vtfCmp :: r h (Ord.Cmp t -> Ord.Cmp f -> Ord.Cmp (M.VectorTF t f))  vtfMatch4 = Double.app4 vtfMatch vtfMatch5 = Double.app5 vtfMatch

@@ -1,5 +1,5 @@ name: DeepDarkFantasy-version: 0.2017.8.18+version: 0.2017.8.19 cabal-version: 1.12 build-type: Simple license: Apache@@ -43,6 +43,7 @@                    DDF.Meta.DiffWrapper                    DDF.Meta.Dual                    DDF.Meta.FreeVector+                   DDF.Meta.Util                    DDF.Meta.VectorTF                    DDF.Option                    DDF.Ordering@@ -59,7 +60,6 @@                    DDF.UnHOAS                    DDF.Unit                    DDF.UnLiftEnv-                   DDF.Util                    DDF.Vector                    DDF.VectorTF                    DDF.WithDiff