add mlish tests

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

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)

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