diff --git a/tapl/tests/mlish/chameneos.mlish b/tapl/tests/mlish/chameneos.mlish new file mode 100644 index 0000000..2688477 --- /dev/null +++ b/tapl/tests/mlish/chameneos.mlish @@ -0,0 +1,96 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type Color Red Yellow Blue) +(define-type (Option X) None (Some X)) +(define-type-alias Meet + (× (Channel (Option (× Color String))) + (× Color String))) +(define-type-alias Result (× Int Int)) +(define-type-alias MeetChan (Channel Meet)) +(define-type-alias ResultChan (Channel Result)) + +(define (change [c1 : Color] [c2 : Color] -> Color) + (match c1 with + [Red -> + (match c2 with + [Blue -> Yellow] + [Yellow -> Blue] + [Red -> c1])] + [Yellow -> + (match c2 with + [Blue -> Red] + [Red -> Blue] + [Yellow -> c1])] + [Blue -> + (match c2 with + [Yellow -> Red] + [Red -> Yellow] + [Blue -> c1])])) + +(check-type (change Red Blue) : Color -> Yellow) +(check-type (change Yellow Red) : Color -> Blue) +(check-type (change Blue Blue) : Color -> Blue) + +(define NONE (None {(× Color String)})) + +(define (get+put [ch-meet : MeetChan] -> Unit) + (match (channel-get ch-meet) with + [ch v -> + (begin (channel-put ch NONE) + (get+put ch-meet))])) + +(define (swap [ch-meet : MeetChan] [n : Int] -> Unit) + (if (zero? n) + (get+put ch-meet) + (match (channel-get ch-meet) with + [ch1 v1 -> + (match (channel-get ch-meet) with + [ch2 v2 -> + (begin (channel-put ch1 (Some v2)) + (channel-put ch2 (Some v1)) + (swap ch-meet (sub1 n)))])]))) + + +(define (place [ch-meet : MeetChan] [n : Int] -> Thread) + (thread (λ () (swap ch-meet n)))) + +(define (rand-name -> String) + (string (integer->char (random 256)))) + +(define (sleeper [ch-meet : MeetChan] [ch-res : ResultChan] + [ch : (Channel (Option (× Color String)))] + [name : String] [c : Color] [met : Int] [same : Int] -> Unit) + (begin + (channel-put ch-meet (tup ch (tup c name))) + (match (channel-get ch) with + [Some c+s -> + (match c+s with + [other-col other-name -> + (begin + (sleep 0) + (sleeper ch-meet ch-res ch + name (change c other-col) + (add1 met) (+ same (if (string=? name other-name) 1 0))))])] + [None -> (channel-put ch-res (tup met same))]))) + +(define (creature [c : Color] [ch-meet : MeetChan] [ch-res : ResultChan] -> Thread) + (thread + (λ () + (let ([ch (make-channel {(Option (× Color String))})] + [name (rand-name)]) + (sleeper ch-meet ch-res ch name c 0 0))))) + +(define (map [f : (→ X Y)] [lst : (List X)] -> (List Y)) + (if (isnil lst) + nil + (cons (f (head lst)) (map f (tail lst))))) + +(define (go [n : Int] [inits : (List Color)] -> (List Result)) + (let* ([ch-res (make-channel {Result})] + [ch-meet (make-channel {Meet})] + [start (place ch-meet n)] + [ths (map (λ ([c : Color]) (creature c ch-meet ch-res)) inits)]) + (map (λ ([c : Color]) (channel-get ch-res)) inits))) + +(check-type (go 100 (list Blue Red Yellow)) : (List Result)) diff --git a/tapl/tests/mlish/trees.mlish b/tapl/tests/mlish/trees.mlish new file mode 100644 index 0000000..9fa508f --- /dev/null +++ b/tapl/tests/mlish/trees.mlish @@ -0,0 +1,45 @@ +#lang s-exp "../../mlish.rkt" +(require "../rackunit-typechecking.rkt") + +(define-type (Tree X) + (Leaf X) + (Node (Tree X) X (Tree X))) + +(define (make [item : Int] [depth : Int] -> (Tree Int)) + (if (zero? depth) + (Leaf item) + (let ([item2 (* item 2)] [depth2 (sub1 depth)]) + (Node (make (sub1 item2) depth2) + item + (make item2 depth2))))) + +(define tree1 (make 4 1)) +(define tree2 (make 3 2)) +(check-type tree1 : (Tree Int) -> (Node (Leaf 7) 4 (Leaf 8))) +(check-type tree2 + : (Tree Int) + -> (Node (Node (Leaf 9) 5 (Leaf 10)) 3 (Node (Leaf 11) 6 (Leaf 12)))) + +(define (sum [t : (Tree Int)] -> Int) + (match t with + [Leaf v -> v] + [Node l v r -> (+ (+ (sum l) v) (sum r))])) + +(check-type (sum tree1) : Int -> 19) +(check-type (sum tree2) : Int -> 56) + +(define (check/acc [t : (Tree Int)] [acc : Int] -> Int) + (match t with + [Leaf v -> (+ acc v)] + [Node l v r -> (check/acc l (- acc (check/acc r 0)))])) +(define (check [t : (Tree Int)] -> Int) + (check/acc t 0)) + +(define min-depth 4) + +(define (main [n : Int] -> Int) + (let* ([max-depth (max (+ min-depth 2) n)] + [stretch-depth (add1 max-depth)]) + (check (make 0 stretch-depth)))) + +(check-type (main 17) : Int -> 0) diff --git a/tapl/tests/run-all-mlish-tests.rkt b/tapl/tests/run-all-mlish-tests.rkt new file mode 100644 index 0000000..937ea47 --- /dev/null +++ b/tapl/tests/run-all-mlish-tests.rkt @@ -0,0 +1,4 @@ +#lang racket +(require "mlish-tests.rkt") +(require "mlish/trees.mlish") +(require "mlish/chameneos.mlish")