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

Thanks!   Just what I needed.

/Jens Axel

2018-05-15 13:04 GMT+02:00 Daniel Prager <daniel.a.pra...@gmail.com>:

> 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)))
>

--
--
Jens Axel Søgaard

--
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