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

// ------------------------------------

// Implementing Church numerals in System F

typedef nat_f = {X:type} (X -> X) -> X -> X

fun print_nat_f (n: nat_f): unit =
  print_int (n {Nat} (op isucc) (0))

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

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

fun add (m: nat_f, n: nat_f): nat_f = m (S) (n)

fun mul (m: nat_f, n: nat_f): nat_f = m {nat_f} (n S) (Z)

fun pow (m: nat_f, n: nat_f): nat_f =
  lam {X:type} => (n {X->X} (m {X}))

val _ = begin
  print_string "pow (3, 5) = ";
  print_nat_f (pow (three, five));
  print_newline ()
end

fun pred (n: nat_f): nat_f =
  let
     val z = '(zero, zero)
     fun s '(n1: nat_f, n2: nat_f): '(nat_f, nat_f) = '(S n1, n1)
     val '(_, res) = n {'(nat_f, nat_f)} s z
  in
     res
  end

fun fact (n: nat_f): nat_f =
  let
     typedef X = '(nat_f, nat_f)
     val z: X = '(one, one)
     fun s ('(x, y): X): X = '(S x, mul (x, y))
  in
     pair_get_snd (n {X} (s) (z))
  end

val _ = begin
  print_string "fact (5) = ";
  print_nat_f (fact five);
  print_newline ()
end

fun fib (n: nat_f): nat_f =
  let
     typedef X = '(nat_f, nat_f)
     val z: X = '(zero, one)
     fun s ('(x, y): X): X = '(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

fun ack (m: nat_f) : nat_f -> nat_f =
  let val helper =
     lam (f: nat_f -> nat_f) (n: nat_f): nat_f =>
       f (n {nat_f} (f) (one)) in
     m {nat_f -> nat_f} helper (S)
  end

val _ = begin
  print_string "ack (3, 5) = ";
  print_nat_f (ack three five);
  print_newline ()
end
// ------------------------------------

// Implementing Lists in System F

typedef list_f (A: type) =
  {X:type} X -> (A -> X -> X) -> X

val Nil = lam {A:type}: list_f (A) => lam n => lam c => n
val Cons =
   lam {A:type} (x: A) (xs: list_f A): list_f A =>
      lam n => lam c => c x (xs n c)

val length =
   lam {A:type} (xs: list_f A): Nat =>
      let
         val nil = 0
         val cons = lam (_: A) (i: Nat): Nat => isucc i
      in
         xs (nil) (cons)
      end

val append =
   lam {A:type} (xs: list_f A, ys: list_f A)
     : list_f A => xs {list_f A} (ys) (Cons)

val reverse =
   lam {A:type} (xs: list_f A): list_f A =>
      let
         val nil = Nil
         val cons =
            lam (x: A) (xs: list_f A): list_f A =>
               append (xs, Cons x Nil)
      in
         xs {list_f A} (nil) (cons)
      end

// Note that the above code make use of no recursion!

// The following is some test code:
  
condef :: = cons

fun gen_list_f (i: Nat): list_f (Nat) =
  if i ieq 0 then Nil
  else Cons (i) (gen_list_f (ipred i))

fun print_list (xs: list Int): unit =
  case xs of
    | '[] => print_newline ()
    | x :: xs => print_list_aux (x, xs)

and print_list_aux (x: Int, xs: list Int): unit =
  case xs of
    | '[] => (print_int x; print_newline ())
    | x' :: xs' =>
        (print_int x; print_string ", "; print_list_aux (x', xs'))

fun print (xs: list_f Nat): unit =
  let
     val nil = '[]
     fun cons (x: Nat) (xs: list Nat)
       : list Nat = x :: xs
  in
     print_list (xs {list Nat} nil cons)
  end

val '() =
  let
     val xs = gen_list_f (5)
     val xs' = reverse xs
     val xsxs = append (xs, xs)
     val xsxs' = reverse xsxs
  in
     print_string "xs = ";
     print xs;
     print_string "length (xs) = ";
     print_int (length xs);
     print_newline ();

     print_string "xs' = ";
     print xs';
     print_string "length (xs') = ";
     print_int (length xs');
     print_newline ();

     print_string "xsxs = ";
     print xsxs;
     print_string "length (xsxs) = ";
     print_int (length xsxs);
     print_newline ();

     print_string "xsxs' = ";
     print xsxs';
     print_string "length (xsxs') = ";
     print_int (length xsxs');
     print_newline ()
  end

// ------------------------------------

// Implementing generic trees in System F

typedef gtree (A: type) =
  {X:type} X -> ((A -> X) -> X) -> X

// E: {A:type} gtree (A)
val E: {A:type} gtree (A) =
   lam {A:type} =>
     lam {X:type} =>
       lam (e: X) =>
         lam (b: (A -> X) -> X) => e

// B: (A -> gtree (A)) -> A
fun B {A:type} (f: A -> gtree (A)): gtree (A) =
  lam {X:type} =>
       lam (e: X) =>
         lam (b: (A -> X) -> X) =>
           b (lam (x: A) => f (x) {X} (e) (b))

typedef A = Bool
typedef btree = gtree (A)

fun print_btree (t: btree): unit =
  let
     typedef X = () -> unit
     val e: X = lam () => print_string "E"
     fun b (f: (A -> X)): X =
       lam () => begin
         print_string "B(";
         f (true) ();
         print_string ", ";
         f (false) ();
         print_string ")"
      end
  in
     t {X} (e) (b) ()
  end

fun size_btree (t: btree): Nat =
  let
     typedef X = Nat
     val e: X = 0
     fun b (f: (A -> X)): X =
       isucc (f true iadd f false)
  in
     t {X} (e) (b)
  end

infix imax

fun height_btree (t: btree): Nat =
  let
     typedef X = Nat
     val e: X = 0
     fun b (f: A -> X): X =
       isucc (f true imax f false)
  in
     t {X} (e) (b)
  end

fun is_perfect_btree (t: btree): Bool =
  let
     typedef X = option Nat
     val e: X = Some 0
     fun b (f: A -> X): X =
       case (f true, f false) of
         | (Some h1, Some h2) =>
             if h1 == h2 then Some (isucc h1) else None
         | (_, _) => None
  in
     case t {X} (e) (b) of None () => false | Some _ => true
  end

fun left_child_btree (t: btree): btree =
  let
     typedef X = '(btree, btree)
     val e: X = '(E, E)
     fun b (f: (A -> X)): X =
       let
          val '(t1, _) = f (true)
          val '(t2, _) = f (false)

          fun f' (x: A): btree = if x then t1 else t2
       in
          '(B {A} (f'), t1)
       end
  in
     pair_get_snd (t {X} (e) (b))
  end

fun right_child_btree (t: btree): btree =
  let
     typedef X = '(btree, btree)
     val e: X = '(E, E)
     fun b (f: (A -> X)): X =
       let
          val '(t1, _) = f (true)
          val '(t2, _) = f (false)

          fun f' (x: A): btree = if x then t1 else t2
       in
          '(B {A} (f'), t2)
       end
  in
     pair_get_snd (t {X} (e) (b))
  end

val t0: btree = E {A}
val t1: btree =
  let
     fun f (x: Bool): btree = if x then t0 else t0
  in
     B {A} (f)
  end

val t2: btree =
  let
     fun f (x: Bool): btree = if x then t1 else t0
  in
     B {A} (f)
  end

val _ = begin
  print_string "The tree t2 = ";
  print_btree t2;
  print_newline ()
end

val t3: btree =
  let
     fun f (x: Bool): btree = if x then t1 else t2
  in
     B {A} (f)
  end

val _ = begin
  print_string "The tree t3 = ";
  print_btree t3;
  print_newline ()
end

val t31: btree = left_child_btree (t3)

val _ = begin
  print_string "The tree t31 = ";
  print_btree t31;
  print_newline ()
end

val t32: btree = right_child_btree (t3)

val _ = begin
  print_string "The tree t32 = ";
  print_btree t32;
  print_newline ()
end

val n: Nat = size_btree (t3)
val _ = begin
  print_string "The size of t3 = ";
  print_int n;
  print_newline ()
end

val n: Nat = height_btree (t3)
val _ = begin
  print_string "The height of t3 = ";
  print_int n;
  print_newline ()
end