{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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 qualified Data.Aeson as J
import Data.Aeson ((.=), (.:))
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 ToySolver.Internal.JSON (withTypedObject)
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 = Sum -> Maybe Sum
forall a. a -> Maybe a
Just (Sum -> Maybe Sum) -> Sum -> Maybe Sum
forall a b. (a -> b) -> a -> b
$
        [ (Integer
c, if Key
x1Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
==Key
x2 then [Key
x1Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1] else [Key
x1Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1, Key
x2Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1])
        | (Key
x1, IntMap Integer
row) <- IntMap (IntMap Integer) -> [(Key, IntMap Integer)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap Integer)
m2
        , (Key
x2, Integer
c) <- IntMap Integer -> [(Key, Integer)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap Integer
row
        ]
    , pbConstraints :: [Constraint]
PBFile.pbConstraints = []
    , pbNumVars :: Key
PBFile.pbNumVars = Problem a -> Key
forall a. Problem a -> Key
QUBO.quboNumVars Problem a
prob
    , pbNumConstraints :: Key
PBFile.pbNumConstraints = Key
0
    }
  , Integer -> QUBO2PBInfo a
forall a. Integer -> QUBO2PBInfo a
QUBO2PBInfo Integer
d
  )
  where
    m1 :: IntMap (IntMap Rational)
m1 = (IntMap a -> IntMap Rational)
-> IntMap (IntMap a) -> IntMap (IntMap Rational)
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Rational) -> IntMap a -> IntMap Rational
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Rational
forall a. Real a => a -> Rational
toRational) (IntMap (IntMap a) -> IntMap (IntMap Rational))
-> IntMap (IntMap a) -> IntMap (IntMap Rational)
forall a b. (a -> b) -> a -> b
$ Problem a -> IntMap (IntMap a)
forall a. Problem a -> IntMap (IntMap a)
QUBO.quboMatrix Problem a
prob
    d :: Integer
d = (Integer -> Integer -> Integer) -> Integer -> [Integer] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
lcm Integer
1 [Rational -> Integer
forall a. Ratio a -> a
denominator Rational
c | IntMap Rational
row <- IntMap (IntMap Rational) -> [IntMap Rational]
forall a. IntMap a -> [a]
IntMap.elems IntMap (IntMap Rational)
m1, Rational
c <- IntMap Rational -> [Rational]
forall a. IntMap a -> [a]
IntMap.elems IntMap Rational
row, Rational
c Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0]
    m2 :: IntMap (IntMap Integer)
m2 = (IntMap Rational -> IntMap Integer)
-> IntMap (IntMap Rational) -> IntMap (IntMap Integer)
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rational -> Integer) -> IntMap Rational -> IntMap Integer
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Rational
c -> Rational -> Integer
forall a. Ratio a -> a
numerator Rational
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
d ` div` Rational -> Integer
forall a. Ratio a -> a
denominator Rational
c))) IntMap (IntMap Rational)
m1

