{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Numeric.LinearProgramming.Test (
   Element,
   forAllOrigin,
   forAllProblem,
   forAllBoundedProblem,
   genObjective,
   forAllObjectives,
   successiveObjectives,
   approxReal,
   approx,
   checkFeasibility,
   affineCombination,
   scalarProduct,
   ) where

import qualified Numeric.LinearProgramming.Common as LP
import Numeric.LinearProgramming.Common ((<=.), (>=.), (.*))

import qualified Test.QuickCheck as QC
import Test.QuickCheck ((.&&.))
import System.Random (Random)

import qualified Data.Array.Comfort.Boxed as BoxedArray
import qualified Data.Array.Comfort.Storable as Array
import qualified Data.Array.Comfort.Shape as Shape
import qualified Data.NonEmpty as NonEmpty
import qualified Data.Ix as Ix
import Data.Array.Comfort.Storable (Array, (!))
import Data.Traversable (sequenceA, for)
import Data.Tuple.HT (mapSnd)
import Data.Maybe (fromMaybe)
import Data.Int (Int64)

import Control.Applicative (liftA2, (<$>))

import Text.Printf (PrintfArg, printf)

import Foreign.Storable (Storable)



type Term = LP.Term Double
type Constraints ix = LP.Constraints Double ix


{- |
Generate constraints in the form of a polyhedron
which contains warrantedly the zero vector.
That is, there is an admissible solution.
In order to assert that the polyhedron is closed,
we bound all variables by a hypercube.
-}
genProblem ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Element a) =>
   Array sh a -> QC.Gen (LP.Bounds ix, Constraints ix)
genProblem :: forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (Bounds ix, Constraints ix)
genProblem Array sh a
origin =
   forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
      (forall sh a.
(Indexed sh, Element a) =>
Array sh a -> Gen [Inequality (Index sh)]
genBounds Array sh a
origin)
      (do
         Int
numConstraints <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1,Int
20)
         forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
numConstraints forall a b. (a -> b) -> a -> b
$ do
            [ix]
ixs <- forall a. [a] -> Gen [a]
QC.sublistOf forall a b. (a -> b) -> a -> b
$ forall sh. Indexed sh => sh -> [Index sh]
Shape.indices forall a b. (a -> b) -> a -> b
$ forall sh a. Array sh a -> sh
Array.shape Array sh a
origin
            [(a, ix)]
terms <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ix]
ixs forall a b. (a -> b) -> a -> b
$ \ix
ix -> do
               a
coeff <- forall a. Random a => (a, a) -> Gen a
QC.choose (-a
10,a
10)
               forall (m :: * -> *) a. Monad m => a -> m a
return (a
coeff, ix
ix)
            let offset :: a
offset = forall sh ix a.
(Indexed sh, Index sh ~ ix, Storable a, Num a) =>
[(a, ix)] -> Array sh a -> a
scalarProductTerms [(a, ix)]
terms Array sh a
origin
            let deviation :: a
deviation = a
25
            forall x. x -> Bound -> Inequality x
LP.Inequality (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a ix. a -> ix -> Term a ix
(.*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Element a => a -> Double
doubleFromElement)) [(a, ix)]
terms)
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               forall a. [Gen a] -> Gen a
QC.oneof (
                  (do a
bound <- forall a. Random a => (a, a) -> Gen a
QC.choose (a
offsetforall a. Num a => a -> a -> a
-a
deviation, a
offsetforall a. Num a => a -> a -> a
+a
deviation)
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                         if a
bound forall a. Ord a => a -> a -> Bool
> a
offset
                            then Double -> Bound
LP.LessEqual    forall a b. (a -> b) -> a -> b
$ forall a. Element a => a -> Double
doubleFromElement a
bound
                            else Double -> Bound
LP.GreaterEqual forall a b. (a -> b) -> a -> b
$ forall a. Element a => a -> Double
doubleFromElement a
bound) forall a. a -> [a] -> [a]
:
                  (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Double -> Double -> Bound
LP.Between
                     (forall a. Element a => a -> Double
doubleFromElement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        forall a. Random a => (a, a) -> Gen a
QC.choose (a
offsetforall a. Num a => a -> a -> a
-a
deviation, a
offset))
                     (forall a. Element a => a -> Double
doubleFromElement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        forall a. Random a => (a, a) -> Gen a
QC.choose (a
offset, a
offsetforall a. Num a => a -> a -> a
+a
deviation))) forall a. a -> [a] -> [a]
:
                  []))

