Relaxation labelling script for a simple case with two labels {Edge, NonEdge}. Compatibility function is provided as a Haskell function (nice!), as well as the initial matrix. Uses [[Double]], so this is slow. Using something like traverse and Repa (or any other fast array library) would make this code a lot faster. So just avoid excessive (500+…

relaxation_labelling.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
import Control.Monad

{-

USAGE:
use the functions directly (if you know what you're doing),
or simply use the provided showStep function to get the matrix
after a certain number of relaxation iterations.

e.g.
showStep 2 comp_1 init_1

to use the initial matrix and compatibility function
from (a) and show the result of 2 iterations.

available matrices:
init_1, init_2, init_3 (for (a) (b) and (c) respectively)
available compatibility functions:
comp_1, comp_2, comp_3 (for (a) (b) and (c) respectively)

note that this code is in some places specialised for the case
of only having two labels (since it uses 1-p for inverse probabilities),
so changing it to work for general relaxation labelling with
more labels requires some extra changes.

-}

type Matrix = [[Double]]

show' :: Matrix -> IO ()
show' = mapM_ print

type Index  = (Int, Int)

data Label = Edge | NonEdge deriving (Show, Eq)

nulls :: [Double]
nulls = [0, 0, 0, 0, 0]

init_1 :: Matrix
init_1 =
  [ nulls 
  , [0, 0.1, 0.1, 0.1, 0]
  , [0, 0.1, 0.9, 0, 0]
  , [0, 0.1, 0, 0, 0]
  , nulls ]

init_2 :: Matrix
init_2 =
  [ nulls  
  , nulls
  , [0, 0, 1, 0, 0]
  , nulls
  , nulls ]

init_3 :: Matrix
init_3 =
  [ nulls
  , [0, 0.1, 0.1, 0.1, 0]
  , [0, 0.1, 1.0, 0.1, 0]
  , [0, 0.1, 0.1, 0.1, 0]
  , nulls ]

comp_1 :: Label -> Label -> Double
comp_1 _ _ = 1

comp_2 :: Label -> Label -> Double
comp_2 Edge Edge = 2
comp_2 _ _ = 1

comp_3 :: Label -> Label -> Double
comp_3 = comp_2

labels = [Edge, NonEdge]

-- Support given by an object aj to the label assignment \l for ai
-- label : proposed \l for ai
-- comp  : compatibility function
-- ps    : Probability of aj having label \k in the current step
contextualSupport :: Label -> (Label -> Label -> Double) -> Double -> Double
contextualSupport label comp ps =
  sum $ map supp' labels
  where
    supp' Edge    = comp label Edge * ps
    supp' NonEdge = comp label NonEdge * (1 - ps)

-- Neighbourhood coefficient function
cy :: Index -> Index -> Double
cy (x, y) (x', y') =
  case (dx, dy) of
    (0, 1) -> 1
    (1, 0) -> 1
    (1, 1) -> 1
    _      -> 0
  where
    dx = abs $ x - x'
    dy = abs $ y - y'

-- Gives the total support for a label assignment as according to the notes
totalSupport :: Label -> Index -> Matrix ->  (Label -> Label -> Double) -> Double
totalSupport l ix ps comp =
  sum $ map f ixs
  where
    f ix'@(x, y) =
      (cy ix ix') * (contextualSupport l comp ((ps !! y) !! x))
    ixs =
      liftM2 (,) [0..4] [0..4]

-- Recomputes the whole matrix by first computing contextual (total)
-- support for each probability in the matrix, and then computing the
-- whole thing
recomputeP :: (Label -> Label -> Double) -> Label -> Matrix -> Matrix
recomputeP comp l ps =
  map rRows [0..4]
  where
    rRows y =
      map (flip rElem y) [0..4]
    rElem x y =
      psLabel / psAll
      where
        psLabel         = psVal * supp Edge
        psAll           = sum $ map getPsLabel [Edge, NonEdge]
        getPsLabel Edge    = psVal * supp Edge
        getPsLabel NonEdge = psValI * supp NonEdge
        supp l'         = totalSupport l' (x, y) ps comp
        psVal           = ((ps !! y) !! x)
        psValI          = 1 - psVal

-- Iterates the relaxation infinitely (use take n or !! to get a
-- certain number of steps)
iterateR :: (Label -> Label -> Double) -> Matrix -> [Matrix]
iterateR comp = iterate (recomputeP comp Edge)

-- Shows the matrix after n iterations
showStep n comp ps =
  show' $ (iterateR comp ps) !! n