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

//
// Assignment Four (Due: Tuesday, June 16, 2009)
//
// Total points: 130 points
//
// Assgn4Ex1: 10 points
// Assgn4Ex2: 10 points
// Assgn4Ex3: 30 points
// Assgn4Ex4: 30 points
// Assgn4Ex5: 20 points
// Assgn4Ex6: 30 points
//

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

staload "assignment4.sats"

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

#include "../../code/BUCASCS320.hats"

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

// stream_car
fun{a:t@ype} stream_car
  (s: stream a):<1,~ref> a = case+ !s of
  | stream_cons (x, _) => x
  | stream_nil () => $raise StreamSubscript ()
// end of [stream_car]

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

(*

// Assgn4Ex1: 10 points
// The following is a well-known series:
// 
// ln 2 = 1 - 1/2 + 1/3 - 1/4 + ...
//
// Please implement a stream consisting of all the partial sums of this
// series. Then compute an accurate approximation to ln2 by using Euler's
// transform.

*)

(*
** val theAssgn4Ex1Stream: stream double
*)
implement theAssgn4Ex1Stream =
  helper (0.0(*sum*), 1(*sign*), 1.0(*denom*)) where {
  fun helper
    (sum: double, sgn: int, denom: double)
    :<1,~ref> stream double = $delay (
    if sgn > 0 then let
      val sum1 = sum + 1.0 / denom in
      stream_cons (sum1, helper (sum1, ~1, denom + 1.0))
    end else let // sgn = ~1 
      val sum1 = sum - 1.0 / denom in
      stream_cons (sum1, helper (sum1,  1, denom + 1.0))
    end : stream_con (double)
  ) // end of [helper]
} (* end of [theAssgn4Ex1Stream] *)

local

#define :: stream_cons
#define nil stream_nil

in // in of [local]

fun euler_trans
  (ss0: stream double):<1,~ref> stream double = $delay (let
  val- s0 :: ss1 = !ss0
  val- s1 :: ss2 = !ss1
  val- s2 :: ss3 = !ss2
  val s01 = s0 - s1 and s21 = s2 - s1
in
  (s2 - s21 * s21 / (s01 + s21)) :: euler_trans ss1
end : stream_con double
) // end of [euler_trans]

end // end of [local]

fun euler_trans_tableau
  (ss: stream double):<1,~ref> stream (stream double) =
  $delay (stream_cons (ss, euler_trans_tableau (euler_trans ss)))
// end of [euler_trans_tableau]

val theAssgn4Ex1StreamDiag =
  stream_map_fun<stream double, double>
    (euler_trans_tableau theAssgn4Ex1Stream, stream_car)
// end of [thePiStreamDiag]

(*

val () = printf ("ln2_4 = %.10f\n", @(stream_nth (theAssgn4Ex1StreamDiag, 4)))
val () = printf ("ln2_5 = %.10f\n", @(stream_nth (theAssgn4Ex1StreamDiag, 5)))
val () = printf ("ln2_6 = %.10f\n", @(stream_nth (theAssgn4Ex1StreamDiag, 6)))
val () = printf ("ln2_7 = %.10f\n", @(stream_nth (theAssgn4Ex1StreamDiag, 7)))
val () = printf ("ln2_8 = %.10f\n", @(stream_nth (theAssgn4Ex1StreamDiag, 8)))

ln2_4 = 0.6931471961
ln2_5 = 0.6931471807
ln2_6 = 0.6931471806
ln2_7 = 0.6931471806
ln2_8 = 0.6931471806

*)

implement ln2 = loop (0.0, theAssgn4Ex1StreamDiag) where {
  fun loop (x0: double, xs: stream double): double = case+ !xs of
    | stream_cons (x, xs) =>
       (if x0 = x then x0 else if isnan x <> 0 then x0 else loop (x, xs))
    | stream_nil () => x0
  // end of [loop]   
} // end of [ln2]

val () = printf ("ln2 = %.10f\n", @(ln2))

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

(*

// Assgn4Ex2: 10 points
// For each $i\geq 1$, we use $P_i$ for the $i^{\it th}$ prime number.  For
// instance, $P_1$ is $2$, $P_2$ is $3$ and $P_3$ is $5$.  Please implement a
// stream consisting of all the sums of the form
// $\Sigma_{i=1}^{n}\frac{1}{P_i}$ for $n\geq 1$.

*)

