(*
** Course: Concepts of Programming Languages (BU CAS CS 320)
** Semester: Summer I, 2009
** Instructor: Hongwei Xi (hwxi AT cs DOT bu DOT edu)
*)

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

staload "assignment3.sats"

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

#define :: list0_cons
#define cons list0_cons
#define nil list0_nil

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

// A given list [b1 :: b2 :: ... :: bn :: nil ()] represents the natural number
// [bn ... b2 b1] in binary notation. For instance, the number 16 is represented
// as [0 :: 0 :: 0 :: 1 :: nil ()]

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

local

typedef bitlst = list0 int
datatype bignum = BIGNUM of (int (*sgn*),  bitlst(*bits*))
assume bignum_t = bignum

fun print_bitlst (bs: bitlst): void = case+ bs of
  | b :: bs => (print b; print_bitlst bs) | nil () => ()
// end of [print_bitlst]

fun uint_of_bitlst (bs: bitlst): uint = let
  fun loop {i:nat} (bs: bitlst, i: int i, res: uint): uint = case+ bs of
    | b :: bs => if b = 0 then loop (bs, i+1, res) else loop (bs, i+1, res + (1U<<i)) 
    | nil () => res
  // end of [loop]
in
  loop (bs, 0, 0U(*res*))
end // end of [uint_of_bitlst]

fun bitlst_of_uint (u: uint): bitlst =
  if u > 0U then let
    val b = int_of_uint (u land 01U) in b :: bitlst_of_uint (u >> 1)
  end else nil () 
// end of [bitlst_of_uint]

fun int_of_bignum (x: bignum): int = let
  val+ BIGNUM (sgn, bs) = x in sgn * int_of_uint (uint_of_bitlst bs)
end // end of [int_of_bignum]

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

nonfix ugt ugte ult ulte uadd usub umul udiv

fun ugt (bs1: bitlst, bs2: bitlst): bool =
  case+ (bs1, bs2) of
  | (b1 :: bs1, b2 :: bs2) =>
      if b1 > b2 then ugte (bs1, bs2) else ugt (bs1, bs2)
  | (nil (), _) => false
  | (_, nil ()) => true
// end of [ugt]

and ugte (bs1: bitlst, bs2: bitlst): bool = let
(*
  val () = begin
    print "ugte: bs1 = "; print (uint_of_bitlst bs1);
    print "("; print_bitlst bs1; print ")";
    print_newline ()
  end // end of [val]  
  val () = begin
    print "ugte: bs2 = "; print (uint_of_bitlst bs2);
    print "("; print_bitlst bs2; print ")";
    print_newline ()
  end // end of [val]  
*)
in
  case+ (bs1, bs2) of
  | (b1 :: bs1, b2 :: bs2) =>
      if b1 >= b2 then ugte (bs1, bs2) else ugt (bs1, bs2)
  | (_, nil ()) => true
  | (nil (), _) => false
end // end of [ugte]

fun ult (bs1: bitlst, bs2: bitlst): bool = ugt (bs2, bs1)
fun ulte (bs1: bitlst, bs2: bitlst): bool = ugte (bs2, bs1)

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

fun usucc (bs: bitlst): bitlst = case+ bs of
  | b :: bs => if b = 0 then 1 :: bs else 0 :: usucc bs
  | nil () => 1 :: nil ()
// end of [usucc]

exception UPREDexception of ()
fun upred (bs: bitlst): bitlst = case+ bs of
  | b :: nil () => nil ()
  | b :: bs => if b = 0 then 1 :: upred bs else 0 :: bs
  | nil () => $raise UPREDexception ()
// end of [usucc]

fun uadd (bs1: bitlst, bs2: bitlst): bitlst = let
  fun aux (bs1: bitlst, bs2: bitlst, c: int): bitlst =
    case+ (bs1, bs2) of
    | (b1 :: bs1, b2 :: bs2) => begin case+ b1+b2 of
      | 0 => c :: aux (bs1, bs2, 0)
      | 1 => (1-c) :: aux (bs1, bs2, c)
      | _ (*2*) => c :: aux (bs1, bs2, 1)
      end // end of [::, ::]
    | (_, nil ()) => if c = 0 then bs1 else usucc bs1
    | (nil (), _) => if c = 0 then bs2 else usucc bs2 
