up to 12

sml/week4/hw3.sml

@@ -1,6 +1,20 @@
 use "operators.sml";
 use "list.sml";
 
+datatype pattern = 
+    Wildcard 
+    | Variable of string 
+    | UnitP 
+    | ConstP of int
+    | TupleP of pattern list 
+    | ConstructorP of string * pattern
+
+datatype valu = 
+    Const of int 
+    | Unit 
+    | Tuple of valu list 
+    | Constructor of string * valu
+
 exception NoAnswer
 
 fun first str = String.sub (str, 0)
@@ -37,7 +51,10 @@ fun first_answer f lst =
         NONE => first_answer f tail
         | SOME answer => answer
 
-fun all_answers (f: ('a -> 'b list option)) lst: 'b list option =
+fun all_answers 
+    (f: ('a -> 'b list option)) 
+    (lst: 'a list)
+    : 'b list option =
     let
         fun collect lst acc =
             case lst of
@@ -49,3 +66,58 @@ fun all_answers (f: ('a -> 'b list option)) lst: 'b list option =
     in
         collect lst []
     end
+
+fun sum a b = a + b
+(*  functions below are too similar to leave them as is.
+    Find a way how to extract reapiting code
+ *)
+fun count_wildcards (p: pattern) : int =
+    case p of
+    Wildcard => 1
+    | TupleP lst => foldl (count_wildcards >> sum) 0 lst
+    | ConstructorP (_, pattern) => count_wildcards pattern
+    | _ => 0
+ 
+fun collect_variables (p: pattern) : string list =
+    case p of
+    Variable str => [str]
+    | TupleP lst => foldl (collect_variables >> append) [] lst
+    | ConstructorP (_, pattern) => collect_variables pattern
+    | _ => []
+
+fun count_variable_lengths (p: pattern) : int =
+    p |> collect_variables |> foldl (size >> sum) 0
+
+fun count_wild_and_variable_lengths (p: pattern) : int =
+    count_wildcards p + count_variable_lengths p
+
+fun count_some_var (var, pattern) =
+    case pattern of
+       Variable v => if v = var then 1 else 0
+    | TupleP lst => foldl (fn p => fn acc => acc + count_some_var (var, p)) 0 lst
+    | ConstructorP (_, pattern) => count_some_var (var, pattern)
+    | _ => 0
+
+fun check_pat (p: pattern) : bool =
+    p 
+    |> collect_variables 
+    |> sort bigger_or_equal
+    |> distinct
+
+fun match (v: valu, p: pattern) : (string * valu) list option = 
+    case (p, v) of
+    (Wildcard, _) => SOME []
+    | (Variable a, v) => SOME [(a, v)]
+    | (UnitP, Unit) => SOME []
+    | (ConstP c1, Const c2) => if c1 = c2 then SOME [] else NONE
+    | (TupleP ps, Tuple vs) => (vs, ps) |> ListPair.zip |> all_answers match
+    | (ConstructorP (s1, p), Constructor (s2, v)) =>
+        if s1 = s2 then match (v, p) else NONE
+    | _ => NONE
+    
+fun first_match 
+    (v: valu) 
+    (patterns: pattern list) : 
+    (string * valu) list option =
+    SOME $ first_answer (fn p => match (v, p)) patterns
+        handle NoAnswer => NONE

sml/week4/hw3_test.sml

@@ -1,6 +1,17 @@
 use "test.sml";
 use "hw3.sml";
 
+fun comp a b = a <= b
+
+val () =
+    assert
+    $ sort comp [1, 2] = [1, 2]
+    $ "sort: sorting"
+
+val () =
+    assert
+    $ sort comp [1, 2, 1, 0, 4, 5, 2] = [0, 1, 1, 2, 2, 4, 5]
+    $ "sort: sorting x2"
 
 val () =
     assert
@@ -86,5 +97,101 @@ val () =
         ["a", "b"] = NONE
     $ "all_answers: NONE on at least one NONE"
 
+val () =
+    assert
+    $ count_wildcards Wildcard = 1
+    $ "count_wildcards: Wildcard"
+
+val () =
+    assert
+    $ count_wildcards (TupleP [Wildcard, Wildcard]) = 2
+    $ "count_wildcards: TupleP"
+
+val () =
+    assert
+    $ count_wildcards (ConstructorP ("wild", Wildcard)) = 1
+    $ "count_wildcards: ConstructorP"
+
+val () =
+    assert
+    $ count_wild_and_variable_lengths (TupleP [Wildcard, Variable "var"]) = 4
+    $ "count_wild_and_variable_lengths: correct length"
+
+val () =
+    let
+      val input = (
+          "var", 
+          TupleP [
+              Wildcard, 
+              Variable "var", 
+              ConstructorP (
+                  "cons", 
+                  Variable "var")])
+        val expected = 2 
+    in
+    assert
+    $ count_some_var input = expected
+    $ "count_some_var: count vars"
+    end
+
+val () =
+    assert
+    $ check_pat (TupleP [Variable "a", Variable "b"]) = true
+    $ "check_pat: true on distinct"
+
+val () =
+    assert
+    $ check_pat (TupleP [Variable "a",ConstructorP ("cons", Variable "a")]) = false
+    $ "check_pat: false on same"
+
+val () =
+    assert
+    $ match (Unit, Wildcard) = SOME []
+    $ "match: SOME [] on wildcard"
+
+val () =
+    assert
+    $ match (Unit, Variable "var") = SOME [("var", Unit)]
+    $ "match: match with var"
+
+val () =
+    assert
+    $ match (Unit, UnitP) = SOME []
+    $ "match: match with unit"
+
+val () =
+    assert
+    $ match (Const 3, ConstP 3) = SOME []
+    $ "match: match with const"
+
+val () =
+    assert
+    $ match (Tuple [Const 3], TupleP [Variable "var"]) = SOME [("var", Const 3)]
+    $ "match: match with tuple"
+
+val () =
+    assert
+    $ match (Tuple [Const 3], TupleP [Variable "var"]) = SOME [("var", Const 3)]
+    $ "match: match with tuple"
+
+val () =
+    let
+      val arg = (Constructor ("c", Unit), ConstructorP ("c", Variable "var"))
+      val expect = SOME [("var", Unit)]
+    in
+        assert
+        $ match arg = expect
+        $ "match: match with Constructor"
+    end
+
+val () =
+    assert
+    $ first_match Unit [ConstP 17, Variable "v"] = SOME [("v", Unit)]
+    $ "first_match: finds match"
+
+val () =
+    assert
+    $ first_match Unit [ConstP 17] = NONE
+    $ "first_match: handles exeption"
 
 val () = complete ()

sml/week4/list.sml

@@ -11,8 +11,35 @@ fun foldl f acc lst =
 
 fun reverse lst = foldl cons [] lst
 
-(* wrong implementation *)
-fun foldr f acc = foldl f acc >> reverse    
+fun sort' f lst =
+    case lst of
+    [] => []
+    | [one] => [one]
+    | first :: second :: rest =>
+        if f first second
+        then first :: sort' f (second :: rest)
+        else second :: sort' f (first :: rest)
+
+(* only for sorted lists *)
+fun distinct lst =
+    case lst of
+    [] => true
+    | [_] => true
+    | first :: second :: rest =>
+        if first = second
+        then false
+        else distinct (second :: rest)
+
+(* simple recursive convergence *)
+fun fix f g x = 
+    if f g x = x 
+    then x 
+    else fix f g (f g x)
+
+(* naive bubble sort *)
+fun sort f x = fix sort' f x
+
+fun foldr f acc lst = lst |> reverse |> foldl f acc     
 
 fun map f = foldr (f >> cons) []