# Re: [racket-users] Edmond's Blossom Algorithm

```A more low-tech approach ...

#lang racket```
```

(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