//
// BU CAS CS 520: Principles of Programing Languages
// Semester: Fall 2005
//

(* ****** ****** *)

//
// Some programming examples in System F
// By Hongwei Xi (November 2, 2005)

//
// HX-2010-08-12:
// This code is updated to compile and run under ATS-0.2.1. Voila!
//

(* ****** ****** *)

//
// Implementing Church numerals in System F
//

typedef nat_f =
  {X:type} (X -<cloref> X) -<cloref> X -<cloref> X
// end of [nat_f]

(* ****** ****** *)

fn pair_get_fst {X,Y:type} '(x: X, _: Y):<> X = x
fn pair_get_snd {X,Y:type} '(_: X, y: Y):<> Y = y

(* ****** ****** *)

typedef int = uintptr
val _0 = uintptr_of_uint (0U)
val _1 = uintptr_of_uint (1U)
#define isucc succ_uintptr
fun print_nat_f (n: nat_f): void = print (n {int} (lam x => isucc x) (_0))
overload print with print_nat_f

(* ****** ****** *)

val Z = (lam s => lam z => z): nat_f
val S = lam (n: nat_f): nat_f =<cloref> lam s => lam z => n(s)(s(z))

(* ****** ****** *)

val zero = Z
val one = S(zero)
val two = S(one)
val three = S(two)
val four = S(three)
val five = S(four)

(* ****** ****** *)

fn add (m: nat_f, n: nat_f):<> nat_f = m (S) (n)
fn mul (m: nat_f, n: nat_f):<> nat_f = m {nat_f} (n S) (Z)
fn pow (m: nat_f, n: nat_f):<> nat_f = n {nat_f-<cloref>nat_f} (m {nat_f}) (S) (Z)

(* ****** ****** *)

val () = begin
  print_string "pow (3, 5) = ";
  print_nat_f (pow (three, five));
  print_newline ()
end // end of [val]

(* ****** ****** *)

fn pred (n: nat_f):<> nat_f = let
  val z = '(zero, zero)
  val s = lam '(n1: nat_f, n2: nat_f): '(nat_f, nat_f) =<cloref> '(S n1, n1)
  val '(_, res) = n {'(nat_f, nat_f)} s z
in
   res
end // end of [pred]

(* ****** ****** *)

fn fact (n: nat_f):<> nat_f = let
  typedef X = '(nat_f, nat_f)
  val z: X = '(zero, one)
  val s = lam ('(x, y): X): X =<cloref> '(S x, mul (S x, y))
in
  pair_get_snd (n {X} (s) (z))
end // end of [fact]

val () = begin
  print_string "fact (5) = ";
  print_nat_f (fact five);
  print_newline ()
end // end of [val]

(* ****** ****** *)

fun fib (n: nat_f): nat_f =
  let
     typedef X = '(nat_f, nat_f)
     val z: X = '(zero, one)
     val s = lam ('(x, y): X): X =<cloref> '(y, add (x, y))
  in
     pair_get_fst (n {X} (s) (z))
  end

val _ = begin
  print_string "fib (10) = ";
  print_nat_f (fib (add (five, five)));
  print_newline ()
end

fn ack
  (m: nat_f):<> nat_f -<cloref> nat_f =
let
  val helper =
    lam (f: nat_f -<cloref> nat_f) =<cloref>
    lam (n: nat_f): nat_f =<cloref> f (n {nat_f} (f) (one))
in
  m {nat_f -<cloref> nat_f} helper (S)
end // end of [ack]

val () = begin
  print_string "ack (3, 5) = ";
  print_nat_f (ack three five);
  print_newline ()
end // end of [val]

(* ****** ****** *)
//
// Implementing Lists in System F
//

typedef list_f (A: type) =
  {X:type} (X, (A, X) -<cloref1> X) -<cloref1> X
// endof [[list_f]

val Nil = lam {A:type}: list_f (A) => lam (n, c) => n
val Cons =
  lam {A:type} (x: A, xs: list_f A): list_f A =<cloref> lam (n, c) => c (x, xs (n, c))
// end of [Cons]

val list_length =
  lam {A:type} (xs: list_f A): int => let
    val nil = _0
    val cons = lam (_: A, i: int): int =<cloref> succ i
  in
    xs {int} (nil, cons)
  end
// end of [list_length]

(* ****** ****** *)

implement main () = ()

(* ****** ****** *)

(* end of [systemf_programming_examples.dats] *)