{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Converter.QUBO
-- Copyright   :  (c) Masahiro Sakai 2018
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module ToySolver.Converter.QUBO
  ( qubo2pb
  , QUBO2PBInfo (..)

  , pb2qubo
  , PB2QUBOInfo

  , pbAsQUBO
  , PBAsQUBOInfo (..)

  , qubo2ising
  , QUBO2IsingInfo (..)

  , ising2qubo
  , Ising2QUBOInfo (..)
  ) where

import Control.Monad
import Control.Monad.State
import Data.Array.Unboxed
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import Data.List
import Data.Maybe
import qualified Data.PseudoBoolean as PBFile
import Data.Ratio
import ToySolver.Converter.Base
import ToySolver.Converter.PB (pb2qubo', PB2QUBOInfo')
import qualified ToySolver.QUBO as QUBO
import qualified ToySolver.SAT.Types as SAT

-- -----------------------------------------------------------------------------

qubo2pb :: Real a => QUBO.Problem a -> (PBFile.Formula, QUBO2PBInfo a)
qubo2pb :: forall a. Real a => Problem a -> (Formula, QUBO2PBInfo a)
qubo2pb Problem a
prob =
  ( PBFile.Formula
    { pbObjectiveFunction :: Maybe Sum
PBFile.pbObjectiveFunction = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
        [ (Integer
c, if Key
x1forall a. Eq a => a -> a -> Bool
==Key
x2 then [Key
x1forall a. Num a => a -> a -> a
+Key
1] else [Key
x1forall a. Num a => a -> a -> a
+Key
1, Key
x2forall a. Num a => a -> a -> a
+Key
1])
        | (Key
x1, IntMap Integer
row) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap Integer)
m2
        , (Key
x2, Integer
c) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap Integer
row
        ]
    , pbConstraints :: [Constraint]
PBFile.pbConstraints = []
    , pbNumVars :: Key
PBFile.pbNumVars = forall a. Problem a -> Key
QUBO.quboNumVars Problem a
prob
    , pbNumConstraints :: Key
PBFile.pbNumConstraints = Key
0
    }
  , forall a. Integer -> QUBO2PBInfo a
QUBO2PBInfo Integer
d
  )
  where
    m1 :: IntMap (IntMap Rational)
m1 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Real a => a -> Rational
toRational) forall a b. (a -> b) -> a -> b
$ forall a. Problem a -> IntMap (IntMap a)
QUBO.quboMatrix Problem a
prob
    d :: Integer
d = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Integral a => a -> a -> a
lcm Integer
1 [forall a. Ratio a -> a
denominator Rational
c | IntMap Rational
row <- forall a. IntMap a -> [a]
IntMap.elems IntMap (IntMap Rational)
m1, Rational
c <- forall a. IntMap a -> [a]
IntMap.elems IntMap Rational
row, Rational
c forall a. Eq a => a -> a -> Bool
/= Rational
0]
    m2 :: IntMap (IntMap Integer)
m2 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Rational
c -> forall a. Ratio a -> a
numerator Rational
c forall a. Num a => a -> a -> a
* (Integer
d ` div` forall a. Ratio a -> a
denominator Rational
c))) IntMap (IntMap Rational)
m1

newtype QUBO2PBInfo a = QUBO2PBInfo Integer
  deriving (QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
$c/= :: forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
== :: QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
$c== :: forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
Eq, Key -> QUBO2PBInfo a -> ShowS
forall a. Key -> QUBO2PBInfo a -> ShowS
forall a. [QUBO2PBInfo a] -> ShowS
forall a. QUBO2PBInfo a -> String
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QUBO2PBInfo a] -> ShowS
$cshowList :: forall a. [QUBO2PBInfo a] -> ShowS
show :: QUBO2PBInfo a -> String
$cshow :: forall a. QUBO2PBInfo a -> String
showsPrec :: Key -> QUBO2PBInfo a -> ShowS
$cshowsPrec :: forall a. Key -> QUBO2PBInfo a -> ShowS
Show, ReadPrec [QUBO2PBInfo a]
ReadPrec (QUBO2PBInfo a)
ReadS [QUBO2PBInfo a]
forall a. ReadPrec [QUBO2PBInfo a]
forall a. ReadPrec (QUBO2PBInfo a)
forall a. Key -> ReadS (QUBO2PBInfo a)
forall a. ReadS [QUBO2PBInfo a]
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [QUBO2PBInfo a]
$creadListPrec :: forall a. ReadPrec [QUBO2PBInfo a]
readPrec :: ReadPrec (QUBO2PBInfo a)
$creadPrec :: forall a. ReadPrec (QUBO2PBInfo a)
readList :: ReadS [QUBO2PBInfo a]
$creadList :: forall a. ReadS [QUBO2PBInfo a]
readsPrec :: Key -> ReadS (QUBO2PBInfo a)
$creadsPrec :: forall a. Key -> ReadS (QUBO2PBInfo a)
Read)

