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