in
  aux (bs1, bs2, 0(*carry*))
end // end of [uadd]

exception USUBexception of ()
fun usub (bs1: bitlst, bs2: bitlst): bitlst = let
  fun aux (bs1: bitlst, bs2: bitlst): bitlst =
    case+ (bs1, bs2) of
    | (b1 :: bs1, b2 :: bs2) => let
        val bs = aux (bs1, bs2) in
        if b1 >= b2 then begin case+ bs of
          | cons _ => (b1-b2) :: bs | nil _ => if b1 = b2 then nil else 1 :: nil
        end else 1 :: upred bs
      end // end of [::, ::]   
    | (_, nil ()) => bs1
    | (nil (), _) => $raise USUBexception ()
  val bs = aux (bs1, bs2)   
in
  bs
end // end of [usub]

fun umul (bs1: bitlst, bs2: bitlst): bitlst =
  case+ bs1 of
  | b1 :: bs1 => let
      val bs = umul (bs1, bs2)
      val bs = (
        case+ bs of cons _ => 0 :: bs | nil _ => nil ()
      ) : bitlst
    in
      if b1 = 0 then bs else uadd (bs, bs2)
    end // end of [::]
  | nil () => nil ()
// end of [umul]

// [bs2] is assumed to be not empty!!!
fun udivrem (bs1: bitlst, bs2: bitlst): @(bitlst(*q*), bitlst(*r*)) =
  case+ bs1 of
  | b1 :: bs1 => let
      val (bs_q, bs_r) = udivrem (bs1, bs2)
      val bs_q = (
        case+ bs_q of cons _ => 0 :: bs_q | nil _ => nil ()
      ) : bitlst // end of [val]
      val bs_r = (case+ bs_r of
        | cons _ => b1 :: bs_r | nil _ => (if b1 = 0 then nil else 1 :: nil)
      ) : bitlst // end of [val]
      val (bs_q, bs_r) =
        if bs_r \ugte bs2 then @(usucc bs_q, usub (bs_r, bs2)) else @(bs_q, bs_r)
      // end of [val]  
    in
      (bs_q, bs_r)
    end // end of [::]
  | nil () => @(nil (), nil ())
// end of [udivrem]
  
in // in of [local]

implement bignum_make_int (i) = let
  val u = (if i >= 0 then i else ~i): int
  val sgn = (if i >= 0 then 1 else ~1): int
in
  BIGNUM (sgn, bitlst_of_uint (uint_of_int u))
end // end of [bignum_make_int]

(*
** fun neg_bignum (x: bignum_t): bignum_t
*)
implement neg_bignum (x) = let
  val+ BIGNUM (sgn, bs) = x in
  case+ bs of cons _ => BIGNUM (~sgn, bs) | nil _ => BIGNUM (1, nil)
end // end of [neg_bignum]

implement succ_bignum (x) = let
  val+ BIGNUM (sgn, bs) = x
in
  if sgn >= 0 then BIGNUM (sgn, usucc bs)
  else let
    val bs1 = upred bs
  in
    case+ bs1 of cons _ => BIGNUM (~1, bs1) | nil _ => BIGNUM (1, nil)
  end // end of [if]
end (* end of [succ_bignum] *)

implement pred_bignum (x) = let
  val+ BIGNUM (sgn, bs) = x
in
  if sgn <= 0 then BIGNUM (~1, usucc bs)
  else begin case+ bs of
    | cons _ => BIGNUM (1, upred bs) | nil _ => BIGNUM (~1, 1 :: nil)
  end // end of [if]
end (* end of [pred_bignum] *)