scalarProductTerms ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Storable a, Num a) =>
   [(a,ix)] -> Array sh a -> a
scalarProductTerms :: forall sh ix a.
(Indexed sh, Index sh ~ ix, Storable a, Num a) =>
[(a, ix)] -> Array sh a -> a
scalarProductTerms [(a, ix)]
terms Array sh a
origin =
   forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(a
coeff, ix
ix) -> a
coeff forall a. Num a => a -> a -> a
* Array sh a
originforall sh a.
(Indexed sh, Storable a) =>
Array sh a -> Index sh -> a
!ix
ix) [(a, ix)]
terms

{- |
Generates bounded, but maybe infeasible problems.
-}
genBoundedProblem ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Element a) =>
   Array sh a -> QC.Gen (LP.Bounds ix, Constraints ix)
genBoundedProblem :: forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (Bounds ix, Constraints ix)
genBoundedProblem Array sh a
origin =
   forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
      (forall sh a.
(Indexed sh, Element a) =>
Array sh a -> Gen [Inequality (Index sh)]
genBounds Array sh a
origin)
      (do
         Int
numConstraints <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1,Int
20)
         forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
numConstraints forall a b. (a -> b) -> a -> b
$ do
            [ix]
ixs <- forall a. [a] -> Gen [a]
QC.sublistOf forall a b. (a -> b) -> a -> b
$ forall sh. Indexed sh => sh -> [Index sh]
Shape.indices forall a b. (a -> b) -> a -> b
$ forall sh a. Array sh a -> sh
Array.shape Array sh a
origin
            [(a, ix)]
terms <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ix]
ixs forall a b. (a -> b) -> a -> b
$ \ix
ix -> do
               a
coeff <- forall a. Random a => (a, a) -> Gen a
QC.choose (-a
10, a
10)
               forall (m :: * -> *) a. Monad m => a -> m a
return (a
coeff, ix
ix)
            let doubleFromElem :: (Element a) => f a -> a -> Double
                doubleFromElem :: forall a (f :: * -> *). Element a => f a -> a -> Double
doubleFromElem f a
_ = forall a. Element a => a -> Double
doubleFromElement
            let choose :: Gen Double
choose = forall a (f :: * -> *). Element a => f a -> a -> Double
doubleFromElem Array sh a
origin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (-a
100, a
100)
            forall x. x -> Bound -> Inequality x
LP.Inequality (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a ix. a -> ix -> Term a ix
(.*) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (f :: * -> *). Element a => f a -> a -> Double
doubleFromElem Array sh a
origin)) [(a, ix)]
terms)
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               forall a. [Gen a] -> Gen a
QC.oneof (
                  (Double -> Bound
LP.LessEqual    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Double
choose) forall a. a -> [a] -> [a]
:
                  (Double -> Bound
LP.GreaterEqual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Double
choose) forall a. a -> [a] -> [a]
:
                  (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
                     (\Double
x Double
y -> Double -> Double -> Bound
LP.Between (forall a. Ord a => a -> a -> a
min Double
x Double
y) (forall a. Ord a => a -> a -> a
max Double
x Double
y))
                     Gen Double
choose Gen Double
choose) forall a. a -> [a] -> [a]
:
                  []))

genBounds ::
   (Shape.Indexed sh, Element a) =>
   Array sh a -> QC.Gen [LP.Inequality (Shape.Index sh)]
genBounds :: forall sh a.
(Indexed sh, Element a) =>
Array sh a -> Gen [Inequality (Index sh)]
genBounds Array sh a
origin =
   forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall sh a.
