Updating: very very minorly

Updating: very very minorly

//
// Game-of-24:
// An example of combining
// ATS2 and Scheme
//
(* ****** ****** *)
//
// Author: Hongwei Xi
// Start time: the last day of August, 2014
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
#define
ATS_DYNLOADNAME
"GameOf24_scm_dynload"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2SCM}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"./GameOf24_scm.sats"
//
(* ****** ****** *)

local

datatype
card_node =
  | CARDint of (int)
  | CARDadd of (card, card)
  | CARDsub of (card, card)
  | CARDmul of (card, card)
  | CARDdiv of (card, card)
// end of [card_node]

where
card = '{
//
card_val= double, card_node= card_node
//
} (* end of [card] *)

assume card_type = card

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

in (* in of [local] *)

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

implement
card_get_val (c) = c.card_val

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

implement
card_make_int (v) = '{
  card_val= int2double (v), card_node= CARDint (v)
} // end of [card_make_int]

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

implement
add_card_card
  (c1, c2) = let
//
val v = c1.card_val + c2.card_val
//
in '{
//
card_val= v, card_node= CARDadd (c1, c2)
//
} end // end of [add_card_card]

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

implement
sub_card_card
  (c1, c2) = let
//
val v = c1.card_val - c2.card_val
//
in '{
//
card_val= v, card_node= CARDsub (c1, c2)
//
} end // end of [sub_card_card]

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

implement
mul_card_card
  (c1, c2) = let
//
val v = c1.card_val * c2.card_val
//
in '{
//
card_val= v, card_node= CARDmul (c1, c2)
//
} end // end of [mul_card_card]

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

implement
div_card_card
  (c1, c2) = let
//
val v = c1.card_val / c2.card_val
//
in '{
//
card_val= v, card_node= CARDdiv (c1, c2)
//
} end // end of [div_card_card]

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

implement
fprint_card
  (out, c0) = let
in
//
case+ c0.card_node of
| CARDint (v) => fprint! (out, "CARDint(", v, ")")
| CARDadd (c1, c2) => fprint! (out, "CARDadd(", c1, ", ", c2, ")")
| CARDsub (c1, c2) => fprint! (out, "CARDsub(", c1, ", ", c2, ")")
| CARDmul (c1, c2) => fprint! (out, "CARDmul(", c1, ", ", c2, ")")
| CARDdiv (c1, c2) => fprint! (out, "CARDdiv(", c1, ", ", c2, ")")
//
end // end of [fprint_card]

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

implement
fpprint_card
  (out, c0) = let
//
overload fprint with fpprint_card of 10
//
in
//
case+ c0.card_node of
| CARDint (v) => fprint! (out, v)
| CARDadd (c1, c2) => fprint! (out, "(", c1, " + ", c2, ")")
| CARDsub (c1, c2) => fprint! (out, "(", c1, " - ", c2, ")")
| CARDmul (c1, c2) => fprint! (out, "(", c1, " * ", c2, ")")
| CARDdiv (c1, c2) => fprint! (out, "(", c1, " / ", c2, ")")
//
end // end of [fpprint_card]

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

end // end of [local]

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

local
//
assume
cardset_type
= List0(card)
//
in (* in-of-local *)
//
implement
cardset_size
  (xs) =
  list_length (xs)
//
implement
cardset_make_list
  (cs) = let
//
typedef res = List0(card)
//
fun loop
(
  res: res, cs: cardlst
) : res =
(
  case+ cs of
  | list_nil () => res
  | list_cons (c, cs) => let
      val res = list_cons (c, res) in loop (res, cs)
    end // end of [list_cons]
) (* end of [loop] *)
//
in
  list_reverse(loop(list_nil(), cs))
end // end of [cardset_make_list]

implement
cardset_get_at
  (cs, i) = let
  val i = g1ofg0(i)
  val () = assertloc(i >= 0)
  val () = assertloc(length(cs) > i)
in
  list_get_at (cs, i)
end // end of [cardset_get_at]

implement
cardset_remove2_add1
  (cs, i, j, c) = cs where
{
//
val i = g1ofg0(i)
val j = g1ofg0(j)
//
val () = assertloc(i >= 0)
val () = assertloc(j >= i+1)
val () = assertloc(length(cs) > j)
//
val $tup(c_j, cs) = list_takeout_at(cs, j)
val $tup(c_i, cs) = list_takeout_at(cs, i)
//
val cs = list_extend (cs, c)
//
} // end of [cardset_remove2_add1]

end // end of [local]

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

local

#define EPSILON 0.1

in (* in-of-local *)

implement
fpprint_cardlst
  (out, cs) = let
//
fun fprone
(
  out: SCMfilr, c: card
) : void = let
  val v = card_get_val (c)
in
  fpprint_card (out, c);
  fprintln! (out, " = ", double2int(v+EPSILON))
end // end of [fprone
//
in
//
case+ cs of
| list_nil () => ()
| list_cons (c, cs) =>
  (
    fprone (out, c); fpprint_cardlst (out, cs)
  ) (* end of [list_cons] *)
//
end // end of [fpprint_cardlst]

end // end of [local]

(* ****** ****** *)
//
#define EPSILON 1E-8
//
fun is0 (v: double): bool = abs(v) < EPSILON
fun isn0 (v: double): bool = abs(v) >= EPSILON
fun is24 (v: double): bool = abs(v - 24.0) < EPSILON
//
(* ****** ****** *)

fun card_isneqz (c: card): bool = isn0(card_get_val(c))

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

extern
fun task_reduce
  (x: cardset, res: List0(cardset)): List0(cardset)
// end of [task_reduce]
extern
fun tasklst_reduce
  (xs: List0(cardset), res: List0(cardset)): List0(cardset)
// end of [tasklst_reduce]

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

implement
task_reduce
  (x, res) = let
//
typedef res = List0(cardset)
//
fun auxdo
(
  x: cardset, i: int, j: int, res: res
) : res = res where
{
//
val ci = x[i] and cj = x[j]
//
typedef cs = cardset
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci+cj), res)
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci-cj), res)
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, cj-ci), res)
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci*cj), res)
//
val res =
(
if card_isneqz (cj)
  then list_cons{cs}(cardset_remove2_add1 (x, i, j, ci/cj), res)
  else res
) : List0(cardset)
//
val res =
(
if card_isneqz (ci)
  then list_cons{cs}(cardset_remove2_add1 (x, i, j, cj/ci), res)
  else res
) : List0(cardset)
//
} (* end of [auxdo] *)
//
fnx loop1
(
  x: cardset
, n:int, i: int, res: res, _: int
) : res =
(
//
if i+1 < n
  then loop2 (x, n, i, i+1, res)
  else res
//
) (* end of [loop1] *)
//
and loop2
(
  x: cardset
, n:int, i: int, j: int, res: res
) : res = let
in
//
if
j < n
then let
//
val res =
  auxdo(x, i, j, res)
//
in
  loop2(x, n, i, j+1, res)
end // end of [then]
else loop1(x, n, i+1, res, 0)
//
end // end of [loop2]
//
in
  loop1(x, cardset_size(x), 0, res, 0)
end // end of [task_reduce]

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

implement
tasklst_reduce
  (xs, res) = let
in
//
case+ xs of
| list_cons
    (x, xs) => let
    val res = task_reduce (x, res)
  in
    tasklst_reduce (xs, res)
  end // end of [tasklst_reduce]
| list_nil () => res
//
end // end of [tasklst_reduce]

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

implement
play24 (n1, n2, n3, n4) = let
//
val c1 = card_make_int (n1)
val c2 = card_make_int (n2)
val c3 = card_make_int (n3)
val c4 = card_make_int (n4)
//
fun f (i:int):<cloref1> card =
(
case+ i of
| 0 => c1 | 1 => c2 | 2 => c3 | _ => c4
)
//
#define :: cons
//
val cs =
(
  c1 :: c2 :: c3 :: c4 :: nil()
)
//
val x0 = cardset_make_list (cs)
//
val xs1 = list_cons{cardset}(x0, list_nil)
//
val res = list_nil()
val res = tasklst_reduce (xs1, res)
val xs2 = list_reverse (res)
//
val res = list_nil()
val res = tasklst_reduce (xs2, res)
val xs3 = list_reverse (res)
//
val res = list_nil()
val res = tasklst_reduce (xs3, res)
val xs4 = list_reverse (res)
//
val res_sol =
  filter (xs4, list_nil) where
{
  fun
  filter
  (
    xs: List0(cardset), res: cardlst
  ) : cardlst =
    case+ xs of
    | list_nil () => res
    | list_cons (x, xs) => let
        val c = x[0]
        val v = card_get_val (c)
        val res =
        (
          if is24(v) then list_cons (c, res) else res
        ) : cardlst // end of [val]
      in
        filter (xs, res)
      end // end of [list_cons]
} (* end of [where] *) // end of [val]
//
in
  list_reverse (res_sol)