(*
** fun add_bignum_bignum (x1: bignum_t, x2: bignum_t): bignum_t
*)
implement add_bignum_bignum (x1, x2) = let
  val+ BIGNUM (sgn1, bs1) = x1
  val+ BIGNUM (sgn2, bs2) = x2
in
  case+ (sgn1, sgn2) of
   | (1, ~1) => begin
       if ugte (bs1, bs2) then BIGNUM (1, usub (bs1, bs2)) else BIGNUM (~1, usub (bs2, bs1))
     end // end of [1, ~1]
   | (~1, 1) => begin
       if ugt (bs1, bs2) then BIGNUM (~1, usub (bs1, bs2)) else BIGNUM (1, usub (bs2, bs1))
     end // end of [~1, 1] 
   | (_, _) (*sgn1=sgn2*) => BIGNUM (sgn1, uadd (bs1, bs2))
end // end of [add_bignum_bignum]

implement sub_bignum_bignum (x1, x2) = let
  val+ BIGNUM (sgn1, bs1) = x1
  val+ BIGNUM (sgn2, bs2) = x2
  val sgn2 = ~sgn2
in
  case+ (sgn1, sgn2) of
   | (1, ~1) => begin
       if ugte (bs1, bs2) then BIGNUM (1, usub (bs1, bs2)) else BIGNUM (~1, usub (bs2, bs1))
     end // end of [1, ~1]
   | (~1, 1) => begin
       if ugt (bs1, bs2) then BIGNUM (~1, usub (bs1, bs2)) else BIGNUM (1, usub (bs2, bs1))
     end // end of [~1, 1] 
   | (_, _) (*sgn1=sgn2*) => BIGNUM (sgn1, uadd (bs1, bs2))
end // end of [sub_bignum_bignum]

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

implement mul_bignum_bignum (x1, x2) = let
  val+ BIGNUM (sgn1, bs1) = x1
  val+ BIGNUM (sgn2, bs2) = x2
  val sgn = sgn1 * sgn2
in
  BIGNUM (sgn, umul (bs1, bs2))
end (* end of [mul_bignum_bignum] *)

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

exception DivisionByZeroException of ()

implement div_bignum_bignum (x1, x2) = let
  val+ BIGNUM (sgn1, bs1) = x1
  val+ BIGNUM (sgn2, bs2) = x2
  val () = (case+ bs2 of cons _ => () | nil _ => $raise DivisionByZeroException ()): void
  val sgn = sgn1 * sgn2
  val @(bs_q, bs_r) = udivrem (bs1, bs2)
in
  BIGNUM (sgn, bs_q)
end (* end of [div_bignum_bignum] *)

implement divrem_bignum_bignum (x1, x2) = let
  val+ BIGNUM (sgn1, bs1) = x1
  val+ BIGNUM (sgn2, bs2) = x2
  val () = (case+ bs2 of cons _ => () | nil _ => $raise DivisionByZeroException ()): void
  val sgn = sgn1 * sgn2
  val @(bs_q, bs_r) = udivrem (bs1, bs2)
in
  @(BIGNUM (sgn, bs_q), BIGNUM (sgn1, bs_r))
end (* end of [divrem_bignum_bignum] *)

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

exception SqrtOfNegException of ()
implement sqrt_bignum (x) = BIGNUM (1, aux bs) where {
  val BIGNUM (sgn, bs) = x
  val () = (if sgn >= 0 then () else $raise SqrtOfNegException ()): void
  macdef _0 = nil (); macdef _1 = 1 :: nil ()
  fun aux (bs: bitlst): bitlst = case+ bs of
    | b1 :: b2 :: bs1 => let
        val rt1 = aux (bs1)
        val rt2 = (case+ rt1 of cons _ => 0 :: rt1 | nil _ => nil ()): bitlst
        val rt3 = usucc rt2
      in
        if umul (rt3, rt3) \ugt bs then rt2 else rt3
      end // end of [_ :: _ :: _]
    | _ :: _ => _1
    | nil () => _0
  // end of [aux]
} // end of [sqrt_bignum]

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