(Indexed sh, Storable a) =>
Array sh a -> [(Index sh, a)]
Array.toAssociations Array sh a
origin) forall a b. (a -> b) -> a -> b
$ \(Index sh
ix,a
x) ->
      forall x. x -> Bound -> Inequality x
LP.Inequality Index sh
ix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Double -> Double -> Bound
LP.Between
         (forall a. Element a => a -> Double
doubleFromElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (-a
100,-a
50))
         (forall a. Element a => a -> Double
doubleFromElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xforall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (a
50,a
100))

genVarShape :: QC.Gen (Shape.Range Char)
genVarShape :: Gen (Range Char)
genVarShape = forall n. n -> n -> Range n
Shape.Range Char
'a' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'a',Char
'j')

genOrigin :: QC.Gen (Array (Shape.Range Char) Int64)
genOrigin :: Gen (Array (Range Char) Int64)
genOrigin = forall sh a. (Indexed sh, Element a) => sh -> Gen (Array sh a)
genVector forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (Range Char)
genVarShape

_genOrigin :: QC.Gen (Array (Shape.Range Char) Double)
_genOrigin :: Gen (Array (Range Char) Double)
_genOrigin = forall sh a. (Indexed sh, Element a) => sh -> Gen (Array sh a)
genVector forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (Range Char)
genVarShape


_shrinkVarShape :: Shape.Range Char -> [Shape.Range Char]
_shrinkVarShape :: Range Char -> [Range Char]
_shrinkVarShape (Shape.Range Char
from Char
to) =
   if Char
fromforall a. Ord a => a -> a -> Bool
<Char
to then [forall n. n -> n -> Range n
Shape.Range Char
from (forall a. Enum a => a -> a
pred Char
to)] else []

shrinkOrigin ::
   (Storable a) => Array (Shape.Range Char) a -> [Array (Shape.Range Char) a]
shrinkOrigin :: forall a.
Storable a =>
Array (Range Char) a -> [Array (Range Char) a]
shrinkOrigin Array (Range Char) a
vec =
   case forall sh a. Array sh a -> sh
Array.shape Array (Range Char) a
vec of
      Shape.Range Char
from Char
to ->
         if Char
fromforall a. Ord a => a -> a -> Bool
<Char
to
            then [forall sh a.
(Indexed sh, Storable a) =>
sh -> (Index sh -> a) -> Array sh a
Array.sample (forall n. n -> n -> Range n
Shape.Range Char
from (forall a. Enum a => a -> a
pred Char
to)) (Array (Range Char) a
vecforall sh a.
(Indexed sh, Storable a) =>
Array sh a -> Index sh -> a
!)]
            else []


forAllOrigin ::
   (QC.Testable prop) =>
   (Array (Shape.Range Char) Int64 -> prop) -> QC.Property
forAllOrigin :: forall prop.
Testable prop =>
(Array (Range Char) Int64 -> prop) -> Property
forAllOrigin = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
QC.forAllShrink Gen (Array (Range Char) Int64)
genOrigin forall a.
Storable a =>
Array (Range Char) a -> [Array (Range Char) a]
shrinkOrigin


class (Storable a, Random a, Num a, Ord a) => Element a where
   doubleFromElement :: a -> Double

instance Element Double where
   doubleFromElement :: Double -> Double
doubleFromElement = forall a. a -> a
id

instance Element Int64 where
   doubleFromElement :: Int64 -> Double
doubleFromElement = forall a b. (Integral a, Num b) => a -> b
fromIntegral

genObjective ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Element a) =>
   Array sh a -> QC.Gen (LP.Direction, LP.Objective sh)
genObjective :: forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (Direction, Objective sh)
genObjective Array sh a
origin =
   forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) forall a. (Bounded a, Enum a) => Gen a
QC.arbitraryBoundedEnum
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall sh a b.
(C sh, Storable a, Storable b) =>
(a -> b) -> Array sh a -> Array sh b
Array.map forall a. Element a => a -> Double
doubleFromElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a -> a
asTypeOf Array sh a
origin) forall a b. (a -> b) -> a -> b
$
       forall sh a. (Indexed sh, Element a) => sh -> Gen (Array sh a)
