Application Center - Maplesoft
  Submit your work
Application Center Applications La méthode hongroise Preview

App Preview:

La méthode hongroise

You can switch back to the summary page by clicking here.

Learn about Maple
Download Application

M?thode hongroise 


? ao?t 2005, Andr? L?vesque

La m?thode hongroise est la mod?lisation d'un algorithme utilis? en recherche op?rationnelle qui permet de minimiser un co?t ou encore de maximiser une satisfaction suite ? une s?rie d'affectations. L'algorithme a ?t? d?velopp? en 1955 par Harold Kuhn et reprise en 1957 par James Munkres.
 

************************************** 

> restart:
ch:="AFFECTATIONS MINIMALES":

couplage:=proc()
local i, j, k, p, q, C:
global a, n, B, iz, jz, nz, mz, m, mi, mj, z:
a:=[]:
z:=1:
while z<>0 do
 iz:='iz':
 jz:='jz':
 while iz<>[] or jz<>[] do
   nz:=[]:
   iz:=[]:
   for i from 1 to n do
     p:=0:
     for j from 1 to n do
       if B[i,j]=0 then
         p:=p+1
       fi:
     od:
     nz:=[op(nz),p]:
   od:
   for i from 1 to n do
     if nz[i]=1 then
       iz:=[op(iz),i]
     fi
   od:
   for i in [op(iz)] do
     for j from 1 to n do
       if B[i,j]=0 then
         a:=[op(a),[i,j]]:
         for k from 1 to n do
           B[i,k]:=1:
           B[k,j]:=1
         od
       fi
     od
   od:
   mz:=[]:
   jz:=[]:
   for i from 1 to n do
     q:=0:
     for j from 1 to n do
       if B[j,i]=0 then
         q:=q+1
       fi:
     od:
     mz:=[op(mz),q]:
   od:
   for i from 1 to n do
     if mz[i]=1 then
       jz:=[op(jz),i]
     fi
   od:
   for i in [op(jz)] do
     for j from 1 to n do
       if B[j,i]=0 then
         a:=[op(a),[j,i]]:
         for k from 1 to n do
           B[j,k]:=1:
           B[k,i]:=1
         od
       fi
     od
   od:
 od:
 z:=0:
 for i from 1 to n do
   for j from 1 to n do
     if B[i,j]=0 then
       z:=z+1
     fi
   od
 od:
 if nops(a)<n and z<>0 then
   C:=matrix(n,n,99999999):
   for i from 1 to n do
     for j from 1 to n do
       p:=0:
       q:=0:
       if B[i,j]=0 then
         for k from 1 to n do
           if B[k,j]=0 then
             p:=p+1:
           fi:
           if B[i,k]=0 then
             q:=q+1:
           fi:
         od:
         C[i,j]:=p+q+abs(p-q)/1e8+min(p,q)/1e8
       fi:
     od:
   od:
   m:=99999999:
   for i from 1 to n do
     for j from 1 to n do
       if C[i,j]<m then
         m:=C[i,j]: mi:=i: mj:=j
       fi
     od
   od:
   a:=[op(a),[mi,mj]]:
   for k from 1 to n do
     B[mi,k]:=1:
     B[k,mj]:=1
   od:
   z:=0:
   for i from 1 to n do
     for j from 1 to n do
       if B[i,j]=0 then
         z:=z+1
       fi
     od
   od
 fi
od
end proc:

support:=proc()
local i, j, k, x, cm, lm, nk, Nk, cq, co:
global X, a, n, lq, mn:
cm:=seq(a[k,1],k=1..nops(a)):
lm:=seq(a[k,2],k=1..nops(a)):
lq:={seq(i,i=1..n)} minus {cm}:
x:=lq:
k:=1:
nk:=0:
co:=[]:
 while nk<>k do
   nk:=k:
   for i in op(lq) do
     for j from 1 to n do
       if X[i,j]=0 and evalb([i,j] in {op(a)})=false then
         co:=[op(co),j]
       fi:
     od:
   od:
   cq:={op(co)}:
   for i from 1 to n do
     for j in op(cq) do      
       if evalb([i,j] in convert(a,set))=true and evalb(i in {cm})=true then
         x:=x union {i}
       fi:
     od:
   od:
   lq:=x:
   k:=nops(lq union cq):
 od:
 x:= {}:
   for i in lq do
     for j in {seq(i,i=1..n)} minus cq do
       x:= x union {X[i,j]}
     od
   od:
   if op(x minus {0})=NULL then
     return
   fi:
   mn:=min(op(x minus {0})):
   for i in lq do
     for j from 1 to n do
       X[i,j]:=X[i,j]-mn
     od
   od:
   for i from 1 to n do
     for j in cq do
       X[i,j]:=X[i,j]+mn
     od
   od
