#lang racket
(require 2htdp/universe)
(provide (all-defined-out))
(define (remf f ls)
(cond [(empty? ls) empty]
[(f (first ls)) (rest ls)]
[else
(cons (first ls)
(remf f (rest ls)))]))
(define (serve1)
(universe '*
(on-new
(λ (is iw)
(make-bundle '* (list (make-mail iw '(initial))) empty)))
(on-msg
(λ (is iw msg)
(make-bundle '*
(cond [(equal? msg '(passive))
(list (make-mail iw '(active)))]
[else empty])
empty)))))
(define (serve-singles)
(thread serve1))
(define-struct u (loner pairs))
(define (serve2)
(universe (make-u #f empty)
(on-new (λ (us iw)
(if (u-loner us)
(make-bundle (make-u #f (cons (list (u-loner us) iw)
(u-pairs us)))
(list (make-mail (u-loner us) '(initial)))
empty)
(make-bundle (make-u iw (u-pairs us))
empty
empty))))
(on-msg (λ (us iw msg)
(cond [(equal? msg '(passive))
(flip-play us iw)]
[(equal? (first msg) 'moment)
(notify-moment us iw (second msg))])))))
(define (serve-couples)
(thread serve2))
(define (pair-partner iw pairs)
(cond [(iworld=? iw (first (first pairs)))
(second (first pairs))]
[else
(pair-partner iw (rest pairs))]))
(define (flip-play us iw)
(let ((iw* (pair-partner iw (u-pairs us))))
(make-bundle
(make-u (u-loner us)
(cons (list iw* iw)
(remf (λ (p) (iworld=? iw (first p))) (u-pairs us))))
(list (make-mail iw* '(active)))
empty)))
(define (notify-moment us iw m)
(make-bundle us
(list (make-mail (pair-partner iw (u-pairs us))
`(moment ,m)))
empty))