L’algorithme de Dijkstra permet de calculer, pour un graphe donné, les plus courts chemins entre une source (un des sommets du graphe) et tous les autres sommets.

On peut se servir de cet algorithme pour résoudre le problème du plus court chemin si on connaît le départ et l’arrivée par exemple.

Ici, on va chercher à implémenter de manière efficace et générique l’algorithme de manière à pouvoir s’en servir plus tard pour résoudre des problèmes de labyrinthe (trouver un chemin entre l’entrée et la sortie du labyrinthe).

Notre implémentation va être générique, donc à la fin elle sera simple, mais on doit commencer par mettre en place toute une machinerie.

On va commencer par étudier deux choses :

les arbres dits “tournois” ;
les files de priorité.

Les concepts de base

A - Tournois

Un arbre de tournoi, c’est tout simplement un arbre dans lequel toutes les feuilles sont les concurrents et à chaque noeud, les concurrents qui ont remporté les tournois des sous-arbres s’affrontent.

Tournois dans la vraie vie

Vous avez forcément déjà vu un arbre tournoi dans votre vie. Toutes les compétitions sportives à élimination directe fonctionnent comme ceci. Par exemple, voici l’arbre tournoi de la dernière coupe du monde de football :

On représente en Haskell un tournoi avec le type suivant :

data Tournoi a = Joueur { vainqueur :: a }
               | Match {
                    vainqueur :: a,
                    tG        :: (Tournoi a),
                    tD        :: (Tournoi a)
                }

Les feuilles sont donc les joueurs, et les noeuds internes contiennent le vainqueur du match entre les joueurs qui ont gagné les tournois des sous-arbres du noeud. Ici, on ajoute une fonction vainqueur même aux feuilles pour des questions de simplification de l’écriture du code par la suite.

1. Construire un Match

On va chercher à écrire une fonction joueMatch qui va prendre en paramètre une fonction de priorité et deux tournois et qui va construire un Match dont le vainqueur est le vainqueur qui a la plus faible priorité entre les vainqueurs des deux tournois donnés.

Dans notre cas, on va considérer que le gagnant est celui qui a la plus faible priorité.

jouerMatch :: Ord b => (a -> b) -- la fonction de priorité
            -> Tournoi a        -- le premier tournoi
            -> Tournoi a        -- le deuxième tournoi
            -> Tournoi a        -- le Match entre les deux
jouerMatch prio t1 t2 | prio v1 <= prio v2 = Match v1 t1 t2 -- on regarde qui a la plus faible priorité
                     | otherwise          = Match v2 t1 t2
    where
        v1 = vainqueur t1
        v2 = vainqueur t2

2. Construire un tournoi à partir d’une liste

Si on a une liste de joueurs de type a, on veut construire le tournoi (équilibré) qui les fait jouer ensemble.

Pour ça, on va transformer les éléments de la liste en Tournoi, en utilisant le constructeur Joueur, puis jouer des tours jusqu’à ce qu’il ne reste qu’un seul tournoi.

Jouer un tour, ça va consister à appliquer jouerMatch aux éléments de la liste deux par deux. Ça va nous produire une nouvelle liste avec deux fois moins de tournois à chaque fois.

jouerTour :: Ord b => (a -> b) -- la fonction de priorité
            -> [Tournoi a]     -- la liste initiale
            -> [Tournoi a]     -- la liste après avoir joué le tour
jouerTour prio (t1:t2:ts) = jouerMatch prio t1 t2 : jouerTour prio ts -- on joue le premier match et on continue
jouerTour _    ts         = ts -- si on a moins de deux tournois, on ne joue rien

On veut maintenant faire ça jusqu’à ce qu’il n’y ai plus qu’un seul tournoi. Si on a une liste vide, ça va échouer, donc on va encapsuler tout ça dans un Maybe.

jouerTournoi :: Ord b => (a -> b)    -- toujours la fonction de priorité
                -> [a]               -- la liste des joueurs initiale
                -> Maybe (Tournoi a) -- le (peut-être) résultat
jouerTournoi _    [] = Nothing
jouerTournoi prio js = Just . go . map Joueur $ js -- on renvoie Just sur le résultat de go sur la liste de Joueur
    where
        go [t] = t                      -- un seul élément, on le renvoie
        go ts  = go $ jouerTour prio ts -- plus, on joue un tour et on recommence

Comme on divise par deux la taille de la liste à chaque itération de jouerTour, on se retrouve avec un tournoi dont la hauteur finale est de \(\mathsf{log}(n)\).

B - Superposer un ABR aux tournois