instance (Eq a, Show a, Read a) => Transformer (QUBO2PBInfo a) where
  type Source (QUBO2PBInfo a) = QUBO.Solution
  type Target (QUBO2PBInfo a) = SAT.Model

instance (Eq a, Show a, Read a) => ForwardTransformer (QUBO2PBInfo a) where
  transformForward :: QUBO2PBInfo a -> Source (QUBO2PBInfo a) -> Target (QUBO2PBInfo a)
transformForward (QUBO2PBInfo Integer
_) Source (QUBO2PBInfo a)
sol = forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbforall a. Num a => a -> a -> a
+Key
1,Key
ubforall a. Num a => a -> a -> a
+Key
1) (forall a. Num a => a -> a -> a
subtract Key
1) Source (QUBO2PBInfo a)
sol
    where
      (Key
lb,Key
ub) = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Source (QUBO2PBInfo a)
sol

instance (Eq a, Show a, Read a) => BackwardTransformer (QUBO2PBInfo a) where
  transformBackward :: QUBO2PBInfo a -> Target (QUBO2PBInfo a) -> Source (QUBO2PBInfo a)
transformBackward (QUBO2PBInfo Integer
_) Target (QUBO2PBInfo a)
m = forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbforall a. Num a => a -> a -> a
-Key
1,Key
ubforall a. Num a => a -> a -> a
-Key
1) (forall a. Num a => a -> a -> a
+Key
1) Target (QUBO2PBInfo a)
m
    where
      (Key
lb,Key
ub) = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Target (QUBO2PBInfo a)
m

instance (Eq a, Show a, Read a) => ObjValueTransformer (QUBO2PBInfo a) where
  type SourceObjValue (QUBO2PBInfo a) = a
  type TargetObjValue (QUBO2PBInfo a) = Integer

instance (Eq a, Show a, Read a, Real a) => ObjValueForwardTransformer (QUBO2PBInfo a) where
  transformObjValueForward :: QUBO2PBInfo a
-> SourceObjValue (QUBO2PBInfo a) -> TargetObjValue (QUBO2PBInfo a)
transformObjValueForward (QUBO2PBInfo Integer
d) SourceObjValue (QUBO2PBInfo a)
obj = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Real a => a -> Rational
toRational SourceObjValue (QUBO2PBInfo a)
obj) forall a. Num a => a -> a -> a
* Integer
d

instance (Eq a, Show a, Read a, Num a) => ObjValueBackwardTransformer (QUBO2PBInfo a) where
  transformObjValueBackward :: QUBO2PBInfo a
-> TargetObjValue (QUBO2PBInfo a) -> SourceObjValue (QUBO2PBInfo a)
transformObjValueBackward (QUBO2PBInfo Integer
d) TargetObjValue (QUBO2PBInfo a)
obj = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ (TargetObjValue (QUBO2PBInfo a)
obj forall a. Num a => a -> a -> a
+ Integer
d forall a. Num a => a -> a -> a
- Integer
1) forall a. Integral a => a -> a -> a
`div` Integer
d

-- -----------------------------------------------------------------------------