newtype QUBO2PBInfo a = QUBO2PBInfo Integer
  deriving (QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
(QUBO2PBInfo a -> QUBO2PBInfo a -> Bool)
-> (QUBO2PBInfo a -> QUBO2PBInfo a -> Bool) -> Eq (QUBO2PBInfo a)
forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
== :: QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
$c/= :: forall a. QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
/= :: QUBO2PBInfo a -> QUBO2PBInfo a -> Bool
Eq, Key -> QUBO2PBInfo a -> ShowS
[QUBO2PBInfo a] -> ShowS
QUBO2PBInfo a -> String
(Key -> QUBO2PBInfo a -> ShowS)
-> (QUBO2PBInfo a -> String)
-> ([QUBO2PBInfo a] -> ShowS)
-> Show (QUBO2PBInfo a)
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
$cshowsPrec :: forall a. Key -> QUBO2PBInfo a -> ShowS
showsPrec :: Key -> QUBO2PBInfo a -> ShowS
$cshow :: forall a. QUBO2PBInfo a -> String
show :: QUBO2PBInfo a -> String
$cshowList :: forall a. [QUBO2PBInfo a] -> ShowS
showList :: [QUBO2PBInfo a] -> ShowS
Show, ReadPrec [QUBO2PBInfo a]
ReadPrec (QUBO2PBInfo a)
Key -> ReadS (QUBO2PBInfo a)
ReadS [QUBO2PBInfo a]
(Key -> ReadS (QUBO2PBInfo a))
-> ReadS [QUBO2PBInfo a]
-> ReadPrec (QUBO2PBInfo a)
-> ReadPrec [QUBO2PBInfo a]
-> Read (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
$creadsPrec :: forall a. Key -> ReadS (QUBO2PBInfo a)
readsPrec :: Key -> ReadS (QUBO2PBInfo a)
$creadList :: forall a. ReadS [QUBO2PBInfo a]
readList :: ReadS [QUBO2PBInfo a]
$creadPrec :: forall a. ReadPrec (QUBO2PBInfo a)
readPrec :: ReadPrec (QUBO2PBInfo a)
$creadListPrec :: forall a. ReadPrec [QUBO2PBInfo a]
readListPrec :: ReadPrec [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 = (Key, Key) -> (Key -> Key) -> UArray Key Bool -> UArray Key Bool
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1,Key
ubKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) (Key -> Key -> Key
forall a. Num a => a -> a -> a
subtract Key
1) UArray Key Bool
Source (QUBO2PBInfo a)
sol
    where
      (Key
lb,Key
ub) = UArray Key Bool -> (Key, Key)
forall i. Ix i => UArray i Bool -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Key Bool
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 = (Key, Key) -> (Key -> Key) -> UArray Key Bool -> UArray Key Bool
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1,Key
ubKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1) (Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) UArray Key Bool
Target (QUBO2PBInfo a)
m
    where
      (Key
lb,Key
ub) = UArray Key Bool -> (Key, Key)
forall i. Ix i => UArray i Bool -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Key Bool
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 = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Rational
forall a. Real a => a -> Rational
toRational a
SourceObjValue (QUBO2PBInfo a)
obj) Integer -> Integer -> Integer
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 = Integer -> SourceObjValue (QUBO2PBInfo a)
forall a. Num a => Integer -> a
fromInteger (Integer -> SourceObjValue (QUBO2PBInfo a))
-> Integer -> SourceObjValue (QUBO2PBInfo a)
forall a b. (a -> b) -> a -> b
$ (Integer
TargetObjValue (QUBO2PBInfo a)
obj Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d

instance J.ToJSON (QUBO2PBInfo a) where
  toJSON :: QUBO2PBInfo a -> Value
toJSON (QUBO2PBInfo Integer
d) =
    [Pair] -> Value
J.object
    [ Key
"type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Value
"QUBO2PBInfo" :: J.Value)
    , Key
"objective_function_scale_factor" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Integer
d
    ]

instance J.FromJSON (QUBO2PBInfo a) where
  parseJSON :: Value -> Parser (QUBO2PBInfo a)
parseJSON =
    String
