--------------------------------------------------------------------------------
-- Iterative Forward Search                                                   --
--------------------------------------------------------------------------------
-- This source code is licensed under the terms found in the LICENSE file in  --
-- the root directory of this source tree.                                    --
--------------------------------------------------------------------------------

module Data.IFS.Algorithm (
    defaultTermination,
    ifs
) where

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

import           Control.Arrow              ( Arrow((&&&)) )
import           Control.Monad.Trans.Class  ( MonadTrans(lift) )
import           Control.Monad.Trans.Reader

import qualified Data.IntMap                as IM
import qualified Data.IntSet                as IS
import           Data.Maybe                 ( fromJust )

import           System.Random

import           Data.IFS.Types

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

-- | `defaultTermination` @iterations currAssign@ determines whether to continue
-- the algorithm or terminate. It terminates if the current assignment assigns
-- all variables or the maximum number of iterations has been exceded (25 times
-- the number of variables)
defaultTermination :: Int
                   -> Assignment
                   -> CSPMonad Solution (Maybe Solution)
defaultTermination :: Int -> Assignment -> CSPMonad Solution (Maybe Solution)
defaultTermination Int
iterations Assignment
currAssign = do
    -- get variables
    Variables
vars <- CSP Solution -> Variables
forall r. CSP r -> Variables
cspVariables (CSP Solution -> Variables)
-> ReaderT (CSP Solution) IO (CSP Solution)
-> ReaderT (CSP Solution) IO Variables
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (CSP Solution) IO (CSP Solution)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    -- check conditions
    case (Variables -> Int
IS.size Variables
vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Assignment -> Int
forall a. IntMap a -> Int
IM.size Assignment
currAssign, Int
iterations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
25 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Variables -> Int
IS.size Variables
vars) of
        (Bool
True, Bool
True)  -> Maybe Solution -> CSPMonad Solution (Maybe Solution)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Solution
forall a. Maybe a
Nothing
        (Bool
True, Bool
False) -> Maybe Solution -> CSPMonad Solution (Maybe Solution)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Solution -> CSPMonad Solution (Maybe Solution))
-> Maybe Solution -> CSPMonad Solution (Maybe Solution)
forall a b. (a -> b) -> a -> b
$ Solution -> Maybe Solution
forall a. a -> Maybe a
Just (Solution -> Maybe Solution) -> Solution -> Maybe Solution
forall a b. (a -> b) -> a -> b
$ Assignment -> Solution
Incomplete Assignment
currAssign
        (Bool
False, Bool
_)    -> Maybe Solution -> CSPMonad Solution (Maybe Solution)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Solution -> CSPMonad Solution (Maybe Solution))
-> Maybe Solution -> CSPMonad Solution (Maybe Solution)
forall a b. (a -> b) -> a -> b
$ Solution -> Maybe Solution
forall a. a -> Maybe a
Just (Solution -> Maybe Solution) -> Solution -> Maybe Solution
forall a b. (a -> b) -> a -> b
$ Assignment -> Solution
Complete Assignment
currAssign

-- | `getMostRestricted` @vars doms cons@ indexes these variables by size of
-- domain - # connected constraints. The lowest index is then the most
-- restricted variable.
getMostRestricted :: Variables
                  -> Domains
                  -> Constraints
                  -> IM.IntMap [Var]
getMostRestricted :: Variables -> Domains -> Constraints -> IntMap [Int]
getMostRestricted Variables
vars Domains
doms Constraints
cons =
    -- TODO: Scaling one of these numbers could be better
    ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> IntMap [Int]
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) ([(Int, [Int])] -> IntMap [Int]) -> [(Int, [Int])] -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ ((Int -> (Int, [Int])) -> [Int] -> [(Int, [Int])])
-> [Int] -> (Int -> (Int, [Int])) -> [(Int, [Int])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> (Int, [Int])) -> [Int] -> [(Int, [Int])]
forall a b. (a -> b) -> [a] -> [b]
map (Variables -> [Int]
IS.toList Variables
vars) ((Int -> (Int, [Int])) -> [(Int, [Int])])
-> (Int -> (Int, [Int])) -> [(Int, [Int])]
forall a b. (a -> b) -> a -> b
$ \Int
var ->
            (Variables -> Int
IS.size (Domains
doms Domains -> Int -> Variables
forall a. IntMap a -> Int -> a
IM.! Int
var) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Constraints -> Int
forall (t :: * -> *) a b.
(Foldable t, Num a) =>
Int -> t (Variables, b) -> a
countConnectedCons Int
var Constraints
cons, [Int
var])

    where
        -- counts the number of constraints connected to @var@
        countConnectedCons :: Int -> t (Variables, b) -> a