end // end of [play24]

(* ****** ****** *)
//
extern
fun
main0_scm
(
  (*void*)
) : void = "mac#GameOf24_scm_main0"
//
implement
main0_scm() =
{
//
val
out =
stdout_get()
//
val n1 = 3
and n2 = 3
and n3 = 8
and n4 = 8
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 4
and n2 = 4
and n3 = 10
and n4 = 10
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 5
and n2 = 5
and n3 = 7
and n4 = 11
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 3
and n2 = 5
and n3 = 7
and n4 = 13
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
} (* end of [main0_scm] *)
//
(* ****** ****** *)

%{$
;;
(GameOf24_scm_main0)
;;
%} // end of [%{$]

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

(* end of [GameOf24_scm.dats] *)

//
// Game-of-24:
// An example of combining
// ATS2 and Scheme
//
(* ****** ****** *)
//
// Author: Hongwei Xi
// Start time: the last day of August, 2014
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
#define
ATS_DYNLOADNAME
"GameOf24_scm_dynload"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2SCM}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"./GameOf24_scm.sats"
//
(* ****** ****** *)

local

datatype
card_node =
  | CARDint of (int)
  | CARDadd of (card, card)
  | CARDsub of (card, card)
  | CARDmul of (card, card)
  | CARDdiv of (card, card)
// end of [card_node]

where
card = '{
//
card_val= double, card_node= card_node
//
} (* end of [card] *)

assume card_type = card

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

in (* in of [local] *)

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

implement
card_get_val (c) = c.card_val

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

implement
card_make_int (v) = '{
  card_val= int2double (v), card_node= CARDint (v)
} // end of [card_make_int]

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

implement
add_card_card
  (c1, c2) = let
//
val v = c1.card_val + c2.card_val
//
in '{
//
card_val= v, card_node= CARDadd (c1, c2)
//
} end // end of [add_card_card]

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

implement
sub_card_card
  (c1, c2) = let
//
val v = c1.card_val - c2.card_val
//
in '{
//
card_val= v, card_node= CARDsub (c1, c2)
//
} end // end of [sub_card_card]

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

implement
mul_card_card
  (c1, c2) = let
//
val v = c1.card_val * c2.card_val
//
in '{
//
card_val= v, card_node= CARDmul (c1, c2)
//
} end // end of [mul_card_card]

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

implement
div_card_card
  (c1, c2) = let
//
val v = c1.card_val / c2.card_val
//
in '{
//
card_val= v, card_node= CARDdiv (c1, c2)
//
} end // end of [div_card_card]

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

implement
fprint_card
  (out, c0) = let
in
//
case+ c0.card_node of
| CARDint (v) => fprint! (out, "CARDint(", v, ")")
| CARDadd (c1, c2) => fprint! (out, "CARDadd(", c1, ", ", c2, ")")
| CARDsub (c1, c2) => fprint! (out, "CARDsub(", c1, ", ", c2, ")")
| CARDmul (c1, c2) => fprint! (out, "CARDmul(", c1, ", ", c2, ")")
| CARDdiv (c1, c2) => fprint! (out, "CARDdiv(", c1, ", ", c2, ")")
//
end // end of [fprint_card]

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

implement
fpprint_card
  (out, c0) = let
//
overload fprint with fpprint_card of 10
//
in
//
case+ c0.card_node of
| CARDint (v) => fprint! (out, v)
| CARDadd (c1, c2) => fprint! (out, "(", c1, " + ", c2, ")")
| CARDsub (c1, c2) => fprint! (out, "(", c1, " - ", c2, ")")
| CARDmul (c1, c2) => fprint! (out, "(", c1, " * ", c2, ")")
| CARDdiv (c1, c2) => fprint! (out, "(", c1, " / ", c2, ")")
//
end // end of [fpprint_card]

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

end // end of [local]

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

local
//
assume
cardset_type
= List0(card)
//
in (* in-of-local *)
//
implement
cardset_size
  (xs) =
  list_length (xs)
//
implement
cardset_make_list
  (cs) = let
//
typedef res = List0(card)
//
fun loop
(
  res: res, cs: cardlst
) : res =
(
  case+ cs of
  | list_nil () => res
  | list_cons (c, cs) => let
      val res = list_cons (c, res) in loop (res, cs)
    end // end of [list_cons]
) (* end of [loop] *)
//
in
  list_reverse(loop(list_nil(), cs))
end // end of [cardset_make_list]

implement
cardset_get_at
  (cs, i) = let
  val i = g1ofg0(i)
  val () = assertloc(i >= 0)
  val () = assertloc(length(cs) > i)
in
  list_get_at (cs, i)
end // end of [cardset_get_at]

implement
cardset_remove2_add1
  (cs, i, j, c) = cs where
{
//
val i = g1ofg0(i)
val j = g1ofg0(j)
//
val () = assertloc(i >= 0)
val () = assertloc(j >= i+1)
val () = assertloc(length(cs) > j)
//
val $tup(c_j, cs) = list_takeout_at(cs, j)
val $tup(c_i, cs) = list_takeout_at(cs, i)
//
val cs = list_extend (cs, c)
//
} // end of [cardset_remove2_add1]

end // end of [local]

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

local

#define EPSILON 0.1

in (* in-of-local *)

implement
fpprint_cardlst
  (out, cs) = let
//
fun fprone
(
  out: SCMfilr, c: card
) : void = let
  val v = card_get_val (c)
in
  fpprint_card (out, c);
  fprintln! (out, " = ", double2int(v+EPSILON))
end // end of [fprone
//
in
//
case+ cs of
| list_nil () => ()
| list_cons (c, cs) =>
  (
    fprone (out, c); fpprint_cardlst (out, cs)
  ) (* end of [list_cons] *)
//
end // end of [fpprint_cardlst]

end // end of [local]

(* ****** ****** *)
//
#define EPSILON 1E-8
//
fun is0 (v: double): bool = abs(v) < EPSILON
fun isn0 (v: double): bool = abs(v) >= EPSILON
fun is24 (v: double): bool = abs(v - 24.0) < EPSILON
//
(* ****** ****** *)

fun card_isneqz (c: card): bool = isn0(card_get_val(c))

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

extern
fun task_reduce
  (x: cardset, res: List0(cardset)): List0(cardset)
// end of [task_reduce]
extern
fun tasklst_reduce
  (xs: List0(cardset), res: List0(cardset)): List0(cardset)
// end of [tasklst_reduce]

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

implement
task_reduce
  (x, res) = let
//
typedef res = List0(cardset)
//
fun auxdo
(
  x: cardset, i: int, j: int, res: res
) : res = res where
{
//
val ci = x[i] and cj = x[j]
//
typedef cs = cardset
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci+cj), res)
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci-cj), res)
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, cj-ci), res)
//
val res =
  list_cons{cs}(cardset_remove2_add1 (x, i, j, ci*cj), res)
//
val res =
(
if card_isneqz (cj)
  then list_cons{cs}(cardset_remove2_add1 (x, i, j, ci/cj), res)
  else res
) : List0(cardset)
//
val res =
(
if card_isneqz (ci)
  then list_cons{cs}(cardset_remove2_add1 (x, i, j, cj/ci), res)
  else res
) : List0(cardset)
//
} (* end of [auxdo] *)
//
fnx loop1
(
  x: cardset, n:int, i: int, res: res
) : res =
(
//
if i+1 < n
  then loop2 (x, n, i, i+1, res) else res
//
) (* end of [loop1] *)
//
and loop2
(
  x: cardset, n:int, i: int, j: int, res: res
) : res = let
in
//
if
j < n
then let
//
val res =
  auxdo (x, i, j, res)
//
in
  loop2 (x, n, i, j+1, res)
end // end of [then]
else loop1 (x, n, i+1, res)
//
end // end of [loop2]
//
in
  loop1 (x, cardset_size (x), 0, res)
end // end of [task_reduce]

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

implement
tasklst_reduce
  (xs, res) = let
in
//
case+ xs of
| list_cons
    (x, xs) => let
    val res = task_reduce (x, res)
  in
    tasklst_reduce (xs, res)
  end // end of [tasklst_reduce]
| list_nil () => res
//
end // end of [tasklst_reduce]

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