-> (Object -> Parser (QUBO2PBInfo a))
-> Value
-> Parser (QUBO2PBInfo a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withTypedObject String
"QUBO2PBInfo" ((Object -> Parser (QUBO2PBInfo a))
 -> Value -> Parser (QUBO2PBInfo a))
-> (Object -> Parser (QUBO2PBInfo a))
-> Value
-> Parser (QUBO2PBInfo a)
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
      Integer -> QUBO2PBInfo a
forall a. Integer -> QUBO2PBInfo a
QUBO2PBInfo (Integer -> QUBO2PBInfo a)
-> Parser Integer -> Parser (QUBO2PBInfo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"objective_function_scale_factor"

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

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

newtype PBAsQUBOInfo a = PBAsQUBOInfo Integer
  deriving (PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
(PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool)
-> (PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool)
-> Eq (PBAsQUBOInfo a)
forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
== :: PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
$c/= :: forall a. PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
/= :: PBAsQUBOInfo a -> PBAsQUBOInfo a -> Bool
Eq, Key -> PBAsQUBOInfo a -> ShowS
[PBAsQUBOInfo a] -> ShowS
PBAsQUBOInfo a -> String
(Key -> PBAsQUBOInfo a -> ShowS)
-> (PBAsQUBOInfo a -> String)
-> ([PBAsQUBOInfo a] -> ShowS)
-> Show (PBAsQUBOInfo a)
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
$cshowsPrec :: forall a. Key -> PBAsQUBOInfo a -> ShowS
showsPrec :: Key -> PBAsQUBOInfo a -> ShowS
$cshow :: forall a. PBAsQUBOInfo a -> String
show :: PBAsQUBOInfo a -> String
$cshowList :: forall a. [PBAsQUBOInfo a] -> ShowS
showList :: [PBAsQUBOInfo a] -> ShowS
Show, ReadPrec [PBAsQUBOInfo a]
ReadPrec (PBAsQUBOInfo a)
Key -> ReadS (PBAsQUBOInfo a)
ReadS [PBAsQUBOInfo a]
(Key -> ReadS (PBAsQUBOInfo a))
-> ReadS [PBAsQUBOInfo a]
-> ReadPrec (PBAsQUBOInfo a)
-> ReadPrec [PBAsQUBOInfo a]
-> Read (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
$creadsPrec :: forall a. Key -> ReadS (PBAsQUBOInfo a)
readsPrec :: Key -> ReadS (PBAsQUBOInfo a)
$creadList :: forall a. ReadS [PBAsQUBOInfo a]
readList :: ReadS [PBAsQUBOInfo a]
$creadPrec :: forall a. ReadPrec (PBAsQUBOInfo a)
readPrec :: ReadPrec (PBAsQUBOInfo a)
$creadListPrec :: forall a. ReadPrec [PBAsQUBOInfo a]
readListPrec :: ReadPrec [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 = (Key, Key) -> (Key -> Key) -> UArray Key Bool -> UArray Key Bool
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1,Key
ubKey -> Key -> Key
forall a. Num a => a -> a -> a
-Key
1) (Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) UArray Key Bool
Source (PBAsQUBOInfo a)
m
    where
      (Key
lb,Key
ub) = UArray Key Bool -> (Key, Key)
forall i. Ix i => UArray i Bool -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Key Bool
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 = (Key, Key) -> (Key -> Key) -> UArray Key Bool -> UArray Key Bool
forall (a :: * -> * -> *) e i j.
(IArray a e, Ix i, Ix j) =>
(i, i) -> (i -> j) -> a j e -> a i e
ixmap (Key
lbKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1,Key
ubKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) (Key -> Key -> Key
forall a. Num a => a -> a -> a
subtract Key
1) UArray Key Bool
Target (PBAsQUBOInfo a)
sol
    where
      (Key
lb,Key
ub) = UArray Key Bool -> (Key, Key)
forall i. Ix i => UArray i Bool -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Key Bool
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 = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer
SourceObjValue (PBAsQUBOInfo a)
obj Integer -> Integer -> Integer
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 = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Rational
forall a. Real a => a -> Rational
toRational a
TargetObjValue (PBAsQUBOInfo a)
obj) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
offset

instance J.ToJSON (PBAsQUBOInfo a) where
  toJSON :: PBAsQUBOInfo a -> Value
toJSON (PBAsQUBOInfo Integer
offset) =
    [Pair] -> Value
J.object
    [ Key
"type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Value
"PBAsQUBOInfo" :: J.Value)
    , Key
"objective_function_offset" Key -> Integer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Integer
offset
    ]

instance J.FromJSON (PBAsQUBOInfo a) where
  parseJSON :: Value -> Parser (PBAsQUBOInfo a)
parseJSON =
    String
-> (Object -> Parser (PBAsQUBOInfo a))
-> Value
-> Parser (PBAsQUBOInfo a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withTypedObject String
"PBAsQUBOInfo" ((Object -> Parser (PBAsQUBOInfo a))
 -> Value -> Parser (PBAsQUBOInfo a))
-> (Object -> Parser (PBAsQUBOInfo a))
-> Value
-> Parser (PBAsQUBOInfo a)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Integer
offset <- Object
obj Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"objective_function_offset"
      PBAsQUBOInfo a -> Parser (PBAsQUBOInfo a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> PBAsQUBOInfo a
forall a. Integer -> PBAsQUBOInfo a
PBAsQUBOInfo 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, PBAsQUBOInfo a
-> SourceObjValue (PBAsQUBOInfo a)
-> TargetObjValue (PBAsQUBOInfo a)
forall a.
ObjValueForwardTransformer a =>
a -> SourceObjValue a -> TargetObjValue a
transformObjValueForward PBAsQUBOInfo a
info2 Integer
SourceObjValue (PBAsQUBOInfo a)
th), PB2QUBOInfo'
-> PBAsQUBOInfo a
-> ComposedTransformer PB2QUBOInfo' (PBAsQUBOInfo a)
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, PBAsQUBOInfo a
info2) = Formula -> Maybe (Problem a, PBAsQUBOInfo a)
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 = IntMap (IntMap a) -> IntMap (IntMap a)
forall a. (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat (IntMap (IntMap a) -> IntMap (IntMap a))
-> IntMap (IntMap a) -> IntMap (IntMap a)
forall a b. (a -> b) -> a -> b
$ IntMap (IntMap a)
jj'
    , isingExternalMagneticField :: IntMap a
QUBO.isingExternalMagneticField = IntMap a -> IntMap a
forall a. (Eq a, Num a) => IntMap a -> IntMap a
normalizeVec IntMap a
h'
    }
  , a -> QUBO2IsingInfo a
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') = ((IntMap (IntMap a), IntMap a, a)
 -> (IntMap (IntMap a), IntMap a, a)
 -> (IntMap (IntMap a), IntMap a, a))
-> (IntMap (IntMap a), IntMap a, a)
-> [(IntMap (IntMap a), IntMap a, a)]
-> (IntMap (IntMap a), IntMap a, a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap (IntMap a), IntMap a, a)
-> (IntMap (IntMap a), IntMap a, a)
-> (IntMap (IntMap a), IntMap a, a)
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 (IntMap (IntMap a)
forall a. IntMap a
IntMap.empty, IntMap a
forall a. IntMap a
IntMap.empty, a
0) ([(IntMap (IntMap a), IntMap a, a)]
 -> (IntMap (IntMap a), IntMap a, a))
-> [(IntMap (IntMap a), IntMap a, a)]
-> (IntMap (IntMap a), IntMap a, a)
forall a b. (a -> b) -> a -> b
$ do
      (Key
i, IntMap a
row)  <- IntMap (IntMap a) -> [(Key, IntMap a)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap a)
qq
      (Key
j, a
q_ij) <- IntMap a -> [(Key, a)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
row
      if Key
i Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= Key
j then
        (IntMap (IntMap a), IntMap a, a)
-> [(IntMap (IntMap a), IntMap a, a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( Key -> IntMap a -> IntMap (IntMap a)
forall a. Key -> a -> IntMap a
IntMap.singleton (Key -> Key -> Key
forall a. Ord a => a -> a -> a
min Key
i Key
j) (IntMap a -> IntMap (IntMap a)) -> IntMap a -> IntMap (IntMap a)
forall a b. (a -> b) -> a -> b
$ Key -> a -> IntMap a
forall a. Key -> a -> IntMap a
IntMap.singleton (Key -> Key -> Key
forall a. Ord a => a -> a -> a
max Key
i Key
j) (a
q_ij a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
4)
          , [(Key, a)] -> IntMap a
forall a. [(Key, a)] -> IntMap a
IntMap.fromList [(Key
i, a
q_ij a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
4), (Key
j, a
q_ij a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
4)]
          , a
q_ij a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
4
          )
      else
        (IntMap (IntMap a), IntMap a, a)
-> [(IntMap (IntMap a), IntMap a, a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( IntMap (IntMap a)
forall a. IntMap a
IntMap.empty
          , Key -> a -> IntMap a
forall a. Key -> a -> IntMap a
IntMap.singleton Key
i (a
q_ij a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2)
          , a
q_ij a -> a -> a
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) =
      ( (IntMap a -> IntMap a -> IntMap a)
-> IntMap (IntMap a) -> IntMap (IntMap a) -> IntMap (IntMap a)
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith ((a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith a -> a -> a
forall a. Num a => a -> a -> a
(+)) IntMap (IntMap a)
jj1 IntMap (IntMap a)
jj2
      , (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith a -> a -> a
forall a. Num a => a -> a -> a
(+) IntMap a
h1 IntMap a
h2
      , c
c1c -> c -> c
forall a. Num a => a -> a -> a
+c
c2
      )

newtype QUBO2IsingInfo a = QUBO2IsingInfo a
  deriving (QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
(QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool)
-> (QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool)
-> Eq (QUBO2IsingInfo a)
forall a. Eq a => QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: QUBO2IsingInfo a -> QUBO2IsingInfo a -> Bool
Eq, Key -> QUBO2IsingInfo a -> ShowS
[QUBO2IsingInfo a] -> ShowS
QUBO2IsingInfo a -> String
(Key -> QUBO2IsingInfo a -> ShowS)
-> (QUBO2IsingInfo a -> String)
-> ([QUBO2IsingInfo a] -> ShowS)
-> Show (QUBO2IsingInfo a)
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
$cshowsPrec :: forall a. Show a => Key -> QUBO2IsingInfo a -> ShowS
showsPrec :: Key -> QUBO2IsingInfo a -> ShowS
$cshow :: forall a. Show a => QUBO2IsingInfo a -> String
show :: QUBO2IsingInfo a -> String
$cshowList :: forall a. Show a => [QUBO2IsingInfo a] -> ShowS
showList :: [QUBO2IsingInfo a] -> ShowS
Show, ReadPrec [QUBO2IsingInfo a]
ReadPrec (QUBO2IsingInfo a)
Key -> ReadS (QUBO2IsingInfo a)
ReadS [QUBO2IsingInfo a]
(Key -> ReadS (QUBO2IsingInfo a))
-> ReadS [QUBO2IsingInfo a]
-> ReadPrec (QUBO2IsingInfo a)
-> ReadPrec [QUBO2IsingInfo a]
-> Read (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
$creadsPrec :: forall a. Read a => Key -> ReadS (QUBO2IsingInfo a)
readsPrec :: Key -> ReadS (QUBO2IsingInfo a)
$creadList :: forall a. Read a => ReadS [QUBO2IsingInfo a]
readList :: ReadS [QUBO2IsingInfo a]
$creadPrec :: forall a. Read a => ReadPrec (QUBO2IsingInfo a)
readPrec :: ReadPrec (QUBO2IsingInfo a)
$creadListPrec :: forall a. Read a => ReadPrec [QUBO2IsingInfo a]
readListPrec :: ReadPrec [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)
Target (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 = Source (QUBO2IsingInfo a)
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 = a
SourceObjValue (QUBO2IsingInfo a)
obj a -> a -> a
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 = a
TargetObjValue (QUBO2IsingInfo a)
obj a -> a -> a
forall a. Num a => a -> a -> a
- a
offset

instance J.ToJSON a => J.ToJSON (QUBO2IsingInfo a) where
  toJSON :: QUBO2IsingInfo a -> Value
toJSON (QUBO2IsingInfo a
offset) =
    [Pair] -> Value
J.object
    [ Key
"type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"QUBO2IsingInfo"
    , Key
"objective_function_offset" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
offset
    ]

instance J.FromJSON a => J.FromJSON (QUBO2IsingInfo a) where
  parseJSON :: Value -> Parser (QUBO2IsingInfo a)
parseJSON =
    String
-> (Object -> Parser (QUBO2IsingInfo a))
-> Value
-> Parser (QUBO2IsingInfo a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withTypedObject String
"QUBO2IsingInfo" ((Object -> Parser (QUBO2IsingInfo a))
 -> Value -> Parser (QUBO2IsingInfo a))
-> (Object -> Parser (QUBO2IsingInfo a))
-> Value
-> Parser (QUBO2IsingInfo a)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      a
offset <- Object
obj Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"objective_function_offset"
      QUBO2IsingInfo a -> Parser (QUBO2IsingInfo a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> QUBO2IsingInfo a
forall a. a -> QUBO2IsingInfo a
QUBO2IsingInfo 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 = [(Key, Key, a)] -> IntMap (IntMap a)
forall a. (Eq a, Num a) => [(Key, Key, a)] -> IntMap (IntMap a)
mkMat [(Key, Key, a)]
m
    }
  , a -> Ising2QUBOInfo a
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 =
      [[(Key, Key, a)]] -> [(Key, Key, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [(Key
i, Key
j, a
4 a -> a -> a
forall a. Num a => a -> a -> a
* a
jj_ij), (Key
i, Key
i,  - a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
jj_ij), (Key
j, Key
j,  - a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
jj_ij)]
      | (Key
i, IntMap a
row) <- IntMap (IntMap a) -> [(Key, IntMap a)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (IntMap a)
jj, (Key
j, a
jj_ij) <- IntMap a -> [(Key, a)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
row
      ] [(Key, Key, a)] -> [(Key, Key, a)] -> [(Key, Key, a)]
forall a. [a] -> [a] -> [a]
++
      [ (Key
i, Key
i,  a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
hi) | (Key
i, a
hi) <- IntMap a -> [(Key, a)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap a
h ]
    offset :: a
offset =
        [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a
jj_ij | IntMap a
row <- IntMap (IntMap a) -> [IntMap a]
forall a. IntMap a -> [a]
IntMap.elems IntMap (IntMap a)
jj, a
jj_ij <- IntMap a -> [a]
forall a. IntMap a -> [a]
IntMap.elems IntMap a
row]
      a -> a -> a
forall a. Num a => a -> a -> a
- [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (IntMap a -> [a]
forall a. IntMap a -> [a]
IntMap.elems IntMap a
h)

newtype Ising2QUBOInfo a = Ising2QUBOInfo a
  deriving (Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
(Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool)
-> (Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool)
-> Eq (Ising2QUBOInfo a)
forall a. Eq a => Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Ising2QUBOInfo a -> Ising2QUBOInfo a -> Bool
Eq, Key -> Ising2QUBOInfo a -> ShowS
[Ising2QUBOInfo a] -> ShowS
Ising2QUBOInfo a -> String
(Key -> Ising2QUBOInfo a -> ShowS)
-> (Ising2QUBOInfo a -> String)
-> ([Ising2QUBOInfo a] -> ShowS)
-> Show (Ising2QUBOInfo a)
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
$cshowsPrec :: forall a. Show a => Key -> Ising2QUBOInfo a -> ShowS
showsPrec :: Key -> Ising2QUBOInfo a -> ShowS
$cshow :: forall a. Show a => Ising2QUBOInfo a -> String
show :: Ising2QUBOInfo a -> String
$cshowList :: forall a. Show a => [Ising2QUBOInfo a] -> ShowS
showList :: [Ising2QUBOInfo a] -> ShowS
Show, ReadPrec [Ising2QUBOInfo a]
ReadPrec (Ising2QUBOInfo a)
Key -> ReadS (Ising2QUBOInfo a)
ReadS [Ising2QUBOInfo a]
(Key -> ReadS (Ising2QUBOInfo a))
-> ReadS [Ising2QUBOInfo a]
-> ReadPrec (Ising2QUBOInfo a)
-> ReadPrec [Ising2QUBOInfo a]
-> Read (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
$creadsPrec :: forall a. Read a => Key -> ReadS (Ising2QUBOInfo a)
readsPrec :: Key -> ReadS (Ising2QUBOInfo a)
$creadList :: forall a. Read a => ReadS [Ising2QUBOInfo a]
readList :: ReadS [Ising2QUBOInfo a]
$creadPrec :: forall a. Read a => ReadPrec (Ising2QUBOInfo a)
readPrec :: ReadPrec (Ising2QUBOInfo a)
$creadListPrec :: forall a. Read a => ReadPrec [Ising2QUBOInfo a]
readListPrec :: ReadPrec [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)
Target (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 = Source (Ising2QUBOInfo a)
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 = a
SourceObjValue (Ising2QUBOInfo a)
obj a -> a -> a
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 = a
TargetObjValue (Ising2QUBOInfo a)
obj a -> a -> a
forall a. Num a => a -> a -> a
- a
offset

instance J.ToJSON a => J.ToJSON (Ising2QUBOInfo a) where
  toJSON :: Ising2QUBOInfo a -> Value
toJSON (Ising2QUBOInfo a
offset) =
    [Pair] -> Value
J.object
    [ Key
"type" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
J.String Text
"Ising2QUBOInfo"
    , Key
"objective_function_offset" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
offset
    ]

instance J.FromJSON a => J.FromJSON (Ising2QUBOInfo a) where
  parseJSON :: Value -> Parser (Ising2QUBOInfo a)
parseJSON =
    String
-> (Object -> Parser (Ising2QUBOInfo a))
-> Value
-> Parser (Ising2QUBOInfo a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withTypedObject String
"Ising2QUBOInfo" ((Object -> Parser (Ising2QUBOInfo a))
 -> Value -> Parser (Ising2QUBOInfo a))
-> (Object -> Parser (Ising2QUBOInfo a))
-> Value
-> Parser (Ising2QUBOInfo a)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      a
offset <- Object
obj Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"objective_function_offset"
      Ising2QUBOInfo a -> Parser (Ising2QUBOInfo a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Ising2QUBOInfo a
forall a. a -> Ising2QUBOInfo a
Ising2QUBOInfo 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 = IntMap (IntMap a) -> IntMap (IntMap a)
forall a. (Eq a, Num a) => IntMap (IntMap a) -> IntMap (IntMap a)
normalizeMat (IntMap (IntMap a) -> IntMap (IntMap a))
-> IntMap (IntMap a) -> IntMap (IntMap a)
forall a b. (a -> b) -> a -> b
$
  (IntMap a -> IntMap a -> IntMap a)
-> [IntMap (IntMap a)] -> IntMap (IntMap a)
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> f (IntMap a) -> IntMap a
IntMap.unionsWith ((a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith a -> a -> a
forall a. Num a => a -> a -> a
(+)) ([IntMap (IntMap a)] -> IntMap (IntMap a))
-> [IntMap (IntMap a)] -> IntMap (IntMap a)
forall a b. (a -> b) -> a -> b
$
  [Key -> IntMap a -> IntMap (IntMap a)
forall a. Key -> a -> IntMap a
IntMap.singleton Key
i (Key -> a -> IntMap a
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 = (IntMap a -> Maybe (IntMap a))
-> IntMap (IntMap a) -> IntMap (IntMap a)
forall a b. (a -> Maybe b) -> IntMap a -> IntMap b
IntMap.mapMaybe ((\IntMap a
m -> if IntMap a -> Bool
forall a. IntMap a -> Bool
IntMap.null IntMap a
m then Maybe (IntMap a)
forall a. Maybe a
Nothing else IntMap a -> Maybe (IntMap a)
forall a. a -> Maybe a
Just IntMap a
m) (IntMap a -> Maybe (IntMap a))
-> (IntMap a -> IntMap a) -> IntMap a -> Maybe (IntMap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> IntMap a
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 = (a -> Bool) -> IntMap a -> IntMap a
forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
0)