countConnectedCons Int
var = ((a -> (Variables, b) -> a) -> a -> t (Variables, b) -> a)
-> a -> (a -> (Variables, b) -> a) -> t (Variables, b) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> (Variables, b) -> a) -> a -> t (Variables, b) -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a
0 ((a -> (Variables, b) -> a) -> t (Variables, b) -> a)
-> (a -> (Variables, b) -> a) -> t (Variables, b) -> a
forall a b. (a -> b) -> a -> b
$ \a
conflicting (Variables
conVars, b
_) ->
            if Int
var Int -> Variables -> Bool
`IS.member` Variables
conVars
            then a
conflicting a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
            else a
conflicting

-- | `selectVariable` @currAssignment@ decides which variable to change next
selectVariable :: Int -> Assignment -> CSPMonad r Var
selectVariable :: Int -> Assignment -> CSPMonad r Int
selectVariable Int
iterations Assignment
currAssignment = do
    -- get CSP parameters
    MkCSP{Int
Constraints
Domains
Variables
Int -> Assignment -> CSPMonad r (Maybe r)
cspTermination :: forall r. CSP r -> Int -> Assignment -> CSPMonad r (Maybe r)
cspRandomCap :: forall r. CSP r -> Int
cspConstraints :: forall r. CSP r -> Constraints
cspDomains :: forall r. CSP r -> Domains
cspTermination :: Int -> Assignment -> CSPMonad r (Maybe r)
cspRandomCap :: Int
cspConstraints :: Constraints
cspVariables :: Variables
cspDomains :: Domains
cspVariables :: forall r. CSP r -> Variables
..} <- ReaderT (CSP r) IO (CSP r)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

    -- get variables currently not assigned. We can assume this is non-empty
    -- as the algorithm terminates when all are assigned
    let unassigned :: Variables
unassigned = Variables
cspVariables Variables -> Variables -> Variables
IS.\\ [Int] -> Variables
IS.fromList (Assignment -> [Int]
forall a. IntMap a -> [Int]
IM.keys Assignment
currAssignment)

    -- find which of these is most restricted
    let restricted :: IntMap [Int]
restricted = Variables -> Domains -> Constraints -> IntMap [Int]
getMostRestricted Variables
unassigned Domains
cspDomains Constraints
cspConstraints

    -- if we are before the random cap then pick one of the most difficult
    -- variables
    if Int
iterations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
cspRandomCap
    then
        -- pick a random variable from the most difficult
        let toChoseFrom :: [Int]