pbAsQUBO :: forall a. Real a => PBFile.Formula -> Maybe (QUBO.Problem a, PBAsQUBOInfo a)
pbAsQUBO :: forall a. Real a => Formula -> Maybe (Problem a, PBAsQUBOInfo a)
pbAsQUBO Formula
formula = do
  (Problem a
prob, Integer
offset) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT Integer Maybe (Problem a)
body Integer
0
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Problem a
prob, forall a. Integer -> PBAsQUBOInfo a
PBAsQUBOInfo Integer
offset)
  where
    body :: StateT Integer Maybe (QUBO.Problem a)
    body :: StateT Integer Maybe (Problem a)
body = do
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Formula -> [Constraint]
PBFile.pbConstraints Formula
formula)
      let f :: PBFile.WeightedTerm -> StateT Integer Maybe [(Integer, Int, Int)]
          f :: WeightedTerm -> StateT Integer Maybe [(Integer, Key, Key)]
f (Integer
c,[]) = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+Integer
c) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
          f (Integer
c,[Key
x]) = forall (m :: * -> *) a. Monad m => a -> m a
return [(Integer
c,Key
x,Key
x)]
          f (Integer
c,[Key
x1,Key
x2]) = forall (m :: * -> *) a. Monad m => a -> m a
return [(Integer
c,Key
x1,Key
x2)]
          f WeightedTerm
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
      [[(Integer, Key, Key)]]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WeightedTerm -> StateT Integer Maybe [(Integer, Key, Key)]
f forall a b. (a -> b) -> a -> b
$ Sum -> Sum
SAT.removeNegationFromPBSum forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ Formula -> Maybe Sum
PBFile.pbObjectiveFunction Formula
formula
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        QUBO.Problem
        { quboNumVars :: Key
QUBO.quboNumVars = Formula -> Key
PBFile.pbNumVars Formula
formula
        , quboMatrix :: IntMap (IntMap a)
QUBO.quboMatrix = forall a. (Eq a, Num a) => [(Key, Key, a)] -> IntMap (IntMap a)
mkMat forall a b. (a -> b) -> a -> b
$
            [ (Key
x1', Key
x2', forall a. Num a => Integer -> a
fromInteger Integer
c)
            | (Integer
c,Key
x1,Key
x2) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Integer, Key, Key)]]
xs, let x1' :: Key
x1' = forall a. Ord a => a -> a -> a
min Key
x1 Key
x2 forall a. Num a => a -> a -> a
- Key
1, let x2' :: Key
x2' = forall a. Ord a => a -> a -> a
max Key
x1 Key
x2 forall a. Num a => a -> a -> a
- Key
1
            ]
        }

data PBAsQUBOInfo a = PBAsQUBOInfo !Integer
  deriving (PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
$c/= :: forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
== :: PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
$c== :: forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
Eq, Key -> PBAsQUBOInfo a -> ShowS
forall a. Key -> PBAsQUBOInfo a -> ShowS
forall a. [PBAsQUBOInfo a] -> ShowS
forall a. PBAsQUBOInfo a -> String
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PBAsQUBOInfo a] -> ShowS
$cshowList :: forall a. [PBAsQUBOInfo a] -> ShowS
show :: PBAsQUBOInfo a -> String
$cshow :: forall a. PBAsQUBOInfo a -> String
showsPrec :: Key -> PBAsQUBOInfo a -> ShowS
$cshowsPrec :: forall a. Key -> PBAsQUBOInfo a -> ShowS
Show, ReadPrec [PBAsQUBOInfo a]
ReadPrec (PBAsQUBOInfo a)
ReadS [PBAsQUBOInfo a]
forall a. ReadPrec [PBAsQUBOInfo a]
forall a. ReadPrec (PBAsQUBOInfo a)
forall a. Key -> ReadS (PBAsQUBOInfo a)
forall a. ReadS [PBAsQUBOInfo a]
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PBAsQUBOInfo a]
$creadListPrec :: forall a. ReadPrec [PBAsQUBOInfo a]
readPrec :: ReadPrec (PBAsQUBOInfo a)
$creadPrec :: forall a. ReadPrec (PBAsQUBOInfo a)
readList :: ReadS [PBAsQUBOInfo a]
$creadList :: forall a. ReadS [PBAsQUBOInfo a]
readsPrec :: Key -> ReadS (PBAsQUBOInfo a)
$creadsPrec :: forall a. Key -> ReadS (PBAsQUBOInfo a)
Read)

