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

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

//
// Game-of-24 with a rough GUI
//

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

staload _(*anon*) = "prelude/DATS/list.dats"
staload _(*anon*) = "prelude/DATS/list_vt.dats"
staload _(*anon*) = "prelude/DATS/list0.dats"
staload _(*anon*) = "prelude/DATS/reference.dats"

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

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

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

staload "contrib/glib/SATS/glib.sats"
staload "contrib/glib/SATS/glib-object.sats"

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

staload "contrib/GTK/SATS/gdk.sats"
staload "contrib/GTK/SATS/gtkclassdec.sats"
staload "contrib/GTK/SATS/gtk.sats"

implement
gtk_widget_show_unref {c} (widget) = let
  prval () = clstrans {c,GtkWidget,GObject} ()
  val () = gtk_widget_show (widget) in g_object_unref (widget)
end // end of [gtk_widget_show_unref]

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

datatype exp =
  | EXPnum of double
  | EXPadd of (exp, exp)
  | EXPsub of (exp, exp)
  | EXPmul of (exp, exp)
  | EXPdiv of (exp, exp)
// end of [exp]
datatype expopt = EXPOPTsome of exp | EXPOPTnone of ()

extern fun play24 (n1: int, n2: int, n3: int, n4: int): expopt

//
// HX: please replace this placeholder with your own implementation!!!
//
implement play24 (n1, n2, n3, n4) = EXPOPTnone ()

(* ****** ****** *)
//
// HX: there is no need to modify the rest of the file
//
(* ****** ****** *)

fun priority_mac (e: exp): Nat = (case+ e of
  | EXPnum _ => 0 | EXPadd _ => 2 | EXPsub _ => 2 | EXPmul _ => 1 | EXPdiv _ => 1
) : Nat // end of [priority]

fun g_print_exp {l:agz}
  (gs: !GString_ptr l, e: exp): void = begin
  case+ e of
  | EXPnum r => g_string_append_printf (gs, "%.0f", @(r))
  | EXPadd (e1, e2) => let
      val p1 = priority_mac e1 and p2 = priority_mac e2
      val () = g_print_exp_ (gs, 2, p1, e1)
      val _ = g_string_append_c (gs, (gchar)'+')
      val () = g_print_exp_ (gs, 2, p2, e2)
    in
      // nothing
    end // end of [Add]
  | EXPsub (e1, e2) => let
      val p1 = priority_mac e1 and p2 = priority_mac e2
      val () = g_print_exp_ (gs, 2, p1, e1)
      val _ = g_string_append_c (gs, (gchar)'-')
      val () = g_print_exp_ (gs, 2, p2, e2)
    in
      // nothing
    end // end of [Sub]
  | EXPmul (e1, e2) => let
      val p1 = priority_mac e1 and p2 = priority_mac e2
      val () = g_print_exp_ (gs, 1, p1, e1)
      val _ = g_string_append_c (gs, (gchar)'*')
      val () = g_print_exp_ (gs, 1, p2, e2)
    in
      // nothing
    end // end of [Mul]
  | EXPdiv (e1, e2) => let
      val p1 = priority_mac e1 and p2 = priority_mac e2
      val () = g_print_exp_ (gs, 1, p1, e1)
      val _ = g_string_append_c (gs, (gchar)'/')
      val () = g_print_exp_ (gs, 1, p2, e2)
    in
      // nothing
    end // end of [Div]
end // end of [print_exp]

and g_print_exp_ {l:agz}
  (gs: !GString_ptr l, p0: Nat, p: Nat, e: exp): void =
  if p < p0 then g_print_exp (gs, e) else let
    val _ = g_string_append_c (gs, (gchar)'\(')
    val () = g_print_exp (gs, e)
    val _ = g_string_append_c (gs, (gchar)')')
  in
    // nothing
  end // end of [if]
// end of [print_exp_]

fun print_exp (e: exp): void = let
  val gs = g_string_new ()
  val () = g_print_exp (gs, e)
  val ptr = g_string_get_str (gs)
  val () = print (string) where {
    val string = __cast (ptr) where { extern castfn __cast (x: ptr): string }
  } // end of [val]
in
  g_string_free_true (gs)
end // end of [print_exp]
  
(* ****** ****** *)

macdef gs = gstring_of_string

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

overload gint with gint_of_GtkResponseType