toChoseFrom = (Int, [Int]) -> [Int]
forall a b. (a, b) -> b
snd ((Int, [Int]) -> [Int]) -> (Int, [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ IntMap [Int] -> (Int, [Int])
forall a. IntMap a -> (Int, a)
IM.findMin IntMap [Int]
restricted
        in ([Int]
toChoseFrom [Int] -> Int -> Int
forall a. [a] -> Int -> a
!!) (Int -> Int) -> CSPMonad r Int -> CSPMonad r Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> CSPMonad r Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0, [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
toChoseFrom Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
    else
        -- pick any random variable
        let unassignedList :: [Int]
unassignedList = Variables -> [Int]
IS.toList Variables
unassigned
        in ([Int]
unassignedList [Int] -> Int -> Int
forall a. [a] -> Int -> a
!!) (Int -> Int) -> CSPMonad r Int -> CSPMonad r Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> CSPMonad r Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0, [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
unassignedList Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- | `setValue` @csp currAssign var@ determines a value to assign to @var@ and
-- returns @currAssign@ with @var@ assigned to the determined value
setValue :: Assignment
         -> Var
         -> CSPMonad r Assignment
setValue :: Assignment -> Int -> CSPMonad r Assignment
setValue Assignment
currAssign Int
var = do
    (Domains
doms, Constraints
cons) <- (CSP r -> Domains
forall r. CSP r -> Domains
cspDomains (CSP r -> Domains)
-> (CSP r -> Constraints) -> CSP r -> (Domains, Constraints)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CSP r -> Constraints
forall r. CSP r -> Constraints
cspConstraints) (CSP r -> (Domains, Constraints))
-> ReaderT (CSP r) IO (CSP r)
-> ReaderT (CSP r) IO (Domains, Constraints)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (CSP r) IO (CSP r)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    let domain :: Variables
domain = ((Int -> Bool) -> Variables -> Variables)
-> Variables -> (Int -> Bool) -> Variables
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Bool) -> Variables -> Variables
IS.filter (Maybe Variables -> Variables
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Variables -> Variables) -> Maybe Variables -> Variables
forall a b. (a -> b) -> a -> b
$ Int -> Domains -> Maybe Variables
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
var Domains
doms) ((Int -> Bool) -> Variables) -> (Int -> Bool) -> Variables
forall a b. (a -> b) -> a -> b
$ \Int
val ->
            Assignment -> Constraints -> Integer
forall (t :: * -> *) a t a.
(Foldable t, Num a) =>
t -> t (a, t -> Bool) -> a
countConflicts (Int -> Int -> Assignment
forall a. Int -> a -> IntMap a
IM.singleton Int
var Int
val) Constraints
cons Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0

    -- If no possible values return current assignment unchanged
    if Variables -> Bool
IS.null Variables
domain
    then Assignment -> CSPMonad r Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assignment
currAssign
    else do
        -- create map with key of the number of contraints violated, and the
        -- value being a list of assignments with that number of conflicts
        let conflictMap :: IntMap [Assignment]
conflictMap = ([Assignment] -> [Assignment] -> [Assignment])
-> [(Int, [Assignment])] -> IntMap [Assignment]
forall a. (a -> a -> a) -> [(Int, a)] -> IntMap a
IM.fromListWith [Assignment] -> [Assignment] -> [Assignment]
forall a. [a] -> [a] -> [a]
(++) ([(Int, [Assignment])] -> IntMap [Assignment])
-> [(Int, [Assignment])] -> IntMap [Assignment]
forall a b. (a -> b) -> a -> b
$ ((Int -> (Int, [Assignment])) -> [Int] -> [(Int, [Assignment])])
-> [Int] -> (Int -> (Int, [Assignment])) -> [(Int, [Assignment])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> (Int, [Assignment])) -> [Int] -> [(Int, [Assignment])]
forall a b. (a -> b) -> [a] -> [b]
map (Variables -> [Int]
IS.toList Variables
domain)
                        ((Int -> (Int, [Assignment])) -> [(Int, [Assignment])])
-> (Int -> (Int, [Assignment])) -> [(Int, [Assignment])]
forall a b. (a -> b) -> a -> b
$ \Int
val ->
                            let assignment :: Assignment
assignment = Int -> Int -> Assignment -> Assignment
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
var Int
val Assignment
currAssign
                            in (Assignment -> Constraints -> Int
forall (t :: * -> *) a t a.
(Foldable t, Num a) =>
t -> t (a, t -> Bool) -> a
countConflicts Assignment
assignment Constraints
cons, [Assignment
assignment])

        -- TODO: Some kind of nice formula - weight the smaller conflicts more
        -- and the weighting should be heaver if the gap between nums of
        -- conflicts is larger
        -- Will chose from the 10% of assignments with the lowest number of
        -- conflicts
        let cap :: Int
cap = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
0.1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variables -> Int
IS.size Variables
domain)

        -- get at least @cap@ assignments in order of conflicts
        let toChoseFrom :: [Assignment]
toChoseFrom = Int -> Int -> [Assignment] -> IntMap [Assignment] -> [Assignment]
getToChoseFrom Int
0 Int
cap [] IntMap [Assignment]
conflictMap

        -- get a radndom assignment from this list
        ([Assignment]
toChoseFrom [Assignment] -> Int -> Assignment
forall a. [a] -> Int -> a
!!) (Int -> Assignment)
-> ReaderT (CSP r) IO Int -> CSPMonad r Assignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int -> ReaderT (CSP r) IO Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (Int
0, [Assignment] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Assignment]
toChoseFrom Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

    where
        -- counts the number of conflicts in @assignment@
        countConflicts :: t -> t (a, t -> Bool) -> a
countConflicts t
assignment = ((a -> (a, t -> Bool) -> a) -> a -> t (a, t -> Bool) -> a)
-> a -> (a -> (a, t -> Bool) -> a) -> t (a, t -> Bool) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> (a, t -> Bool) -> a) -> a -> t (a, t -> Bool) -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a
0 ((a -> (a, t -> Bool) -> a) -> t (a, t -> Bool) -> a)
-> (a -> (a, t -> Bool) -> a) -> t (a, t -> Bool) -> a
forall a b. (a -> b) -> a -> b
$
            \a