instance Transformer (PBAsQUBOInfo a) where
  type Source (PBAsQUBOInfo a) = SAT.Model
  type Target (PBAsQUBOInfo a) = QUBO.Solution

instance ForwardTransformer (PBAsQUBOInfo a) where
  transformForward :: PBAsQUBOInfo a
-> Source (PBAsQUBOInfo a) -> Target (PBAsQUBOInfo a)
transformForward (PBAsQUBOInfo Integer
_offset) Source (PBAsQUBOInfo a)
m = forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbforall a. Num a => a -> a -> a
-Key
1,Key
ubforall a. Num a => a -> a -> a
-Key
1) (forall a. Num a => a -> a -> a
+Key
1) Source (PBAsQUBOInfo a)
m
    where
      (Key
lb,Key
ub) = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Source (PBAsQUBOInfo a)
m

instance BackwardTransformer (PBAsQUBOInfo a) where
  transformBackward :: PBAsQUBOInfo a
-> Target (PBAsQUBOInfo a) -> Source (PBAsQUBOInfo a)
transformBackward (PBAsQUBOInfo Integer
_offset) Target (PBAsQUBOInfo a)
sol = forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbforall a. Num a => a -> a -> a
+Key
1,Key
ubforall a. Num a => a -> a -> a
+Key
1) (forall a. Num a => a -> a -> a
subtract Key
1) Target (PBAsQUBOInfo a)
sol
    where
      (Key
lb,Key
ub) = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Target (PBAsQUBOInfo a)
sol

instance ObjValueTransformer (PBAsQUBOInfo a) where
  type SourceObjValue (PBAsQUBOInfo a) = Integer
  type TargetObjValue (PBAsQUBOInfo a) = a

instance Num a => ObjValueForwardTransformer (PBAsQUBOInfo a) where
  transformObjValueForward :: PBAsQUBOInfo a
-> SourceObjValue (PBAsQUBOInfo a)
-> TargetObjValue (PBAsQUBOInfo a)
transformObjValueForward (PBAsQUBOInfo Integer
offset) SourceObjValue (PBAsQUBOInfo a)
obj = forall a. Num a => Integer -> a
fromInteger (SourceObjValue (PBAsQUBOInfo a)
obj forall a. Num a => a -> a -> a
- Integer
offset)

instance Real a => ObjValueBackwardTransformer (PBAsQUBOInfo a) where
  transformObjValueBackward :: PBAsQUBOInfo a
-> TargetObjValue (PBAsQUBOInfo a)
-> SourceObjValue (PBAsQUBOInfo a)
transformObjValueBackward (PBAsQUBOInfo Integer
offset) TargetObjValue (PBAsQUBOInfo a)
obj = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Real a => a -> Rational
toRational TargetObjValue (PBAsQUBOInfo a)
obj) forall a. Num a => a -> a -> a
+ Integer
offset

-- -----------------------------------------------------------------------------