implement
play24 (n1, n2, n3, n4) = let
//
val c1 = card_make_int (n1)
val c2 = card_make_int (n2)
val c3 = card_make_int (n3)
val c4 = card_make_int (n4)
//
fun f (i:int):<cloref1> card =
(
case+ i of
| 0 => c1 | 1 => c2 | 2 => c3 | _ => c4
)
//
#define :: cons
//
val cs =
(
  c1 :: c2 :: c3 :: c4 :: nil()
)
//
val x0 = cardset_make_list (cs)
//
val xs1 = list_cons{cardset}(x0, list_nil)
//
val res = list_nil()
val res = tasklst_reduce (xs1, res)
val xs2 = list_reverse (res)
//
val res = list_nil()
val res = tasklst_reduce (xs2, res)
val xs3 = list_reverse (res)
//
val res = list_nil()
val res = tasklst_reduce (xs3, res)
val xs4 = list_reverse (res)
//
val res_sol =
  filter (xs4, list_nil) where
{
  fun
  filter
  (
    xs: List0(cardset), res: cardlst
  ) : cardlst =
    case+ xs of
    | list_nil () => res
    | list_cons (x, xs) => let
        val c = x[0]
        val v = card_get_val (c)
        val res =
        (
          if is24(v) then list_cons (c, res) else res
        ) : cardlst // end of [val]
      in
        filter (xs, res)
      end // end of [list_cons]
} (* end of [where] *) // end of [val]
//
in
  list_reverse (res_sol)
end // end of [play24]

(* ****** ****** *)
//
extern
fun
main0_scm
(
  (*void*)
) : void = "mac#GameOf24_scm_main0"
//
implement
main0_scm() =
{
//
val
out =
stdout_get()
//
val n1 = 3
and n2 = 3
and n3 = 8
and n4 = 8
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 4
and n2 = 4
and n3 = 10
and n4 = 10
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 5
and n2 = 5
and n3 = 7
and n4 = 11
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
val n1 = 3
and n2 = 5
and n3 = 7
and n4 = 13
val res = play24 (n1, n2, n3, n4)
val () = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
val () = fpprint_cardlst (out, res)
//
} (* end of [main0_scm] *)
//
(* ****** ****** *)

%{$
;;
(GameOf24_scm_main0)
;;
%} // end of [%{$]

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

(* end of [GameOf24_scm.dats] *)


Updating: very very minorly

Updating: very very minorly

(*
** libatscc-common
*)

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

(*
staload "./../basics.sats"
staload "./../SATS/intrange.sats"
*)

(* ****** ****** *)
//
implement
int_repeat_lazy
  (n0, f) =
  int_repeat_cloref(n0, lazy2cloref(f))
//
(* ****** ****** *)

implement
int_repeat_cloref
  (n0, fwork) = let
//
fun
loop
(
  n: int, fwork: cfun0(void)
) : void = (
//
if n > 0
  then (fwork(); loop(n-1, fwork)) else ()
//
) (* end of [loop] *)
//
in
  loop (n0, fwork)
end // end of [int_repeat_cloref]

(* ****** ****** *)
//
implement
int_exists_cloref
  (n0, pred) =
(
  intrange_exists_cloref(0, n0, pred)
)
implement
int_forall_cloref
  (n0, pred) =
(
  intrange_forall_cloref (0, n0, pred)
)
//
implement
int_foreach_cloref
  (n0, pred) =
(
  intrange_foreach_cloref (0, n0, pred)
)
//
(* ****** ****** *)
//
implement
int_exists_method
  (n0) = lam(f) => int_exists_cloref(n0, f)
implement
int_forall_method
  (n0) = lam(f) => int_forall_cloref(n0, f)
//
implement
int_foreach_method
  (n0) = lam(f) => int_foreach_cloref(n0, f)
//
(* ****** ****** *)
//
implement
int_foldleft_cloref
  {res}
  (n0, ini, fopr) =
(
  intrange_foldleft_cloref{res}(0, n0, ini, fopr)
)
//
implement
int_foldleft_method
  {res}(n0, ini) =
(
lam(fopr) => int_foldleft_cloref{res}(n0, ini, fopr)
) (* int_foldleft_method *)
//
(* ****** ****** *)
//
implement
int_list_map_cloref
  {a}{n}(n0, fopr) = let
//
fun
aux
{ i:nat
| i <= n
} (i: int(i)): list(a, n-i) = (
//
if
(i < n0)
then list_cons(fopr(i), aux(i+1))
else list_nil()
// end of [if]
)
//
in
  aux(0)
end // end of [int_list_map_cloref]
//
implement
int_list_map_method
  {a}{n}(n0, tres) =
(
//
lam(fopr) =>
  int_list_map_cloref{a}{n}(n0, fopr)
//
)
//
(* ****** ****** *)
//
implement
int_stream_map_cloref
  {a}(n0, fopr) = let
//
fun
aux
{i:nat}
(
  i: int(i)
) : stream(a) = $delay(
//
if
(i < n0)
then (
  stream_cons(fopr(i), aux(i+1))
) else stream_nil()
// end of [if]
)
//
in
  aux(0)
end // end of [aux]
//
implement
int_stream_map_method
  {a}(n0, tres) =
(
//
lam(fopr) =>
  int_stream_map_cloref{a}(n0, fopr)
//
) (* end of [int_stream_map_method] *)
//
(* ****** ****** *)
//
implement
int_stream_vt_map_cloref
  {a}(n0, fopr) = let
//
fun
aux
{i:nat}
(
  i: int(i)
) : stream_vt(a) = $ldelay
(
//
if
(i < n0)
then (
  stream_vt_cons(fopr(i), aux(i+1))
) else stream_vt_nil((*void*))
// end of [if]
) : stream_vt_con(a) // [aux]
//
in
  aux(0)
end // end of [aux]
//
implement
int_stream_vt_map_method
  {a}(n0, tres) =
(
//
llam(fopr) =>
  int_stream_vt_map_cloref{a}(n0, fopr)
//
) (* end of [int_stream_vt_map_method] *)
//
(* ****** ****** *)
//
implement
int2_exists_cloref
  (n1, n2, pred) =
(
  intrange2_exists_cloref (0, n1, 0, n2, pred)
)
implement
int2_forall_cloref
  (n1, n2, pred) =
(
  intrange2_forall_cloref (0, n1, 0, n2, pred)
)
//
implement
int2_foreach_cloref
  (n1, n2, pred) =
(
  intrange2_foreach_cloref (0, n1, 0, n2, pred)
)
//
(* ****** ****** *)

implement
intrange_exists_cloref
  (l, r, pred) = let
//
fun
loop
(
  l: int, r: int, pred: cfun1(int, bool)
) : bool = (
//
if l < r
  then (
    if pred(l) then true else loop (l+1, r, pred)
  ) else false
//
) (* end of [loop] *)
//
in
  loop (l, r, pred)
end // end of [intrange_exists_cloref]
//
implement
intrange_exists_method(lr) =
(
lam(pred) =>
  intrange_exists_cloref(lr.0, lr.1, pred)
) (* intrange_exists_method *)
//
(* ****** ****** *)

implement
intrange_forall_cloref
  (l, r, pred) = let
//
fun
loop
(
  l: int, r: int, pred: cfun1(int, bool)
) : bool = (
//
if l < r
  then (
    if pred(l) then loop(l+1, r, pred) else false
  ) else true
//
) (* end of [loop] *)
//
in
  loop (l, r, pred)
end // end of [intrange_forall_cloref]
//
implement
intrange_forall_method(lr) =
(
lam(pred) =>
  intrange_forall_cloref(lr.0, lr.1, pred)
) (* intrange_forall_method *)
//
(* ****** ****** *)

implement
intrange_foreach_cloref
  (l, r, fwork) = let
//
fun
loop (
  l: int, r: int, fwork: cfun1(int, void)
) : void = (
//
if (l < r)
then let
  val () = fwork(l) in loop(l+1, r, fwork)
end // end of [then]
else ((*void*)) // else
//
) (* end of [loop] *)
//
in
  loop(l, r, fwork)
end // end of [intrange_foreach_cloref]
//
implement
intrange_foreach_method(lr) =
(
lam(fwork) =>
  intrange_foreach_cloref(lr.0, lr.1, fwork)
) (* intrange_foreach_method *)
//
(* ****** ****** *)

implement
intrange_foldleft_cloref
  {res}
  (l, r, ini, fopr) = let
//
fun
loop
(
  l: int, r: int
, ini: res, f: cfun2(res, int, res)
) : res = (
//
if l < r then loop(l+1, r, f(ini, l), fopr) else ini
//
) (* end of [loop] *)
//
in
  loop(l, r, ini, fopr)
end // end of [intrange_foldleft_cloref]

(* ****** ****** *)
//
implement
intrange_foldleft_method
  {res}
  ( $tup(l, r), ini ) =
(
  lam(fopr) =>
    intrange_foldleft_cloref{res}(l, r, ini, fopr)
  // end of [lam]
)
//
(* ****** ****** *)

