A more low-tech approach ...

#lang racket

(require threading)

(define students '(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z))

(define indexes (for/hash ([s students] [i (in-naturals)])
                  (values s i)))

; A -> 0, B -> 1, ...
(define (index student)
  (hash-ref indexes student))

; Generate synthetic preferences for 'student'
;
(define (random-preferences student)
  (~> students
      (remove student _)
      shuffle
      (take 3)))

; Generate synthetic preferences for all the students
;
(define preferences
  (for/hash ([s students])
    (define prefs (random-preferences s))
    (displayln (list s prefs))
    (values s prefs)))

; Score 1 if a likes b; 0 otherwise
;
(define (likes a b)
  (if (~> preferences (hash-ref a) (member b _)) 1 0))

; Score 2 is a and b like each other
; Score 1 if only one likes the other
; Score 0 otherwise
;
(define (pair-score a b)
  (+ (likes a b) (likes b a)))

; Find all the pairings where the pair-score is n
;
(define (scores-exactly n)
  (shuffle
   (for*/list ([a students]
               [b students]
               #:when (and (< (index a) (index b))
                           (= (pair-score a b) n)))
     (list a b))))

; What is the total score and pair-wise score for these pairs?
;
(define (score-assignment pairs)
  (define scored-pairs
    (for/list ([p pairs])
      (list p (apply pair-score p))))
  (list (for/sum ([p scored-pairs])
          (last p))
        scored-pairs))

; First try tp pair up students who want to work together
; Next students where at least one wants to work with the other
; Finally there may be some unlucky ones
;
(define (assign-pairs [options (apply append (map scores-exactly '(2 1 0)))]
                      [remaining students]
                      [acc null])
  (if (null? remaining)
      (score-assignment (reverse acc))
      (match-let ([(list a b) (first options)])
        (if (and (member a remaining)
                 (member b remaining))
            (assign-pairs (rest options)
                          (~>> remaining (remove a) (remove b))
                          (cons (first options) acc))
            (assign-pairs (rest options)
                          remaining
                          acc)))))

(newline)
(argmax first (for/list ([i 10]) (assign-pairs)))



*Sample output*

(A (D T B))
(B (I A L))
(C (B J P))
(D (K O P))
(E (K Z B))
(F (C O Y))
(G (E C I))
(H (I W M))
(I (V G W))
(J (H Z T))
(K (O M Q))
(L (K V T))
(M (Y R E))
(N (M D J))
(O (N K P))
(P (W R C))
(Q (T O E))
(R (C F Y))
(S (N E U))
(T (B S H))
(U (V N K))
(V (L U Q))
(W (B O X))
(X (A Q Z))
(Y (T B R))
(Z (V T N))

'(18
  (((G I) 2)
   ((U V) 2)
   ((A B) 2)
   ((C P) 2)
   ((K O) 2)
   ((R Y) 2)
   ((E S) 1)
   ((J Z) 1)
   ((D N) 1)
   ((L T) 1)
   ((H W) 1)
   ((Q X) 1)
   ((F M) 0)))

-- 
You received this message because you are subscribed to the Google Groups 
"Racket Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email 
to racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.

Reply via email to