pb2qubo :: Real a => PBFile.Formula -> ((QUBO.Problem a, a), PB2QUBOInfo a)
pb2qubo :: forall a. Real a => Formula -> ((Problem a, a), PB2QUBOInfo a)
pb2qubo Formula
formula = ((Problem a
qubo, forall a. Num a => Integer -> a
fromInteger (Integer
th forall a. Num a => a -> a -> a
- Integer
offset)), forall a b. a -> b -> ComposedTransformer a b
ComposedTransformer PB2QUBOInfo'
info1 PBAsQUBOInfo a
info2)
  where
    ((Formula
qubo', Integer
th), PB2QUBOInfo'
info1) = Formula -> ((Formula, Integer), PB2QUBOInfo')
pb2qubo' Formula
formula
    Just (Problem a
qubo, info2 :: PBAsQUBOInfo a
info2@(PBAsQUBOInfo Integer
offset)) = forall a. Real a => Formula -> Maybe (Problem a, PBAsQUBOInfo a)
pbAsQUBO Formula
qubo'

type PB2QUBOInfo a = ComposedTransformer PB2QUBOInfo' (PBAsQUBOInfo a)

-- -----------------------------------------------------------------------------

qubo2ising :: (Eq a, Show a, Fractional a) => QUBO.Problem a -> (QUBO.IsingModel a, QUBO2IsingInfo a)
qubo2ising :: forall a.
(Eq a, Show a, Fractional a) =>
Problem a -> (IsingModel a, QUBO2IsingInfo a)
qubo2ising QUBO.Problem{ quboNumVars :: forall a. Problem a -> Key
QUBO.quboNumVars = Key
n, quboMatrix :: forall a. Problem a -> IntMap (IntMap a)
QUBO.quboMatrix = IntMap (IntMap a)
qq } =
  ( QUBO.IsingModel
    { isingNumVars :: Key
QUBO.isingNumVars = Key
n
    , isingInteraction :: IntMap (IntMap a)
QUBO.isingInteraction = forall a. (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat forall a b. (a -> b) -> a -> b
$ IntMap (IntMap a)
jj'
    , isingExternalMagneticField :: IntMap a
QUBO.isingExternalMagneticField = forall a. (Eq a, Num a) => IntMap a -> IntMap a
normalizeVec IntMap a
h'
    }
  , forall a. a -> QUBO2IsingInfo a
QUBO2IsingInfo a
c'
  )
  where
    {-
       Let xi = (si + 1)/2.

       Then,
         Qij xi xj
       = Qij (si + 1)/2 (sj + 1)/2
       = 1/4 Qij (si sj + si + sj + 1).

       Also,
         Qii xi xi
       = Qii (si + 1)/2 (si + 1)/2
       = 1/4 Qii (si si + 2 si + 1)
       = 1/4 Qii (2 si + 2).
    -}
    (IntMap (IntMap a)
jj', IntMap a
h', a
c') = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {a} {c}.
(Num a, Num a, Num c) =>
(IntMap (IntMap a), IntMap a, c)
-> (IntMap (IntMap a), IntMap a, c)
-> (IntMap (IntMap a), IntMap a, c)
f (forall a. IntMap a
IntMap.empty, forall a. IntMap a
IntMap.empty, a
0) forall a b. (a -> b) -> a -> b
$ do
      (Key
i, IntMap a
row)  <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap a)
qq
      (Key
j, a
q_ij) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
row
      if Key
i forall a. Eq a => a -> a -> Bool
/= Key
j then
        forall (m :: * -> *) a. Monad m => a -> m a
return
          ( forall a. Key -> a -> IntMap a
IntMap.singleton (forall a. Ord a => a -> a -> a
min Key
i Key
j) forall a b. (a -> b) -> a -> b
$ forall a. Key -> a -> IntMap a
IntMap.singleton (forall a. Ord a => a -> a -> a
max Key
i Key
j) (a
q_ij forall a. Fractional a => a -> a -> a
/ a
4)
          , forall a. [(Key, a)] -> IntMap a
IntMap.fromList [(Key
i, a
q_ij forall a. Fractional a => a -> a -> a
/ a
4), (Key
j, a
q_ij forall a. Fractional a => a -> a -> a
/ a
4)]
          , a
q_ij forall a. Fractional a => a -> a -> a
/ a
4
          )
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return
          ( forall a. IntMap a
IntMap.empty
          , forall a. Key -> a -> IntMap a
IntMap.singleton Key
i (a
q_ij forall a. Fractional a => a -> a -> a
/ a
2)
          , a
q_ij forall a. Fractional a => a -> a -> a
/ a
2
          )

    f :: (IntMap (IntMap a), IntMap a, c)
-> (IntMap (IntMap a), IntMap a, c)
-> (IntMap (IntMap a), IntMap a, c)
f (IntMap (IntMap a)
jj1, IntMap a
h1, c
c1) (IntMap (IntMap a)
jj2, IntMap a
h2, c
c2) =
      ( forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith (forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith forall a. Num a => a -> a -> a
(+)) IntMap (IntMap a)
jj1 IntMap (IntMap a)
jj2
      , forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith forall a. Num a => a -> a -> a
(+) IntMap a
h1 IntMap a
h2
      , c
c1forall a. Num a => a -> a -> a
+c
c2
      )

data QUBO2IsingInfo a = QUBO2IsingInfo a
  deriving (QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
forall a. Eq a => QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
$c/= :: forall a. Eq a => QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
== :: QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
$c== :: forall a. Eq a => QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
Eq, Key -> QUBO2IsingInfo a -> ShowS
forall a. Show a => Key -> QUBO2IsingInfo a -> ShowS
forall a. Show a => [QUBO2IsingInfo a] -> ShowS
forall a. Show a => QUBO2IsingInfo a -> String
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QUBO2IsingInfo a] -> ShowS
$cshowList :: forall a. Show a => [QUBO2IsingInfo a] -> ShowS
show :: QUBO2IsingInfo a -> String
$cshow :: forall a. Show a => QUBO2IsingInfo a -> String
showsPrec :: Key -> QUBO2IsingInfo a -> ShowS
$cshowsPrec :: forall a. Show a => Key -> QUBO2IsingInfo a -> ShowS
Show, ReadPrec [QUBO2IsingInfo a]
ReadPrec (QUBO2IsingInfo a)
ReadS [QUBO2IsingInfo a]
forall a. Read a => ReadPrec [QUBO2IsingInfo a]
forall a. Read a => ReadPrec (QUBO2IsingInfo a)
forall a. Read a => Key -> ReadS (QUBO2IsingInfo a)
forall a. Read a => ReadS [QUBO2IsingInfo a]
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [QUBO2IsingInfo a]
$creadListPrec :: forall a. Read a => ReadPrec [QUBO2IsingInfo a]
readPrec :: ReadPrec (QUBO2IsingInfo a)
$creadPrec :: forall a. Read a => ReadPrec (QUBO2IsingInfo a)
readList :: ReadS [QUBO2IsingInfo a]
$creadList :: forall a. Read a => ReadS [QUBO2IsingInfo a]
readsPrec :: Key -> ReadS (QUBO2IsingInfo a)
$creadsPrec :: forall a. Read a => Key -> ReadS (QUBO2IsingInfo a)
Read)

instance (Eq a, Show a) => Transformer (QUBO2IsingInfo a) where
  type Source (QUBO2IsingInfo a) = QUBO.Solution
  type Target (QUBO2IsingInfo a) = QUBO.Solution

instance (Eq a, Show a) => ForwardTransformer (QUBO2IsingInfo a) where
  transformForward :: QUBO2IsingInfo a
-> Source (QUBO2IsingInfo a) -> Target (QUBO2IsingInfo a)
transformForward QUBO2IsingInfo a
_ Source (QUBO2IsingInfo a)
sol = Source (QUBO2IsingInfo a)
sol

instance (Eq a, Show a) => BackwardTransformer (QUBO2IsingInfo a) where
  transformBackward :: QUBO2IsingInfo a
-> Target (QUBO2IsingInfo a) -> Source (QUBO2IsingInfo a)
transformBackward QUBO2IsingInfo a
_ Target (QUBO2IsingInfo a)
sol = Target (QUBO2IsingInfo a)
sol

instance ObjValueTransformer (QUBO2IsingInfo a) where
  type SourceObjValue (QUBO2IsingInfo a) = a
  type TargetObjValue (QUBO2IsingInfo a) = a

instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (QUBO2IsingInfo a) where
  transformObjValueForward :: QUBO2IsingInfo a
-> SourceObjValue (QUBO2IsingInfo a)
-> TargetObjValue (QUBO2IsingInfo a)
transformObjValueForward (QUBO2IsingInfo a
offset) SourceObjValue (QUBO2IsingInfo a)
obj = SourceObjValue (QUBO2IsingInfo a)
obj forall a. Num a => a -> a -> a
- a
offset

instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (QUBO2IsingInfo a) where
  transformObjValueBackward :: QUBO2IsingInfo a
-> TargetObjValue (QUBO2IsingInfo a)
-> SourceObjValue (QUBO2IsingInfo a)
transformObjValueBackward (QUBO2IsingInfo a
offset) TargetObjValue (QUBO2IsingInfo a)
obj = TargetObjValue (QUBO2IsingInfo a)
obj forall a. Num a => a -> a -> a
+ a
offset

-- -----------------------------------------------------------------------------

ising2qubo :: (Eq a, Num a) => QUBO.IsingModel a -> (QUBO.Problem a, Ising2QUBOInfo a)
ising2qubo :: forall a.
(Eq a, Num a) =>
IsingModel a -> (Problem a, Ising2QUBOInfo a)
ising2qubo QUBO.IsingModel{ isingNumVars :: forall a. IsingModel a -> Key
QUBO.isingNumVars = Key
n, isingInteraction :: forall a. IsingModel a -> IntMap (IntMap a)
QUBO.isingInteraction = IntMap (IntMap a)
jj, isingExternalMagneticField :: forall a. IsingModel a -> IntMap a
QUBO.isingExternalMagneticField = IntMap a
h } =
  ( QUBO.Problem
    { quboNumVars :: Key
QUBO.quboNumVars = Key
n
    , quboMatrix :: IntMap (IntMap a)
QUBO.quboMatrix = forall a. (Eq a, Num a) => [(Key, Key, a)] -> IntMap (IntMap a)
mkMat [(Key, Key, a)]
m
    }
  , forall a. a -> Ising2QUBOInfo a
Ising2QUBOInfo a
offset
  )
  where
    {-
       Let si = 2 xi - 1

       Then,
         Jij si sj
       = Jij (2 xi - 1) (2 xj - 1)
       = Jij (4 xi xj - 2 xi - 2 xj + 1)
       = 4 Jij xi xj - 2 Jij xi    - 2 Jij xj    + Jij
       = 4 Jij xi xj - 2 Jij xi xi - 2 Jij xj xj + Jij

         hi si
       = hi (2 xi - 1)
       = 2 hi xi - hi
       = 2 hi xi xi - hi
    -}
    m :: [(Key, Key, a)]
m =
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [(Key
i, Key
j, a
4 forall a. Num a => a -> a -> a
* a
jj_ij), (Key
i, Key
i,  - a
2 forall a. Num a => a -> a -> a
* a
jj_ij), (Key
j, Key
j,  - a
2 forall a. Num a => a -> a -> a
* a
jj_ij)]
      | (Key
i, IntMap a
row) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap a)
jj, (Key
j, a
jj_ij) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
row
      ] forall a. [a] -> [a] -> [a]