(*
** val theAssgn4Ex2Stream : stream double 
*)

fun sieve (s: stream int):<1,~ref> stream int = $delay (let
  val- stream_cons (p1, s1) = !s
  val s1 = stream_filter_cloref<int> (s1, lam x => x mod p1 <> 0)
in    
  stream_cons (p1, sieve (s1))
end) // end of [sieve]

val thePrimeNumberStream = sieve (from 2) where {
  fun from (n: int):<1,~ref> stream int = $delay (stream_cons (n, from (n+1)))
} (* end of [thePrimeNumberStream] *)

implement theAssgn4Ex2Stream =
  aux (thePrimeNumberStream, 0.0(*partial sum*)) where {
  fun aux
    (ns: stream int, sum: double)
    :<1,~ref> stream double = $delay (let
    val- stream_cons (n, ns) = !ns
    val sum = sum + 1.0 / n in stream_cons (sum, aux (ns, sum))
   end : stream_con double
  ) // end of [aux]  
} (* end of [theAssgn4Ex2Stream] *)

(*

val () = printf ("sum0 = %f", @(stream_nth (theAssgn4Ex2Stream, 0)))
val () = print_newline ()
val () = printf ("sum1 = %f", @(stream_nth (theAssgn4Ex2Stream, 1)))
val () = print_newline ()
val () = printf ("sum2 = %f", @(stream_nth (theAssgn4Ex2Stream, 2)))
val () = print_newline ()
val () = printf ("sum1000 = %f", @(stream_nth (theAssgn4Ex2Stream, 1000)))
val () = print_newline ()
val () = printf ("sum5000 = %f", @(stream_nth (theAssgn4Ex2Stream, 5000)))
val () = print_newline ()

// sum0 = 0.500000
// sum1 = 0.833333
// sum2 = 1.033333
// sum1000 = 2.457537
// sum5000 = 2.640573

*)

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

(*

// Assgn4Ex3: 30 points
// Implement a procedure that takes two matrices and returns their
// product. Note that two matrices can be multiplied only if they are of
// dimensions $p\times q$ and $q \times r$ for some natural numbers $p,q,r$.

*)

(*
** typedef matrx = list0 (list0 double)
** fun mul_matrx_matrx (A: matrx, B: matrx): matrx
*)

local

typedef lstlst (a:t@ype) = list0 (list0 a)

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

in

fun{a:t@ype} lstlst_transpos
  (M: lstlst a): lstlst a = tp (M) where {
  fun tp (xss: lstlst a): lstlst a = case+ xss of
    | xs :: xss => begin case+ xss of
      | cons _ => list0_map2_cloref<a, list0 a, list0 a> (xs, tp xss, lam (x, xs) => x :: xs)
      | nil () => list0_map_cloref<a, list0 a> (xs, lam (x) => x :: nil ())
      end // end of [::]
    | nil () => nil ()
  // end of [tp]
} // end of [lstlst_transpos]

fun innerprod
  (xs: list0 double, ys: list0 double): double =
  loop (xs, ys, 0.0) where {
  fun loop (xs: list0 double, ys: list0 double, sum: double): double =
    case+ (xs, ys) of
    | (x :: xs, y :: ys) => loop (xs, ys, sum + x * y) | (_, _) => sum
  // end of [loop]  
} // end of [innerprod]

implement mul_matrx_matrx (M1, M2) = list0_map_cloref (M1, f) where {
  val f = lam (xs: list0 double): list0 double =<cloref1>
    list0_map_cloref<list0 double, double> (M2, lam ys => innerprod (xs, ys))
  // end of [val]  
} // end of [mul_matrx_matrx]

end // end of [implement]

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

(*

// Assgn4Ex4: 30 points
// A natural number $n$ is a Ramanujan number if there exist two distinct
// pairs of natural numbers $(i_1,j_1)$ and $(i_2,j_2)$ such that
// $n=i_1^3+j_1^3=i_2^3+j_2^3$. For instance, $1729$ is a Ramanujan number as
// $1729=1^3+12^3=9^3+10^3$.  Please construct a stream of {\em all} Ramanujan
// numbers and then use it to find the first twenty Ramanujan numbers.

*)

(*
** try to re-use some code used in class
*)
datatype seq (a:t@ype) =
  Nil(a) of () | Cons(a) of (a, () -<cloref1,~ref> seq a)