Pour qu’on puisse retrouver facilement un joueur dans un tournoi, et notamment la feuille qui lui correspond, on va supposer que les éléments n’ont pas qu’une priorité, mais également une clé. Du coup, on va aussi stocker dans chaque noeud la clé maximale de chaque sous-arbre. On va aussi supposer que les joueurs sont maintenant initialement ordonnés par clé, la plus petite à gauche, la plus grande à droite.

Le modèle qu’on a est donc maintenant le suivant :

data CP p k = CP {
                priorite :: p, -- la priorité de l'élément
                cle      :: k -- la clé (unique)
             }

data TABR p k = Joueur { vainqueur :: CP p k }
              | Match {
                vainqueur :: CP p k,
                maxCleG   :: k,
                maxCleD   :: k,
                tG        :: (TABR p k),
                tD        :: (TABR p k)
               }

Les joueurs contiennent maintenant une clé de type k et une priorité de type p.

1. Refaire les tournois

On va devoir réécrire nos fonctions précédentes pour qu’elles prennent en considération ce nouveau type.

Les changements vont être légers, mais vont permettre de conserver les invariants des ABR, à savoir que les clés du sous-arbre gauche doivent être plus petites que les clés du sous-arbre droit.

On n’a notamment plus besoin d’une fonction de priorité, puisqu’elle est désormais contenue dans les éléments.

jouerMatch :: Ord p => TABR p k -- le premier tournoi
            -> TABR p k         -- le deuxième tournoi
            -> TABR p k         -- le tournoi construit
jouerMatch t1 t2 | priorite v1 <= priorite v2 = mkMatch v1
                 | otherwise                  = mkMatch v2
    where
        mkMatch :: CP p k -> Tournoi p k -- construit un Match
        mkMatch v = Match v (cleMax t1) (cleMax t2) t1 t2
        cleMax :: Tournoi p k -> k -- trouve la clé maximale d'un tournoi (la plus à droite)
        cleMax (Joueur a) = cle a
        cleMax t          = maxCleD t
        v1 = vainqueur t1
        v2 = vainqueur t2

-- Ici, à part les types, c'est sensiblement la même chose qu'avant
jouerTour :: Ord p => [TABR p k] -> [TABR p k]
jouerTour (t1:t2:ts) = jouerMatch t1 t2 : jouerTour ts
jouerTour ts         = ts

-- Ici, on a besoin que les clés soient Ord pour trier la liste
-- et que les priorités soient Ord pour les comparer
jouerTournoi :: (Ord k, Ord p) => [CP p k] -- la liste initiale
                -> Maybe (TABR p k) -- (peut-être) le tournoi final
jouerTournoi []  = Nothing
jouerTournoi cps = Just . go . map Joueur . sortOn cle $ l
    where
        go [t] = t
        go ts  = go $ jouerTour ts

2. Modifier la priorité d’un élément

Maintenant qu’on a un arbre tournoi qui est aussi un ABR, on peut retrouver efficacement un joueur en fonction de sa clé.

Pour modifier la priorité d’un joueur en connaissant la clé, on descend dans l’arbre, on change la valeur de la priorité de la feuille, et on rejoue uniquement les matchs nécessaires en remontant.

On a donc une fonction qui a cette tête :


1
2
3
4
5
6
7
8

ajuste :: (Ord p, Ord k) => (p -> p) -- la modification de priorité
            -> k                     -- la clé du joueur à modifier
            -> TABR p k              -- l'arbre dans lequel on modifie
            -> TABR p k              -- l'arbre modifié
ajuste f k j@(Joueur cp)        | k == cle cp = Joueur $ cp{priorite = f (priorite cp)}
                                | otherwise   = j
ajuste f k (Match _ cg _ tg td) | k <= cg   = jouerMatch (ajuste f k tg) td
                                | otherwise = jouerMatch tg (ajuste f k td)

Il est important de noter qu’en utilisant la syntaxe d’enregistrement on peut modifier la valeur de la priorité sans reconstruire l’élément complet (ligne 5).

3. Enlever l’élément de priorité minimale

Pour enlever l’élément de priorité minimale, il suffit de regarder le vainqueur qui se trouve à la racine. Pour l’enlever, il suffit de descendre jusqu’à sa feuille la supprimer, et rejouer le tournoi en remontant.

La fonction pourra échouer si l’arbre est vide notamment, donc on va encapsuler tout ça dans un Maybe pour éviter les problèmes.

supprMin :: (Ord p, Ord k) => TABR p k -- l'arbre dans lequel on supprime
            -> Maybe (TABR p k)        -- (peut-être) l'arbre modifié
