home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / MODULA2 / MARRIAGE.MOD < prev    next >
Text File  |  2000-06-30  |  3KB  |  123 lines
  1. (* Find a solution to the stable marriage problem.  n men and
  2.    n women state their preferences of partners.  Find n pairs
  3.    such that no man would prefer to be married to another woman
  4.    who would also prefer him to her partner.  A set of pairs is
  5.    called stable, if no such cases exist.
  6.    [see also Comm. ACM 14, 7, 486-92 (July 71)]. *)
  7.  
  8. MODULE marriage;
  9.  
  10. FROM  InOut IMPORT WriteString, Write, WriteLn, WriteCard, ReadCard;
  11.  
  12. CONST n = 8;
  13.  
  14. TYPE man = [1..n];
  15.      woman = [1..n];
  16.      rank = [1..n];
  17.  
  18. VAR m: man;
  19.     w: woman;
  20.     r: rank;
  21.     wmr: ARRAY man,rank OF woman;
  22.     mwr: ARRAY woman,rank OF man;
  23.     rmw: ARRAY man,woman OF rank;
  24.     rwm: ARRAY woman,man OF rank;
  25.     x: ARRAY man OF woman;
  26.     y: ARRAY woman OF man;
  27.     single: ARRAY woman OF BOOLEAN;
  28.  
  29. PROCEDURE print;
  30. VAR m: man;
  31.     rm,rw: CARDINAL;
  32.  
  33. BEGIN
  34.   rm := 0; rw := 0;
  35.   FOR m := 1 TO n DO
  36.     WriteCard(x[m],4);
  37.     rm := rm + rmw[m,x[m]];
  38.     rw := rw + rwm[x[m],m]
  39.   END;
  40.   WriteCard(rm,8); WriteCard(rw,4);
  41.   WriteLn
  42. END print;
  43.  
  44. PROCEDURE try(m: man);
  45. VAR r: rank;
  46.     w: woman;
  47.  
  48.   PROCEDURE stable(): BOOLEAN;
  49.   VAR pm: man;
  50.       pw: woman;
  51.       i,lim: rank;
  52.       s: BOOLEAN;
  53.  
  54.   BEGIN
  55.     s := TRUE; i := 1;
  56.     WHILE (i < r) AND s DO
  57.       pw := wmr[m,i];
  58.       INC(i);
  59.       IF NOT single[pw] THEN s := rwm[pw,m] > rwm[pw,y[pw]] END;
  60.     END;
  61.     i := 1;
  62.     lim := rwm[w,m];
  63.     WHILE (i < lim) AND s DO
  64.       pm := mwr[w,i]; INC(i);
  65.       IF pm < m THEN s := rmw[pm,w] > rmw[pm,x[pm]] END;
  66.     END;
  67.     RETURN s
  68.   END stable;
  69.  
  70. BEGIN
  71.   FOR r := 1 TO n DO
  72.     w := wmr[m,r];
  73.     IF single[w] THEN
  74.       IF stable() THEN
  75.         x[m] := w;
  76.         y[w] := m;
  77.         single[w] := FALSE;
  78.         IF m < n THEN try(m+1) ELSE print END;
  79.         single[w] := TRUE
  80.       END
  81.     END
  82.   END
  83. END try;
  84.  
  85. BEGIN
  86.   Write('1'); WriteLn;
  87.   FOR m := 1 TO n DO
  88.     FOR r := 1 TO n DO
  89. WriteString('Enter> ');
  90.       ReadCard(wmr[m,r]);
  91.       rmw[m,wmr[m,r]] := r;
  92. WriteLn;
  93.     END
  94.   END;
  95.   FOR w := 1 TO n DO
  96.     FOR r := 1 TO n DO
  97. WriteString('Enter2> ');
  98.       ReadCard(mwr[w,r]);
  99.       rwm[w,mwr[w,r]] := r;
  100. WriteLn;
  101.     END
  102.   END;
  103.   FOR w := 1 TO n DO single[w] := TRUE END;
  104.   try(1)
  105. END marriage.
  106.  
  107.     (* 5 7 1 2 6 8 4 3
  108.        2 3 7 5 4 1 8 6
  109.        8 5 1 4 6 2 3 7
  110.        3 2 7 4 1 6 8 5
  111.        7 2 5 1 3 6 8 4
  112.        1 6 7 5 8 4 2 3
  113.        2 5 7 6 3 4 8 1
  114.        3 8 4 5 7 2 6 1
  115.        5 3 7 6 1 2 8 4
  116.        8 6 3 5 7 2 1 4
  117.        1 5 6 2 4 8 7 3
  118.        8 7 3 2 4 1 5 6
  119.        6 4 7 3 8 1 2 5
  120.        2 8 5 4 6 3 7 1
  121.        7 5 2 1 8 6 4 3
  122.        7 4 1 5 2 3 6 8 *)
  123.