// end of [seq]
  
typedef int2 = @(int, int)

fun from2_one
  (i: int, j: int):<1,~ref> seq (int2) =
  Cons ( @(i, j), lam () => from2_one (i, j+1) ) 
// end of [from2_one]

fun{a:t@ype} seq_merge 
  (xs1: seq a, xs2: seq a, lte: (a, a) -<cloref> bool):<1,~ref> seq a =
  case+ xs1 of
  | Cons (x1, fxs1) => begin case+ xs2 of
    | Cons (x2, fxs2) => begin
        if x1 \lte x2 then Cons (x1, lam () => seq_merge (fxs1 (), xs2, lte))
                      else Cons (x2, lam () => seq_merge (xs1, fxs2 (), lte))
      end // end of [Cons]
    | Nil () => xs1
    end // end of [Cons]  
  | Nil () => xs2
// end of [seq_merge]

fun lte_int2_int2 .<>.
  (xy1: int2, xy2: int2):<> bool = let
  val x1 = xy1.0 and y1 = xy1.1
  val x2 = xy2.0 and y2 = xy2.1
in
  (x1 * x1 * x1 + y1 * y1 * y1) <= (x2 * x2 * x2 + y2 * y2 * y2)
end (* end of [lte_int2_int2] *) 

fun from2_all
  (i: int, j: int):<1,~ref> seq int2 = let
  val ij = @(i, j)
in
  Cons (ij
  , lam () => let
      val fstrow = from2_one (i, j+1)
      val restbl = (
        if i = j then from2_all (i+1, i+1) else from2_all (i+1, j)
      ) : seq int2 
    in
      seq_merge<int2> (restbl, fstrow, lam (xy1, xy2) => xy1 \lte_int2_int2 xy2)
    end (* end of [lam] *)
  ) // end of [Cons]
end // end of [from2_all]

(*
** val theRamanujanStream: seq int
** val theFirstTwentyRamanujanNumbers : list0 int 
*)

val theCubeSumStream = from2_all (1, 1)

macdef cubesum (x, y) = let
  val x = ,(x) and y = ,(y) in x * x * x + y * y * y
end // end of [cubesum]

val theRamanujanSeq: seq int = aux
  (0(*sum*), 0(*times*), theCubeSumStream) where {
  fun aux
    (sum: int, times: int, xys: seq int2)
    :<1,~ref> seq int = let
    val- Cons (xy, fxys) = xys; val x = xy.0 and y = xy.1
    val sum1 = cubesum (x, y)
  in
    if sum < sum1 then begin
      if times > 0 then
        Cons (sum, lam () => aux (sum1, 0, fxys ()))
      else aux (sum1, 0, fxys ())
    end else begin
      aux (sum, times+1, fxys ())
    end // end of [if]
  end (* end of [aux] *)
} (* end of [theRamanujanStream] *)

implement theRamanujanStream =
  aux (theRamanujanSeq) where { // turning a seq into a stream 
  fun aux (xs: seq int):<1,~ref> stream int = $delay (begin case+ xs of
    | Cons (x, fxs) => stream_cons (x, aux (fxs ())) | Nil () => stream_nil ()
  end : stream_con int) // end of [aux]  
} (* end of [theRamanujanStream] *)

implement
  theFirstTwentyRamanujanNumbers =
    aux (theRamanujanStream, 20) where {
  fun aux (xs: stream int, n: int): list0 int =
    if n > 0 then let
      val- stream_cons (x, xs) = !xs
(*
      val () = printf ("%i\n", @(x)) 
*)
    in
      list0_cons (x, aux (xs, n-1))
    end else list0_nil ()  
} (* end of [theFirstTwentyRamanujanNumbers] *)

(*

The first twenty Ramanujan numbers are listed as follows:

1729
4104
13832
20683
32832
39312
40033
46683
64232
65728
110656
110808
134379
149389
165464
171288
195841
216027
216125
262656

*)

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

(*

// Assgn4Ex5: 20 points
// Please write a function that extracts out the (first) longest line in a given file.
// The implementation should be stream-based.

*)

(*
** fun longest_line_get (inp: FILEref): string
*)