fun answering
  (xs: List exp): void = () where {
  val dialog = gtk_dialog_new ()
//
  val (fpf_win | win) = gtk_dialog_get_window (dialog)
  val (fpf_x | x) = (gs)"Game-of-24 Answer Dialog"
  val () = gtk_window_set_title (dialog, x)
  prval () = fpf_x (x)
  prval () = minus_addback (fpf_win, win | dialog)
//
  val (fpf_x | x) = (gs)"_Close"
  val (fpf_button | button) = gtk_dialog_add_button (dialog, x, (GtkResponseType)0)
  prval () = fpf_x (x)
  prval () = minus_addback (fpf_button, button | dialog)
//
  val (fpf_vbox0 | vbox0) = gtk_dialog_get_vbox (dialog)
//
  val hbox1 = gtk_hbox_new (GFALSE, (gint)0)
  val () = gtk_box_pack_start (vbox0, hbox1, GTRUE, GTRUE, guint(10))
  val () = (case+ xs of
    | list_cons _ => let
//
        val (fpf_x | x) = (gstring_of_string)"Solution(s) found:"
        val frame = gtk_frame_new (x)
        prval () = fpf_x (x)
        val () = gtk_box_pack_start (hbox1, frame, GTRUE, GFALSE, guint(10))
        val [l_box:addr] vbox2 = gtk_vbox_new (GTRUE, gint(2))
        val () = gtk_container_add (frame, vbox2)
//
        val [l_str:addr] gs  = g_string_new ()
        val () = loop (vbox2, gs, xs) where {
         fun loop (
             vbox2: !gobjref (GtkVBox, l_box), gs: !GString_ptr l_str, xs: List exp
           ) : void = case+ xs of
           | list_cons (x, xs) => let
               val _ptr = g_string_truncate (gs, gsize(0))
               val () = g_print_exp (gs , x)
               val () = g_string_append_printf (gs, " = 24", @())
               val ptr = g_string_get_str (gs)
               extern castfn __cast (x: ptr): [l:agz] (gstring l -<lin,prf> void | gstring l)
               val (fpf_x | x) = __cast (ptr)
               val label_msg = gtk_label_new (x)
               prval () = fpf_x (x)
              val () = gtk_box_pack_start (vbox2, label_msg, GFALSE, GTRUE, guint(0))
              val () = gtk_widget_show_unref (label_msg)
            in
              loop (vbox2, gs, xs)
            end // end of [list_cons]
          | list_nil () => ()
        }
        val () = g_string_free_true (gs)
        val () = gtk_widget_show_unref (vbox2)
        val () = gtk_widget_show_unref (frame)
      in
        // nothing
      end // end of [if]
    | list_nil _ => let
        val (fpf_x | x) = (gstring_of_string)"No solution found!"
        val label_ans = gtk_label_new (x)
        prval () = fpf_x (x)
        val () = gtk_box_pack_start (hbox1, label_ans, GTRUE, GFALSE, guint(10))
        val () = gtk_widget_show_unref (label_ans)
      in
        // nothing
      end // end of [if]
  ) : void // end of [val]
  val () = gtk_widget_show_unref (hbox1)
//
  prval () = minus_addback (fpf_vbox0, vbox0 | dialog)
  // val () = gtk_widget_show (dialog) // this is automatically done
//
  val () = while (true) let
    val response = gtk_dialog_run (dialog)
    // val () = (print "response = "; print ((int_of)response); print_newline ())
  in
    case+ 0 of
    | _ when response = (gint)0 => break
    | _ when response = (gint)GTK_RESPONSE_DELETE_EVENT => break
    | _ => ()
  end // end of [val]
//
  val () = gtk_widget_destroy (dialog)
} // end of [answering]

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

#define nil list_nil
#define :: list_cons
typedef explst (n:int) = list (exp, n)
typedef explst = [n:nat] explst n

