Add multiply-by-positive-constant primitive hmulpos.

hvx.cabal

@@ -1,5 +1,5 @@
 name               : hvx
-version            : 0.3.0.1
+version            : 0.3.1.0
 synopsis           : Solves convex optimization problems with subgradient methods.
 license-file       : LICENSE
 author             : Chris Copeland and Michael Haggblade

src/HVX.hs

@@ -11,7 +11,9 @@ module HVX
   , hadd
   , (+~)
   , hmul
+  , hmulpos
   , (*~)
+  , (*~+)
   , habs
   , neg
   , hlog
@@ -48,6 +50,8 @@ module HVX
   -- * check validity without calling an optimizer
   , validVex
   , ApplyVex
+  , ValidVex
+  , ApplyMon
 
   ) where
 

src/HVX/Internal/Primitives.hs

@@ -44,6 +44,7 @@ getProperties expr = getVex expr ++ " " ++ getMon expr
 
 data Fun (vex :: Vex) (mon :: Mon) where
   Mul                :: Mat -> Fun 'Affine 'Nonmon
+  MulPos             :: Mat -> Fun 'Affine 'Nondec
   Abs                :: Fun 'Convex 'Nonmon
   Neg                :: Fun 'Affine 'Noninc
   Log                :: Fun 'Concave 'Nondec
@@ -63,6 +64,7 @@ data Fun (vex :: Vex) (mon :: Mon) where
 
 instance Show (Fun vex mon) where
   show (Mul _) = "mul"
+  show (MulPos _) = "mulpos"
   show Abs = "abs"
   show Neg = "-"
   show Log = "log"
@@ -82,6 +84,7 @@ instance Show (Fun vex mon) where
 
 getFun :: Fun vex mon -> Mat -> Mat
 getFun (Mul a) x = a <> x
+getFun (MulPos a) x = a <> x
 getFun Abs x = abs x
 getFun Neg x = negate x
 getFun Exp x = exp x
@@ -109,6 +112,7 @@ getFun (PowBaseP1InfNotInt p) x
 
 getJacobian :: Fun vex mon -> Mat -> Mat
 getJacobian (Mul a) _ = a
+getJacobian (MulPos a) _ = a
 getJacobian Abs x = diagMat $ signum x
 getJacobian Neg x = (-1) * ident (rows x)
 getJacobian Log x = diagMat $ 1 / x

src/HVX/Primitives.hs

@@ -10,6 +10,8 @@ module HVX.Primitives
   , (+~)
   , hmul
   , (*~)
+  , hmulpos
+  , (*~+)
   , habs
   , neg
   , hlog
@@ -53,13 +55,24 @@ infixl 6 +~
 hmul :: (ApplyVex 'Affine 'Nonmon v1 m1 ~ v2, ValidVex v2)
   => Expr 'Affine 'Const -> Expr v1 m1 -> Expr v2 (ApplyMon 'Nonmon m1)
 hmul (EConst a) e = apply (Mul a) e
-hmul _ _ = error "the left argument of a multiply must be a constant"
+hmul _ _ = error "The left argument of a multiply must be a constant"
 
 infixl 7 *~
 (*~) :: (ApplyVex 'Affine 'Nonmon v1 m1 ~ v2, ValidVex v2)
   => Expr 'Affine 'Const -> Expr v1 m1 -> Expr v2 (ApplyMon 'Nonmon m1)
-(*~) (EConst a) e = apply (Mul a) e
-(*~) _ _ = error "the left argument of a multiply must be a constant"
+(*~) = hmul
+
+hmulpos :: (ApplyVex 'Affine 'Nondec v1 m1 ~ v2, ValidVex v2)
+  => Expr 'Affine 'Const -> Expr v1 m1 -> Expr v2 (ApplyMon 'Nondec m1)
+hmulpos (EConst a) e
+  | 0 <= minElement a = apply (MulPos a) e
+  | otherwise = error "The left argument of a positive multiply must have non-negative entries"
+hmulpos _ _ = error "The left argument of a positive multiply must be a constant"
+
+infixl 7 *~+
+(*~+) :: (ApplyVex 'Affine 'Nondec v1 m1 ~ v2, ValidVex v2)
+  => Expr 'Affine 'Const -> Expr v1 m1 -> Expr v2 (ApplyMon 'Nondec m1)
+(*~+) = hmulpos
 
 habs :: (ApplyVex 'Convex 'Nonmon v1 m1 ~ v2, ValidVex v2)
   => Expr v1 m1 -> Expr v2 (ApplyMon 'Nonmon m1)