supprMin (Joueur _)          = Nothing --  si on n'avait qu'un joueur, alors on renvoie rien
supprMin m@(Match v _ _ _ _) = Just $ go (cle v) m -- sinon, on supprime la feuille quand on la trouve et on rejoue
    where
        go :: (Ord k) => k -> TABR p k -> TABR p k
        go k (Match _ cg _ tg td) | k <= cg   = case tg of
                                                    Joueur _ -> td -- à gauche c'est une feuille, donc celle qu'on cherche
                                                    _        -> joueMatch (go k tg) td -- c'est pas une feuille, on continue à gauche
                                  | otherwise = case td of
                                                    Joueur _ -> tg
                                                    _        -> joueMatch tg (go k td)

Dijkstra (enfin)

Pour simplifier un peu notre code, on va ajouter un champ dans notre structure de donnée CP. On va lui donner un attribut actif, qui permettra de simplement désactiver une feuille quand on la retire du tournoi, sans la supprimer de l’arbre.

Ça va changer légèrement deux fonctions :

jouerMatch fera toujours gagner un joueur actif face à un inactif
supprMin bascule simplement le champ à False et renvoie l’arbre modifié

De ce fait, la fonction de suppression sera maintenant totale : elle n’a plus besoin de Maybe.

Les types qu’on utilise sont donc désormais :

data CP p k = CP {
                priorite :: p, -- la priorité de l'élément
                cle      :: k, -- la clé (unique)
                actif    :: Bool
               }

data TABR p k = Joueur { vainqueur :: CP p k }
              | Match {
                    vainqueur :: CP p k,
                    maxCleG   :: k,
                    maxCleD   :: k,
                    tG        :: (TABR p k),
                    tD        :: (TABR p k)
                }

Par ailleurs, au lieu de considérer que les priorités dans un TABR sont instances de la classe Ord, nous allons considérer qu’elles sont instances d’une classe PreOrd. Un type qui implémente la classe PreOrd est totalement ordonnée par une relation qui vérifie toutes les propriétés d’un ordre total (toute paire de valeurs est comparable, réflexivité, transitivité), mais pas forcément l’anti-symétrie : si nous avons \(x \preceq y\) et \(y \preceq x\), on ne peut pas en déduire que \(x = y\). Voici cette classe, nous ajoutons également le type Pre qui permet de transformer une instance de la classe Ord en instance de la classe PreOrd. Nous ajoutons aussi les instances de foncteurs applicatifs afin de pouvoir implémenter plus élégamment nos instances et notamment de pouvoir transporter une instance de Num pour un type a sur le type Pre a.

Implémentation de PreOrd

class PreOrd a where
    preCompare :: a -> a -> Ordering
    (≺), (≺=), (≻), (≻=) :: a -> a -> Bool
    preMin, preMax :: a -> a -> a

    preCompare a b | a ≻ b     = GT
                   | b ≻ a     = LT
                   | otherwise = EQ

    x ≺ y  = case preCompare x y of {LT -> True; _ -> False}
    x ≺= y = case preCompare x y of {GT -> False; _ -> True}
    x ≻ y  = not (x ≺= y)
    x ≻= y = not (x ≺ y)

    preMin x y = case preCompare x y of {GT -> y; _ -> x}
    preMax x y = case preCompare x y of {LT -> y; _ -> x}


newtype Pre a = Pre {getPre :: a}

instance Functor Pre where
    fmap :: (a -> b) -> Pre a -> Pre b
    fmap f = Pre . f . getPre

instance Applicative Pre where
    pure :: a -> Pre a
    pure = Pre

    liftA2 :: (a -> b -> c) -> Pre a -> Pre b -> Pre c
    liftA2 f p1 p2 = Pre (f (getPre p1) (getPre p2))

    liftProj :: (a -> b -> c) -> Pre a -> Pre b -> c
    liftProj f p1 p2 = getPre $ liftA2 f p1 p2

    instance Ord a => PreOrd (Pre a) where
    preCompare :: Ord a => Pre a -> Pre a -> Ordering
    preCompare = liftProj compare

    (≺) :: Ord a => Pre a -> Pre a -> Bool
    (≺) = liftProj (<)
    (≻) :: Ord a => Pre a -> Pre a -> Bool
    (≻) = liftProj (>)
    (≺=) :: Ord a => Pre a -> Pre a -> Bool
    (≺=) = liftProj (<=)
    (≻=) :: Ord a => Pre a -> Pre a -> Bool
    (≻=) = liftProj (>=)

    preMin :: Ord a => Pre a -> Pre a -> Pre a
    preMin = liftA2 min
    preMax :: Ord a => Pre a -> Pre a -> Pre a
    preMax = liftA2 max

