home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / ada / setl2 / samples / gs.stl < prev    next >
Text File  |  1991-11-16  |  3KB  |  111 lines
  1. --
  2. --  STABLE ASSIGNMENT PROGRAM
  3. --  =========================
  4. --
  5. --  This program matches students with colleges in such a way that the
  6. --  following three conditions are satisfied:
  7. --
  8. --     1.  No college accepts more than quota(c).
  9. --     2.  A college never admits a student if it has filled its quota
  10. --         and there exists an unassigned student to whom the college is
  11. --         acceptable and the college prefers.
  12. --     3.  There is not situation in which two students each prefer the
  13. --         other's college, and each college prefers the other's student.
  14. --
  15. --  The algorithm is due to David Gale and Lloyd Shapley.
  16. --
  17.  
  18. program gale_shapley;
  19.  
  20.    -- colleges
  21.  
  22.    const A := "NYU", B := "Harvard", C := "Princeton", D := "MIT";
  23.  
  24.    -- student preferences
  25.  
  26.    stud_pref := {[1,[A,B,C]],[2,[B,C,A,D]],[3,[C,A,B]],[4,[B,A,C]]};
  27.  
  28.    -- college preferences
  29.    
  30.    coll_pref := {[A,[1,2,3,4]],[B,[4,3,2,1]],[C,[2,4,3]],[D,[1,2,3]]};
  31.  
  32.    -- college quotas
  33.  
  34.    quota := {[A,2],[B,1],[C,1],[D,2]};
  35.  
  36.    -- perform the assignment and print results
  37.  
  38.    print(assign(stud_pref,coll_pref,quota));
  39.  
  40.    --
  41.    --  Assign
  42.    --  ------
  43.    --
  44.    --  Make the stable assignment.
  45.    --
  46.  
  47.    procedure assign(rw stud_pref,coll_pref,quota);
  48.  
  49.       colleges := domain quota;
  50.       active := {[c,[]] : c in colleges};  -- active list by college
  51.       applicants := domain stud_pref;      -- initialize applicant list
  52.  
  53.       -- we may need as many rounds as there are colleges
  54.  
  55.       for j in [1 .. #quota] loop
  56.  
  57.          new_applicants := applicants;
  58.         
  59.          -- each student who has a college to apply to does so
  60.  
  61.          for s in applicants | stud_pref(s) /= [] loop
  62.  
  63.             first_choice fromb stud_pref(s);
  64.             active(first_choice) with:= s;
  65.             new_applicants less:= s;
  66.     
  67.          end loop;
  68.  
  69.          applicants := new_applicants;
  70.  
  71.          -- drop all over quota applicants
  72.  
  73.          for c in colleges | #active(c) > quota(c) loop
  74.  
  75.             active(c) := pref_sort(active(c),coll_pref(c));
  76.  
  77.             for k in [quota(c)+1 .. #active(c)] loop
  78.                applicants with:= active(c)(k);
  79.             end loop;
  80.  
  81.             active(c) := active(c)(1 .. #active(c) min quota(c));
  82.  
  83.          end loop;
  84.  
  85.          if not (exists s in applicants | stud_pref(c) /= []) then
  86.             exit;
  87.          end if;
  88.  
  89.       end loop;
  90.  
  91.       return [active,applicants];
  92.  
  93.    end assign;
  94.  
  95.    --
  96.    --  Pref_sort
  97.    --  ---------
  98.    --
  99.    --  Sort applicants by college choice.
  100.    --
  101.  
  102.    procedure pref_sort(apvect,order);
  103.  
  104.       applicants := {x : x in apvect};
  105.       return [x in order | x in applicants];
  106.  
  107.    end pref_sort;
  108.  
  109. end gale_shapley;
  110.  
  111.