end proc:

matrice:=proc()
local i, j, k, P, x, dp, ml, lg, mc, nl, nc, ct, cp, temps:
global A, B, X, a, n, lq, mn, d, dl, E, db:
a:='a': n:='n': A:='A': B:='B': mn:='mn': lq:=[]:
temps:=time():
if Maplets:-Tools:-Get('TB1')<>"" then
 d:=Maplets:-Tools:-Get('TB1'):
   if d[length(d)]<>"
   " then d:=cat(d,"
")
   fi
else
 use Maplets[Tools] in
 Maplets[Examples][Alert]( "Vous devez d'abord donner les indices d'affectation\nd'au moins deux ?l?ments. Par cons?quent, la troisi?me\ncase doit contenir au moins deux lignes de valeurs.")
 end use:
 return
fi:
 dl:=[]:
 db:="":
 dp:="":
   for i from 1 to length(d) do
     if (d[i]="." and dp<>".")  or (d[i]="," and dp<>",") or (d[i]="-" and dp<>"-") or d[i]="0" or d[i]="1" or d[i]="2" or d[i]="3" or d[i]="4" or d[i]="5" or d[i]="6" or d[i]="7" or d[i]="8" or d[i]="9"  then
       db:=cat(convert(db,string),convert(d[i],string)):
       dp:=d[i]:
     elif d[i]="        " or d[i]="\t" then
       db:=cat(convert(db,string),","):
     elif db<>"" and d[i]="\n" then
         if d[i]="\n" and d[i-1]="," then
         db:=cat("[",seq(db[k], k=1..length(db)-1),"]"):
         dl:=[op(dl),parse(db)]:db:=""
       else
         db:=cat("[",convert(db,string),"]"):
         dl:=[op(dl),parse(db)]:db:=""
       fi
     fi
   od:
   B:=matrix([op(dl),parse(db)]):
   nl:=linalg[rowdim](B):
   nc:=linalg[coldim](B):
   if nl<=1 then
     Maplets[Examples][Alert]("Vous devez d'abord donner les indices d'affectation\nd'au moins deux ?l?ments. Par cons?quent, la troisi?me\ncase doit contenir au moins deux lignes de valeurs."):
     return
   fi:
   n:=max(nl,nc):
   if Maplets:-Tools:-Get('RB1')=true then k:=99999999 else k:=-99999999 fi:
   A:=matrix(n,n,k):
     for i from 1 to nl do
       for j from 1 to nc do
         if whattype(B[i,j])=indexed then
           A[i,j]:=k
         else
           A[i,j]:=B[i,j]
         fi
       od
     od:
   n:=linalg[rowdim](A):
   d:=Maplets:-Tools:-Get('TBE'):
   E:=[]:
   db:="":
     for i from 1 to length(d) do
       if d[i]<>"," and d[i]<>"        " and d[i]<>"\n" and d[i]<>"\t" then
         db:=cat(convert(db,string),convert(d[i],string))
       else
         E:=[op(E),db]:
         db:=""
       fi
     od:
     E:=[op(E),db]:
   d:=Maplets:-Tools:-Get('TBP'):
   P:=[]:
   db:="":
     for i from 1 to length(d) do
       if d[i]<>"," and d[i]<>"        " and d[i]<>"\n"  and d[i]<>"\t" then  
         db:=cat(convert(db,string),convert(d[i],string))
       else
         P:=op[op(P),db]:
         db:=""
       fi
     od:
     P:=[op(P),db]:
     for i from 1 to n do
       lg:="":
       for j from 1 to n do
         lg:=cat(convert(lg,string)," ",convert(A[i,j],string)):
       od:
       Set(TW1(appendline)=lg):
     od:
   B:=matrix(A):
     if Maplets:-Tools:-Get('RB1')=false then
       k:=B[1,1]:
       for i from 1 to n do
         for j from 1 to n do
           if B[i,j]>k then
             k:=B[i,j]
           fi
         od
       od:
       for i from 1 to n do
         for j from 1 to n do
           B[i,j]:=k-B[i,j]
         od
       od
     fi:
     for i from 1 to n do
       ml:=min(seq(B[i,j],j=1..n)):
       for j from 1 to n do
         B[i,j]:=B[i,j]-ml
       od:
     od:
     for j from 1 to n do
       mc:=min(seq(B[i,j],i=1..n));
       for i from 1 to n do
         B[i,j]:=B[i,j]-mc
       od:
     od:
     X:=matrix(B):
     k:=0:
     ct:=0:
       while nops(a)<n and nops(lq)<n and ct<=ceil(n) do
         couplage():
         support():
         B:=matrix(X):
           if nops(a)=cp then
             ct:=ct+1
           fi:
           if ct=ceil(n) then
             Maplets[Examples][Alert]("D?sol?, le programme doit s'arr?ter.\nLa solution est incompl?te.")
           fi:
           cp:=nops(a):         
         k:=k+1:
       od:
       k:=[]:
       for i from 1 to nops(a) do
         for j from 1 to nops(a) do
           if op(1,a[j])=i then
             k:=[op(k),a[j]]
           fi
         od
       od:
       a:=k:
       if nops(E)<nl then
         E:=[seq(i,i=1..n)]:
       fi:
       if nops(P)<nl then
         P:=[seq(i,i=1..n)]:
       fi:
       k:=0:
       for i from 1 to nops(a) do
         if A[a[i,1],a[i,2]]<>99999999 and A[a[i,1],a[i,2]]<>-99999999 then
           Maplets:-Tools:-Set(TFR(appendline)=cat(convert(E[a[i,1]], string), " -> ", convert(P[a[i,2]], string), "  (", convert(A[a[i,1],a[i,2]],string), ")")):
           k:=k+A[a[i,1],a[i,2]]
         fi
       od:
       Maplets:-Tools:-Set(TFR(appendline)=" "):
       Maplets:-Tools:-Set(TFR(appendline)=cat("Indice total = ", convert(k,string))):
       Maplets:-Tools:-Set(TFR(appendline)=cat("Temps = ", convert(time()-temps,CaractDec), " sec."))