conflicting (a
_, t -> Bool
constraintF) ->
                if t -> Bool
constraintF t
assignment
                then a
conflicting
                else a
conflicting a -> a -> a
forall a. Num a => a -> a -> a
+ a
1

        -- gets lowest number of assignments >cap possible when sorting by
        -- conflict number
        getToChoseFrom :: Int
                       -> Int
                       -> [Assignment]
                       -> IM.IntMap [Assignment]
                       -> [Assignment]
        getToChoseFrom :: Int -> Int -> [Assignment] -> IntMap [Assignment] -> [Assignment]
getToChoseFrom Int
n Int
cap [Assignment]
added IntMap [Assignment]
toAdd
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
cap   = [Assignment]
added
            | Bool
otherwise = let ((Int
_,[Assignment]
as), IntMap [Assignment]
toAdd') = IntMap [Assignment] -> ((Int, [Assignment]), IntMap [Assignment])
forall a. IntMap a -> ((Int, a), IntMap a)
IM.deleteFindMin IntMap [Assignment]
toAdd
                          in Int -> Int -> [Assignment] -> IntMap [Assignment] -> [Assignment]
getToChoseFrom (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Assignment] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Assignment]
as)
                                            Int
cap
                                            ([Assignment]
added [Assignment] -> [Assignment] -> [Assignment]
forall a. [a] -> [a] -> [a]
++ [Assignment]
as)
                                            IntMap [Assignment]
toAdd'

-- | `removeConflicts'` @var assign constraintF toRemove@ repeated unassigns
-- one of the least constrained variables except @var@ from @assign@ until the
-- @constraintF@ passes
removeConflicts' :: Var
                 -> Assignment
                 -> (Assignment -> Bool)
                 -> IM.IntMap [Var]
                 -> Assignment
removeConflicts' :: Int
-> Assignment -> (Assignment -> Bool) -> IntMap [Int] -> Assignment
removeConflicts' Int
var Assignment
assign Assignment -> Bool
constraintF IntMap [Int]
toRemove
    | Assignment -> Bool
constraintF Assignment
assign = Assignment
assign
    | Bool
otherwise          =
        let
            -- get next minimum variables
            (Int
_, Int
x:[Int]
remaining) = IntMap [Int] -> (Int, [Int])
forall a. IntMap a -> (Int, a)
IM.findMax IntMap [Int]
toRemove
            -- remove this variable from the map
            toRemove' :: IntMap [Int]
toRemove' = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
remaining
                        then ((Int, [Int]), IntMap [Int]) -> IntMap [Int]
forall a b. (a, b) -> b
snd (((Int, [Int]), IntMap [Int]) -> IntMap [Int])
-> ((Int, [Int]), IntMap [Int]) -> IntMap [Int]
forall a b. (a -> b) -> a -> b
$ IntMap [Int] -> ((Int, [Int]), IntMap [Int])
forall a. IntMap a -> ((Int, a), IntMap a)
IM.deleteFindMax IntMap [Int]
toRemove
                        else ([Int] -> Maybe [Int]) -> IntMap [Int] -> IntMap [Int]