++
      [ (Key
i, Key
i,  a
2 forall a. Num a => a -> a -> a
* a
hi) | (Key
i, a
hi) <- forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
h ]
    offset :: a
offset =
        forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a
jj_ij | IntMap a
row <- forall a. IntMap a -> [a]
IntMap.elems IntMap (IntMap a)
jj, a
jj_ij <- forall a. IntMap a -> [a]
IntMap.elems IntMap a
row]
      forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a. IntMap a -> [a]
IntMap.elems IntMap a
h)

data Ising2QUBOInfo a = Ising2QUBOInfo a
  deriving (Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
forall a. Eq a => Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
$c/= :: forall a. Eq a => Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
== :: Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
$c== :: forall a. Eq a => Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
Eq, Key -> Ising2QUBOInfo a -> ShowS
forall a. Show a => Key -> Ising2QUBOInfo a -> ShowS
forall a. Show a => [Ising2QUBOInfo a] -> ShowS
forall a. Show a => Ising2QUBOInfo a -> String
forall a.
(Key -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ising2QUBOInfo a] -> ShowS
$cshowList :: forall a. Show a => [Ising2QUBOInfo a] -> ShowS
show :: Ising2QUBOInfo a -> String
$cshow :: forall a. Show a => Ising2QUBOInfo a -> String
showsPrec :: Key -> Ising2QUBOInfo a -> ShowS
$cshowsPrec :: forall a. Show a => Key -> Ising2QUBOInfo a -> ShowS
Show, ReadPrec [Ising2QUBOInfo a]
ReadPrec (Ising2QUBOInfo a)
ReadS [Ising2QUBOInfo a]
forall a. Read a => ReadPrec [Ising2QUBOInfo a]
forall a. Read a => ReadPrec (Ising2QUBOInfo a)
forall a. Read a => Key -> ReadS (Ising2QUBOInfo a)
forall a. Read a => ReadS [Ising2QUBOInfo a]
forall a.
(Key -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Ising2QUBOInfo a]
$creadListPrec :: forall a. Read a => ReadPrec [Ising2QUBOInfo a]
readPrec :: ReadPrec (Ising2QUBOInfo a)
$creadPrec :: forall a. Read a => ReadPrec (Ising2QUBOInfo a)
readList :: ReadS [Ising2QUBOInfo a]
$creadList :: forall a. Read a => ReadS [Ising2QUBOInfo a]
readsPrec :: Key -> ReadS (Ising2QUBOInfo a)
$creadsPrec :: forall a. Read a => Key -> ReadS (Ising2QUBOInfo a)
Read)