implement
intrange2_exists_cloref
  (l1_, r1_, l2_, r2_, pred) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, f: cfun2 (int, int, bool)
) : bool = (
//
if l1 < r1
  then loop2(l1, r1, l2, r2, pred) else false
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if (
l2 < r2
) then (
//
if (
pred(l1, l2)
) then true
  else loop2(l1, r1, l2+1, r2, pred)
// end of [if]
) else loop1(l1+1, r1, l2_, r2_, pred)
//
) (* end of [loop2] *)
//
in
  loop1(l1_, r1_, l2_, r2_, pred)
end // end of [intrange2_exists_cloref]

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

implement
intrange2_forall_cloref
  (l1_, r1_, l2_, r2_, pred) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if l1 < r1
  then loop2 (l1, r1, l2, r2, pred) else true
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if (
l2 < r2
) then
(
if (
pred(l1, l2)
) then loop2(l1, r1, l2+1, r2, pred)
  else false
// end of [if]
) else loop1(l1+1, r1, l2_, r2_, pred)
//
) (* end of [loop2] *)
//
in
  loop1 (l1_, r1_, l2_, r2_, pred)
end // end of [intrange2_forall_cloref]

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

implement
intrange2_foreach_cloref
  (l1_, r1_, l2_, r2_, fwork) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, fwork: cfun2 (int, int, void)
) : void = (
//
if l1 < r1
  then loop2(l1, r1, l2, r2, fwork)
  else ((*void*))
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, fwork: cfun2 (int, int, void)
) : void = (
//
if (
l2 < r2
) then (
//
fwork(l1, l2);
loop2(l1, r1, l2+1, r2, fwork)
//
) else (
  loop1(succ(l1), r1, l2_, r2_, fwork)
) (* end of [else] *)
//
) (* end of [loop2] *)
//
in
  loop1 (l1_, r1_, l2_, r2_, fwork)
end // end of [intrange2_foreach_cloref]

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

(* end of [intrange.dats] *)

(*
** libatscc-common
*)

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

(*
staload "./../basics.sats"
staload "./../SATS/intrange.sats"
*)

(* ****** ****** *)
//
implement
int_repeat_lazy
  (n0, f) =
  int_repeat_cloref(n0, lazy2cloref(f))
//
(* ****** ****** *)

implement
int_repeat_cloref
  (n0, fwork) = let
//
fun
loop
(
  n: int, fwork: cfun0(void)
) : void = (
//
if n > 0
  then (fwork(); loop(n-1, fwork)) else ()
//
) (* end of [loop] *)
//
in
  loop (n0, fwork)
end // end of [int_repeat_cloref]

(* ****** ****** *)
//
implement
int_exists_cloref
  (n0, pred) =
(
  intrange_exists_cloref(0, n0, pred)
)
implement
int_forall_cloref
  (n0, pred) =
(
  intrange_forall_cloref (0, n0, pred)
)
//
implement
int_foreach_cloref
  (n0, pred) =
(
  intrange_foreach_cloref (0, n0, pred)
)
//
(* ****** ****** *)
//
implement
int_exists_method
  (n0) = lam(f) => int_exists_cloref(n0, f)
implement
int_forall_method
  (n0) = lam(f) => int_forall_cloref(n0, f)
//
implement
int_foreach_method
  (n0) = lam(f) => int_foreach_cloref(n0, f)
//
(* ****** ****** *)
//
implement
int_foldleft_cloref
  {res}
  (n0, ini, fopr) =
(
  intrange_foldleft_cloref{res}(0, n0, ini, fopr)
)
//
implement
int_foldleft_method
  {res}(n0, ini) =
(
lam(fopr) => int_foldleft_cloref{res}(n0, ini, fopr)
) (* int_foldleft_method *)
//
(* ****** ****** *)
//
implement
int_list_map_cloref
  {a}{n}(n0, fopr) = let
//
fun
aux
{ i:nat
| i <= n
} (i: int(i)): list(a, n-i) = (
//
if
(i < n0)
then list_cons(fopr(i), aux(i+1))
else list_nil()
// end of [if]
)
//
in
  aux(0)
end // end of [int_list_map_cloref]
//
implement
int_list_map_method
  {a}{n}(n0, tres) =
(
//
lam(fopr) =>
  int_list_map_cloref{a}{n}(n0, fopr)
//
)
//
(* ****** ****** *)
//
implement
int_stream_map_cloref
  {a}(n0, fopr) = let
//
fun
aux
{i:nat}
(
  i: int(i)
) : stream(a) = $delay(
//
if
(i < n0)
then (
  stream_cons(fopr(i), aux(i+1))
) else stream_nil()
// end of [if]
)
//
in
  aux(0)
end // end of [int_list_map_cloref]
//
implement
int_stream_map_method
  {a}(n0, tres) =
(
//
lam(fopr) =>
  int_stream_map_cloref{a}(n0, fopr)
//
) (* end of [int_stream_map_method] *)
//
(* ****** ****** *)
//
implement
int_stream_vt_map_cloref
  {a}(n0, fopr) = let
//
fun
aux
{i:nat}
(
  i: int(i)
) : stream_vt(a) = $ldelay
(
//
if
(i < n0)
then (
  stream_vt_cons(fopr(i), aux(i+1))
) else stream_vt_nil((*void*))
// end of [if]
) : stream_vt_con(a) // [aux]
//
in
  aux(0)
end // end of [int_list_map_cloref]
//
implement
int_stream_vt_map_method
  {a}(n0, tres) =
(
//
llam(fopr) =>
  int_stream_vt_map_cloref{a}(n0, fopr)
//
) (* end of [int_stream_vt_map_method] *)
//
(* ****** ****** *)
//
implement
int2_exists_cloref
  (n1, n2, pred) =
(
  intrange2_exists_cloref (0, n1, 0, n2, pred)
)
implement
int2_forall_cloref
  (n1, n2, pred) =
(
  intrange2_forall_cloref (0, n1, 0, n2, pred)
)
//
implement
int2_foreach_cloref
  (n1, n2, pred) =
(
  intrange2_foreach_cloref (0, n1, 0, n2, pred)
)
//
(* ****** ****** *)

implement
intrange_exists_cloref
  (l, r, pred) = let
//
fun
loop
(
  l: int, r: int, pred: cfun1(int, bool)
) : bool = (
//
if l < r
  then (
    if pred(l) then true else loop (l+1, r, pred)
  ) else false
//
) (* end of [loop] *)
//
in
  loop (l, r, pred)
end // end of [intrange_exists_cloref]
//
implement
intrange_exists_method(lr) =
(
lam(pred) =>
  intrange_exists_cloref(lr.0, lr.1, pred)
) (* intrange_exists_method *)
//
(* ****** ****** *)

implement
intrange_forall_cloref
  (l, r, pred) = let
//
fun
loop
(
  l: int, r: int, pred: cfun1(int, bool)
) : bool = (
//
if l < r
  then (
    if pred(l) then loop(l+1, r, pred) else false
  ) else true
//
) (* end of [loop] *)
//
in
  loop (l, r, pred)
end // end of [intrange_forall_cloref]
//
implement
intrange_forall_method(lr) =
(
lam(pred) =>
  intrange_forall_cloref(lr.0, lr.1, pred)
) (* intrange_forall_method *)
//
(* ****** ****** *)

implement
intrange_foreach_cloref
  (l, r, fwork) = let
//
fun
loop (
  l: int, r: int, fwork: cfun1(int, void)
) : void = (
//
if (l < r)
then let
  val () = fwork(l) in loop(l+1, r, fwork)
end // end of [then]
else ((*void*)) // else
//
) (* end of [loop] *)
//
in
  loop(l, r, fwork)
end // end of [intrange_foreach_cloref]
//
implement
intrange_foreach_method(lr) =
(
lam(fwork) =>
  intrange_foreach_cloref(lr.0, lr.1, fwork)
) (* intrange_foreach_method *)
//
(* ****** ****** *)

implement
intrange_foldleft_cloref
  {res}
  (l, r, ini, fopr) = let
//
fun
loop
(
  l: int, r: int
, ini: res, f: cfun2(res, int, res)
) : res = (
//
if l < r then loop(l+1, r, f(ini, l), fopr) else ini
//
) (* end of [loop] *)
//
in
  loop(l, r, ini, fopr)
end // end of [intrange_foldleft_cloref]

(* ****** ****** *)
//
implement
intrange_foldleft_method
  {res}
  ( $tup(l, r), ini ) =
(
  lam(fopr) =>
    intrange_foldleft_cloref{res}(l, r, ini, fopr)
  // end of [lam]
)
//
(* ****** ****** *)

implement
intrange2_exists_cloref
  (l1_, r1_, l2_, r2_, pred) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, f: cfun2 (int, int, bool)
) : bool = (
//
if l1 < r1
  then loop2(l1, r1, l2, r2, pred) else false
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if (
l2 < r2
) then (
//
if (
pred(l1, l2)
) then true
  else loop2(l1, r1, l2+1, r2, pred)
// end of [if]
) else loop1(l1+1, r1, l2_, r2_, pred)
//
) (* end of [loop2] *)
//
in
  loop1(l1_, r1_, l2_, r2_, pred)