forall a. (a -> Maybe a) -> IntMap a -> IntMap a
IM.updateMax (Maybe [Int] -> [Int] -> Maybe [Int]
forall a b. a -> b -> a
const (Maybe [Int] -> [Int] -> Maybe [Int])
-> Maybe [Int] -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe [Int]
forall a. a -> Maybe a
Just [Int]
remaining) IntMap [Int]
toRemove
            -- unassign this variable unless it is the variable just assigned
            newAssign :: Assignment
newAssign = if Int
xInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
var then Assignment
assign else Int -> Assignment -> Assignment
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
x Assignment
assign
        in Int
-> Assignment -> (Assignment -> Bool) -> IntMap [Int] -> Assignment
removeConflicts' Int
var Assignment
newAssign Assignment -> Bool
constraintF IntMap [Int]
toRemove'

-- | `removeConflicts` @currAssign var@ checks which constraints from @csp@
-- are violated by @currAssign@ and removes all variables involved in the
-- violated constraints except @var@
removeConflicts :: Assignment
                -> Var
                -> CSPMonad r Assignment
removeConflicts :: Assignment -> Int -> CSPMonad r Assignment
removeConflicts Assignment
currAssignment Int
var = do
    (Domains
doms, Constraints
cons) <- (CSP r -> Domains
forall r. CSP r -> Domains
cspDomains (CSP r -> Domains)
-> (CSP r -> Constraints) -> CSP r -> (Domains, Constraints)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CSP r -> Constraints
forall r. CSP r -> Constraints
cspConstraints) (CSP r -> (Domains, Constraints))
-> ReaderT (CSP r) IO (CSP r)
-> ReaderT (CSP r) IO (Domains, Constraints)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (CSP r) IO (CSP r)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    -- check each constraint and if it is violated unassign variables until
    -- the constraint passes
    Assignment -> CSPMonad r Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Assignment -> CSPMonad r Assignment)
-> Assignment -> CSPMonad r Assignment
forall a b. (a -> b) -> a -> b
$ ((Assignment -> (Variables, Assignment -> Bool) -> Assignment)
 -> Constraints -> Assignment)
-> Constraints
-> (Assignment -> (Variables, Assignment -> Bool) -> Assignment)
-> Assignment
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Assignment -> (Variables, Assignment -> Bool) -> Assignment)
 -> Assignment -> Constraints -> Assignment)
-> Assignment
-> (Assignment -> (Variables, Assignment -> Bool) -> Assignment)
-> Constraints
-> Assignment
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Assignment -> (Variables, Assignment -> Bool) -> Assignment)
-> Assignment -> Constraints -> Assignment
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Assignment
currAssignment) Constraints
cons ((Assignment -> (Variables, Assignment -> Bool) -> Assignment)
 -> Assignment)
-> (Assignment -> (Variables, Assignment -> Bool) -> Assignment)
-> Assignment
forall a b. (a -> b) -> a -> b
$
            \Assignment
assign (Variables
constraintVars, Assignment -> Bool
constraintF) ->
                if Assignment -> Bool
constraintF Assignment
assign
                then Assignment
assign
                else Int
-> Assignment -> (Assignment -> Bool) -> IntMap [Int] -> Assignment
removeConflicts' Int
var Assignment
assign Assignment -> Bool
constraintF
                        (IntMap [Int] -> Assignment) -> IntMap [Int] -> Assignment
forall a b. (a -> b) -> a -> b
$ Variables -> Domains -> Constraints -> IntMap [Int]
getMostRestricted Variables
constraintVars Domains
doms Constraints
cons

-- | `getBest` @newAssign bestAssign@ determines whether @newAssign@ is better
-- than @bestAssign@ and returns the best out of the two. A random is picked
-- if both are deemed equally good
getBest :: Assignment
        -> Assignment
        -> CSPMonad r Assignment
getBest :: Assignment -> Assignment -> CSPMonad r Assignment
getBest Assignment
newAssign Assignment
bestAssign =
    case Assignment -> Int