fun play24_ {n:nat}
  (ns: list_vt (int, n)) = let
  val n = list_vt_length (ns)
  val () = assert_errmsg (n >= 4, #LOCATION)
  val ~list_vt_cons (n1, ns) = ns
  val ~list_vt_cons (n2, ns) = ns
  val ~list_vt_cons (n3, ns) = ns
  val ~list_vt_cons (n4, ns) = ns
  val () = list_vt_free (ns)
  val res = play24 (n1, n2, n3, n4)
  val res = (case+ res of
    | EXPOPTsome e => list_cons (e, list_nil) | EXPOPTnone _ => list_nil
  ) : explst // end of [val]
  val () = answering (res)
in
  // nothing
end // end of [play24_]

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

fun suit_spinner_gen
  (): GtkSpinButton_ref1 = let
  val adj = gtk_adjustment_new
    (1.0, 1.0, 13.0, 1.0, 0.0(*ignored*), 0.0(*ignored*))
  val spinner = gtk_spin_button_new (adj, (gdouble)0.0, (guint)0)
  val () = gtk_spin_button_set_numeric (spinner, GTRUE)
  val () = gtk_spin_button_set_wrap (spinner, GTRUE)
  val () = g_object_unref (adj)
in
  spinner
end // end of [suit_spinner_gen]

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

viewtypedef
suitSpinnerLst = List_vt (GtkSpinButton_ref1)

val theSuitSpinnerLst =
  ref_make_elt<suitSpinnerLst> (list_vt_nil)
// end of [val]

fun theSuitSpinnerLst_add
  (x: !GtkSpinButton_ref1): void = () where {
  val (vbox pf_xs | p_xs) = ref_get_view_ptr (theSuitSpinnerLst)
  val x1 = $effmask_ref (g_object_ref (x))
  val () = !p_xs := list_vt_cons (x1, !p_xs)
} // end of [theSuitSpinnerLst_add]

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

fun inputapp (): void = () where {
  fun loop (xs: !suitSpinnerLst): void =
    case+ xs of
    | list_vt_cons (!p_x, !p_xs) => let
        var min: gdouble and max: gdouble
        val () = gtk_spin_button_get_range (!p_x, min, max)
        val max = double_of(max) and min = double_of(min)
        val v = $MATH.floor (min + (max + 1 - min) * $RAND.drand48 ())
        val v = gtk_spin_button_set_value (!p_x, (gdouble)v)
        val () = loop (!p_xs)
        prval () = fold@ (xs)
      in
        // nothing
      end // end of [list_vt_cons]
    | list_vt_nil () => (fold@ xs)
  // end of [loop]
  val () = $effmask_ref (loop (!p_xs)) where {
    val (vbox pf_xs | p_xs) = ref_get_view_ptr (theSuitSpinnerLst)
  }
} // end of [inputapp]

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

fun evalapp (): void = let
  fun loop (xs: !suitSpinnerLst): List_vt int =
    case+ xs of
    | list_vt_cons (!p_x, !p_xs) => let
        val v = gtk_spin_button_get_value_as_int (!p_x)
        val v = int_of(v)
        val vs = loop (!p_xs)
        val () = fold@ (xs)
      in
        list_vt_cons (v, vs)
      end // end of [list_vt_cons]
    | list_vt_nil () => (fold@ xs; list_vt_nil)
  // end of [loop]
  val (vbox pf_xs | p_xs) = ref_get_view_ptr (theSuitSpinnerLst)
  val vs = $effmask_ref (loop (!p_xs))
  val () = $effmask_ref (play24_ (vs))
in
  // nothing
end // end of [evalapp]

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

staload PRINTF = "libc/SATS/printf.sats"

fun suit_spinnerlst_hbox_gen
  {n:nat} (n: int n): GtkHBox_ref1 = let
  val hbox = gtk_hbox_new (GTRUE(*homo*), (gint)10(*spacing*))
  val () = loop (hbox, n, 1) where {
    fun loop
      {c:cls | c <= GtkBox}
      {l:agz} {n:nat} .<n>. (
        box: !gobjref (c, l), n: int n, i: int
      ) : void =
      if n > 0 then let
        val vbox = gtk_vbox_new (GFALSE, (gint)0)
        val () = gtk_box_pack_start (box, vbox, GTRUE, GTRUE, (guint)20)
        val name = g_strdup_printf ("Card %d:", @(i))
        val label = gtk_label_new (name)
        val () = gstring_free (name)
        val () = gtk_box_pack_start (vbox, label, GFALSE, GTRUE, (guint)2)
        val spinner = suit_spinner_gen ()
        val () = theSuitSpinnerLst_add (spinner)
        val () = gtk_box_pack_start (vbox, spinner, GFALSE, GTRUE, (guint)2)
        val () = gtk_widget_show_unref (label)
        val () = gtk_widget_show_unref (spinner)
        val () = gtk_widget_show_unref (vbox)
      in
        loop (box, n-1, i+1)
      end // end of [if]
    // end of [loop]
  } // end of [val]
in
  hbox
end // end of [suit_spinnerlst_hbox_gen]

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

fun quitapp
  {c:cls | c <= GtkWidget} {l:agz}
  (widget: !gobjref (c, l), event: &GdkEvent, _: gpointer): gboolean = let
  val () = gtk_main_quit ()
in
  GFALSE // delivered!
end // end of [quitapp]

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

%{^
extern
ats_void_type
mainats (ats_int_type argc, ats_ptr_type argv) ;
%} // end of [%{^]

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

extern fun main1 (): void = "main1"

implement main1 () = () where {
//
  val () = $RAND.srand48_with_time ()
//
  val window = gtk_window_new (GTK_WINDOW_TOPLEVEL)
  val (fpf_window | window_) = g_object_vref (window)
  val _sig = g_signal_connect0
    (window_, (gsignal)"destroy", G_CALLBACK(gtk_widget_destroy), (gpointer)null)
  val _sig = g_signal_connect1
    (window, (gsignal)"delete_event", G_CALLBACK(quitapp), (gpointer)null)
  val (fpf_x | x) = (gstring_of_string)"Game-of-24"
  val () = gtk_window_set_title (window, x)
  prval () = fpf_x (x)
//
  val vbox0 = gtk_vbox_new (GFALSE(*homo*), (gint)0)
//
  val (fpf_x | x) = (gstring_of_string)"Game-of-24"
  val label_title = gtk_label_new (x)
  prval () = fpf_x (x)
  val () = gtk_box_pack_start (vbox0, label_title, GTRUE, GTRUE, (guint)10)
  val () = gtk_widget_show_unref (label_title)
//
  val hsep = gtk_hseparator_new ()
  val () = gtk_box_pack_start (vbox0, hsep, GTRUE, GTRUE, (guint)0)
  val () = gtk_widget_show_unref (hsep)
//
  val hbox_suits = suit_spinnerlst_hbox_gen (4)
  val () = gtk_box_pack_start (vbox0, hbox_suits, GTRUE, GTRUE, (guint)10)
  val () = gtk_widget_show_unref (hbox_suits)
//
  val hsep = gtk_hseparator_new ()
  val () = gtk_box_pack_start (vbox0, hsep, GTRUE, GTRUE, (guint)0)
  val () = gtk_widget_show_unref (hsep)
//
  val hbox = gtk_hbox_new (GFALSE, (gint)0)
  val () = gtk_box_pack_start (vbox0, hbox, GTRUE, GTRUE, (guint)10)
//
  val () = () where { // adding the [input] button
    val (fpf_x | x) = (gstring_of_string)"Random Input"
    val button = gtk_button_new_with_label (x)
    prval () = fpf_x (x)
    val _sid = g_signal_connect
      (button, (gsignal)"clicked", G_CALLBACK(inputapp), (gpointer)null)
    val () = gtk_box_pack_start (hbox, button, GTRUE, GTRUE, (guint)10)
    val () = gtk_widget_show_unref (button)
  } // end of [val]
//
  val () = () where { // adding the [eval] button
    val (fpf_x | x) = (gstring_of_string)"Eval"
    val button = gtk_button_new_with_label (x)
    prval () = fpf_x (x)
    val _sid = g_signal_connect
      (button, (gsignal)"clicked", G_CALLBACK(evalapp), (gpointer)null)
    val () = gtk_box_pack_start (hbox, button, GTRUE, GTRUE, (guint)10)
    val () = gtk_widget_show_unref (button)
  } // end of [val]
//
  val () = gtk_widget_show_unref (hbox)
//
  val hsep = gtk_hseparator_new ()
  val () = gtk_box_pack_start (vbox0, hsep, GTRUE, GTRUE, (guint)0)
  val () = gtk_widget_show_unref (hsep)
//
  val hbox = gtk_hbox_new (GFALSE, (gint)0)
  val (fpf_x | x) = (gstring_of_string)"_Quit"
  val button = gtk_button_new_with_mnemonic (x)
  prval () = fpf_x (x)
  val _sid = g_signal_connect_swapped
    (button, (gsignal)"clicked", G_CALLBACK(quitapp), window)
  val () = gtk_box_pack_start (hbox, button, GTRUE, GTRUE, (guint)10)
  val () = gtk_widget_show_unref (button)
  val () = gtk_box_pack_start (vbox0, hbox, GTRUE, GTRUE, (guint)10)
  val () = gtk_widget_show_unref (hbox)
//
  val () = gtk_container_add (window, vbox0)
  val () = gtk_widget_show_unref (vbox0)
//
  val () = gtk_widget_show (window)
  prval () = fpf_window (window)
  val () = gtk_main ()
} // end of [main1]

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

implement main_dummy () = ()

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

%{$
ats_void_type
mainats (
  ats_int_type argc, ats_ptr_type argv
) {
  gtk_init ((int*)&argc, (char***)&argv) ; main1 () ; return ;
} // end of [mainats]
%} // end of [%{$]

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

(* end of [assgn3ex4.dats] *)