instance (Eq a, Show a) => Transformer (Ising2QUBOInfo a) where
  type Source (Ising2QUBOInfo a) = QUBO.Solution
  type Target (Ising2QUBOInfo a) = QUBO.Solution

instance (Eq a, Show a) => ForwardTransformer (Ising2QUBOInfo a) where
  transformForward :: Ising2QUBOInfo a
-> Source (Ising2QUBOInfo a) -> Target (Ising2QUBOInfo a)
transformForward Ising2QUBOInfo a
_ Source (Ising2QUBOInfo a)
sol = Source (Ising2QUBOInfo a)
sol

instance (Eq a, Show a) => BackwardTransformer (Ising2QUBOInfo a) where
  transformBackward :: Ising2QUBOInfo a
-> Target (Ising2QUBOInfo a) -> Source (Ising2QUBOInfo a)
transformBackward Ising2QUBOInfo a
_ Target (Ising2QUBOInfo a)
sol = Target (Ising2QUBOInfo a)
sol

instance (Eq a, Show a) => ObjValueTransformer (Ising2QUBOInfo a) where
  type SourceObjValue (Ising2QUBOInfo a) = a
  type TargetObjValue (Ising2QUBOInfo a) = a

instance (Eq a, Show a, Num a) => ObjValueForwardTransformer (Ising2QUBOInfo a) where
  transformObjValueForward :: Ising2QUBOInfo a
