chameneos.mlish (4107B)
1 #lang s-exp "../../mlish.rkt" 2 (require "../rackunit-typechecking.rkt") 3 4 (define-type Color Red Yellow Blue) 5 6 (define-type (Option X) None (Some X)) 7 8 (define-type-alias Meet 9 (× (Channel (Option (× Color String))) 10 (× Color String))) 11 12 (define-type-alias Result (× Int Int)) 13 14 (define-type-alias MeetChan (Channel Meet)) 15 (define-type-alias ResultChan (Channel Result)) 16 17 (typecheck-fail (channel-put (make-channel {Bool}) 1) 18 #:with-msg "channel-put: type mismatch: expected Bool, given Int\n *expression: 1") 19 20 (define (change [c1 : Color] [c2 : Color] -> Color) 21 (match c1 with 22 [Red -> 23 (match c2 with 24 [Blue -> Yellow] 25 [Yellow -> Blue] 26 [Red -> c1])] 27 [Yellow -> 28 (match c2 with 29 [Blue -> Red] 30 [Red -> Blue] 31 [Yellow -> c1])] 32 [Blue -> 33 (match c2 with 34 [Yellow -> Red] 35 [Red -> Yellow] 36 [Blue -> c1])])) 37 38 (check-type (change Red Blue) : Color -> Yellow) 39 (check-type (change Yellow Red) : Color -> Blue) 40 (check-type (change Blue Blue) : Color -> Blue) 41 42 (define NONE (None {(× Color String)})) 43 44 (define (get+put [ch-meet : MeetChan] -> Unit) 45 (match (channel-get ch-meet) with 46 [ch v -> 47 (begin (channel-put ch NONE) 48 (get+put ch-meet))])) 49 50 (define (swap [ch-meet : MeetChan] [n : Int] -> Unit) 51 (if (zero? n) 52 (get+put ch-meet) 53 (match (channel-get ch-meet) with 54 [ch1 v1 -> 55 (match (channel-get ch-meet) with 56 [ch2 v2 -> 57 (begin (channel-put ch1 (Some v2)) 58 (channel-put ch2 (Some v1)) 59 (swap ch-meet (sub1 n)))])]))) 60 61 62 (define (place [ch-meet : MeetChan] [n : Int] -> Thread) 63 (thread (λ () (swap ch-meet n)))) 64 65 (define (rand-name -> String) 66 (string (integer->char (random 256)))) 67 68 (define (sleeper [ch-meet : MeetChan] [ch-res : ResultChan] 69 [ch : (Channel (Option (× Color String)))] 70 [name : String] [c : Color] [met : Int] [same : Int] 71 -> Unit) 72 (begin 73 (channel-put ch-meet (tup ch (tup c name))) 74 (match (channel-get ch) with 75 [Some c+s -> 76 (match c+s with 77 [other-col other-name -> 78 (begin 79 (sleep 0) 80 (sleeper 81 ch-meet ch-res ch 82 name (change c other-col) 83 (add1 met) (+ same (if (string=? name other-name) 1 0))))])] 84 [None -> (channel-put ch-res (tup met same))]))) 85 86 (define (creature [c : Color] [ch-meet : MeetChan] [ch-res : ResultChan] 87 -> Thread) 88 (thread 89 (λ () 90 (let ([ch (make-channel {(Option (× Color String))})] 91 [name (rand-name)]) 92 (sleeper ch-meet ch-res ch name c 0 0))))) 93 94 (define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) 95 (if (isnil lst) 96 nil 97 (cons (f (head lst)) (map f (tail lst))))) 98 99 (define (go [n : Int] [inits : (List Color)] -> (List Result)) 100 (let* ([ch-res (make-channel {Result})] 101 [ch-meet (make-channel {Meet})] 102 [start (place ch-meet n)] 103 [ths (map (λ ([c : Color]) (creature c ch-meet ch-res)) inits)]) 104 (map (λ ([c : Color]) (channel-get ch-res)) inits))) 105 106 (define res1 (go 100 (list Blue Red Yellow))) 107 108 (define (check-res1 [r : Result] -> Bool) 109 (match r with 110 [met same -> (or (= met 66) (= met 67))])) 111 112 (check-type (length res1) : Int -> 3) 113 114 (check-type (check-res1 (list-ref res1 0)) : Bool -> #t) 115 (check-type (check-res1 (list-ref res1 1)) : Bool -> #t) 116 (check-type (check-res1 (list-ref res1 2)) : Bool -> #t) 117 ;; -> (list (list 67 0) 118 ;; (list 66 0) 119 ;; (list 67 0))) 120 121 (define res2 122 (map (λ ([x : Result]) (proj x 0)) 123 (go 1000 (list Blue Red Yellow Red Yellow Blue)))) 124 (check-type res2 : (List Int)) 125 (define (=333/4 [x : Int] -> Bool) (or (= x 333) (= x 334))) 126 (define (andmap [p? : (→ X Bool)] [xs : (List X)] → Bool) 127 (match2 xs with 128 [nil -> #t] 129 [x :: rst -> (and (p? x) (andmap p? rst))])) 130 (check-type (andmap =333/4 res2) : Bool -> #t) 131 ;; -> (list (list 333 0) 132 ;; (list 333 0) 133 ;; (list 333 0) 134 ;; (list 333 0) 135 ;; (list 334 0) 136 ;; (list 334 0)))