genVector forall a b. (a -> b) -> a -> b
$ forall sh a. Array sh a -> sh
Array.shape Array sh a
origin)

genVector :: (Shape.Indexed sh, Element a) => sh -> QC.Gen (Array sh a)
genVector :: forall sh a. (Indexed sh, Element a) => sh -> Gen (Array sh a)
genVector sh
shape =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall sh a. (C sh, Storable a) => Array sh a -> Array sh a
Array.fromBoxed forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$
   forall sh a. Indexed sh => a -> sh -> [(Index sh, a)] -> Array sh a
BoxedArray.fromAssociations (forall a. Random a => (a, a) -> Gen a
QC.choose (-a
10,a
10)) sh
shape []
--    BoxedArray.constant shape (QC.choose (-10,10))

shrinkProblem ::
   (LP.Bounds ix, Constraints ix) ->
   [(LP.Bounds ix, Constraints ix)]
shrinkProblem :: forall ix.
(Bounds ix, Constraints ix) -> [(Bounds ix, Constraints ix)]
shrinkProblem (Bounds ix
bounds, Constraints ix
constraints) =
   forall a b. (a -> b) -> [a] -> [b]
map (\Constraints ix
shrinked -> (Bounds ix
bounds, Constraints ix
shrinked)) forall a b. (a -> b) -> a -> b
$
   forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a. (a -> [a]) -> [a] -> [[a]]
QC.shrinkList (forall a b. a -> b -> a
const []) Constraints ix
constraints

forAllProblem ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) =>
   (QC.Testable prop, Element a) =>
   Array sh a -> (LP.Bounds ix -> Constraints ix -> prop) -> QC.Property
forAllProblem :: forall sh ix prop a.
(Indexed sh, Index sh ~ ix, Show ix, Testable prop, Element a) =>
Array sh a -> (Bounds ix -> Constraints ix -> prop) -> Property
forAllProblem Array sh a
origin =
   forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
QC.forAllShrink (forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (Bounds ix, Constraints ix)
genProblem Array sh a
origin) forall ix.
(Bounds ix, Constraints ix) -> [(Bounds ix, Constraints ix)]
shrinkProblem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry

forAllBoundedProblem ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) =>
   (QC.Testable prop, Element a) =>
   Array sh a -> (LP.Bounds ix -> Constraints ix -> prop) -> QC.Property
forAllBoundedProblem :: forall sh ix prop a.
(Indexed sh, Index sh ~ ix, Show ix, Testable prop, Element a) =>
Array sh a -> (Bounds ix -> Constraints ix -> prop) -> Property
forAllBoundedProblem Array sh a
origin =
   forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
QC.forAllShrink (forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (Bounds ix, Constraints ix)
genBoundedProblem Array sh a
origin) forall ix.
(Bounds ix, Constraints ix) -> [(Bounds ix, Constraints ix)]
shrinkProblem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry


genObjectives ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Element a) =>
   Array sh a -> QC.Gen (NonEmpty.T [] (LP.Direction, [Term ix]))
genObjectives :: forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (T [] (Direction, [Term ix]))
genObjectives Array sh a
origin = do
   let shape :: sh
shape = forall sh a. Array sh a -> sh
Array.shape Array sh a
origin
   let stageRange :: (Int,Int)
       stageRange :: (Int, Int)
stageRange = (Int
0,Int
3)
   [(ix, Int)]
stages <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall sh. Indexed sh => sh -> [Index sh]
Shape.indices sh
shape) forall a b. (a -> b) -> a -> b
$ \ix
ix -> (,) ix
ix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (Int, Int)
stageRange
   let varSets :: T [] [ix]
varSets =
         forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"there should be at least one stage") forall a b. (a -> b) -> a -> b
$
         forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
NonEmpty.fetch forall a b. (a -> b) -> a -> b
$
         forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
         forall a b. (a -> b) -> [a] -> [b]
map (\Int
k -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
kforall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ix, Int)]
stages) forall a b. (a -> b) -> a -> b
$
         forall a. Ix a => (a, a) -> [a]