-> SourceObjValue (Ising2QUBOInfo a)
-> TargetObjValue (Ising2QUBOInfo a)
transformObjValueForward (Ising2QUBOInfo a
offset) SourceObjValue (Ising2QUBOInfo a)
obj = SourceObjValue (Ising2QUBOInfo a)
obj forall a. Num a => a -> a -> a
- a
offset

instance (Eq a, Show a, Num a) => ObjValueBackwardTransformer (Ising2QUBOInfo a) where
  transformObjValueBackward :: Ising2QUBOInfo a
-> TargetObjValue (Ising2QUBOInfo a)
-> SourceObjValue (Ising2QUBOInfo a)
transformObjValueBackward (Ising2QUBOInfo a
offset) TargetObjValue (Ising2QUBOInfo a)
obj = TargetObjValue (Ising2QUBOInfo a)
obj forall a. Num a => a -> a -> a
+ a
offset

-- -----------------------------------------------------------------------------

mkMat :: (Eq a, Num a) => [(Int,Int,a)] -> IntMap (IntMap a)
mkMat :: forall a. (Eq a, Num a) => [(Key, Key, a)] -> IntMap (IntMap a)
mkMat [(Key, Key, a)]
m = forall a. (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IntMap.unionsWith (forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith forall a. Num a => a -> a -> a
(+)) forall a b. (a -> b) -> a -> b
$
  [forall a. Key -> a -> IntMap a
IntMap.singleton Key
i (forall a. Key -> a -> IntMap a
IntMap.singleton Key
j a
qij) | (Key
i,Key
j,a
qij) <- [(Key, Key, a)]
m]

normalizeMat :: (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat :: forall a. (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat = forall a b. (a -> Maybe b) -> IntMap a -> IntMap b
IntMap.mapMaybe ((\IntMap a
m -> if forall a. IntMap a -> Bool
IntMap.null IntMap a
m then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just IntMap a
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => IntMap a -> IntMap a
normalizeVec)

normalizeVec :: (Eq a, Num a) => IntMap a -> IntMap a
normalizeVec :: forall a. (Eq a, Num a) => IntMap a -> IntMap a
normalizeVec = forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter (forall a. Eq a => a -> a -> Bool
/=a
0)