end // end of [intrange2_exists_cloref]

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

implement
intrange2_forall_cloref
  (l1_, r1_, l2_, r2_, pred) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if l1 < r1
  then loop2 (l1, r1, l2, r2, pred) else true
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, pred: cfun2 (int, int, bool)
) : bool = (
//
if (
l2 < r2
) then
(
if (
pred(l1, l2)
) then loop2(l1, r1, l2+1, r2, pred)
  else false
// end of [if]
) else loop1(l1+1, r1, l2_, r2_, pred)
//
) (* end of [loop2] *)
//
in
  loop1 (l1_, r1_, l2_, r2_, pred)
end // end of [intrange2_forall_cloref]

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

implement
intrange2_foreach_cloref
  (l1_, r1_, l2_, r2_, fwork) = let
//
// HX-2016-07-26:
// loop1 and loop2 need to have
// the same number of arguments
// in order to support atscc2clj
//
fnx
loop1
(
  l1: int, r1: int
, l2: int, r2: int
, fwork: cfun2 (int, int, void)
) : void = (
//
if l1 < r1
  then loop2(l1, r1, l2, r2, fwork)
  else ((*void*))
//
) (* end of [loop1] *)
//
and
loop2
(
  l1: int, r1: int
, l2: int, r2: int
, fwork: cfun2 (int, int, void)
) : void = (
//
if (
l2 < r2
) then (
//
fwork(l1, l2);
loop2(l1, r1, l2+1, r2, fwork)
//
) else (
  loop1(succ(l1), r1, l2_, r2_, fwork)
) (* end of [else] *)
//
) (* end of [loop2] *)
//
in
  loop1 (l1_, r1_, l2_, r2_, fwork)
end // end of [intrange2_foreach_cloref]

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

(* end of [intrange.dats] *)


Updating: improving JSclock

Updating: improving JSclock

(*
//
An example of atscc2js: Wall Clock
//
Author: Hongwei Xi
Authoremail: hwxi AT cs DOT bu DOT edu
Start Time: September, 2014
//
This example is essentially translated from
the JS code at the following site:
//
http://www.neilwallis.com/projects/html5/clock/
//
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)

macdef PI = JSmath_PI
macdef sin = JSmath_sin and cos = JSmath_cos

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

fun
draw_mark
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx = 110 * sa
val sy = 110 * ca
val ex = 120 * sa
val ey = 120 * ca
//
val () = ctx.lineWidth(2)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark] *)

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

fun
draw_mark2
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx =  95 * sa
val sy = ~95 * ca
val ex =  120 * sa
val ey = ~120 * ca
val nx =  80 * sa
val ny = ~80 * ca
//
val () = ctx.fillText(toString(i/5), nx, ny)
//
val () = ctx.lineWidth(8)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark2] *)

(* ****** ****** *)
//
extern
fun
draw_clock
(
  ctx: canvas2d
, nhr: double, nmin: double, nsec: double
) : void = "mac#" // end-of-fun
//
implement
draw_clock
(
  ctx, nhr, nmin, nsec
) = () where {
//
val () = ctx.clearRect(0.0, 0.0, 300.0, 300.0)
//
// Define gradients for 3D-shadow effect
//
val g1 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g1.addColorStop(0.0, "#D83040")
val () = g1.addColorStop(1.0, "#801020")
//
val g2 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g2.addColorStop(0.0, "#801020")
val () = g2.addColorStop(1.0, "#D83040")
//
val () = ctx.font("bold 20px arial")
val () = ctx.textAlign("center")
val () = ctx.textBaseline("middle")
val () = ctx.lineWidth(1)
//
val () = ctx.strokeStyle_gradient(g1)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 138.0, 0.0, 2*PI, true)
val () = ctx.closePath()
val () = ctx.shadowBlur(6)
val () = ctx.shadowOffsetX(4)
val () = ctx.shadowOffsetY(4)
val () = ctx.shadowColor("rgba(0,0,0,0.6)")
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle_gradient(g2)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 129.0, 0.0, 2*PI, true);
val () = ctx.closePath()
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle("#222")
//
val pf = ctx.save()
//
val () = ctx.translate(150.0, 150.0)
//
val () = let
//
fun loop
(
  ctx: canvas2d, i: int
) : void =
(
if
i <= 60
then let
  val () =
  (
    if i % 5 != 0
      then draw_mark (ctx, i) else draw_mark2 (ctx, i)
    // end of [if]
  ) : void // end of [val]
in
  loop (ctx, i+1)
end // end of [then]
else () // end of [else]
) (* end of [loop] *)
//
in
  loop (ctx, 1)
end // end of [val]
//
val ampm =
  (if (nhr < 12.0) then "AM" else "PM"): string
//
val () = ctx.strokeStyle("#000")
val () = ctx.lineWidth(1)
val () = ctx.strokeRect(21.0, ~14.0, 44.0, 27.0)
val () = ctx.fillText(ampm, 43.0, 0.0)
val () = ctx.lineWidth(6)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nhr*PI/6)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 10.0)
  val () = ctx.lineTo(0.0, ~60.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nmin*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.lineWidth (3)
val () = ctx.strokeStyle("#E33")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nsec*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.fillStyle("#000")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.beginPath()
  val () = ctx.arc(0.0, 0.0, 6.5, 0.0, 2*PI, true)
  val () = ctx.closePath()
  val () = ctx.fill()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.restore (pf.0 | (*none*))
//
} (* end of [where] *) // [draw_clock]
//
(* ****** ****** *)

%{$
//
var
canvas =
document.getElementById("Patsoptaas-Evaluate-Canvas");
var context = canvas.getContext( '2d' );
//
var w = canvas.w
var h = canvas.h
var xc = w / 2
var yc = h / 2
var wh = Math.min (w, h)
var alpha = wh / 300
//
function
draw2_clock()
{
var date = new Date() ;
var secs = date.getSeconds()
var mins = date.getMinutes()
var mins = mins + secs / 60.0
var hours = date.getHours()
var hours = hours + mins / 60.0
//
context.save();
context.translate(xc-wh/2, yc-wh/2);
context.scale (alpha, alpha);
draw_clock(context, hours, mins, secs);
context.restore();
//
setTimeout(draw2_clock, 500);
//
return;
//
} // end of [draw2_clock]
//
jQuery(document).ready(function(){draw2_clock();});
//
%} // end of [%{$]

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

(* end of [myclock1-2.dats] *)

(*
//
An example of atscc2js: Wall Clock
//
Author: Hongwei Xi
Authoremail: hwxi AT cs DOT bu DOT edu
Start Time: September, 2014
//
This example is essentially translated from
the JS code at the following site:
//
http://www.neilwallis.com/projects/html5/clock/
//
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/HTML/canvas-2d/canvas2d.sats"
//
(* ****** ****** *)

macdef PI = JSmath_PI
macdef sin = JSmath_sin and cos = JSmath_cos

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

fun
draw_mark
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx = 110 * sa
val sy = 110 * ca
val ex = 120 * sa
val ey = 120 * ca
//
val () = ctx.lineWidth(2)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark] *)

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

fun
draw_mark2
(
  ctx: canvas2d, i: int
) : void = {
//
val a = PI/30*i
val sa = sin(a)
val ca = cos(a)
val sx =  95 * sa
val sy = ~95 * ca
val ex =  120 * sa
val ey = ~120 * ca
val nx =  80 * sa
val ny = ~80 * ca
//
val () = ctx.fillText(toString(i/5), nx, ny)
//
val () = ctx.lineWidth(8)
//
val () = ctx.beginPath()
val () = ctx.moveTo(sx, sy)
val () = ctx.lineTo(ex, ey)
val () = ctx.closePath()
//
val () = ctx.stroke()
//
} (* end of [draw_mark2] *)