Ix.range (Int, Int)
stageRange
   let asTypeOfElement :: a -> f a -> a
       asTypeOfElement :: forall a (f :: * -> *). a -> f a -> a
asTypeOfElement = forall a b. a -> b -> a
const
   forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for T [] [ix]
varSets forall a b. (a -> b) -> a -> b
$ \[ix]
varSet ->
      forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
         forall a. (Bounded a, Enum a) => Gen a
QC.arbitraryBoundedEnum
         (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ix]
varSet forall a b. (a -> b) -> a -> b
$ \ix
ix ->
            (forall a ix. a -> ix -> Term a ix
.*ix
ix) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Element a => a -> Double
doubleFromElement
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (-a
10, a
10 forall a (f :: * -> *). a -> f a -> a
`asTypeOfElement` Array sh a
origin))

shrinkObjectives ::
   NonEmpty.T [] (LP.Direction, [Term ix]) ->
   [NonEmpty.T [] (LP.Direction, [Term ix])]
shrinkObjectives :: forall ix.
T [] (Direction, [Term ix]) -> [T [] (Direction, [Term ix])]
shrinkObjectives (NonEmpty.Cons (Direction, [Term ix])
obj [(Direction, [Term ix])]
objs) =
   forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. a -> f a -> T f a
NonEmpty.Cons (Direction, [Term ix])
obj) forall a b. (a -> b) -> a -> b
$
   forall a. (a -> [a]) -> [a] -> [[a]]
QC.shrinkList
      (\(Direction
dir,[Term ix]
terms) ->
         forall a b. (a -> b) -> [a] -> [b]
map ((,) Direction
dir) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
         forall a. (a -> [a]) -> [a] -> [[a]]
QC.shrinkList (forall a b. a -> b -> a
const []) [Term ix]
terms)
      [(Direction, [Term ix])]
objs

forAllObjectives ::
   (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) =>
   (QC.Testable prop, Element a) =>
   Array sh a ->
   (NonEmpty.T [] (LP.Direction, [Term (Shape.Index sh)]) -> prop) ->
   QC.Property
forAllObjectives :: forall sh ix prop a.
(Indexed sh, Index sh ~ ix, Show ix, Testable prop, Element a) =>
Array sh a
-> (T [] (Direction, [Term (Index sh)]) -> prop) -> Property
forAllObjectives Array sh a
origin =
   forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
QC.forAllShrink (forall sh ix a.
(Indexed sh, Index sh ~ ix, Element a) =>
Array sh a -> Gen (T [] (Direction, [Term ix]))
genObjectives Array sh a
origin) forall ix.
T [] (Direction, [Term ix]) -> [T [] (Direction, [Term ix])]
shrinkObjectives

constraintsFromSolution ::
   Double -> (LP.Direction, x) -> Double -> [LP.Inequality x]
constraintsFromSolution :: forall x. Double -> (Direction, x) -> Double -> [Inequality x]
constraintsFromSolution Double
tol (Direction
dir,x
obj) Double
opt =
   case Direction
dir of
      Direction
LP.Minimize -> [x
obj forall x. x -> Double -> Inequality x
<=. Double
opt forall a. Num a => a -> a -> a
+ Double
tol]
      Direction
LP.Maximize -> [x
obj forall x. x -> Double -> Inequality x
>=. Double
opt forall a. Num a => a -> a -> a
- Double
tol]

successiveObjectives ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Array sh a -> Double ->
   NonEmpty.T [] (LP.Direction, [Term ix]) ->
   ((LP.Direction, LP.Objective sh),
    [(Double -> Constraints ix, (LP.Direction, LP.Objective sh))])
successiveObjectives :: forall sh ix a.
(Indexed sh, Index sh ~ ix) =>
Array sh a
-> Double
-> T [] (Direction, [Term ix])
-> ((Direction, Objective sh),
    [(Double -> Constraints ix, (Direction, Objective sh))])
successiveObjectives Array sh a
origin Double
tol T [] (Direction, [Term ix])
xs =
   let shape :: sh