end proc:

max_min:=proc()
local ch:
 if Maplets:-Tools:-Get('RB1')=true then
   ch:="AFFECTATIONS MINIMALES"
 else
   ch:="AFFECTATIONS MAXIMALES"
 fi:
Maplets:-Tools:-Set('L1'(caption)=ch):
end proc:

`convert/CaractDec`:= proc(x)
local X, i, j:
X:= sprintf(cat("%", 2*Digits+2, ".", Digits, "f"), x):
for i while X[i] = " " do od:
for j from length(X) by -1 while X[j] = "0" do od:
if X[j] = "." then j:= j-1 fi:
X[i..j]
end:

with(Maplets[Elements]):
hongroise:=Maplet('onstartup'=RunWindow('W0'),
Window['W1'](title="Aide",'layout' = 'BL2', resizable = false),
BoxLayout['BL2'](
BoxColumn(border=true,
TextBox['TB2'](width=70,height=20,editable=false,
"
M?THODE HONGROISE (Algorithme d'affectation)

La m?thode hongroise est un algorithme qui permet de minimiser un co?t ou de maximiser une satisfaction suite ? une s?rie d'affectations. L'algorithme a ?t? d?velopp? en 1955 par Harold Kuhn et reprise en 1957 par James Munkres.

Supposons par exemple qu'un employeur vient d'accueillir cinq stagiaires ? qui il a demand? d'exprimer par une note de 1 ? 5, leurs pr?f?rences vis-?-vis de cinq postes ? pourvoir.

               Poste 1  Poste 2  Poste 3  Poste 4  Poste 5
                      
  Stagiaire 1     1        2        3        4        5
  Stagiaire 2     1        4        2        5        3
  Stagiaire 3     3        2        1        5        4
  Stagiaire 4     1        2        3        5        4
  Stagiaire 5     2        1        4        3        5

La m?thode hongroise permet d'obtenir une affectation qui r?pond le mieux aux souhaits des stagiaires.

  Stagiaire 1 -> Poste 5  (indice de satisfaction 5)
  Stagiaire 2 -> Poste 2  (indice de satisfaction 4)
  Stagiaire 3 -> Poste 1  (indice de satisfaction 3)
  Stagiaire 4 -> Poste 4  (indice de satisfaction 5)
  Stagiaire 5 -> Poste 3  (indice de satisfaction 4)

Indice de satisfaction global 21.


MARCHE ? SUIVRE

Pour obtenir la r?ponse pr?c?dente en utilisant l'application fournie,
il faut:

 a) cocher la case ?AFFECTATIONS MAXIMALES?

 b) indiquer les ?l?ments ? affecter ? la case ? X = ?
      Stagiaire 1, Stagiaire 2, Stagiaire 3, Stagiaire 4, Stagiaire 5

 c) indiquer les affectations possibles ? la case ? Y = ?
      Poste 1, Poste 2, Poste 3, Poste 4, Poste 5

 d) indiquer les indices de satisfaction pour les diff?rentes
    affections ? la derni?re case
      1, 2, 3, 4, 5
      1, 4, 2, 5, 3
      3, 2, 1, 5, 4
      1, 2, 3, 5, 4
      2, 1, 4, 3, 5

Notons que les ?tapes b) et c) sont des ?tapes optionnelles. Lorsque les cases associ?es ? ces ?tapes sont vides, les ?l?ments ? affecter et les affectations possibles seront num?rot?s (1, 2, 3, ...). Les diff?rentes donn?es peuvent ?tre copi?es et coll?es ? partir d'un tableur comme Excel.

