[racket-users] Edmond's Blossom Algorithm

[Stephen Foster]

Sounds like a variation on the Stable Roommate problem?

https://en.m.wikipedia.org/wiki/Stable_roommates_problem?wprov=sfla1

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

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

[Jens Axel Søgaard]

Thanks!   Just what I needed.

/Jens Axel


2018-05-15 13:04 GMT+02:00 Daniel Prager :

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



-- 
-- 
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 
to racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.

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

[Daniel Prager]

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.

[racket-users] Edmond's Blossom Algorithm

[Jens Axel Søgaard]

Context:

I have students A, B, C, ..., Z that needs to work in pairs for their exam.
Each student has made a wish list with 3 other students that they'd like to
work with.
I need to find the maximum possible pairing.

I think - maybe - that the algorithm I need is Edmond's blossom algorithm.

Am I so lucky that someone has this in Racket?

https://en.wikipedia.org/wiki/Blossom_algorithm
http://www.cs.dartmouth.edu/~ac/Teach/CS105-Winter05/Handouts/tarjan-blossom.pdf

/Jens Axel

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