shape = forall sh a. Array sh a -> sh
Array.shape Array sh a
origin in
   (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> [Term Double ix] -> Objective sh
LP.objectiveFromTerms sh
shape) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. T f a -> a
NonEmpty.head T [] (Direction, [Term ix])
xs,
    forall (f :: * -> *) a b.
Traversable f =>
(a -> a -> b) -> T f a -> f b
NonEmpty.mapAdjacent
      (\(Direction
dir,[Term ix]
obj) (Direction, [Term ix])
y1 ->
         (forall x. Double -> (Direction, x) -> Double -> [Inequality x]
constraintsFromSolution Double
tol (Direction
dir,[Term ix]
obj),
          forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (forall sh ix.
(Indexed sh, Index sh ~ ix) =>
sh -> [Term Double ix] -> Objective sh
LP.objectiveFromTerms sh
shape) (Direction, [Term ix])
y1))
      T [] (Direction, [Term ix])
xs)


approxReal :: (Ord a, Num a) => a -> a -> a -> Bool
approxReal :: forall a. (Ord a, Num a) => a -> a -> a -> Bool
approxReal a
tol a
x a
y = forall a. Num a => a -> a
abs (a
xforall a. Num a => a -> a -> a
-a
y) forall a. Ord a => a -> a -> Bool
<= a
tol

approx :: (PrintfArg a, Ord a, Num a) => String -> a -> a -> a -> QC.Property
approx :: forall a.
(PrintfArg a, Ord a, Num a) =>
[Char] -> a -> a -> a -> Property
approx [Char]
name a
tol a
x a
y =
   forall prop. Testable prop => [Char] -> prop -> Property
QC.counterexample (forall r. PrintfType r => [Char] -> r
printf [Char]
"%s: %f - %f" [Char]
name a
x a
y) (forall a. (Ord a, Num a) => a -> a -> a -> Bool
approxReal a
tol a
x a
y)



checkBound :: Double -> LP.Bound -> Double -> QC.Property
checkBound :: Double -> Bound -> Double -> Property
checkBound Double
tol Bound
bound Double
x =
   forall prop. Testable prop => [Char] -> prop -> Property
QC.counterexample (forall a. Show a => a -> [Char]
show (Double
x, Bound
bound)) forall a b. (a -> b) -> a -> b
$
   case Bound
bound of
      LP.LessEqual Double
up -> Double
xforall a. Ord a => a -> a -> Bool
<=Double
upforall a. Num a => a -> a -> a
+Double
tol
      LP.GreaterEqual Double
lo -> Double
xforall a. Ord a => a -> a -> Bool
>=Double
loforall a. Num a => a -> a -> a
-Double
tol
      LP.Between Double
lo Double
up -> Double
loforall a. Num a => a -> a -> a
-Double
tolforall a. Ord a => a -> a -> Bool
<=Double
x Bool -> Bool -> Bool
&& Double
xforall a. Ord a => a -> a -> Bool
<=Double
upforall a. Num a => a -> a -> a
+Double
tol
      LP.Equal Double
y -> forall a. (Ord a, Num a) => a -> a -> a -> Bool
approxReal Double
tol Double
x Double
y
      Bound
LP.Free -> Bool
True

checkBounds ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Double -> LP.Bounds ix -> Array sh Double -> QC.Property
checkBounds :: forall sh ix.
(Indexed sh, Index sh ~ ix) =>
Double -> Bounds ix -> Array sh Double -> Property
checkBounds Double
tol Bounds ix
bounds Array sh Double
sol =
   forall prop. Testable prop => [prop] -> Property
QC.conjoin forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(ix
ix,Bound
bnd) -> Double -> Bound -> Double -> Property
checkBound Double
tol Bound
bnd (Array sh Double
solforall sh a.
(Indexed sh, Storable a) =>
Array sh a -> Index sh -> a
!ix
ix)) forall a b. (a -> b) -> a -> b
$
   forall sh a. Indexed sh => Array sh a -> [(Index sh, a)]
BoxedArray.toAssociations forall a b. (a -> b) -> a -> b
$
   forall sh a. Indexed sh => a -> sh -> [(Index sh, a)] -> Array sh a