La m?thode produit une seule solution optimale m?me si la solution optimale n'est pas unique.

Soyez conscient que les temps de calcul augmentent rapidement. La dur?e des calculs d?pend ?videmment du nombre d'indices d'affection mais aussi de la diversit? de ces indices. Par exemple un probl?me contenant 10 000 indices d'affectation s'?chelonnant de 0 ? 10 000 prendra entre 1 et 4 minutes sur un PC cadenc? ? 3,2 Ghz.
"
),
Button("FERMER",CloseWindow('W1'))
)
),
Window['W0'](title="Probl?me d'affectation (m?thode hongroise)", 'menubar'='MB1', resizable = false,
[border=true, 'inset'=0, 'spacing'=0,
 [
   [
     [
     RadioButton['RB1']("AFFECTATIONS MINIMALES", 'value'=true,'group'='BG1'),
     RadioButton['RB2']("AFFECTATIONS MAXIMALES", 'value'=false,'group'='BG1')
     ],
   Label(" ", font=Font('Helvetica',4)),
   Label("Indiquez tous les ?l?ments ? affecter (optionnel)", font=Font('Helvetica',11)),
     [
     "X = ",TextField['TBE'](" X1, X2, X3, X4, X5, X6, X7, X8, X9, X10", width=60, tooltip="Tapez ou copiez et collez les ?l?ments", 'popupmenu'='P1')
     ],
   Label("Indiquez les diff?rentes affectations (optionnel)", font=Font('Helvetica',11)),
     [
     "Y = ",
     TextField['TBP'](" Y1, Y2, Y3, Y4, Y5, Y6, Y7, Y8, Y9, Y10", width=60, tooltip="Tapez ou copiez et collez les ?l?ments", 'popupmenu'='P2')
     ],
   Label("Donnez les indices d'affection", font=Font('Helvetica',11)),
     [
     "X    ",
     TextBox['TB1'](" 30, 60, 24, 45, 59, 61, 21, 34, 43, 86\n 44, 32, 22, 37, 45, 63, 15, 34, 35, 43\n 95, 19, 11, 95, 20, 21, 17, 53, 75, 91\n 69, 85, 86, 33, 85, 26, 25, 75, 51, 31\n 64, 56, 15, 58, 38, 70, 77, 62, 54, 88\n 27, 71, 54, 21, 74, 26, 42, 92, 52, 34\n 15, 37, 13, 95, 21, 19, 80, 80, 48, 86\n 24, 37, 59, 35, 53, 62, 86, 33, 65, 48\n 12, 50, 54, 33, 90, 78, 39, 74, 90, 76\n 59, 89, 65, 48, 94, 21, 34, 36, 25, 14
", height=12, width=60, wrapped = false, tooltip="Tapez ou copiez et collez les indices d'affectation", 'popupmenu'='P3')
     ],
   "Y",
     [
     Button['B1']("EFFECTUER", onclick=Action(Evaluate('TFR'=""), SetOption('B1'(enabled)=false), Evaluate('function'='matrice()'), SetOption('B1'(enabled)=true))),
     Label("? Andr? L?vesque", halign =left, font=Font('Helvetica',italic,10))
     ]
   ],
   [
   Label['L1']("AFFECTATIONS MINIMALES", font=Font('Helvetica', bold, 11), foreground="#31AE31"),
   TextBox['TFR'](height=24, width=25, editable=false, wrapped = false)
   ]
 ]
],
 MenuBar['MB1'](
   Menu("Fichier",
       MenuItem("Fermer", Shutdown())
   ),
   Menu("?",
       MenuItem("Aide", RunWindow('W1'))
   )
 ),
 PopupMenu['P1'](
   MenuItem("Effacer", onclick = Action(SetOption('TBE' = ""), SetOption('TFR' = "")))
 ),
 PopupMenu['P2'](
   MenuItem("Effacer", onclick = Action(SetOption('TBP' = ""), SetOption('TFR' = "")))
 ),
 PopupMenu['P3'](
   MenuItem("Effacer", onclick = Action(SetOption('TB1' = ""), SetOption('TFR' = "")))
 )
),
ButtonGroup['BG1'](onchange=Evaluate('L1'='max_min()'))
):
Maplets[Display](hongroise):