(* ****** ****** *)
//
extern
fun
draw_clock
(
  ctx: canvas2d
, nhr: double, nmin: double, nsec: double
) : void = "mac#" // end-of-fun
//
implement
draw_clock
(
  ctx, nhr, nmin, nsec
) = () where {
//
val () = ctx.clearRect(0.0, 0.0, 300.0, 300.0)
//
// Define gradients for 3D-shadow effect
//
val g1 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g1.addColorStop(0.0, "#D83040")
val () = g1.addColorStop(1.0, "#801020")
//
val g2 = ctx.createLinearGradient(0.0, 0.0, 300.0, 300.0)
val () = g2.addColorStop(0.0, "#801020")
val () = g2.addColorStop(1.0, "#D83040")
//
val () = ctx.font("bold 20px arial")
val () = ctx.textAlign("center")
val () = ctx.textBaseline("middle")
val () = ctx.lineWidth(1)
//
val () = ctx.strokeStyle_gradient(g1)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 138.0, 0.0, 2*PI, true)
val () = ctx.closePath()
val () = ctx.shadowBlur(6)
val () = ctx.shadowOffsetX(4)
val () = ctx.shadowOffsetY(4)
val () = ctx.shadowColor("rgba(0,0,0,0.6)")
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle_gradient(g2)
val () = ctx.lineWidth(10)
//
val pf = ctx.save()
val () = ctx.beginPath()
val () = ctx.arc(150.0, 150.0, 129.0, 0.0, 2*PI, true);
val () = ctx.closePath()
val () = ctx.stroke()
val () = ctx.restore(pf.0 | (*none*))
//
val () = ctx.strokeStyle("#222")
//
val pf = ctx.save()
//
val () = ctx.translate(150.0, 150.0)
//
val () = let
//
fun loop
(
  ctx: canvas2d, i: int
) : void =
(
if
i <= 60
then let
  val () =
  (
    if i % 5 != 0
      then draw_mark (ctx, i) else draw_mark2 (ctx, i)
    // end of [if]
  ) : void // end of [val]
in
  loop (ctx, i+1)
end // end of [then]
else () // end of [else]
) (* end of [loop] *)
//
in
  loop (ctx, 1)
end // end of [val]
//
val ampm =
  (if (nhr < 12.0) then "AM" else "PM"): string
//
val () = ctx.strokeStyle("#000")
val () = ctx.lineWidth(1)
val () = ctx.strokeRect(21.0, ~14.0, 44.0, 27.0)
val () = ctx.fillText(ampm, 43.0, 0.0)
val () = ctx.lineWidth(6)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nhr*PI/6)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 10.0)
  val () = ctx.lineTo(0.0, ~60.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nmin*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.lineWidth (3)
val () = ctx.strokeStyle("#E33")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.rotate(nsec*PI/30)
  val () = ctx.beginPath()
  val () = ctx.moveTo(0.0, 20.0)
  val () = ctx.lineTo(0.0, ~110.0)
  val () = ctx.closePath()
  val () = ctx.stroke()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.fillStyle("#000")
//
val () =
{
  val pf = ctx.save()
  val () = ctx.beginPath()
  val () = ctx.arc(0.0, 0.0, 6.5, 0.0, 2*PI, true)
  val () = ctx.closePath()
  val () = ctx.fill()
  val () = ctx.restore(pf.0 | (*none*))
} (* end of [val] *)
//
val () = ctx.restore (pf.0 | (*none*))
//
} (* end of [where] *) // [draw_clock]
//
(* ****** ****** *)

%{$
//
var
canvas =
document.getElementById("Patsoptaas-Evaluate-Canvas");
var context = canvas.getContext( '2d' );
//
var w = 920.0
var h = 600.0
var mn = Math.min (w, h)
var xc = w / 2
var yc = h / 2
var alpha = mn / 300
//
function
draw2_clock()
{
var date = new Date() ;
var secs = date.getSeconds()
var mins = date.getMinutes()
var mins = mins + secs / 60.0
var hours = date.getHours()
var hours = hours + mins / 60.0
//
context.save();
context.translate(xc-mn/2, yc-mn/2);
context.scale (alpha, alpha);
draw_clock(context, hours, mins, secs);
context.restore();
//
setTimeout(draw2_clock, 500);
//
return;
//
} // end of [draw2_clock]
//
jQuery(document).ready(function(){draw2_clock();});
//
%} // end of [%{$]

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