BoxedArray.fromAssociations (Double -> Bound
LP.GreaterEqual Double
0) (forall sh a. Array sh a -> sh
Array.shape Array sh Double
sol) forall a b. (a -> b) -> a -> b
$
   forall a b. (a -> b) -> [a] -> [b]
map (\(LP.Inequality ix
ix Bound
bnd) -> (ix
ix,Bound
bnd)) Bounds ix
bounds

checkContraint ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Double -> LP.Inequality [LP.Term Double ix] -> Array sh Double -> QC.Property
checkContraint :: forall sh ix.
(Indexed sh, Index sh ~ ix) =>
Double
-> Inequality [Term Double ix] -> Array sh Double -> Property
checkContraint Double
tol (LP.Inequality [Term Double ix]
terms Bound
bnd) Array sh Double
sol =
   Double -> Bound -> Double -> Property
checkBound Double
tol Bound
bnd forall a b. (a -> b) -> a -> b
$
   forall sh ix a.
(Indexed sh, Index sh ~ ix, Storable a, Num a) =>
[(a, ix)] -> Array sh a -> a
scalarProductTerms (forall a b. (a -> b) -> [a] -> [b]
map (\(LP.Term Double
c ix
ix) -> (Double
c,ix
ix)) [Term Double ix]
terms) Array sh Double
sol

checkFeasibility ::
   (Shape.Indexed sh, Shape.Index sh ~ ix) =>
   Double -> LP.Bounds ix -> Constraints ix -> Array sh Double -> QC.Property
checkFeasibility :: forall sh ix.
(Indexed sh, Index sh ~ ix) =>
Double
-> Bounds ix -> Constraints ix -> Array sh Double -> Property
checkFeasibility Double
tol Bounds ix
bounds Constraints ix
constrs Array sh Double
sol =
   forall sh ix.
(Indexed sh, Index sh ~ ix) =>
Double -> Bounds ix -> Array sh Double -> Property
checkBounds Double
tol Bounds ix
bounds Array sh Double
sol
   forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
   forall prop. Testable prop => [prop] -> Property
QC.conjoin (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall sh ix.
(Indexed sh, Index sh ~ ix) =>
Double
-> Inequality [Term Double ix] -> Array sh Double -> Property
checkContraint Double
tol) Array sh Double
sol) Constraints ix
constrs)


affineCombination ::
   (Shape.C sh, Eq sh, Storable a, Num a) =>
   a -> Array sh a -> Array sh a -> Array sh a
affineCombination :: forall sh a.
(C sh, Eq sh, Storable a, Num a) =>
a -> Array sh a -> Array sh a -> Array sh a
affineCombination a
c Array sh a
x Array sh a
y =
   forall sh a b c.
(C sh, Eq sh, Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Array sh a -> Array sh b -> Array sh c
Array.zipWith forall a. Num a => a -> a -> a
(+) (forall sh a b.
(C sh, Storable a, Storable b) =>
(a -> b) -> Array sh a -> Array sh b
Array.map ((a
1forall a. Num a => a -> a -> a
-a
c)forall a. Num a => a -> a -> a
*) Array sh a
x) (forall sh a b.
(C sh, Storable a, Storable b) =>
(a -> b) -> Array sh a -> Array sh b
Array.map (a
cforall a. Num a => a -> a -> a
*) Array sh a
y)

scalarProduct ::
   (Shape.C sh, Eq sh, Storable a, Num a) =>
   Array sh a -> Array sh a -> a
scalarProduct :: forall sh a.
(C sh, Eq sh, Storable a, Num a) =>
Array sh a -> Array sh a -> a
scalarProduct Array sh a
x Array sh a
y = forall sh a. (C sh, Storable a, Num a) => Array sh a -> a
Array.sum forall a b. (a -> b) -> a -> b
$ forall sh a b c.
(C sh, Eq sh, Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Array sh a -> Array sh b -> Array sh c
Array.zipWith forall a. Num a => a -> a -> a
(*) Array sh a
x Array sh a
y