fun print_bignum
  (x: bignum_t, base: uint): void = () where {
  val+ BIGNUM (sgn, bs) = x 
  val base = bitlst_of_uint (base)
  val () = (if sgn >= 0 then () else print "-"): void
  val () = aux (bs, base) where {
    fun aux
      (bs: bitlst, base: bitlst): void = case bs of
      | cons _ => let
          val (bs_q, bs_r) = udivrem (bs, base) in
          aux (bs_q, base); print_uint (uint_of_bitlst bs_r)
        end // end of [val]
      | nil () => ()    
    // end of [aux]  
  }
  val () = case+ bs of
    | cons _ => () | nil () => print "0"
  // end of [val]  
} // end of [print_bignum]

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

val ((*test*)) = () where {
  val u = 20U
  val u1 = uint_of_bitlst (upred (bitlst_of_uint u))
  val () = printf ("u = %u and u1 = %u\n", (u, u1))
  val bn0 = bignum_make_int (11)
  val bn1 = bignum_make_int (1000)
  val () = (print "bn1 = "; print (int_of_bignum bn1); print_newline ())
  val bn2 = add_bignum_bignum (bn1, bn1)
  val () = (print "bn2 = "; print (int_of_bignum bn2); print_newline ())
  val bn3 = sub_bignum_bignum (bn2, bn1)
  val () = (print "bn3 = "; print (int_of_bignum bn3); print_newline ())
  val bn4 = sub_bignum_bignum (bn1, bn2)
  val () = (print "bn4 = "; print (int_of_bignum bn4); print_newline ())
  val bn5 = mul_bignum_bignum (bn3, bn4)
  val () = (print "bn5 = "; print (int_of_bignum bn5); print_newline ())
  val (bn6, bn7) = divrem_bignum_bignum (bn5, bn0)
  val () = (print "bn6 = "; print (int_of_bignum bn6); print_newline ())
  val () = (print "bn7 = "; print (int_of_bignum bn7); print_newline ())
} // end of [val]

fun fib (n: int): bignum_t = ans where {
  val _0 = bignum_make_int (0) and _1 = bignum_make_int (1)
  val ans = loop (n, _0, _1) where {
    fun loop (n: int, f1: bignum_t, f2: bignum_t): bignum_t =
      if n > 0 then loop (n-1, f2, add_bignum_bignum (f1, f2)) else f1
    // end of [loop]
  } // end of [val]
} // end of [fib]

(*

fun sqrt_bignum (x: bignum_t): bignum_t

*)

end // end of [local]

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

implement main () = () where {

val nchunk = gc_chunk_count_limit_max_get ()
val () = (print "nchunk = "; print nchunk; print_newline ()) 
val () = gc_chunk_count_limit_max_set (nchunk << 2) // enough?

val () = begin
  print "fib (10) = "; print_bignum (fib 10, 10U); print_newline ()
end // end of [val]

val () = begin
  print "sqrt (1023) = ";
  print_bignum (sqrt_bignum (bignum_make_int 1023), 10U);
  print_newline ()
end // end of [val]

val () = begin
  print "sqrt (1024) = ";
  print_bignum (sqrt_bignum (bignum_make_int 1024), 10U);
  print_newline ()
end // end of [val]

val fib100 = fib 100

val () = begin
  print "fib (100) = "; print_bignum (fib100, 10U); print_newline ()
end // end of [val]

val () = begin
  print "sqrt (fib100*fib100-1) = ";
  print_bignum (sqrt_bignum (pred_bignum (mul_bignum_bignum (fib100, fib100))), 10U);
  print_newline ()
end // end of [val]

val () = begin
  print "fib (1000) = "; print_bignum (fib 1000, 10U); print_newline ()
end // end of [val]

(*
val () = begin
  print "fib (10000) = "; print_bignum (fib 10000, 10U); print_newline ()
end // end of [val]
*)

} // end of [main]

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

(* end of [assgn3ex2.dats] *)