Programming Languages assignment 1 (with smbt and qcheck)

build.sm

target hw1
    sources
        hw1.mlb
        hw1.main.sml
    end

    option compiler = mlton
    option output = hw1
end

hw1.main.sml

run();

hw1.mlb

$(SML_LIB)/basis/basis.mlb
$(SMACKAGE)/qcheck/v1.2.0/qcheck.mlb
hw1.sml
hw1.tests.sml
hw1.qcheck.sml

hw1.qcheck.sml

open QCheck infix ==>;

fun check_method desc func = let
    val id = fn x => x
    val pred_all_true = pred (List.all (fn x => x))
  in
    checkOne NONE ("check " ^ desc, pred_all_true) func
  end

fun run () =
  [ check_method "is_older" is_older_t
  , check_method "number_in_month" number_in_month_t
  , check_method "number_in_months" number_in_months_t
  , check_method "dates_in_month" dates_in_month_t
  , check_method "dates_in_months" dates_in_months_t
  , check_method "get_nth" get_nth_t
  , check_method "date_to_string" date_to_string_t
  , check_method "number_before_reaching_sum" number_before_reaching_sum_t
  , check_method "what_month_t" what_month_t
  , check_method "month_range" month_range_t
  , check_method "oldest" oldest_t
  , check_method "number_in_months_challenge" number_in_months_challenge_t
  , check_method "dates_in_months_challenge_t" dates_in_months_challenge_t
  , check_method "reasonable_date" reasonalbe_date_t
  ]

hw1.sml

(* TYPE INITIALIZING *)
type year = int
type month = int
type day = int
type date = (year * month * day)

(* BORING ROUTINES *)
fun filter p l =
  if null l then [] else
  let
    val x = hd l
    val xs = tl l
  in
    if p x
      then x :: filter p xs
      else filter p xs
  end

fun map f l =
  if null l then [] else
    f (hd l) :: map f (tl l)

fun sum l =
  if null l then 0 else
    hd l + sum (tl l)

fun concat l =
  if null l then [] else
    (hd l) @ concat (tl l)

fun concatMap f l =
  concat (map f l)

fun range a b =
  if a > b then [] else a :: range (a+1) b

fun member x l =
  if null l then false else
    (x = hd l) orelse member x (tl l)

fun uniq l =
  if null l then [] else
    let
      val x = hd l
      val xs = tl l
    in
      if member x xs then uniq xs else x :: uniq xs
    end


(* ACTUAL SOLUTIONS *)
val days_in_months = [31,28,31,30,31,30,31,31,30,31,30,31]
val days_in_months_leap = [31,29,31,30,31,30,31,31,30,31,30,31]
val string_months = [ "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" ]

fun is_older ((y1,m1,d1):date, (y2,m2,d2):date) =
  if (y1 > y2) then false else
    if (y1 = y2) andalso (m1 > m2) then false else
      if (y1 = y2) andalso (m1 = m2) andalso (d1 >= d2) then false else
        true