implement longest_line_get (inp) = let
  val cs = char_stream_make_file (inp)
  fn* aux1 (cs: stream char, res: list0 char, n: int): list0 char =
    case+ !cs of
    | stream_cons (c, cs) => begin
        if c = '\n' then aux2 (cs, res, n, list0_nil, 0)
                    else aux1 (cs, list0_cons (c, res), n+1) 
      end // end of [stream_cons]
    | stream_nil () => res
  // end of [aux1]
  
  and aux2 (
      cs: stream char
    , maxline: list0 char, maxlen: int
    , res: list0 char, n: int
    ) : list0 char = case+ !cs of
    | stream_cons (c, cs) => begin
        if c = '\n' then begin
          if maxlen >= n then
            aux2 (cs, maxline, maxlen, list0_nil, 0)
          else aux2 (cs, res, n, list0_nil, 0)
        end else begin
          aux2 (cs, maxline, maxlen, list0_cons (c, res), n+1)
        end // end of [if]
      end (* end of [stream_cons] *)
    | stream_nil () => (if maxlen >= n then maxline else res)
  // end of [aux2]  
in
  string_implode (list0_reverse (aux1 (cs, list0_nil, 0)))
end // end of [longest_line_get]

(*
// val () = printf ("%s\n", @(longest_line_get (stdin_ref)))
*)

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

(*

//
// Assgn4Ex6: 30 points
//

datatype ltree (a:t@ype) =
  | ltree_nil (a) of ()
  | ltree_cons (a) of (a, ref int(*size*), ref (ltree a), ref (ltree a))
// end of [ltree]

// Please implement in-place left (BST) rotation
fun{a:t@ype} ltree_rotate_l (r_t: ref (ltree a)): void

// Please implement in-place right (BST) rotation
fun{a:t@ype} ltree_rotate_r (r_t: ref (ltree a)): void

// Please implement a function that changes the root of a given (bst)
// tree to a randomly choosen node inside the tree:
fun{a:t@ype} ltree_random_root (r_t: ref (ltree a)): void

*)

fun{a:t@ype} tree_size (t: ltree a): int = case+ t of
  | ltree_cons (_, r_sz, _, _) => !r_sz | ltree_nil () => 0
// end of [tree_size]

implement{a} ltree_rotate_l (t) = let
  val- ltree_cons (x, r_sz, r_tl, r_tr) = t
  val sz = !r_sz
  val tl = !r_tl and tr = !r_tr
  val- ltree_cons (xr, r_szr, r_trl, r_trr) = tr
  val trl = !r_trl
(*
   val trr = !r_trr
*)
//
  val () = (!r_tr := trl)
  val () = (
    !r_sz := tree_size (tl) + tree_size (trl) + 1
  ) // end of [val]
//
  val () = (!r_trl := t)
  val () = (!r_szr := sz)
//
in
  tr
end // end of [ltree_rotate_l]

implement{a} ltree_rotate_r (t) = let
  val- ltree_cons (x, r_sz, r_tl, r_tr) = t
  val sz = !r_sz
  val tl = !r_tl and tr = !r_tr
  val- ltree_cons (xl, r_szl, r_tll, r_tlr) = tl
(*
  val tll = !r_tll
*)
  val tlr = !r_tlr
//
  val () = (!r_tl := tlr)
  val () = (
    !r_sz := tree_size (tlr) + tree_size (tr) + 1
  ) // end of [val]
//
  val () = (!r_tlr := t)
  val () = (!r_szl := sz)
//
in
  tl
end // end of [ltree_rotate_r]

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

local

staload RAND = "libc/SATS/random.sats"

in // in of [local]

implement randint (n) = let
  val n = int1_of_int n in
  if n > 0 then $RAND.randint (n) else $raise Domain ()
end // end of [randint]

end // end of [local]

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

implement{a} ltree_random_root (t) = let
  val sz = tree_size (t)
in
  if sz > 0 then let
    val n = randint (sz)
    val- ltree_cons (x, _(*r_sz*), r_tl, r_tr) = t
    val tl = !r_tl; val szl = tree_size (tl)
  in
    if n < szl then let
      val tl = ltree_random_root (tl)
      val () = !r_tl := tl
    in
      ltree_rotate_r (t)
    end else if n > szl then let
      val tr = ltree_random_root (!r_tr)
      val () = !r_tr := tr 
    in
      ltree_rotate_l (t)
    end else t (* n = szl *)    
  end else begin
    t // there is no change
  end (* end of [if] *)  
end (* end of [ltree_random_root] *)

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

(* end of [assignment4_solu.dats] *)