instance Num a => Num (Pre a) where
    (+) :: Num a => Pre a -> Pre a -> Pre a
    (+) = liftA2 (+)
    (*) :: Num a => Pre a -> Pre a -> Pre a
    (*) = liftA2 (*)
    abs :: Num a => Pre a -> Pre a
    abs = fmap abs
    signum :: Num a => Pre a -> Pre a
    signum = fmap signum
    fromInteger :: Num a => Integer -> Pre a
    fromInteger = Pre . fromInteger
    negate :: Num a => Pre a -> Pre a
    negate = fmap negate

Après cette variation, les fonctions qu’on a définies précédemment ont maintenant les types suivants :

jouerTournoi :: (PreOrd p, Ord k) => [CP p k] -> Maybe (TABR p k)
ajuste :: (PreOrd p, Ord k) => (p -> p) -> k -> TABR p k -> TABR p k
supprMin :: (PreOrd p, Ord k) => TABR p k -> TABR p k

A - Dijkstra

Les graphes peuvent être représentés par un modèle très simple :

class Graph g s where
    -- la fonction vertices renvoie la liste des sommets d'un graphe g
    vertices :: g -> [s]
    -- la fonction neighbours renvoie la liste des sommets voisins de s dans g
    neighbours :: g -> s -> [s]

L’algorithme de Dijkstra permet de calculer les meilleures distances entre un sommet source et tous les sommets d’un graphe. Il permet également de calculer un chemin ou encore tous les chemins de meilleure longueur pour chaque sommet du graphe à partir du sommet source.

Afin de pouvoir représenter les distances le long d’une arête, on définit la classe de types des graphes pondérés WGraph g s p où le type g est le type des graphes de sommets de type s et dont les arêtes sont étiquetées avec des valeurs de type p.

class Graph g s => WGraph g s p where
    -- on ajoute une fonction wNeighbours qui renvoie la liste
    -- des sommets voisins avec le poids des arêtes
    wNeighbours :: g -> s -> [(s, p)]

Pour finir, on va ajouter un nouveau type de donnée pour représenter les distances. On va définir le type Infini a, qui sera une instance de Num, Ord, PreOrd quand a est lui même une instance de Num, Ord ou PreOrd.

En d’autres mots, on va encapsuler la possibilité d’avoir des distances infinies également, ce qui va nous servir à représenter le fait qu’on ne connaît pas la distance entre un sommet du graphe et la source (pour le moment).

Implémentation de Infini a

data Infini a = Infini | Fini a
                deriving Eq

instance Num a => Num (Infini a) where
    (+) (Fini a) (Fini b) = Fini (a+b)
    (+) _ _ = Infini

    (*) (Fini a) (Fini b) = Fini (a*b)
    (*) _ _ = Infini

    abs (Fini a) = Fini (abs a)
    abs Infini = Infini

    signum (Fini a) = Fini(signum a)
    signum Infini = 1

    fromInteger = Fini . fromInteger

    negate (Fini a) = Fini (negate a)
    negate Infini = Infini

instance PreOrd a => PreOrd (Infini a) where
    preCompare (Fini a1) (Fini a2) = preCompare a1 a2
    preCompare Infini Infini       = EQ
    preCompare Infini _            = GT
    preCompare _      Infini       = LT

instance Ord a => Ord (Infini a) where
    compare (Fini a1) (Fini a2) = compare a1 a2
    compare Infini Infini = EQ
    compare Infini _      = GT
    compare _      Infini = LT

1. Être infini ?

On va s’écrire une petite fonction utile qui va nous dire si une valeur de type Infini a est infinie ou non

estInfini :: Infini a -> Bool
estInfini Infini = True
estInfini _      = False

2. Graphes avec étiquettes `Ord`

Souvent, les graphes qu’on va utiliser seront étiquetés avec des valeurs qui implémentent Ord et pas PreOrd. Comme on veut imposer l’utilisation de PreOrd pour les priorités et qu’on sait que si on a un Ord, on a facilement un PreOrd, on va montrer qu’une instance de graphe pondéré par Ord l’est aussi par PreOrd.

instance (WGraph g s p, Ord p) => WGraph g s (Pre p) where
    -- il suffit de redéfinir la fonction wNeighbours
    -- pour qu'on affecte le constructeur Pre dans les poids des arêtes
    wNeighbours g s = map (\(s', w) -> (s', Pre w)) $ wNeighbours g s