fun number_in_month (dates : date list, m : month) : int =
  length (filter (fn x => #2 x = m) dates)

fun number_in_months (dates : date list, months : month list) : int =
  sum (map (fn m => number_in_month (dates,m)) months)

fun dates_in_month (dates : date list, m : month) : date list =
  filter (fn x => #2 x = m) dates

fun dates_in_months (dates : date list, months : month list) : date list =
  concatMap (fn m => dates_in_month (dates,m)) months

fun get_nth (l, n) =
  if n <= 1 then hd l else
    get_nth (tl l, n-1)

fun date_to_string ((y,m,d) : date) : string =
  get_nth (string_months, m) ^ " " ^ Int.toString d ^ ", " ^ Int.toString y

exception EmptyList
fun number_before_reaching_sum (sum : int, l : int list) : int =
  if null l then raise EmptyList else
    if hd l >= sum then 0 else
      1 + number_before_reaching_sum (sum - hd l, tl l)

fun what_month (d : int) : int =
  1 + number_before_reaching_sum (d, days_in_months)

fun month_range (day1 : int, day2 : int) : month list =
  map what_month (range day1 day2)

fun oldest (l : date list) : date option =
  if null l then NONE else
    let
      fun foldl f z [] = z
        | foldl f z l = foldl f (f z (hd l)) (tl l)
      fun min a b = if is_older (a,b) then a else b
    in
      SOME (foldl min (hd l) (tl l))
    end

fun number_in_months_challenge (l,months) =
  number_in_months (l, uniq months)

fun dates_in_months_challenge (l,months) =
  dates_in_months (l, uniq months)

fun reasonable_date ((y,m,d) : date) : bool =
  if y <= 0 then false else
    if m < 1 orelse m > 12 then false else
      let
        val is_leap_year = y mod 400 = 0 orelse (y mod 4 = 0 andalso y mod 100 <> 0)
        val dim = if is_leap_year then days_in_months_leap else days_in_months
      in
        if d > get_nth (dim,m) then false else true
      end

hw1.tests.sml

val d1 = (1983,5,28)
val d2 = (1983,9,12)
val d3 = (1983,9,10)
val d4 = (1980,10,1)
val ds = [d1,d2,d3,d4]
val ms1 = [5,9]
val ms2 = [9,11,6]
val ms3 = [1,2,3,4,6,7,8]
val ms4 = [10,5]

val is_older_t =
  [ is_older (d1,d2) = true
  , is_older (d2,d1) = false
  , is_older (d1,d1) = false
  , is_older (d3,d2) = true
  , is_older (d2,d3) = false
  , is_older (d4,d1) = true
  ]


val number_in_month_t =
  [ number_in_month (ds,5) = 1
  , number_in_month (ds,9) = 2
  , number_in_month (ds,7) = 0
  ]


val number_in_months_t =
  [ number_in_months (ds,ms1) = 3
  , number_in_months (ds,ms2) = 2
  , number_in_months (ds,ms3) = 0
  ]

val dates_in_month_t =
  [ dates_in_month (ds,5) = [d1]
  , dates_in_month (ds,9) = [d2,d3]
  , dates_in_month (ds,7) = []
  ]

val dates_in_months_t =
  [ dates_in_months (ds,ms1) = [d1,d2,d3]
  , dates_in_months (ds,ms2) = [d2,d3]
  , dates_in_months (ds,ms3) = []
  , dates_in_months (ds,ms4) = [d4,d1]
  ]

val ss1 = ["one","two","three","four","five"]

val get_nth_t =
  [ get_nth (ss1,2) = "two"
  , get_nth (ss1,1) = "one"
  ]

val date_to_string_t =
  [ date_to_string d1 = "May 28, 1983"
  , date_to_string d2 = "September 12, 1983"
  , date_to_string d3 = "September 10, 1983"
  , date_to_string d4 = "October 1, 1980"
  ]

val numbers = [1, 6, 9, 4, 2, 19]

val number_before_reaching_sum_t =
  [ number_before_reaching_sum (8, numbers) = 2
  , number_before_reaching_sum (17, numbers) = 3
  , number_before_reaching_sum (21, numbers) = 4
  , number_before_reaching_sum (1, numbers) = 0
  ]

val what_month_t =
  [ what_month 10 = 1
  , what_month 360 = 12
  , what_month 150 = 5
  , what_month 290 = 10
  , what_month 60 = 3 (* no leap years *)
  ]

val month_range_t =
  [ month_range (29,34) = [1,1,1,2,2,2]
  , month_range (20,19) = []
  , month_range (101,101) = [4]
  , month_range (304,305) = [10,11]
  ]

val oldest_t =
  [ oldest [] = NONE
  , oldest [d2] = SOME d2
  , oldest ds = SOME d4
  ]

val number_in_months_challenge_t =
  [ number_in_months_challenge (ds,ms1) = number_in_months (ds,ms1)
  , number_in_months_challenge (ds,ms2) = number_in_months (ds,ms2)
  , number_in_months_challenge (ds,ms3) = number_in_months (ds,ms3)
  , number_in_months_challenge (ds,ms1@ms1) = number_in_months (ds,ms1)
  , number_in_months_challenge (ds,ms2@ms2) = number_in_months (ds,ms2)
  , number_in_months_challenge (ds,ms3@ms3) = number_in_months (ds,ms3)
  ]

val dates_in_months_challenge_t =
  [ dates_in_months_challenge (ds,ms1) = dates_in_months (ds,ms1)
  , dates_in_months_challenge (ds,ms2) = dates_in_months (ds,ms2)
  , dates_in_months_challenge (ds,ms3) = dates_in_months (ds,ms3)
  , dates_in_months_challenge (ds,ms4) = dates_in_months (ds,ms4)
  , dates_in_months_challenge (ds,ms1@ms1) = dates_in_months (ds,ms1)
  , dates_in_months_challenge (ds,ms2@ms2) = dates_in_months (ds,ms2)
  , dates_in_months_challenge (ds,ms3@ms3) = dates_in_months (ds,ms3)
  , dates_in_months_challenge (ds,ms4@ms4) = dates_in_months (ds,ms4)
  ]

val reasonalbe_date_t =
  [ reasonable_date d1 = true
  , reasonable_date d2 = true
  , reasonable_date d3 = true
  , reasonable_date d4 = true
  , reasonable_date (~10,1,1) = false
  , reasonable_date (1900,2,29) = false
  , reasonable_date (1904,2,29) = true
  ]

Compile module with smbt:

$> smbt hw1
smbt 0.3.1
 - Build file: build.sm
 - Target: hw1
 - Running pre-hooks
 - Invoking MLton
 - Output: hw1 (543562 bytes)
 - Running post-hooks

Run tests:

$> ./hw1 
check is_older.........ok      (1 passed)          
check number_in_month..ok      (1 passed)          
check number_in_months.ok      (1 passed)          
check dates_in_month...ok      (1 passed)          
check dates_in_months..ok      (1 passed)          
check get_nth..........ok      (1 passed)          
check date_to_string...ok      (1 passed)          
check number_before_reaching_sum.ok      (1 passed)          
check what_month_t.....ok      (1 passed)          
check month_range......ok      (1 passed)          
check oldest...........ok      (1 passed)          
check number_in_months_challenge.ok      (1 passed)          
check dates_in_months_challenge_t.ok      (1 passed)          
check reasonable_date..ok      (1 passed)