forall a. IntMap a -> Int
IM.size Assignment
newAssign Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Assignment -> Int
forall a. IntMap a -> Int
IM.size Assignment
bestAssign of
        -- if more variables are assigned in the current assignment it is better
        Ordering
GT -> Assignment -> CSPMonad r Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assignment
newAssign
        -- if less variables are assigned it is worse
        Ordering
LT -> Assignment -> CSPMonad r Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assignment
bestAssign
        -- if both have an equal number of variables assigned pick randomly
        Ordering
EQ -> do
            Bool
useNew <- (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.5) (Double -> Bool)
-> ReaderT (CSP r) IO Double -> ReaderT (CSP r) IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Double -> ReaderT (CSP r) IO Double
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Double
forall a. Random a => IO a
randomIO :: CSPMonad r Double)
            Assignment -> CSPMonad r Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Assignment -> CSPMonad r Assignment)
-> Assignment -> CSPMonad r Assignment
forall a b. (a -> b) -> a -> b
$ if Bool
useNew then Assignment
newAssign else Assignment
bestAssign

-- | `ifs'` @iterations currAssign bestAssign@ checks whether it should continue
-- the search given @currAssign@, and if so performs the next iteration of the
-- IFS algorithm and recursively calls this function again with the new
-- assignment. If `canContinue` returns false the best assignment found so far
-- is returned
ifs' :: Int
     -> Assignment
     -> Assignment
     -> CSPMonad r r
ifs' :: Int -> Assignment -> Assignment -> CSPMonad r r
ifs' Int
iterations Assignment
currAssign Assignment
bestAssign = do
    Int -> Assignment -> CSPMonad r (Maybe r)
canContinue <- CSP r -> Int -> Assignment -> CSPMonad r (Maybe r)
forall r. CSP r -> Int -> Assignment -> CSPMonad r (Maybe r)
cspTermination (CSP r -> Int -> Assignment -> CSPMonad r (Maybe r))
-> ReaderT (CSP r) IO (CSP r)
-> ReaderT (CSP r) IO (Int -> Assignment -> CSPMonad r (Maybe r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (CSP r) IO (CSP r)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Maybe r
continue <- Int -> Assignment -> CSPMonad r (Maybe r)
canContinue Int
iterations Assignment
bestAssign
    case Maybe r
continue of
        Maybe r
Nothing -> do
            -- get variable to change
            Int
var <- Int -> Assignment -> CSPMonad r Int
forall r. Int -> Assignment -> CSPMonad r Int
selectVariable Int
iterations Assignment
currAssign

            -- determine and set new value for @var@
            Assignment
newAssignment <- Assignment -> Int -> CSPMonad r Assignment
forall r. Assignment -> Int -> CSPMonad r Assignment
setValue Assignment
currAssign Int
var

            -- find and unassign conflicting variables
            Assignment
conflictsRemoved <- Assignment -> Int -> CSPMonad r Assignment
forall r. Assignment -> Int -> CSPMonad r Assignment
removeConflicts Assignment
newAssignment Int
var

            -- run ifs' with the new assignment
            Assignment
nextAssignment <- Assignment -> Assignment -> CSPMonad r Assignment
forall r. Assignment -> Assignment -> CSPMonad r Assignment
getBest Assignment
conflictsRemoved Assignment
bestAssign
            Int -> Assignment -> Assignment -> CSPMonad r r
forall r. Int -> Assignment -> Assignment -> CSPMonad r r
ifs' (Int
iterationsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Assignment
conflictsRemoved Assignment
nextAssignment

        Just r
a -> r -> CSPMonad r r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
a

-- | `ifs` @csp startingAssignment@ performs an iterative first search on @csp@
-- using @startingAssignment@ as the initial assignment
ifs :: CSP r
    -> Assignment
    -> IO r
ifs :: CSP r -> Assignment -> IO r
ifs CSP r
csp Assignment
startingAssignment =
    ReaderT (CSP r) IO r -> CSP r -> IO r
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Int -> Assignment -> Assignment -> ReaderT (CSP r) IO r
forall r. Int -> Assignment -> Assignment -> CSPMonad r r
ifs' Int
0 Assignment
startingAssignment Assignment
startingAssignment) CSP r
csp

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