(* end of [myclock1-2.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** For writing ATS code
** that translates into JavaScript
*)

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

(*
** Permission to use, copy, modify, and distribute this software for any
** purpose with or without fee is hereby granted, provided that the above
** copyright notice and this permission notice appear in all copies.
**
** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
** WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
** MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
** ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
** WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
** ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

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

(*
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
** Start Time: October, 2015
*)

(* ****** ****** *)
//
staload
"./../../basics_js.sats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "./../../SATS/Worker/channel.sats"

(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_new_file
  (file) { var chn = new Worker(file); return chn; }
//
%} // end of [%{^]
//
(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_close(chn) { return chn.terminate(); }
function
ats2js_worker_channeg1_close(chn) { return chn.terminate(); }
//
%} // end of [%{^]
//
(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_send(chn, k0)
{
  chn.onmessage =
  function(event)
    { return ats2jspre_cloref2_app(k0, chn, event.data); };
  return/*void*/;
}
function
ats2js_worker_channeg0_recv(chn, x0, k0)
{
  chn.postMessage(x0); return ats2jspre_cloref1_app(k0, chn);
}
//
function
ats2js_worker_channeg1_send
  (chn, k0)
{
  return ats2js_worker_channeg0_send(chn, k0);
}
function
ats2js_worker_channeg1_recv
  (chn, x0, k0)
{
  return ats2js_worker_channeg0_recv(chn, x0, k0);
}
//
%} // end of [%{^]
//
(* ****** ****** *)

implement
{a}{b}
rpc_client
  (chn, arg, fopr) = let
//
(*
val () = println! ("rpc_client")
*)
//
in
//
channeg0_recv{a}
( chn
, arg
, lam(chn) =>
  channeg0_send{b}
  ( chn
  , lam(chn, e) => fopr(chmsg_parse<b>(e))
  )
)
//
end (* end of [rpc_client] *)

(* ****** ****** *)
//
(*
fun{}
channeg1_append
  {ss1,ss2:type}
(
  channeg(ssappend(ss1,ss2)), k0: chncont0_nil
, fserv1: channeg_nullify(ss1), fserv2: channeg_nullify(ss2)
) : void // end of [channeg1_append]
*)
//
implement
{}(*tmp*)
channeg1_append
  {ss1,ss2}
(
  chn, k0, fserv1, fserv2
) = (
//
fserv1
(
  $UN.castvwtp0{channeg(ss1)}(chn)
, $UN.castvwtp0{chncont0_nil}(lam(chn:channeg(ss2)) =<cloref1> fserv2(chn, k0))
) (* end of [fserv1] *)
//
) (* end of [channeg1_append] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_choose_conj
  {ss0,ss1}
  (chn, k0, fserv0, fserv1) = let
//
val chn0 =
  $UN.castvwtp0{channeg()}(chn)
val tag0 =
  channeg1_choose_conj$choose()
val ((*void*)) =
  channeg1_choose_conj$fwork_tag<>(tag0)
//
in
//
case+
tag0 of
| 0 =>
  channeg0_recv{int}
  (
    chn0, tag0, lam(chn0) => fserv0($UN.castvwtp0(chn0), k0)
  ) (* end of [0] *)
| _ =>
  channeg0_recv{int}
  (
    chn0, tag0, lam(chn0) => fserv1($UN.castvwtp0(chn0), k0)
  ) (* end of [1] *)
//
end // end of [channeg1_choose_conj]]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_choose_disj
  {ss0,ss1}
  (chn, k0, fserv0, fserv1) = let
//
val chn0 = $UN.castvwtp0{channeg()}(chn)
//
in
//
channeg0_send
  {int}
(
  chn0
, lam(chn0, tag0) => let
    val tag0 =
      chmsg_parse<int>(tag0)
    // end of [val]
    val ((*void*)) =
      channeg1_choose_disj$fwork_tag<>(tag0)
    // end of [val]
  in
    case+ tag0 of
    | 0 => fserv0($UN.castvwtp0(chn0), k0)
    | _ => fserv1($UN.castvwtp0(chn0), k0)
  end // end of [lam]
) (* end of [channeg0_send] *)
//
end // end of [channeg1_choose_disj]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_option_conj
  {ss}(chn, k0, fserv) = let
//
val chn0 =
  $UN.castvwtp0{channeg()}(chn)
val tag0 =
  channeg1_option_conj$choose()
val ((*void*)) =
  channeg1_option_conj$fwork_tag<>(tag0)
//
in
//
case+
tag0 of
| 0 =>
  channeg0_recv{int}(chn0, tag0, $UN.cast{chncont0()}(k0))
| _ =>
  channeg0_recv{int}
  (
    chn0, tag0, lam(chn0) => fserv($UN.castvwtp0(chn0), k0)
  ) (* end of [1] *)
//
end // end of [channeg1_option_conj]]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_option_disj
  {ss}(chn, k0, fserv) = let
//
val chn0 = $UN.castvwtp0{channeg()}(chn)
//
in
//
channeg0_send
  {int}
(
  chn0
, lam(chn0, tag0) => let
    val tag0 =
      chmsg_parse<int>(tag0)
    // end of [val]
    val ((*void*)) =
      channeg1_option_disj$fwork_tag<>(tag0)
    // end of [val]
  in
    case+ tag0 of
    | 0 => k0($UN.castvwtp0(chn0))
    | _ => fserv($UN.castvwtp0(chn0), k0)
  end // end of [lam]
) (* end of [channeg0_send] *)
//
end // end of [channeg1_option_disj]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_option_conj$fwork_tag(tag) = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_option_disj$fwork_tag(tag) = () // nothing is done by default
//
(* ****** ****** *)
//
(*
fun{}
channeg1_repeat_conj
  {ss:type}
(
  channeg(ssconj(ssrepeat(ss)))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_repeat_conj]
*)
//
implement
{}(*tmp*)
channeg1_repeat_conj
  {ss}(chn, k0, fserv) = let
//
typedef
loop =
$d2ctype
  (channeg1_repeat_conj<>)
//
fun
loop: loop =
lam(chn, k0, fserv) => let
  val chn0 =
    $UN.castvwtp0{channeg()}(chn)
  val tag0 =
    channeg1_repeat_conj$choose()
  // end of [val]
  val ((*void*)) =
    channeg1_repeat_conj$fwork_tag<>(tag0)
  // end of [val]
in
//
case+
tag0 of
| 0 =>
  channeg0_recv{int}(chn0, tag0, $UN.cast{chncont0()}(k0))
| _ =>
  channeg0_recv{int}
  (
    chn0, tag0
  , lam(chn0) =>
    fserv (
      $UN.castvwtp0(chn0)
    , lam(chn) => channeg1_repeat_conj$spawn(llam() => loop($UN.castvwtp0(chn), k0, fserv))
    ) (*fserv*)
    // end of [lam]
  ) (* end of [1] *)
//
end // end of [loop]
//
val () = channeg1_repeat_conj$init<>()
//
in
  channeg1_repeat_conj$spawn(llam() => loop(chn, k0, fserv))
end // end of [channeg1_repeat_conj]]
//
(* ****** ****** *)
//
(*
fun{}
channeg1_repeat_disj
  {ss:type}
(
  channeg(ssrepeat(ss))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_repeat_disj]
*)
//
implement
{}(*tmp*)
channeg1_repeat_disj
  {ss}(chn, k0, fserv) = let
//
typedef
loop =
$d2ctype
  (channeg1_repeat_disj<>)
//
fun
loop: loop =
lam(chn, k0, fserv) => let
  val chn0 =
    $UN.castvwtp0{channeg()}(chn)
  // end of [val]
in
//
channeg0_send
  {int}
(
  chn0
, lam(chn0, tag0) => let
    val tag0 =
      chmsg_parse<int>(tag0)
    // end of [val]
    val ((*void*)) =
      channeg1_repeat_disj$fwork_tag<>(tag0)
    // end of [val]
  in
    case+ tag0 of
    | 0 => k0($UN.castvwtp0(chn0))
    | _ => fserv($UN.castvwtp0(chn0), lam(chn) => loop($UN.castvwtp0(chn), k0, fserv))
  end // end of [lam]
) (* end of [channeg0_send] *)
//
end // end of [loop]
//
val () = channeg1_repeat_disj$init<>()
//
in
  loop(chn, k0, fserv)
end // end of [channeg1_repeat_disj]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_repeat_conj$init() = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_disj$init() = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_conj$fwork_tag(tag) = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_disj$fwork_tag(tag) = () // nothing is done by default
//
(* ****** ****** *)

(* end of [channeg.dats] *)

(*
** For writing ATS code
** that translates into JavaScript
*)

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

(*
** Permission to use, copy, modify, and distribute this software for any
** purpose with or without fee is hereby granted, provided that the above
** copyright notice and this permission notice appear in all copies.
**
** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
** WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
** MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
** ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
** WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
** ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

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

(*
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
** Start Time: October, 2015
*)

(* ****** ****** *)
//
staload
"./../../basics_js.sats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "./../../SATS/Worker/channel.sats"

(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_new_file
  (file) { var chn = new Worker(file); return chn; }
//
%} // end of [%{^]
//
(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_close(chn) { return chn.terminate(); }
function
ats2js_worker_channeg1_close(chn) { return chn.terminate(); }
//
%} // end of [%{^]
//
(* ****** ****** *)
//
%{^
//
function
ats2js_worker_channeg0_send(chn, k0)
{
  chn.onmessage =
  function(event)
    { return ats2jspre_cloref2_app(k0, chn, event.data); };
  return/*void*/;
}
function
ats2js_worker_channeg0_recv(chn, x0, k0)
{
  chn.postMessage(x0); return ats2jspre_cloref1_app(k0, chn);
}
//
function
ats2js_worker_channeg1_send
  (chn, k0)
{
  return ats2js_worker_channeg0_send(chn, k0);
}
function
ats2js_worker_channeg1_recv
  (chn, x0, k0)
{
  return ats2js_worker_channeg0_recv(chn, x0, k0);
}
//
%} // end of [%{^]
//
(* ****** ****** *)

implement
{a}{b}
rpc_client
  (chn, arg, fopr) = let
//
(*
val () = println! ("rpc_client")
*)
//
in
//
channeg0_recv{a}
( chn
, arg
, lam(chn) =>
  channeg0_send{b}
  ( chn
  , lam(chn, e) => fopr(chmsg_parse<b>(e))
  )
)
//
end (* end of [rpc_client] *)

(* ****** ****** *)
//
(*
fun{}
channeg1_append
  {ss1,ss2:type}
(
  channeg(ssappend(ss1,ss2)), k0: chncont0_nil
, fserv1: channeg_nullify(ss1), fserv2: channeg_nullify(ss2)
) : void // end of [channeg1_append]
*)
//
implement
{}(*tmp*)
channeg1_append
  {ss1,ss2}
(
  chn, k0, fserv1, fserv2
) = (
//
fserv1
(
  $UN.castvwtp0{channeg(ss1)}(chn)
, $UN.castvwtp0{chncont0_nil}(lam(chn:channeg(ss2)) =<cloref1> fserv2(chn, k0))
) (* end of [fserv1] *)
//
) (* end of [channeg1_append] *)
//
(* ****** ****** *)
//
(*
fun{}
channeg1_option_conj
  {ss:type}
(
  channeg(ssconj(ssoption(ss)))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_option_conj]
*)
//
implement
{}(*tmp*)
channeg1_option_conj
  {ss}(chn, k0, fserv) = let
//
val chn0 =
  $UN.castvwtp0{channeg()}(chn)
val tag0 =
  channeg1_option_conj$choose()
val ((*void*)) =
  channeg1_option_conj$fwork_tag<>(tag0)
//
in
//
case+
tag0 of
| 0 =>
  channeg0_recv{int}(chn0, tag0, $UN.cast{chncont0()}(k0))
| _ =>
  channeg0_recv{int}
  (
    chn0, tag0, lam(chn0) => fserv($UN.castvwtp0(chn0), k0)
  ) (* end of [1] *)
//
end // end of [channeg1_option_conj]]
//
(* ****** ****** *)
//
(*
fun{}
channeg1_option_disj
  {ss:type}
(
  channeg(ssoption(ss))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_option_disj]
*)
//
implement
{}(*tmp*)
channeg1_option_disj
  {ss}(chn, k0, fserv) = let
//
val chn0 = $UN.castvwtp0{channeg()}(chn)
//
in
//
channeg0_send
  {int}
(
  chn0
, lam(chn0, tag0) => let
    val tag0 =
      chmsg_parse<int>(tag0)
    // end of [val]
    val ((*void*)) =
      channeg1_option_disj$fwork_tag<>(tag0)
    // end of [val]
  in
    case+ tag0 of
    | 0 => k0($UN.castvwtp0(chn0))
    | _ => fserv($UN.castvwtp0(chn0), k0)
  end // end of [lam]
) (* end of [channeg0_send] *)
//
end // end of [channeg1_option_disj]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_option_conj$fwork_tag(tag) = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_option_disj$fwork_tag(tag) = () // nothing is done by default
//
(* ****** ****** *)
//
(*
fun{}
channeg1_repeat_conj
  {ss:type}
(
  channeg(ssconj(ssrepeat(ss)))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_repeat_conj]
*)
//
implement
{}(*tmp*)
channeg1_repeat_conj
  {ss}(chn, k0, fserv) = let
//
typedef
loop =
$d2ctype
  (channeg1_repeat_conj<>)
//
fun
loop: loop =
lam(chn, k0, fserv) => let
  val chn0 =
    $UN.castvwtp0{channeg()}(chn)
  val tag0 =
    channeg1_repeat_conj$choose()
  // end of [val]
  val ((*void*)) =
    channeg1_repeat_conj$fwork_tag<>(tag0)
  // end of [val]
in
//
case+
tag0 of
| 0 =>
  channeg0_recv{int}(chn0, tag0, $UN.cast{chncont0()}(k0))
| _ =>
  channeg0_recv{int}
  (
    chn0, tag0
  , lam(chn0) =>
    fserv (
      $UN.castvwtp0(chn0)
    , lam(chn) => channeg1_repeat_conj$spawn(llam() => loop($UN.castvwtp0(chn), k0, fserv))
    ) (*fserv*)
    // end of [lam]
  ) (* end of [1] *)
//
end // end of [loop]
//
val () = channeg1_repeat_conj$init<>()
//
in
  channeg1_repeat_conj$spawn(llam() => loop(chn, k0, fserv))
end // end of [channeg1_repeat_conj]]
//
(* ****** ****** *)
//
(*
fun{}
channeg1_repeat_disj
  {ss:type}
(
  channeg(ssrepeat(ss))
, k0: chncont0_nil, fserv: channeg_nullify(ss)
) : void // end of [channeg1_repeat_disj]
*)
//
implement
{}(*tmp*)
channeg1_repeat_disj
  {ss}(chn, k0, fserv) = let
//
typedef
loop =
$d2ctype
  (channeg1_repeat_disj<>)
//
fun
loop: loop =
lam(chn, k0, fserv) => let
  val chn0 =
    $UN.castvwtp0{channeg()}(chn)
  // end of [val]
in
//
channeg0_send
  {int}
(
  chn0
, lam(chn0, tag0) => let
    val tag0 =
      chmsg_parse<int>(tag0)
    // end of [val]
    val ((*void*)) =
      channeg1_repeat_disj$fwork_tag<>(tag0)
    // end of [val]
  in
    case+ tag0 of
    | 0 => k0($UN.castvwtp0(chn0))
    | _ => fserv($UN.castvwtp0(chn0), lam(chn) => loop($UN.castvwtp0(chn), k0, fserv))
  end // end of [lam]
) (* end of [channeg0_send] *)
//
end // end of [loop]
//
val () = channeg1_repeat_disj$init<>()
//
in
  loop(chn, k0, fserv)
end // end of [channeg1_repeat_disj]
//
(* ****** ****** *)
//
implement
{}(*tmp*)
channeg1_repeat_conj$init() = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_disj$init() = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_conj$fwork_tag(tag) = () // nothing is done by default
//
implement
{}(*tmp*)
channeg1_repeat_disj$fwork_tag(tag) = () // nothing is done by default
//
(* ****** ****** *)

(* end of [channeg.dats] *)


Updating: very minorly fixing

Updating: very minorly fixing

(*
** Implementing the doublet game
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/strarr.sats"
staload _ = "libats/ML/DATS/array0.dats"
staload _ = "libats/ML/DATS/strarr.dats"

(* ****** ****** *)
//
staload
"libats/SATS/hashtbl_linprb.sats"
//
(* ****** ****** *)
//
staload _ = "libats/DATS/qlist.dats"
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_linprb.dats"
//
(* ****** ****** *)

staload "./doublet.sats"

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

local
//
typedef key = strarr
typedef itm = int(*0/1*)
//
#define CAPACITY 131072
//
(*
//
// resizing is not allowed!
//
implement
hashtbl$recapacitize<> () = 0
*)
//
implement
hash_key<strarr>
  (str) = let
//
val K = 31UL
val n = length (str)
//
fun loop
(
  i: size_t, res: ulint
) : ulint = let
in
//
if i < n then let
  val res = K * res + $UN.cast{ulint}(str[i])
in
  loop (succ(i), res)
end else (res) // end of [if]
//
end // end of [loop]
//
in
  $effmask_all (loop (i2sz(0), 31415926536UL))
end // end of [hash_key]
//
implement
gequal_val_val<strarr> (str1, str2) = (str1 = str2)
//
implement(itm)
hashtbl_linprb_keyitm_is_null<strarr,itm> (kx) = ($UN.cast2ptr(kx.0) = 0)
//
in (* in of [local] *)

#include "{$LIBATSHWXI}/globals/HATS/ghashtbl_linprb.hats"

end // end of [local]

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

#define WORDS "/usr/share/dict/words"

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

val () = // initialization
{
//
val-~Some_vt(filr) =
  fileref_open_opt (WORDS, file_mode_r)
//
val () = let
//
fun loop
(
  filr: FILEref
) : void = let
  val isnot = fileref_isnot_eof (filr)
in
  if isnot
    then let
      val str =
        fileref_get_line_string (filr)
      val str2 = strarr_make_string ($UN.castvwtp1{string}(str))
      val ((*void*)) = strptr_free (str)
      val-~None_vt() = insert_opt (str2, 1)
    in
      loop (filr)
    end // end of [then]
    else () // end of [else]
  // end of [if]
end // end of [loop]
//
in
  loop (filr)
end // end of [val]
//
val ((*void*)) = fileref_close (filr)
//
} (* end of [val] *)

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

implement
word_is_legal (w) = let
  val cp = search_ref (w)
in
  if cptr2ptr (cp) > 0 then true else false
end // end of [word_is_legal]

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

(* end of [doublet_dict.dats] *)

(*
** Implementing the doublet game
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/strarr.sats"
staload _ = "libats/ML/DATS/array0.dats"
staload _ = "libats/ML/DATS/strarr.dats"

(* ****** ****** *)
//
staload
"libats/SATS/hashtbl_linprb.sats"
//
(* ****** ****** *)
//
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_linprb.dats"
//
(* ****** ****** *)

staload "./doublet.sats"

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

local
//
typedef key = strarr
typedef itm = int(*0/1*)
//
#define CAPACITY 131072
//
(*
//
// resizing is not allowed!
//
implement
hashtbl$recapacitize<> () = 0
*)
//
implement
hash_key<strarr>
  (str) = let
//
val K = 31UL
val n = length (str)
//
fun loop
(
  i: size_t, res: ulint
) : ulint = let
in
//
if i < n then let
  val res = K * res + $UN.cast{ulint}(str[i])
in
  loop (succ(i), res)
end else (res) // end of [if]
//
end // end of [loop]
//
in
  $effmask_all (loop (i2sz(0), 31415926536UL))
end // end of [hash_key]
//
implement
gequal_val_val<strarr> (str1, str2) = (str1 = str2)
//
implement(itm)
hashtbl_linprb_keyitm_is_null<strarr,itm> (kx) = ($UN.cast2ptr(kx.0) = 0)
//
in (* in of [local] *)

#include "{$LIBATSHWXI}/globals/HATS/ghashtbl_linprb.hats"

end // end of [local]

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

#define WORDS "/usr/share/dict/words"

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

val () = // initialization
{
//
val-~Some_vt(filr) =
  fileref_open_opt (WORDS, file_mode_r)
//
val () = let
//
fun loop
(
  filr: FILEref
) : void = let
  val isnot = fileref_isnot_eof (filr)
in
  if isnot
    then let
      val str =
        fileref_get_line_string (filr)
      val str2 = strarr_make_string ($UN.castvwtp1{string}(str))
      val ((*void*)) = strptr_free (str)
      val-~None_vt() = insert_opt (str2, 1)
    in
      loop (filr)
    end // end of [then]
    else () // end of [else]
  // end of [if]
end // end of [loop]
//
in
  loop (filr)
end // end of [val]
//
val ((*void*)) = fileref_close (filr)
//
} (* end of [val] *)

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

implement
word_is_legal (w) = let
  val cp = search_ref (w)
in
  if cptr2ptr (cp) > 0 then true else false
end // end of [word_is_legal]

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

(* end of [doublet_dict.dats] *)


Not using -> is a good style.

Not using -> is a good style.

#include "config.hats"
staload "{$TOP}/SATS/arduino.sats"

absvtype lcd_t = ptr

fun lcd_open (rs: int, rw: int, enable: int, d0: int, d1: int, d2: int, d3: int): lcd_t
fun lcd_close (lcd: lcd_t): void
fun lcd_clear (lcd: !lcd_t): void
fun lcd_setCursor (lcd: !lcd_t, col: int, row: int): void
fun lcd_print {n:int}{i:nat | i < n}{j:nat | i + j <= n}
              (lcd: !lcd_t, str: string (n), start: size_t (i), len: size_t (j)): void

#include "config.hats"
staload "{$TOP}/SATS/arduino.sats"

absvtype lcd_t = ptr

fun lcd_open (rs: int, rw: int, enable: int, d0: int, d1: int, d2: int, d3: int): lcd_t
fun lcd_close: (lcd_t) -> void
fun lcd_clear: (!lcd_t) -> void
fun lcd_setCursor (lcd: !lcd_t, col: int, row: int): void
fun lcd_print {n:int}{i:nat | i < n}{j:nat | i + j <= n}
              (lcd: !lcd_t, str: string (n), start: size_t (i), len: size_t (j)): void