Updating: very minorly improving

Updating: very minorly improving

(*
** Tetris
*)

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

#define
ATS_STATIC_PREFIX "tetris_autoplay__"

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

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris_autoplay_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
fun
power
(
  x: int, n: int
): int = (
//
if n >= 2
  then x * power(x, n-1) else (if n >= 1 then x else 1)
//
) (* end of [power] *)
//
(* ****** ****** *)
//
typedef
matrix0(a:t@ype) = mtrxszref(a)
//
(* ****** ****** *)
//
val
theAutoBoard =
  mtrxszref_make_elt{int}(GCOLS, GROWS, 0)
//
fun
theAutoBoard_update() =
theGameBoard_iforeach
  (lam(i, j, b) => theAutoBoard[i,j] := bool2int0(b))
//
(* ****** ****** *)
//
#define PDIM1 (PDIM-1)
//
val
theAutoPiece = mtrxszref_make_elt{int}(PDIM, PDIM, 0)
//
fun
theAutoPiece_update
  (P0: Piece, nrot: natLt(4)) = (
//
case+ nrot of
| 0 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[i      ,j    ] := bool2int0(b))
  // Piece_iforeach
| 1 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[PDIM1-j,i    ] := bool2int0(b))
  // Piece_iforeach
| 2 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[PDIM1-i,PDIM1-j] := bool2int0(b))
  // Piece_iforeach
| 3 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[j      ,PDIM1-i] := bool2int0(b))
  // Piece_iforeach
//
)
(* ****** ****** *)
//
fun
theAutoBoard_isset_at
  (i: int, j: int): bool =
  (i < 0 || i >= GCOLS) || (j < 0 || j >= GROWS) || (theAutoBoard[i,j] > 0)
//
(* ****** ****** *)

fun
theAutoBoard_eval1
  ((*void*)): double = let
//
fun
loop1
(
  i: int, res: double
) : double =
(
if i < GCOLS
  then loop2(i, 0, res) else res
)
//
and
loop2
(
  i: int, j: int, res: double
) : double =
(
//
if
j < GROWS
then (
  if theAutoBoard[i,j] = 0
    then loop2 (i, j+1, res)
    else loop2 (i, j+1, res + power(GROWS-j, 2))
  // end of [if]
) else loop1(i+1, res)
//
) (* end of [loop2] *)
//
in
  loop1 (0, 0.0)
end // end of [theAutoBoard_eval1]

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

fun
theAutoBoard_eval2
  ((*void*)): double = let
//
fun
loop1
(
  i: int, res: double
) : double =
(
if i < GCOLS
  then loop2(i, 0, res) else res
)
//
and
loop2
(
  i: int, j: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] = 0
  then loop2(i, j+1, res) else loop3(i, j+1, 0, res)
//
) else loop1(i+1, res)
//
) (* end of [loop2] *)
//
and
loop3
(
  i: int, j: int, n: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] > 0
  then loop3(i, j+1, n+1, res) else loop4(i, j, n+1, res)
//
) else loop1(i+1, res)
//
) (* end of [loop3] *)
//
and
loop4
(
  i: int, j: int, n: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] > 0
  then loop4(i, j+1, n, res)
  else loop4(i, j+1, n, res + n + power(GROWS-j, 2)*GCOLS)
//
) else loop1(i+1, res)
//
) (* end of [loop3] *)
//
in
  loop1 (0, 0.0)
end // end of [theAutoBoard_eval2]

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

fun
theAutoBoard_eval3
  ((*void*)): double = let
//
fun
auxful
(
  j: int, i: int
) : bool =
(
//
if
i < GCOLS
then (
  if (theAutoBoard[i,j] > 0) then auxful(j, i+1) else false
) else true // end of [if]
//
) (* end of [auxful] *)
//
fun
loop(j: int, res: double): double =
(
if
j < GROWS
then (
  if auxful(j, 0)
    then loop(j+1, res + power(GROWS-j, 2)*GCOLS) else loop(j+1, res)
  // end of [if]
) else res // end of [if]
)
//
in
  loop(0, 0.0)
end // end of [theAutoBoard_eval3]

(* ****** ****** *)
//
fun
theAutoBoard_eval_all
  ((*void*)): double =
( 0
+ theAutoBoard_eval1()
+ theAutoBoard_eval2()
- theAutoBoard_eval3()
)
//
(* ****** ****** *)

fun
theAutoPiece_collide_at
  (x0: int, y0: int) =
(
//
mtrxszref_exists_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then theAutoBoard_isset_at(x0+i, y0+j) else false
  // end of [if]
) (* mtrxszref_exists_cloref *)
//
) (* end of [theAutoPiece_collide_at] *)

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

fun
theAutoPiece_maxfall_at
  (x0: int, y0: int): int = let
//
fun
loop(y: int): int =
if theAutoPiece_collide_at(x0, y+1) then y else loop(y+1)
//
in
  if theAutoPiece_collide_at(x0, y0) then ~1 else loop(y0)
end // end of [theAutoPiece_maxfall_at]

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

fun
theAutoPiece_dump_at
  (x0: int, y0: int) =
(
mtrxszref_foreach_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then let
      val x = x0+i and y = y0+j in
      theAutoBoard[x,y] := theAutoBoard[x,y] + 1
    end // end of [then]
  // end of [if]
) (* mtrxszref_foreach_cloref *)
) (* end of [theAutoPiece_dump_at] *)

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

fun
theAutoPiece_undump_at
  (x0: int, y0: int) =
(
mtrxszref_foreach_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then let
      val x = x0+i and y = y0+j in
      theAutoBoard[x,y] := theAutoBoard[x,y] - 1
    end // end of [then]
  // end of [if]
) (* mtrxszref_foreach_cloref *)
) (* end of [theAutoPiece_undump_at] *)

(* ****** ****** *)
//
datatype
sitscore =
| SITSCORE0 of ()
| SITSCORE1 of
    (double, int(*xmove*), int(*rotate*))
  // end of [SITSCORE1]
//
(* ****** ****** *)
//
extern
fun
lte_sitscore_scorexmvrot
  (sitscore, score2: double, xmv2: int, rot2: int): bool = "mac#"
//
implement
lte_sitscore_scorexmvrot
  (ss1, score2, xmv2, rot2) =
(
case+ ss1 of
| SITSCORE0() => false
| SITSCORE1(score1, xmv1, rot1) =>
  (
    case+ 0 of
    | _ when
        score1 < score2 => true
    | _ when
        score1 > score2 => false
    | _ (* score1 = score2 *) => let
        val xmv1 = abs(xmv1)
        val xmv2 = abs(xmv2)
      in
        if xmv1 > xmv2
          then true else (if xmv1 < xmv2 then false else (abs(rot1) <= abs(rot2)))
        // end of [if]
      end // end of [score1 = score2]
  ) (* end of [SITSCORE1] *)
)
//
(* ****** ****** *)
//
extern
fun
theAutoplay_eval
  (Piece, x0: int, y0: int): sitscore = "mac#"
//
(* ****** ****** *)

implement
theAutoplay_eval
  (P0, x0, y0) = let
//
fun
auxmin_l
(
  ss: sitscore, xmv: int, rot: int
) : sitscore = let
//
val x1 = x0 + xmv
val y1 = theAutoPiece_maxfall_at(x1, y0)
//
(*
val () = alert("auxmin_l: y1 = " + String(y1))
*)
//
in
//
if y1 < 0 then ss else let
  val () = theAutoPiece_dump_at(x1, y1)
  val score = theAutoBoard_eval_all((*void*))
(*
  val () = alert("auxmin_l: score = " + String(score))
*)
  val () = theAutoPiece_undump_at(x1, y1)
  val test2 =
    lte_sitscore_scorexmvrot(ss, score, xmv, rot)
  // end of [val]
in
  if test2
    then auxmin_l(ss, xmv-1, rot)
    else auxmin_l(SITSCORE1(score, xmv, rot), xmv-1, rot)
  // end of [if]
end // end of [else] // end of [if]
//
end // end of [auxmin_l]
//
fun
auxmin_r
(
  ss: sitscore, xmv: int, rot: int
) : sitscore = let
//
val x1 = x0 + xmv
val y1 = theAutoPiece_maxfall_at(x1, y0)
//
(*
val () = alert("auxmin_r: y1 = " + String(y1))
*)
//
in
//
if y1 < 0 then ss else let
  val () = theAutoPiece_dump_at(x1, y1)
  val score = theAutoBoard_eval_all((*void*))
(*
  val () = alert("auxmin_r: score = " + String(score))
*)
  val () = theAutoPiece_undump_at(x1, y1)
  val test2 =
    lte_sitscore_scorexmvrot(ss, score, xmv, rot)
  // end of [val]
in
  if test2
    then auxmin_r(ss, xmv+1, rot)
    else auxmin_r(SITSCORE1(score, xmv, rot), xmv+1, rot)
  // end of [if]
end // end of [else] // end of [if]
//
end // end of [auxmin_r]
//
fun
auxmin2
(
  ss: sitscore, nrot: natLte(4)
) : sitscore = (
//
if
nrot < 4
then let
//
val () =
  theAutoPiece_update(P0, nrot)
//
val rot =
(
  if nrot <= 2
    then nrot else (nrot-4)
  // end of [if]
) : int // end of [val]
val ss_r = auxmin_r(ss, 0, rot)
val ss_r_l = auxmin_l(ss_r, ~1, rot)
//
in
  auxmin2 (ss_r_l, nrot + 1)
end // end of [then]
else ss // end of [else]
//
) (* end of [auxmin2] *)
//
in
  auxmin2 (SITSCORE0(), 0)
end // end of [theAutoplay_eval]

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

fun
autoplay_rot
(
  P0: Piece, rot: int
) : void =
(
case+ rot of
| _ when rot = 1 =>
  {
    val _ = Piece_rrotate(P0)
  }
| _ when rot = ~1 =>
  {
    val _ = Piece_lrotate(P0)
  }
| _ when rot = 2 =>
  {
    val _ = Piece_rrotate(P0)
    val _ = Piece_rrotate(P0)
  }
| _ (* rot = 0 *) => ()
)

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

fun
autoplay_xmv
  (P0: Piece, xmv: int) = let
//
(*
val () =
  alert("autoplay_xmove: xmv = "+String(xmv))
*)
//
in
//
case+ 0 of
| _ when xmv > 0 => let
    val moved = Piece_xmove_r(P0)
  in
    if moved then autoplay_xmv (P0, xmv - 1)
  end
| _ when xmv < 0 => let
    val moved = Piece_xmove_l(P0)
  in
    if moved then autoplay_xmv (P0, xmv + 1)
  end
| _ (* xmv = 0 *) => ((*void*))
//
end (* end of [autoplay_xmv] *)

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

fun
autoplay_rotxmv
(
  P0: Piece
, xmv: int, rot: int
) : void =
{
  val () = autoplay_rot (P0, rot)
  val () = autoplay_xmv (P0, xmv)
  val () = theGameTQuota_delta_space()
}

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

#define DONE 0
#define XMV_L 1
#define XMV_R 2
#define ROT_L 3
#define ROT_R 4

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

local

typedef
fact = () -<cloref1> void

val
theFact =
ref{fact}($UN.cast{fact}(0))

val
theROTXMVlist =
arrszref_make_elt{int}(GCOLS+2, 0)

fun
fact_spawn(fact: fact) = theFact[] := fact

fun
theROTXMVlist_add_end
  (i: int): int = let
  val () = theROTXMVlist[i] := DONE
in
  i+1
end // end of [theROTXMVlist_add_end]

fun
theROTXMVlist_add_rot
  (rot: int, i: int): int =
(
case+ rot of
| _ when
    rot =  1 => i+1 where
  {
    val () = theROTXMVlist[i] := ROT_R
  }
| _ when
    rot = ~1 => i+1 where
  {
    val () = theROTXMVlist[i] := ROT_L
  }
| _ when
    rot =  2 => i+2 where
  {
    val () = theROTXMVlist[i+0] := ROT_R
    val () = theROTXMVlist[i+1] := ROT_R
  }
| _ (* rot = 0 *) => i
)

fun
theROTXMVlist_add_xmv
  (xmv: int, i: int): int =
(
//
case+ 0 of
| _ when xmv > 0 => let
    val () =
      theROTXMVlist[i] := XMV_R
    // end of [val]
  in
    theROTXMVlist_add_xmv (xmv-1, i+1)
  end
| _ when xmv < 0 => let
    val () =
      theROTXMVlist[i] := XMV_L
    // end of [val]
  in
    theROTXMVlist_add_xmv (xmv+1, i+1)
  end
| _ (* xmv = 0 *) => i
//
) (* end of [theROTXMVlist_add_xmv] *)

fun
theROTXMVlist_add_rotxmv
(
  rot: int, xmv: int, i: int
) : int = let
//
  val i = theROTXMVlist_add_rot(rot, i)
  val i = theROTXMVlist_add_xmv(xmv, i)
//
in
  theROTXMVlist_add_end(i)
end // end of [theROTXMVlist_add_rotxmv]

fun
theROTXMVlist_autoplay
  (P0: Piece, i: int) = let
//
val act = theROTXMVlist[i]
//
(*
val () = alert("theROTXMVlist_autoplay:i="+String(i)+";act="+String(act))
*)
//
in
//
case 0 of
//
| _ when
    (act = ROT_L) => let
    val acted = Piece_lrotate(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [ROT_L]
//
| _ when
    (act = ROT_R) => let
    val acted = Piece_rrotate(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [ROT_R]
//
| _ when
    (act = XMV_L) => let
    val acted = Piece_xmove_l(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [XMV_L]
//
| _ when
    (act = XMV_R) => let
    val acted = Piece_xmove_r(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [XMV_R]
//
| _(* DONE *) => theGameTQuota_delta_space()
//
end // end of [theROTXMVlist_autoplay]

in (* in-of-local *)

fun
autoplay2_rotxmv
(
  P0: Piece
, xmv: int, rot: int
) : void = let
//
val
_(*i*) =
theROTXMVlist_add_rotxmv
  (rot, xmv, 0)
//
in
  theROTXMVlist_autoplay(P0, 0)
end // end of [autoplay2_rotxmv]

implement
theAutoplay_fact
  ((*void*)) = let
  val fact = theFact[]
  val ((*void*)) =
    theFact[] := $UN.cast{fact}(0)
  // end of [val]
in
  if $UN.cast{int}(fact) != 0 then fact()
end // end of [theAutoplay_fact]

end // end of [local]

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

implement
theGame_autoplay_piece
  (P0) = let
//
(*
val () =
  alert("theGame_autoplay_piece")
*)
//
val x0 = Piece_get_x(P0)
val y0 = Piece_get_y(P0)
//
val () = theAutoBoard_update()
val ss = theAutoplay_eval(P0, x0, y0)
//
(*
val () =
  alert("theGame_autoplay_piece: x0 = "+String(x0))
val () =
  alert("theGame_autoplay_piece: y0 = "+String(y0))
*)
//
in
//
case+ ss of
| SITSCORE0() => ()
(*
| SITSCORE1(score, xmv, rot) => autoplay_rotxmv(P0, xmv, rot)
*)
| SITSCORE1(score, xmv, rot) => autoplay2_rotxmv(P0, xmv, rot)
//
end // end of [theGame_autoplay_piece]

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

(* end of [tetris_autoplay.dats] *)

(*
** Tetris
*)

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

#define
ATS_STATIC_PREFIX "tetris_autoplay__"

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

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "tetris_autoplay_initize"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload (*opened*) "./tetris.sats"
//
(* ****** ****** *)
//
#include "{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
fun
power
(
  x: int, n: int
): int = (
//
if n >= 2
  then x * power(x, n-1) else (if n >= 1 then x else 1)
//
) (* end of [power] *)
//
(* ****** ****** *)
//
typedef
matrix0(a:t@ype) = mtrxszref(a)
//
(* ****** ****** *)
//
val
theAutoBoard =
  mtrxszref_make_elt{int}(GCOLS, GROWS, 0)
//
fun
theAutoBoard_update() =
theGameBoard_iforeach
  (lam(i, j, b) => theAutoBoard[i,j] := bool2int0(b))
//
(* ****** ****** *)
//
#define PDIM1 (PDIM-1)
//
val
theAutoPiece = mtrxszref_make_elt{int}(PDIM, PDIM, 0)
//
fun
theAutoPiece_update
  (P0: Piece, nrot: natLt(4)) = (
//
case+ nrot of
| 0 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[i      ,j    ] := bool2int0(b))
  // Piece_iforeach
| 1 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[PDIM1-j,i    ] := bool2int0(b))
  // Piece_iforeach
| 2 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[PDIM1-i,PDIM1-j] := bool2int0(b))
  // Piece_iforeach
| 3 =>
  Piece_iforeach
    (P0, lam(i, j, b) => theAutoPiece[j      ,PDIM1-i] := bool2int0(b))
  // Piece_iforeach
//
)
(* ****** ****** *)
//
fun
theAutoBoard_isset_at
  (i: int, j: int): bool =
  (i < 0 || i >= GCOLS) || (j < 0 || j >= GROWS) || (theAutoBoard[i,j] > 0)
//
(* ****** ****** *)

fun
theAutoBoard_eval1
  ((*void*)): double = let
//
fun
loop1
(
  i: int, res: double
) : double =
(
if i < GCOLS
  then loop2(i, 0, res) else res
)
//
and
loop2
(
  i: int, j: int, res: double
) : double =
(
//
if
j < GROWS
then let
  val res =
    res + theAutoBoard[i,j] * power(GROWS-j, 2)
  // end of [val]
in
  loop2(i, j+1, res)
end // end of [then]
else loop1(i+1, res)
//
) (* end of [loop2] *)
//
in
  loop1 (0, 0.0)
end // end of [theAutoBoard_eval1]

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

fun
theAutoBoard_eval2
  ((*void*)): double = let
//
fun
loop1
(
  i: int, res: double
) : double =
(
if i < GCOLS
  then loop2(i, 0, res) else res
)
//
and
loop2
(
  i: int, j: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] > 0
  then loop3(i, j+1, 0, res) else loop2(i, j+1, res)
//
) else loop1(i+1, res)
//
) (* end of [loop2] *)
//
and
loop3
(
  i: int, j: int, n: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] > 0
  then loop3(i, j+1, n+1, res) else loop4(i, j, n+1, res)
//
) else loop1(i+1, res)
//
) (* end of [loop3] *)
//
and
loop4
(
  i: int, j: int, n: int, res: double
) : double =
(
//
if
j < GROWS
then (
//
if theAutoBoard[i,j] > 0
  then loop4(i, j+1, n, res)
  else loop4(i, j+1, n, res + power(GROWS-j, 2)*GROWS)
//
) else loop1(i+1, res)
//
) (* end of [loop3] *)
//
in
  loop1 (0, 0.0)
end // end of [theAutoBoard_eval2]

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

fun
theAutoBoard_eval3
  ((*void*)): double = let
//
fun
auxful
(
  j: int, i: int
) : bool =
(
//
if
i < GCOLS
then (
  if (theAutoBoard[i,j] > 0) then auxful(j, i+1) else false
) else true // end of [if]
//
) (* end of [auxful] *)
//
fun
loop(j: int, res: double): double =
(
if
j < GROWS
then (
  if auxful(j, 0)
    then loop(j+1, res + power(GROWS-j, 2)*GCOLS) else loop(j+1, res)
  // end of [if]
) else res // end of [if]
)
//
in
  loop(0, 0.0)
end // end of [theAutoBoard_eval3]

(* ****** ****** *)
//
fun
theAutoBoard_eval_all
  ((*void*)): double =
( 0
+ theAutoBoard_eval1()
+ theAutoBoard_eval2()
- theAutoBoard_eval3()
)
//
(* ****** ****** *)

fun
theAutoPiece_collide_at
  (x0: int, y0: int) =
(
//
mtrxszref_exists_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then theAutoBoard_isset_at(x0+i, y0+j) else false
  // end of [if]
) (* mtrxszref_exists_cloref *)
//
) (* end of [theAutoPiece_collide_at] *)

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

fun
theAutoPiece_maxfall_at
  (x0: int, y0: int): int = let
//
fun
loop(y: int): int =
if theAutoPiece_collide_at(x0, y+1) then y else loop(y+1)
//
in
  if theAutoPiece_collide_at(x0, y0) then ~1 else loop(y0)
end // end of [theAutoPiece_maxfall_at]

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

fun
theAutoPiece_dump_at
  (x0: int, y0: int) =
(
mtrxszref_foreach_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then let
      val x = x0+i and y = y0+j in
      theAutoBoard[x,y] := theAutoBoard[x,y] + 1
    end // end of [then]
  // end of [if]
) (* mtrxszref_foreach_cloref *)
) (* end of [theAutoPiece_dump_at] *)

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

fun
theAutoPiece_undump_at
  (x0: int, y0: int) =
(
mtrxszref_foreach_cloref
( theAutoPiece
, lam(i, j) =>
  if theAutoPiece[i,j] > 0
    then let
      val x = x0+i and y = y0+j in
      theAutoBoard[x,y] := theAutoBoard[x,y] - 1
    end // end of [then]
  // end of [if]
) (* mtrxszref_foreach_cloref *)
) (* end of [theAutoPiece_undump_at] *)

(* ****** ****** *)
//
datatype
sitscore =
| SITSCORE0 of ()
| SITSCORE1 of
    (double, int(*xmove*), int(*rotate*))
  // end of [SITSCORE1]
//
(* ****** ****** *)
//
extern
fun
lte_sitscore_scorexmvrot
  (sitscore, score2: double, xmv2: int, rot2: int): bool = "mac#"
//
implement
lte_sitscore_scorexmvrot
  (ss1, score2, xmv2, rot2) =
(
case+ ss1 of
| SITSCORE0() => false
| SITSCORE1(score1, xmv1, rot1) =>
  (
    case+ 0 of
    | _ when
        score1 < score2 => true
    | _ when
        score1 > score2 => false
    | _ (* score1 = score2 *) => let
        val xmv1 = abs(xmv1)
        val xmv2 = abs(xmv2)
      in
        if xmv1 > xmv2
          then true else (if xmv1 < xmv2 then false else (abs(rot1) <= abs(rot2)))
        // end of [if]
      end // end of [score1 = score2]
  ) (* end of [SITSCORE1] *)
)
//
(* ****** ****** *)
//
extern
fun
theAutoplay_eval
  (Piece, x0: int, y0: int): sitscore = "mac#"
//
(* ****** ****** *)

implement
theAutoplay_eval
  (P0, x0, y0) = let
//
fun
auxmin_l
(
  ss: sitscore, xmv: int, rot: int
) : sitscore = let
//
val x1 = x0 + xmv
val y1 = theAutoPiece_maxfall_at(x1, y0)
//
(*
val () = alert("auxmin_l: y1 = " + String(y1))
*)
//
in
//
if y1 < 0 then ss else let
  val () = theAutoPiece_dump_at(x1, y1)
  val score = theAutoBoard_eval_all((*void*))
(*
  val () = alert("auxmin_l: score = " + String(score))
*)
  val () = theAutoPiece_undump_at(x1, y1)
  val test2 =
    lte_sitscore_scorexmvrot(ss, score, xmv, rot)
  // end of [val]
in
  if test2
    then auxmin_l(ss, xmv-1, rot)
    else auxmin_l(SITSCORE1(score, xmv, rot), xmv-1, rot)
  // end of [if]
end // end of [else] // end of [if]
//
end // end of [auxmin_l]
//
fun
auxmin_r
(
  ss: sitscore, xmv: int, rot: int
) : sitscore = let
//
val x1 = x0 + xmv
val y1 = theAutoPiece_maxfall_at(x1, y0)
//
(*
val () = alert("auxmin_r: y1 = " + String(y1))
*)
//
in
//
if y1 < 0 then ss else let
  val () = theAutoPiece_dump_at(x1, y1)
  val score = theAutoBoard_eval_all((*void*))
(*
  val () = alert("auxmin_r: score = " + String(score))
*)
  val () = theAutoPiece_undump_at(x1, y1)
  val test2 =
    lte_sitscore_scorexmvrot(ss, score, xmv, rot)
  // end of [val]
in
  if test2
    then auxmin_r(ss, xmv+1, rot)
    else auxmin_r(SITSCORE1(score, xmv, rot), xmv+1, rot)
  // end of [if]
end // end of [else] // end of [if]
//
end // end of [auxmin_r]
//
fun
auxmin2
(
  ss: sitscore, nrot: natLte(4)
) : sitscore = (
//
if
nrot < 4
then let
//
val () =
  theAutoPiece_update(P0, nrot)
//
val rot =
(
  if nrot <= 2
    then nrot else (nrot-4)
  // end of [if]
) : int // end of [val]
val ss_r = auxmin_r(ss, 0, rot)
val ss_r_l = auxmin_l(ss_r, ~1, rot)
//
in
  auxmin2 (ss_r_l, nrot + 1)
end // end of [then]
else ss // end of [else]
//
) (* end of [auxmin2] *)
//
in
  auxmin2 (SITSCORE0(), 0)
end // end of [theAutoplay_eval]

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

fun
autoplay_rot
(
  P0: Piece, rot: int
) : void =
(
case+ rot of
| _ when rot = 1 =>
  {
    val _ = Piece_rrotate(P0)
  }
| _ when rot = ~1 =>
  {
    val _ = Piece_lrotate(P0)
  }
| _ when rot = 2 =>
  {
    val _ = Piece_rrotate(P0)
    val _ = Piece_rrotate(P0)
  }
| _ (* rot = 0 *) => ()
)

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

fun
autoplay_xmv
  (P0: Piece, xmv: int) = let
//
(*
val () =
  alert("autoplay_xmove: xmv = "+String(xmv))
*)
//
in
//
case+ 0 of
| _ when xmv > 0 => let
    val moved = Piece_xmove_r(P0)
  in
    if moved then autoplay_xmv (P0, xmv - 1)
  end
| _ when xmv < 0 => let
    val moved = Piece_xmove_l(P0)
  in
    if moved then autoplay_xmv (P0, xmv + 1)
  end
| _ (* xmv = 0 *) => ((*void*))
//
end (* end of [autoplay_xmv] *)

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

fun
autoplay_rotxmv
(
  P0: Piece
, xmv: int, rot: int
) : void =
{
  val () = autoplay_rot (P0, rot)
  val () = autoplay_xmv (P0, xmv)
  val () = theGameTQuota_delta_space()
}

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

#define DONE 0
#define XMV_L 1
#define XMV_R 2
#define ROT_L 3
#define ROT_R 4

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

local

typedef
fact = () -<cloref1> void

val
theFact =
ref{fact}($UN.cast{fact}(0))

val
theROTXMVlist =
arrszref_make_elt{int}(GCOLS+2, 0)

fun
fact_spawn(fact: fact) = theFact[] := fact

fun
theROTXMVlist_add_end
  (i: int): int = let
  val () = theROTXMVlist[i] := DONE
in
  i+1
end // end of [theROTXMVlist_add_end]

fun
theROTXMVlist_add_rot
  (rot: int, i: int): int =
(
case+ rot of
| _ when
    rot =  1 => i+1 where
  {
    val () = theROTXMVlist[i] := ROT_R
  }
| _ when
    rot = ~1 => i+1 where
  {
    val () = theROTXMVlist[i] := ROT_L
  }
| _ when
    rot =  2 => i+2 where
  {
    val () = theROTXMVlist[i+0] := ROT_R
    val () = theROTXMVlist[i+1] := ROT_R
  }
| _ (* rot = 0 *) => i
)

fun
theROTXMVlist_add_xmv
  (xmv: int, i: int): int =
(
//
case+ 0 of
| _ when xmv > 0 => let
    val () =
      theROTXMVlist[i] := XMV_R
    // end of [val]
  in
    theROTXMVlist_add_xmv (xmv-1, i+1)
  end
| _ when xmv < 0 => let
    val () =
      theROTXMVlist[i] := XMV_L
    // end of [val]
  in
    theROTXMVlist_add_xmv (xmv+1, i+1)
  end
| _ (* xmv = 0 *) => i
//
) (* end of [theROTXMVlist_add_xmv] *)

fun
theROTXMVlist_add_rotxmv
(
  rot: int, xmv: int, i: int
) : int = let
//
  val i = theROTXMVlist_add_rot(rot, i)
  val i = theROTXMVlist_add_xmv(xmv, i)
//
in
  theROTXMVlist_add_end(i)
end // end of [theROTXMVlist_add_rotxmv]

fun
theROTXMVlist_autoplay
  (P0: Piece, i: int) = let
//
val act = theROTXMVlist[i]
//
(*
val () = alert("theROTXMVlist_autoplay:i="+String(i)+";act="+String(act))
*)
//
in
//
case 0 of
//
| _ when
    (act = ROT_L) => let
    val acted = Piece_lrotate(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [ROT_L]
//
| _ when
    (act = ROT_R) => let
    val acted = Piece_rrotate(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [ROT_R]
//
| _ when
    (act = XMV_L) => let
    val acted = Piece_xmove_l(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [XMV_L]
//
| _ when
    (act = XMV_R) => let
    val acted = Piece_xmove_r(P0)
  in
    if acted then
      fact_spawn (lam() => theROTXMVlist_autoplay(P0, i+1))
    // end of [if]
  end // end of [XMV_R]
//
| _(* DONE *) => theGameTQuota_delta_space()
//
end // end of [theROTXMVlist_autoplay]

in (* in-of-local *)

fun
autoplay2_rotxmv
(
  P0: Piece
, xmv: int, rot: int
) : void = let
//
val
_(*i*) =
theROTXMVlist_add_rotxmv
  (rot, xmv, 0)
//
in
  theROTXMVlist_autoplay(P0, 0)
end // end of [autoplay2_rotxmv]

implement
theAutoplay_fact
  ((*void*)) = let
  val fact = theFact[]
  val ((*void*)) =
    theFact[] := $UN.cast{fact}(0)
  // end of [val]
in
  if $UN.cast{int}(fact) != 0 then fact()
end // end of [theAutoplay_fact]

end // end of [local]

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

implement
theGame_autoplay_piece
  (P0) = let
//
(*
val () =
  alert("theGame_autoplay_piece")
*)
//
val x0 = Piece_get_x(P0)
val y0 = Piece_get_y(P0)
//
val () = theAutoBoard_update()
val ss = theAutoplay_eval(P0, x0, y0)
//
(*
val () =
  alert("theGame_autoplay_piece: x0 = "+String(x0))
val () =
  alert("theGame_autoplay_piece: y0 = "+String(y0))
*)
//
in
//
case+ ss of
| SITSCORE0() => ()
(*
| SITSCORE1(score, xmv, rot) => autoplay_rotxmv(P0, xmv, rot)
*)
| SITSCORE1(score, xmv, rot) => autoplay2_rotxmv(P0, xmv, rot)
//
end // end of [theGame_autoplay_piece]

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

(* end of [tetris_autoplay.dats] *)


Updating: minorly improving

Updating: minorly improving

(*
** Session Option
*)

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

staload "./basis.sats"

(* ****** ****** *)
//
(*
datatype
ssopt (a:vt@ype) =
| ssopt_none of (nil)
| ssopt_some of (chsnd(a) :: nil)
*)
//
abstype ssopt(a:vt@ype)
//
(* ****** ****** *)
//
datavtype
channeg_opt (a:vt@ype) =
| channeg_opt_none of (channeg(nil))
| channeg_opt_some of (channeg(chsnd(a) :: nil))
//
(* ****** ****** *)
//
fun{}
chanpos_opt_none
  {a:vt@ype}
  (!chanpos(ssopt(a)) >> chanpos(nil)): void
fun{}
chanpos_opt_some
  {a:vt@ype}
  (!chanpos(ssopt(a)) >> chanpos(chsnd(a)::nil)): void
//
(* ****** ****** *)
//
fun{}
channeg_opt
  {a:vt@ype}(channeg(ssopt(a))): channeg_opt(a)
//
(* ****** ****** *)

(* end of [option.sats] *)

(*
** Session Option
*)

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

staload "./basis.sats"

(* ****** ****** *)
//
(*
datatype
ssopt (a:vt@ype) =
| ssopt_none of (nil)
| ssopt_some of (chsnd(a) :: nil)
*)
//
abstype ssopt(a:vt@ype)
//
(* ****** ****** *)
//
datavtype
channeg_opt (a:vt@ype) =
| channeg_opt_none of (channeg(nil))
| channeg_opt_some of (channeg(chsnd(a) :: nil))
//
(* ****** ****** *)
//
fun{}
chanpos_opt_nil
  {a:vt@ype}
  (!chanpos(ssopt(a)) >> chanpos(nil)): void
fun{}
chanpos_opt_cons
  {a:vt@ype}
  (!chanpos(ssopt(a)) >> chanpos(chsnd(a)::nil)): void
//
(* ****** ****** *)
//
fun{}
channeg_opt
  {a:vt@ype}(channeg(ssopt(a))): channeg_opt(a)
//
(* ****** ****** *)

(* end of [option.sats] *)


How close vtypedef?

How close vtypedef?

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  tsc: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| tsc: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void

implement
tcp_socket_connection_open () = let
  val (pfgc, pfat | p) = ptr_alloc<TCPSocketConnection_struct> ()
  val () = p->sock := socket_open (SOCK_STREAM)
  val () = p->endpoint := endpoint_open ()
  // xxx
  val tsc = $UN.castvwtp0{TCPSocketConnection}((pfat, pfgc | p))
in
  tsc
end

implement
tcp_socket_connection_close (tsc) = {
  val (pfat | p) = TCPSocketConnection_takeout_struct (tsc)
//  val () = endpoint_close (p->endpoint)
//  val () = socket_close (p->sock, true)
  prval () = TCPSocketConnection_addback_struct (pfat | tsc)
  val () = __free (tsc) where {
    extern fun __free {vt:vtype} (x: vt): void = "atspre_mfree_gc"
  }
}

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  sock: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| sock: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void


strbuf works now.

strbuf works now.

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"

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

// NOTE: one issue with these lemmas is that
// strbuf is assumed to always hold the null-terminated string
//
// it is a win when you work with strings, but it isn't when
// you only want to build up a string (in this case, to not break
// the invariant you have to put null-terminator every time
// you append a character)
//
// however, when a strbuf is being built, we really do not want
// to make it consumable as a string

absvt@ype sstrbuf_vt (int, int, addr) = (ptr, ptr, size_t)
vtypedef sstrbuf_vt0 = sstrbuf_vt (0, 0, null)?
vtypedef sstrbuf_vt1 (m:int, l:addr) = [n:int | n <= m] sstrbuf_vt (m, n, l)

extern
fun
sstrbuf_make {n:pos} {l:addr} (b0ytes_v (l, n) | ptr l, size_t n, &sstrbuf_vt0 >> sstrbuf_vt (n-1, 0, l)): void

extern
fun
sstrbuf_check {m,n:int} {l:addr} (&sstrbuf_vt (m, n, l)): size_t (m-n)

extern
fun
sstrbuf_cons {m,n:int | n < m} {l:addr} (&sstrbuf_vt (m, n, l) >> sstrbuf_vt (m, n+1, l), charNZ): void

extern
fun
sstrbuf_free_strnptr {m,n:int} {l:addr} (
  &sstrbuf_vt (m, n, l) >> sstrbuf_vt0
) : [l1:agz] (b0ytes_v (l, m+1) | strnptr (l1, n))

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

extern
prfun lemma_sizeof_byte_char (): [sizeof(byte) == sizeof(char)] void

dataprop LTE (int, int) = {m,n:int | n <= m} LTE (m, n)

assume sstrbuf_vt (m:int, n:int, l:addr) = @(
  (array_v (charNZ, l, n), array_v (byte?, l + n*sizeof(byte), m-n+1) | ptr l)
, size_t m
, (LTE (m, n) | size_t n)
) (* end of [sstrbuf_vt] *)

implement
sstrbuf_make {n} {l} (pf_bytes | p, n, sbf) = let
  prval () = lemma_array_v_param {byte?} (pf_bytes)
  prval () = $effmask_wrt (sbf.0.0 := array_v_nil {charNZ} ())
  prval () = $effmask_wrt (sbf.0.1 := pf_bytes)
  val () = sbf.0.2 := p
  val () = sbf.1 := pred (n)
  val () = sbf.2 := (LTE () | g1int2uint_int_size(0))
in
  // nothing
end

implement
sstrbuf_check {m,n} {l} (sbf) = let
  prval LTE () = sbf.2.0
in
  sbf.1 - sbf.2.1
end

implement
sstrbuf_cons {m,n} {l} (sbf, c) = let
  extern
  prfun lemma_char_size () : [sizeof(char)==sizeof(byte)] void
  prval () = lemma_char_size ()
  prval (pf2_at, pf2_arr) = array_v_uncons {byte?} {l+n*sizeof(byte)} (sbf.0.1)
  val p1 = ptr_add<char> (sbf.0.2, sbf.2.1)
  prval pf2_at = $UN.castview0 {charNZ? @ l+n*sizeof(char)} (pf2_at)
  val () = ptr_set<charNZ> (pf2_at | p1, c)
  prval LTE () = sbf.2.0
  val () = sbf.2 := (LTE () | succ (sbf.2.1))
  prval pf1_arr = array_v_extend (sbf.0.0, pf2_at)
  prval () = $effmask_wrt (sbf.0.0 := pf1_arr)
  prval () = $effmask_wrt (sbf.0.1 := pf2_arr)
in
  // nothing
end

// now, if you want to get a string, put 0 at p+n
// and that's all!
// there is always enough space

////
(*
implement
sstrbuf_free_strnptr {m,n} {l} (sbf) = let
in
end

  &sstrbuf_vt (m, n, l) >> sstrbuf_vt0
) : [l1:agz] (b0ytes_v (l, m+1) | strnptr (n, l1))

implement
sstrbuf_
*)

////

extern
prfun
lemma_strbuf_v_param_nat
  {l:addr}{m,n:int} (pf: !strbuf_v (l, m, n)): [m>=0;n>=0] void

extern
praxi strbuf_v_nil
  {n:int} {l:addr} // [n] must be a nat
  (pf1: char(0) @ l, pf2: b0ytes_v (l + 1*sizeof(char), n))
  : strbuf_v (l, n+1, 0)
// end of [strbuf_v]

extern
praxi strbuf_v_unnil
  {m:pos} {l:addr}
  (pf1: strbuf_v (l, n, 0))
  : (char(0) @ l, b0ytes_v (l + 1*sizeof(char), n-1))

extern
praxi strbuf_v_cons
  {m,n:int} {l:addr} // [m] and [n] must be nats
  (pf1: charNZ @ l, pf2: strbuf_v (l + 1*sizeof(char), m, n))
  :<prf> strbuf_v (l, m+1, n+1)
// end of [strbuf_v_cons]

dataview
strbufopt_v (int, int, addr, int) =
  | {m:nat} {l:addr}
    strbufopt_v_none (m, ~1, l, 0) of b0ytes m @ l
  | {m,n:nat} {l:addr} {c:int8 | c > 0}
    strbufopt_v_some (m, n, l, c) of strbuf_v (l, m, n)
// end of [strbufopt_v]

extern
praxi strbuf_v_uncons
  {m,n:int} {l:addr} (pf: strbuf_v (l, m, n))
  :<prf> [c:int8] @(
   char c @ l, strbufopt_v (m-1, n-1, l + sizeof(char), c)
) // end of [strbuf_v_uncons]

extern
prfun strbuf_v_split
  {m,n:int}
  {i:nat | i <= n}
  {l:addr} (
  f_str: strbuf_v (l, m, n)
) : (array_v (charNZ, l, i), strbuf_v (l+i*sizeof(char), m-i, n-i))
// end of [strbuf_v_split]

extern
prfun strbuf_v_unsplit
  {n1:nat}
  {m2,n2:nat}
  {l:addr} (
  pf_buf: array_v (charNZ, l, n1)
, pf_str: strbuf_v (l+n1*sizeof(char), m2, n2)
) : strbuf_v (n1+m2, n1+n2, l)
// end of [strbuf_v_unsplit]

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

extern
fun
strbuf_null
  {n:pos} {l:addr}
  (pf: b0ytes_v (l, n) | ptr l)
  : (strbuf_v (l, n, 0) | void)

extern
fun
strbuf_cons
  {m,n:int | n < m} // [m] and [n] must be nats
  (&strbuf (m, n) >> strbuf (m, n+1), &size_t n >> size_t (n+1), charNZ): void
// end of [strbuf_cons]

(*
extern
castfn
strbuf_strnptr_takeout
  {m,n:int} {l:addr} (
  strbuf_v (l, m, n)
| ptr l
) : (
  strnptr (l, n) -<lin,prf> strbuf_v (l, m, n)
| strnptr (l, n)
)
*)

extern
fun
strbuf_to_strnptr {m,n:int} (
  &strbuf (m, n) >> _
) : strnptr (n)

extern
fun
strbuf_to_string {m,n:int} {l:addr} (
  &strbuf (m, n) >> _
) : string (n)

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

extern
prfun lemma_sizeof_byte_char (): [sizeof(byte) == sizeof(char)] void

implement
strbuf_null
  {n} {l}
  (pf_bytes | p) = let
  prval (pf_at, pf1_bytes) = array_v_uncons {byte?} (pf_bytes)
  prval pf_at = __cast (pf_at) where {
    extern
    prfun __cast {l:addr} (x: byte? @ l): char(0)? @ l
  }
  prval () = lemma_sizeof_byte_char ()
  val () = ptr_set<char(0)> (pf_at | p, $UN.castvwtp0{char(0)}(0))
  prval pf_sbf = strbuf_v_nil (pf_at, pf1_bytes)
in
  (pf_sbf | ())
end

implement
strbuf_cons
  {m,n} // [m] and [n] must be nats
  (sbf, n, c) = let
  val p = addr@(sbf)
  prval (pf_chars, pf_sbf1) = strbuf_v_split (view@(sbf))
  prval (pf_at, pf_bytes) = strbuf_v_unnil (pf_sbf1)
  prval (pf_at, pf_sbf1opt) = strbuf_v_uncons (pf_sbf1)
  val pn = ptr_add (p, n)
  val pc = ptr_get (pf_at | pn)
in
  if iszero (pc) then let
    prval strbufopt_v_none (pf_bytes) = pf_sbf1opt
    val () = ptr_set (pf_at | ptr_add (p, n), c)
    val () = n := succ n
  in
  end else let
    prval strbufopt_v_some (pf_sbf1) = pf_sbf1opt
  in
  end

extern
praxi strbuf_v_cons
  {m,n:int} {l:addr} // [m] and [n] must be nats
  (pf1: charNZ @ l, pf2: strbuf_v (l + 1*sizeof(char), m, n))
  :<prf> strbuf_v (l, m+1, n+1)
  prval pf_

  // if the next byte is a zero
  prval pf_sbf1 = strbuf_v_cons (pf_at, pf_sbf1opt)
in

  val (
extern
praxi strbuf_v_uncons
  {m,n:int} {l:addr} (pf: strbuf_v (l, m, n))
  :<prf> [c:int8] @(
   char c @ l, strbufopt_v (m-1, n-1, l + sizeof(char), c)
) // end of [strbuf_v_uncons]
in
end
  trbuf (m, n) >> strbuf (m, n+1), &size_t n >> size_t (n+1), charNZ): void
// end of [strbuf_cons]

implement
strbuf_to_strnptr {m,n} (
  sbf
) = let
  val (fpf | s) = strbuf_strnptr_takeout (view@(sbf) | addr@(sbf))
  val s1 = strnptr_copy (s)
  prval () = view@(sbf) := fpf (s)
in
  s1
end

implement
strbuf_to_string {m,n} (
  sbf
) = let
  prval () = lemma_strbuf_v_param_nat (view@(sbf))
  val s = strbuf_to_strnptr (sbf)
  prval () = lemma_strnptr_param (s)
in
  strnptr2string (s)
end

(* ****** ****** *)
////
staload UN = "prelude/SATS/unsafe.sats"
implement
main (argc, argv) = 0 where {
  var A = @[byte][5]()
  val () = $UN.castvwtp0{byte} (0)

}

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"

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

// NOTE: one issue with these lemmas is that
// strbuf is assumed to always hold the null-terminated string
//
// it is a win when you work with strings, but it isn't when
// you only want to build up a string (in this case, to not break
// the invariant you have to put null-terminator every time
// you append a character)
//
// however, when a strbuf is being built, we really do not want
// to make it consumable as a string

absvt@ype sstrbuf_vt (int, int, addr) = (ptr, ptr, size_t)
vtypedef sstrbuf_vt0 = sstrbuf_vt (0, 0, null)?
vtypedef sstrbuf_vt1 (m:int, l:addr) = [n:int | n <= m] sstrbuf_vt (m, n, l)

extern
fun
sstrbuf_make {n:pos} {l:addr} (b0ytes_v (l, n) | ptr l, size_t n, &sstrbuf_vt0 >> sstrbuf_vt (n-1, 0, l)): void

extern
fun
sstrbuf_check {m,n:int} {l:addr} (&sstrbuf_vt (m, n, l)): size_t (m-n)

extern
fun
sstrbuf_cons {m,n:int | n <= m} {l:addr} (&sstrbuf_vt (m, n, l) >> sstrbuf_vt (m, n+1, l), charNZ): void

extern
fun
sstrbuf_free_strnptr {m,n:int} {l:addr} (
  &sstrbuf_vt (m, n, l) >> sstrbuf_vt0
) : [l1:agz] (b0ytes_v (l, m+1) | strnptr (l1, n))

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

extern
prfun lemma_sizeof_byte_char (): [sizeof(byte) == sizeof(char)] void

dataprop LTE (int, int) = {m,n:int | n <= m} LTE (m, n)

assume sstrbuf_vt (m:int, n:int, l:addr) = @(
  (array_v (charNZ, l, n), array_v (byte?, l + n*sizeof(char), m-n+1) | ptr l)
, size_t m
, (LTE (m, n) | size_t n)
) (* end of [sstrbuf_vt] *)

implement
sstrbuf_make {n} {l} (pf_bytes | p, n, sbf) = let
  prval () = lemma_array_v_param {byte?} (pf_bytes)
  prval () = $effmask_wrt (sbf.0.0 := array_v_nil {charNZ} ())
  prval () = $effmask_wrt (sbf.0.1 := pf_bytes)
  val () = sbf.0.2 := p
  val () = sbf.1 := pred (n)
  val () = sbf.2 := (LTE () | g1int2uint_int_size(0))
in
  // nothing
end

implement
sstrbuf_check {m,n} {l} (sbf) = let
  prval LTE () = sbf.2.0
in
  sbf.1 - sbf.2.1
end

// this one doesn't work
implement
sstrbuf_cons {m,n} {l} (sbf, c) = let
  prval (pf2_at, pf2_arr) = array_v_uncons {byte?} {l+n*sizeof(byte)} (sbf.0.1)
  val p1 = ptr_add<char> (sbf.0.2, sbf.2.1)
  val () = ptr_set<charNZ> (pf2_at | p1)
  val () = sbf.2 := succ (sbf.2)
  prval pf1_arr = array_v_extend (sbf.0.0, pf2_at)
  prval () = $effmask_wrt (sbf.0.0 := pf1_arr)
  prval () = $effmask_wrt (sbf.0.1 := pf2_arr)
in
  // nothing
end
////
(*
implement
sstrbuf_free_strnptr {m,n} {l} (sbf) = let
in
end

  &sstrbuf_vt (m, n, l) >> sstrbuf_vt0
) : [l1:agz] (b0ytes_v (l, m+1) | strnptr (n, l1))

implement
sstrbuf_
*)

////

extern
prfun
lemma_strbuf_v_param_nat
  {l:addr}{m,n:int} (pf: !strbuf_v (l, m, n)): [m>=0;n>=0] void

extern
praxi strbuf_v_nil
  {n:int} {l:addr} // [n] must be a nat
  (pf1: char(0) @ l, pf2: b0ytes_v (l + 1*sizeof(char), n))
  : strbuf_v (l, n+1, 0)
// end of [strbuf_v]

extern
praxi strbuf_v_unnil
  {m:pos} {l:addr}
  (pf1: strbuf_v (l, n, 0))
  : (char(0) @ l, b0ytes_v (l + 1*sizeof(char), n-1))

extern
praxi strbuf_v_cons
  {m,n:int} {l:addr} // [m] and [n] must be nats
  (pf1: charNZ @ l, pf2: strbuf_v (l + 1*sizeof(char), m, n))
  :<prf> strbuf_v (l, m+1, n+1)
// end of [strbuf_v_cons]

dataview
strbufopt_v (int, int, addr, int) =
  | {m:nat} {l:addr}
    strbufopt_v_none (m, ~1, l, 0) of b0ytes m @ l
  | {m,n:nat} {l:addr} {c:int8 | c > 0}
    strbufopt_v_some (m, n, l, c) of strbuf_v (l, m, n)
// end of [strbufopt_v]

extern
praxi strbuf_v_uncons
  {m,n:int} {l:addr} (pf: strbuf_v (l, m, n))
  :<prf> [c:int8] @(
   char c @ l, strbufopt_v (m-1, n-1, l + sizeof(char), c)
) // end of [strbuf_v_uncons]

extern
prfun strbuf_v_split
  {m,n:int}
  {i:nat | i <= n}
  {l:addr} (
  f_str: strbuf_v (l, m, n)
) : (array_v (charNZ, l, i), strbuf_v (l+i*sizeof(char), m-i, n-i))
// end of [strbuf_v_split]

extern
prfun strbuf_v_unsplit
  {n1:nat}
  {m2,n2:nat}
  {l:addr} (
  pf_buf: array_v (charNZ, l, n1)
, pf_str: strbuf_v (l+n1*sizeof(char), m2, n2)
) : strbuf_v (n1+m2, n1+n2, l)
// end of [strbuf_v_unsplit]

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

extern
fun
strbuf_null
  {n:pos} {l:addr}
  (pf: b0ytes_v (l, n) | ptr l)
  : (strbuf_v (l, n, 0) | void)

extern
fun
strbuf_cons
  {m,n:int | n < m} // [m] and [n] must be nats
  (&strbuf (m, n) >> strbuf (m, n+1), &size_t n >> size_t (n+1), charNZ): void
// end of [strbuf_cons]

(*
extern
castfn
strbuf_strnptr_takeout
  {m,n:int} {l:addr} (
  strbuf_v (l, m, n)
| ptr l
) : (
  strnptr (l, n) -<lin,prf> strbuf_v (l, m, n)
| strnptr (l, n)
)
*)

extern
fun
strbuf_to_strnptr {m,n:int} (
  &strbuf (m, n) >> _
) : strnptr (n)

extern
fun
strbuf_to_string {m,n:int} {l:addr} (
  &strbuf (m, n) >> _
) : string (n)

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

extern
prfun lemma_sizeof_byte_char (): [sizeof(byte) == sizeof(char)] void

implement
strbuf_null
  {n} {l}
  (pf_bytes | p) = let
  prval (pf_at, pf1_bytes) = array_v_uncons {byte?} (pf_bytes)
  prval pf_at = __cast (pf_at) where {
    extern
    prfun __cast {l:addr} (x: byte? @ l): char(0)? @ l
  }
  prval () = lemma_sizeof_byte_char ()
  val () = ptr_set<char(0)> (pf_at | p, $UN.castvwtp0{char(0)}(0))
  prval pf_sbf = strbuf_v_nil (pf_at, pf1_bytes)
in
  (pf_sbf | ())
end

implement
strbuf_cons
  {m,n} // [m] and [n] must be nats
  (sbf, n, c) = let
  val p = addr@(sbf)
  prval (pf_chars, pf_sbf1) = strbuf_v_split (view@(sbf))
  prval (pf_at, pf_bytes) = strbuf_v_unnil (pf_sbf1)
  prval (pf_at, pf_sbf1opt) = strbuf_v_uncons (pf_sbf1)
  val pn = ptr_add (p, n)
  val pc = ptr_get (pf_at | pn)
in
  if iszero (pc) then let
    prval strbufopt_v_none (pf_bytes) = pf_sbf1opt
    val () = ptr_set (pf_at | ptr_add (p, n), c)
    val () = n := succ n
  in
  end else let
    prval strbufopt_v_some (pf_sbf1) = pf_sbf1opt
  in
  end

extern
praxi strbuf_v_cons
  {m,n:int} {l:addr} // [m] and [n] must be nats
  (pf1: charNZ @ l, pf2: strbuf_v (l + 1*sizeof(char), m, n))
  :<prf> strbuf_v (l, m+1, n+1)
  prval pf_

  // if the next byte is a zero
  prval pf_sbf1 = strbuf_v_cons (pf_at, pf_sbf1opt)
in

  val (
extern
praxi strbuf_v_uncons
  {m,n:int} {l:addr} (pf: strbuf_v (l, m, n))
  :<prf> [c:int8] @(
   char c @ l, strbufopt_v (m-1, n-1, l + sizeof(char), c)
) // end of [strbuf_v_uncons]
in
end
  trbuf (m, n) >> strbuf (m, n+1), &size_t n >> size_t (n+1), charNZ): void
// end of [strbuf_cons]

implement
strbuf_to_strnptr {m,n} (
  sbf
) = let
  val (fpf | s) = strbuf_strnptr_takeout (view@(sbf) | addr@(sbf))
  val s1 = strnptr_copy (s)
  prval () = view@(sbf) := fpf (s)
in
  s1
end

implement
strbuf_to_string {m,n} (
  sbf
) = let
  prval () = lemma_strbuf_v_param_nat (view@(sbf))
  val s = strbuf_to_strnptr (sbf)
  prval () = lemma_strnptr_param (s)
in
  strnptr2string (s)
end

(* ****** ****** *)
////
staload UN = "prelude/SATS/unsafe.sats"
implement
main (argc, argv) = 0 where {
  var A = @[byte][5]()
  val () = $UN.castvwtp0{byte} (0)

}


Updating: adding PEULER/P3

Updating: adding PEULER/P3

(*
** Project Euler: P3
** See https://projecteuler.net
*)
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February 2, 2015
//
(* ****** ****** *)
//
#include "share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)
//
propdef ISPRIME(p:int) = PRIME(p, true)
//
(* ****** ****** *)
//
datatype
FACTORIZE(n:int) =
  | FACTprime of (ISPRIME(n) | int(n))
  | {p,q:int |
     p >= 2; q >= p; n==p*q}
    FACTcompose of (ISPRIME(p) | int(p), int(q))
//
(* ****** ****** *)
//
fun
factorize{n:int | n >= 2}(int(n)): FACTORIZE(n)
//
(* ****** ****** *)
//
fun
findMaxPrime
{n:int | n >= 2}
  (n: int(n)): [p:int] (MOD(n, p, 0), ISPRIME(p) | int(p))
//
(* ****** ****** *)

(* end of [P3.sats] *)

(*
** Project Euler: P3
** See https://projecteuler.net
*)
(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February 2, 2015
//
(* ****** ****** *)
//
#include "share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/PEULER/SATS/peuler.sats"
//
(* ****** ****** *)
//
propdef ISPRIME(p:int) = PRIME(p, true)
//
(* ****** ****** *)
//
datatype
FACTORIZE(n:int) =
  | FACTprime of (ISPRIME(n) | int(n))
  | {p,q:int |
     p >= 2; q >= p; n==p*q}
    FACTcompose of (ISPRIME(p) | int(p), int(q))
//
(* ****** ****** *)
//
fun
factorize{n:int | n >= 2}(int(n)): FACTORIZE(n)
//
(* ****** ****** *)
//
fun
findMaxPrime
{n:int | n >= 2}
  (n: int(n)): [p:nat] (MOD(n, p, 0), ISPRIME(p) | int(p))
//
(* ****** ****** *)

(* end of [P3.sats] *)


Updating: merging

Updating: merging

(*
** Proving that
** the 3 altitudes of a triangle
** are concurrent
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
//
(* ****** ****** *)

stacst x1: real
stacst y1: real // A: (x1, y1)
stacst x2: real
stacst y2: real // B: (x2, y2)
stacst x3: real
stacst y3: real // C: (x3, y3)

(* ****** ****** *)
//
stadef x12 = (x1 + x2) / 2
stadef y12 = (y1 + y2) / 2
//
stadef x23 = (x2 + x3) / 2
stadef y23 = (y2 + y3) / 2
//
stadef x31 = (x3 + x1) / 2
stadef y31 = (y3 + y1) / 2
//
(* ****** ****** *)
//
stadef
A_med(x: real, y: real) = (x-x1)*(y23-y1)-(y-y1)*(x23-x1)
stadef
B_med(x: real, y: real) = (x-x2)*(y31-y2)-(y-y2)*(x31-x2)
stadef
C_med(x: real, y: real) = (x-x3)*(y12-y3)-(y-y3)*(x12-x3)
//
(* ****** ****** *)
//
extern
prfun
MainLemma
{ x,y:real
| A_med(x, y)==0 && B_med(x, y)==0
} ((*void*)): [C_med(x, y)==0] void
//
(* ****** ****** *)
//
primplmnt MainLemma{x,y}() = ()
//
(* ****** ****** *)

(* end of [ConcurrentMedians.dats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(*
** HX-2014:
** Toplevel array-based deque
*)

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

staload D =
{
//
typedef T = double
//
#define CAPACITY1 1024
//
#include "./../HATS/gdeqarray.hats"
//
} (* end of [staload] *)

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

implement
main0 () =
{
//
val () =
println! ("$D.get_size() = ", $D.get_size())
val () =
println! ("$D.get_capacity() = ", $D.get_capacity())
//
val () =
$D.insert_atbeg_exn (1.0)
val-~None_vt() =
$D.insert_atbeg_opt (2.0)
val () = println! ("$D.get_size() = ", $D.get_size())
//
val x1 =
  $D.takeout_atend_exn ()
val () = assertloc (x1 = 1.0)
val-~Some_vt(x2) =
  $D.takeout_atend_opt ()
val () = assertloc (x2 = 2.0)
val () = println! ("$D.get_size() = ", $D.get_size())
//
} (* end of [main0] *)

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

(* end of [test04.dats] *)

(*
** HX-2014:
** Toplevel array-based deque
*)

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

staload D =
{
//
typedef T = double
//
#define CAPACITY1 1024
//
#include "./../HATS/gdeqarray.hats"
//
} (* end of [staload] *)

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

implement
main0 () =
{
//
val () =
println! ("$D.get_size() = ", $D.get_size())
val () =
println! ("$D.get_capacity() = ", $D.get_capacity())
//
val () = $D.insert_atbeg_exn (1.0)
val-~None_vt() = $D.insert_atbeg_opt (2.0)
val () = println! ("$D.get_size() = ", $D.get_size())
val x1 = $D.takeout_atend_exn ()
val () = assertloc (x1 = 1.0)
val-~Some_vt (x2) = $D.takeout_atend_opt ()
val () = assertloc (x2 = 2.0)
val () = println! ("$D.get_size() = ", $D.get_size())
//
} (* end of [main0] *)

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

(* end of [test04.dats] *)


Updating: minorly tidying-up

Updating: minorly tidying-up

(*
** Copyright (C) 2011 Chris Double.
**
** 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
** Time: May, 2014
**
** Ported the original code by Chris Double to ATS2
*)

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

staload "./../SATS/event.sats"

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

fun
get_request_result
(
  req: !evhttp1_request
) : Strptr1 = src2 where
{
//
val (fpf_buf | buf) =
  evhttp_request_get_input_buffer (req)
(*
val len = evbuffer_get_length (buf)
*)
val ssz = g0i2i(~1)
val (fpf_src | src) = evbuffer_pullup (buf, ssz)
val () = assertloc (isneqz(src))
val src2 = string0_copy ($UN.strptr2string(src))
prval () = fpf_src (src)
prval () = minus_addback (fpf_buf, buf | req)
//
} (* end of [get_request_result] *)
//
(* ****** ****** *)

vtypedef
myenv (l:addr) = @{
  bas= event_base(l)
, cnn= Option_vt (evhttp1_connection), cbk= string -> void
} (* end of [myenv] *)

viewtypedef myenv1 = [l:addr | l > null] myenv(l)

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

extern
fun download_renew_request (url: string, env: &myenv1 >> _): void

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

fun
document_moved
(
  req: !evhttp1_request, env: &myenv1 >> _
) : void = () where
{
  val (fpf_headers | headers) =
    evhttp_request_get_input_headers(req)
  val (fpf_location | location) =
    evhttp_find_header(headers, "Location")
  val () = assertloc (isneqz(location))
  val () = println! ("Moved to ", $UN.strptr2string(location))
  val () = download_renew_request ($UN.strptr2string(location), env)
  prval () = fpf_location (location)
  prval () = minus_addback (fpf_headers, headers | req)
} (* end of [document_moved] *)

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

fun document_okay
(
  req: !evhttp1_request, env: &myenv1
) : void = let
  val result = get_request_result (req)
  val ((*void*)) = env.cbk($UN.strptr2string(result))
  val ((*void*)) = strptr_free(result)
in
  ignoret(event_base_loopexit(env.bas, $UN.cast{cPtr0(timeval)}(0)))
end // end of [document_okay]

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

fun document_error
(
  req: !evhttp1_request, env: &myenv1
) :void = let
  val () = println! ("error!")
in
  ignoret(event_base_loopexit(env.bas, $UN.cast{cPtr0(timeval)}(0)))
end // end of [document_error]

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

fun
download_callback
(
  req: !evhttp1_request, env: &myenv1 >> _
) : void = let
  val code = evhttp_request_get_response_code (req)
in
//
case+ 0 of
| _ when code = HTTP_OK => document_okay (req, env)
| _ when code = HTTP_MOVEPERM => document_moved (req, env)
| _ when code = HTTP_MOVETEMP => document_moved (req, env)
| _ (*all-the-rest*) => document_error (req, env)
//
end // end of [download_callback]

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

fun
download_url
(
  url: string
) : void = () where
{
  var env: myenv(null)?
  val evb = event_base_new()
  val () = assertlocmsg(isneqz(evb), "[event_base_new] failed")
  val () = env.bas := evb
  val () = env.cnn := None_vt(*void*)
  val () = env.cbk := (lam (msg: string): void => println! (msg))
//
  val () = download_renew_request (url, env)
//
  val err = // -1/0/1
    event_base_dispatch (env.bas)
  val () = (
    case+ env.cnn of
    | ~Some_vt(cnn) => evhttp_connection_free (cnn) | ~None_vt () => ()
  ) : void // end of [val]
  val () = event_base_free (env.bas)
  prval ((*void*)) = topize (env.cbk)
} (* end of [download_url] *)

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

implement
download_renew_request
  (url, env) = () where
{
//
val uri = evhttp_uri_parse (url)
val () = assertlocmsg (isneqz(uri), "[evhttp_uri_parse] failed")
val (fpf_host | host) = evhttp_uri_get_host (uri)
val () = assertlocmsg (isneqz(host), "[evhttp_uri_parse] failed")
val port = evhttp_uri_get_port (uri)
val port = (if (port >= 0) then g0i2u(port) else 80u): uint
val cnn = evhttp_connection_base_new(env.bas,
                                    the_null_ptr,
                                    $UN.strptr2string(host),
                                    $UN.cast{uint16}(port))
val () = assertlocmsg (isneqz(cnn), "[evhttp_connection_base_new] failed")

val req = evhttp_request_new1_ref {myenv1} (download_callback, env)

val () = assertlocmsg (isneqz(req), "evhttp_request_new failed")
//
val (fpf_headers | headers) =
  evhttp_request_get_output_headers(req)
val err = evhttp_add_header (headers, "Host", $UN.strptr2string(host))
prval () = minus_addback (fpf_headers, headers | req)
//
prval () = fpf_host (host)
//
val err =
  evhttp_make_request(cnn, req, EVHTTP_REQ_GET, "/")
val () = (
  case+ env.cnn of
  | ~Some_vt (c) => evhttp_connection_free(c) | ~None_vt () => ()
) : void // end of [val]
val () = env.cnn := Some_vt(cnn)
val ((*freed*)) = evhttp_uri_free(uri)
//
} (* end of [download_renew_request] *)

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

implement
main0 (argc, argv) =
(
  if argc < 2
    then
      println! ("usage: ", argv[0], " http://example.com/")
    else download_url (argv[1])
  // end of [if]
) (* end of [main0] *)

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

(* end of [test_download.dats] *)

(*
** Copyright (C) 2011 Chris Double.
**
** 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
** Time: May, 2014
**
** Ported the original code by Chris Double to ATS2
*)

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

staload "./../SATS/event.sats"

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

fun
get_request_result
(
  req: !evhttp1_request
) : Strptr1 = src2 where
{
//
val (fpf_buf | buf) =
  evhttp_request_get_input_buffer (req)
(*
val len = evbuffer_get_length (buf)
*)
val ssz = g0i2i(~1)
val (fpf_src | src) = evbuffer_pullup (buf, ssz)
val () = assertloc (isneqz(src))
val src2 = string0_copy ($UN.strptr2string(src))
prval () = fpf_src (src)
prval () = minus_addback (fpf_buf, buf | req)
//
} (* end of [get_request_result] *)
//
(* ****** ****** *)

vtypedef
myenv (l:addr) = @{
  base= event_base(l)
, cn= Option_vt (evhttp1_connection), cb= string -> void
} (* end of [myenv] *)

viewtypedef myenv1 = [l:addr | l > null] myenv(l)

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

extern
fun download_renew_request (url: string, env: &myenv1 >> _): void

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

fun
document_moved
(
  req: !evhttp1_request, env: &myenv1 >> _
) : void = () where
{
  val (fpf_headers | headers) =
    evhttp_request_get_input_headers(req)
  val (fpf_location | location) =
    evhttp_find_header(headers, "Location")
  val () = assertloc (isneqz(location))
  val () = println! ("Moved to ", $UN.strptr2string(location))
  val () = download_renew_request ($UN.strptr2string(location), env)
  prval () = fpf_location (location)
  prval () = minus_addback (fpf_headers, headers | req)
} (* end of [document_moved] *)

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

fun document_okay
(
  req: !evhttp1_request, env: &myenv1
) : void = let
  val result = get_request_result (req)
  val ((*void*)) = env.cb($UN.strptr2string(result))
  val ((*void*)) = strptr_free(result)
in
  ignoret(event_base_loopexit(env.base, $UN.cast{cPtr0(timeval)}(0)))
end // end of [document_okay]

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

fun document_error
(
  req: !evhttp1_request, env: &myenv1
) :void = let
  val () = println! ("error!")
in
  ignoret(event_base_loopexit(env.base, $UN.cast{cPtr0(timeval)}(0)))
end // end of [document_error]

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

fun
download_callback
(
  req: !evhttp1_request, env: &myenv1 >> _
) : void = let
  val code = evhttp_request_get_response_code (req)
in
//
case+ 0 of
| _ when code = HTTP_OK => document_okay (req, env)
| _ when code = HTTP_MOVEPERM => document_moved (req, env)
| _ when code = HTTP_MOVETEMP => document_moved (req, env)
| _ (*all-the-rest*) => document_error (req, env)
//
end // end of [download_callback]

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

fun
download_url
(
  url: string
) : void = () where
{
  var env: myenv(null)?
  val evb = event_base_new()
  val () = assertlocmsg(isneqz(evb), "[event_base_new] failed")
  val () = env.base := evb
  val () = env.cn := None_vt(*void*)
  val () = env.cb := (lam (msg: string): void => println! (msg))
//
  val () = download_renew_request (url, env)
//
  val err = // -1/0/1
    event_base_dispatch (env.base)
  val () = (
    case+ env.cn of
    | ~Some_vt(c) => evhttp_connection_free (c) | ~None_vt () => ()
  ) : void // end of [val]
  val () = event_base_free (env.base)
  prval ((*void*)) = topize (env.cb)
} (* end of [download_url] *)

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

implement
download_renew_request
  (url, env) = () where
{
  val uri = evhttp_uri_parse (url)
  val () = assertlocmsg (isneqz(uri), "[evhttp_uri_parse] failed")
  val (fpf_host | host) = evhttp_uri_get_host (uri)
  val () = assertlocmsg (isneqz(host), "[evhttp_uri_parse] failed")
  val port = evhttp_uri_get_port (uri)
  val port = (if (port >= 0) then g0i2u(port) else 80u): uint
  val cn = evhttp_connection_base_new(env.base,
                                      the_null_ptr,
                                      $UN.strptr2string(host),
                                      $UN.cast{uint16}(port))
  val () = assertlocmsg (isneqz(cn), "[evhttp_connection_base_new] failed")

  val req = evhttp_request_new1_ref {myenv1} (download_callback, env)

  val () = assertlocmsg (isneqz(req), "evhttp_request_new failed")
//
  val (fpf_headers | headers) =
    evhttp_request_get_output_headers(req)
  val err = evhttp_add_header (headers, "Host", $UN.strptr2string(host))
  prval () = minus_addback (fpf_headers, headers | req)
//
  prval () = fpf_host (host)
//
  val _ = evhttp_make_request(cn, req, EVHTTP_REQ_GET, "/")
  val () = (
    case+ env.cn of
    | ~Some_vt (c) => evhttp_connection_free(c) | ~None_vt () => ()
  ) : void // end of [val]
  val () = env.cn := Some_vt(cn)
  val ((*freed*)) = evhttp_uri_free(uri)
} (* end of [download_renew_request] *)

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

implement
main0 (argc, argv) =
(
  if argc < 2
    then
      println! ("usage: ", argv[0], " http://example.com/")
    else download_url (argv[1])
  // end of [if]
) (* end of [main0] *)

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

(* end of [test_download.dats] *)


Updating: merging

Updating: merging

(*
** 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: minorly fixing due to renaming

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "./atsparemit.sats"

(* ****** ****** *)
//
extern
fun
typedef_insert
  (name: symbol, def: tyrec): void
//
(* ****** ****** *)
//
extern
fun
typedef_search_opt (name: symbol): Option_vt (tyrec)
//
(* ****** ****** *)

staload TYPEDEF =
{
//
#include
"share/atspre_define.hats"
//
staload "./atsparemit.sats"
//
typedef key = symbol and itm = tyrec
//
implement
gequal_val_val<key> (k1, k2) = (k1 = k2)
//
staload
"libats/SATS/hashtbl_chain.sats"
//
implement
hash_key<key> (sym) =
//
// HX: [gidentity] is called to avoid a bug
//
  gidentity(hash_key<string>(symbol_get_name(sym)))
//
implement hashtbl$recapacitize<> () = 1(*resizable*)
//
#define CAPACITY 1024
//
#include "{$LIBATSHWXI}/globals/HATS/ghashtbl_chain.hats"
//
} (* end of [staload] *)

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

implement
typedef_insert
  (name, def) = let
(*
//
val () =
  println! ("typedef_insert")
//
*)
in
//
$TYPEDEF.insert_any (name, def)
//
end // end of [typedef_insert]

(* ****** ****** *)
//
implement
typedef_search_opt
  (name) = $TYPEDEF.search_opt (name)
//
(* ****** ****** *)

(* end of [atsparemit_typedef.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "./atsparemit.sats"

(* ****** ****** *)
//
extern
fun
typedef_insert
  (name: symbol, def: tyrec): void
//
(* ****** ****** *)
//
extern
fun
typedef_search_opt (name: symbol): Option_vt (tyrec)
//
(* ****** ****** *)

staload TYPEDEF =
{
//
#include
"share/atspre_define.hats"
//
staload "./atsparemit.sats"
//
typedef key = symbol and itm = tyrec
//
implement
gequal_val<key> (k1, k2) = (k1 = k2)
//
staload
"libats/SATS/hashtbl_chain.sats"
//
implement
hash_key<key> (sym) =
//
// HX: [gidentity] is called to avoid a bug
//
  gidentity(hash_key<string>(symbol_get_name(sym)))
//
implement hashtbl$recapacitize<> () = 1(*resizable*)
//
#define CAPACITY 1024
//
#include "{$LIBATSHWXI}/globals/HATS/ghashtbl_chain.hats"
//
} (* end of [staload] *)

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

implement
typedef_insert
  (name, def) = let
(*
//
val () =
  println! ("typedef_insert")
//
*)
in
//
$TYPEDEF.insert_any (name, def)
//
end // end of [typedef_insert]

(* ****** ****** *)
//
implement
typedef_search_opt
  (name) = $TYPEDEF.search_opt (name)
//
(* ****** ****** *)

(* end of [atsparemit_typedef.dats] *)


Simplifying numtokens function

Simplifying numtokens function

staload UN = "prelude/SATS/unsafe.sats"

staload "contrib/libats-/wdblair/jsmn/SATS/jsmn.sats"

implement
jsmntokptr_numtokens (jsv) =
    if jsv.type = JSMN_PRIMITIVE then let
    in
        1
    end
    else if jsv.type = JSMN_STRING then let
    in
        1
    end
    else if jsv.type = JSMN_ARRAY orelse
               jsv.type = JSMN_OBJECT then let
        val stop = jsv.ending

        fun loop (jsv: jsmntokptr, n:int): int = let
            val p = $UN.cast{ptr} (jsv)
            val p = add_ptr_bsz (p, sizeof<jsmntok_t>)
            val next = $UN.cast{jsmntokptr}(p)
            val ending = next.ending
        in
            if ending > stop orelse ending = 0 then
                n
            else
                loop (next, succ(n))
        end

     in
          loop (jsv, 1)
     end

     else let
         val () = prerrln! ("Invalid json value.")
         val () = prerrln! ("Has type: ", jsv.type)
         val () = println! ("Invalid json value starts @ ", jsv.start)
     in
         ~1
     end

staload UN = "prelude/SATS/unsafe.sats"

staload "contrib/libats-/wdblair/jsmn/SATS/jsmn.sats"

implement
jsmntokptr_numtokens (jsv) =
    if jsv.type = JSMN_PRIMITIVE then let
    in
        1
    end
    else if jsv.type = JSMN_STRING then let
    in
        1
    end
    else if jsv.type = JSMN_ARRAY then let
        //
        fun loop (jsv: jsmntokptr, i: int, n:int): int =
            if i = jsmntok_size (jsv) then let
            in
                n
            end
            else let
                val p = $UN.cast{ptr} (jsv)
                val ofs =  g0i2u(n)*sizeof<jsmntok_t>
                val nextjsv = $UN.cast{jsmntokptr} (add_ptr_bsz(p, ofs))
                val objectsize = jsmntokptr_numtokens (nextjsv)
                val nextoffset = n + objectsize
            in
                loop (jsv, succ (i), nextoffset)
            end
        //
    in
        loop (jsv, 0, 1)
    end
    else if jsv.type = JSMN_OBJECT then let

        fun loop (jsv: jsmntokptr, i: int, n: int): int =
            if i = jsmntok_size (jsv) then
                n
            else let
                val p =  $UN.cast{ptr}(jsv)
                val keyofs =  g0i2u(n)*sizeof<jsmntok_t>
                val keyjsv = $UN.cast{jsmntokptr}(add_ptr_bsz(p, keyofs))
                val keysize = jsmntokptr_numtokens (keyjsv)
                //
                val valueofs = g0i2u(n + keysize) * sizeof<jsmntok_t>
                val valuejsv = $UN.cast{jsmntokptr}(add_ptr_bsz(p, valueofs))
                val valuesize = jsmntokptr_numtokens (valuejsv)
            in
                loop (jsv, succ(i), n + keysize + valuesize)
            end
     in
         loop (jsv, 0, 1)
     end
     else let
         val () = prerrln! ("Invalid json value.")
         val () = prerrln! ("Has type: ", jsv.type)
         val () = println! ("Invalid json value starts @ ", jsv.start)
     in
         ~1
     end


Upating: minorly tidying-up

Upating: minorly tidying-up

//
// Animating Quicksort
//
(* ****** ****** *)
//
#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/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_chain.sats"
//
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_chain.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/testing/SATS/randgen.sats"
staload _ =
"{$LIBATSHWXI}/testing/DATS/randgen.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/teaching/BUCS/DATS/BUCS.dats"
//
(* ****** ****** *)

#define MYMAX 100

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

typedef int2 = (int, int)

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

local
//
val theExchlst =
  ref<list0(int2)> (nil0())
//
in (* in-of-local *)

fun
theExchlst_add
  (i1: int, i2: int): void =
(
  !theExchlst := cons0 ((i1, i2), !theExchlst)
)

fun
theExchlst_get_all
(
// argumentlst
) : list0(int2) = let
  val xys = !theExchlst
  val ((*void*)) = !theExchlst := nil0((*void*))
in
  list0_reverse (xys)
end // end of [theExchlst_get_all]

end // end of [local]

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

extern
fun{
a:t@ype
} array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

implement
{a}(*tmp*)
array0_swap
  (A, i, j) =
{
  val tmp = A[i]
  val () = A[i] := A[j]
  val () = A[j] := tmp
  val () = theExchlst_add (sz2i(i), sz2i(j))
}

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

extern
fun{
a:t@ype
} quicksort (A: array0 (a)): void

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

extern
fun{
a:t@ype
} quicksort2
(
  A: array0 (a), st: size_t, len: size_t
) : void // end of [quicksort2]

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

extern
fun{a:t@ype}
qsort_partition
(
  A: array0 (a), st: size_t, len: size_t
) : size_t // end of [qsort_partition]

(* ****** ****** *)
//
implement
{a}(*tmp*)
quicksort (A) =
  quicksort2 (A, i2sz(0), A.size)
//
(* ****** ****** *)

implement
{a}(*tmp*)
quicksort2 (A, st, len) =
(
if
len >= 2
then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = quicksort2<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = quicksort2<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end // end of [then]
else () // end of [else]
//
) (* end of [qsort] *)

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

implement
{a}(*tmp*)
qsort_partition
  (A, st, len) = let
//
val len = g1ofg0 (len)
val () = assertloc (len > 0)
val last = pred (st + len)
val pind = st + i2sz(randint(sz2i(len)))
val () = array0_swap (A, pind, last)
val pivot = A[last]
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else (k1) // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

local

implement
randgen_val<int> () = randint (MYMAX)

in (* in-of-local *)

fun
genScript{n:int}
(
  out: FILEref, asz: size_t(n)
) :
(
  array0 (int), list0(int2)
) = let
//
val A =
randgen_arrayref<int> (asz)
//
val A = array0 (A, asz)
val A2 = array0_copy (A)
//
val () = quicksort (A2)
//
(*
val () = fprint (out, A, asz)
val () = fprint_newline (out)
val () = fprint (out, A2, asz)
val () = fprint_newline (out)
*)
//
in
  (A, theExchlst_get_all ())
end (* end of [genScript] *)

end // end of [local]

(* ****** ****** *)
//
staload "{$CAIRO}/SATS/cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw.sats"
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw_cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_bargraph.dats"
//
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw.dats"
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_cairo.dats"
//
(* ****** ****** *)
//
staload "{$LIBATSHWXI}/teaching/myGTK/SATS/gtkcairotimer.sats"
staload "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_toplevel.dats"
//
staload CP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/ControlPanel.dats"
staload DP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/DrawingPanel.dats"
staload MAIN = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_main.dats"
staload TIMER = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_timer.dats"
//
(* ****** ****** *)

dynload "./gtkcairotimer_toplevel.dats"

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

local
//
val () = srandom_with_time ()
//
val xy0 = ref<int2> ((~1, 0))
//
val (A0, xys0) =
  genScript (stdout_ref, i2sz(96))
//
val theExchlst2 = ref<list0(int2)> (xys0)
//
in (* in-of-local *)

val ASZ = array0_copy (A0)

extern
fun
ASZ_reset (): void
implement
ASZ_reset () = {
//
val () = srandom_with_time ()
//
var i: size_t
val () = !xy0 := ((~1, 0))
val () = for (i := i2sz(0); i < A0.size; i := succ(i)) ASZ[i] := A0[i]
val () = !theExchlst2 := xys0
//
} (* end of [ASZ_reset] *)

extern
fun
ASZ_update (): void
implement
ASZ_update () = let
//
  val ij = !xy0
  val xys = !theExchlst2
//
  val () = (
    case+ xys of
    | nil0 () => !xy0 := ((~1, 0))
    | cons0 (xy, xys) => (!xy0 := xy; !theExchlst2 := xys)
  ) (* end of [val] *)
//
  val i = ij.0 and j = ij.1
//
in
  if i >= 0 then array0_interchange (ASZ, g0i2u(i), g0i2u(j))
end (* end of [ASZ_update] *)

end // end of [local]

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

implement
the_timer_reset_after<> () = ASZ_reset ()

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

extern
fun
cairo_draw_array0
(
  cr: !cairo_ref1
, point, point, point, point, array0(int)
) : void // end-of-fun

(* ****** ****** *)
//
extern
fun
colorgen (x: int): color
//
implement
colorgen (x) = let
//
  val x = $UN.cast{uint32}(x)
  val hval = $extfcall (uint32, "atslib_inthash_jenkins", x)
  val hval = $UN.cast{uint}(hval)
//
  val r = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val g = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val b = $UN.cast{int}(hval mod 256u)
//
in
  color_make (r/256.0, g/256.0, b/256.0)
end // end of [colorgen]
//
(* ****** ****** *)

implement
cairo_draw_array0
(
  cr, p1, p2, p3, p4, ASZ
) = let
//
val p_cr = ptrcast (cr)
//
implement
mydraw_get0_cairo<> () = let
//
extern
castfn __cast {l:addr} (ptr(l)): vttakeout (void, cairo_ref(l))
//
in
  __cast (p_cr)
end // end of [mydraw_get0_cairo]
//
implement
mydraw_bargraph$color<> (i) = colorgen (ASZ[i])

implement
mydraw_bargraph$height<> (i) = 1.0 * (ASZ[i]+1) / MYMAX
//
val asz = ASZ.size
val asz = sz2i (asz)
val asz = ckastloc_gintGt (asz, 0)
//
in
  mydraw_bargraph (asz, p1, p2, p3, p4)
end // end of [cairo_draw_array0]

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

extern
fun
mydraw_clock
  (cr: !cairo_ref1, width: int, height: int) : void
// end of [mydraw_clock]

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

implement
mydraw_clock
  (cr, W, H) = let
//
val W =
g0int2float_int_double(W)
and H =
g0int2float_int_double(H)
//
val WH = min (W, H)
//
val xm = (W - WH) / 2
val ym = (H - WH) / 2
//
val v0 = vector_make (xm, ym)
//
val p1 = point_make (0. , WH) + v0
val p2 = point_make (WH , WH) + v0
val p3 = point_make (WH , 0.) + v0
val p4 = point_make (0. , 0.) + v0
//
val () =
if the_timer_is_running () then ASZ_update ()
//
val (pf | ()) = cairo_save (cr)
val () = cairo_draw_array0 (cr, p1, p2, p3, p4, ASZ)
val ((*void*)) = cairo_restore (pf | cr)
//
in
  // nothing
end // [mydraw_clock]

(* ****** ****** *)
//
%{^
typedef char **charptrptr ;
%} ;
abstype charptrptr = $extype"charptrptr"
//
(* ****** ****** *)

implement
main0{n}
(
  argc, argv
) = let
//
var argc: int = argc
var argv: charptrptr = $UN.castvwtp1{charptrptr}(argv)
//
val () = $extfcall (void, "gtk_init", addr@(argc), addr@(argv))
//
implement
gtkcairotimer_title<>
(
// argumentless
) = stropt_some"QuicksortAnimation"
implement
gtkcairotimer_timeout_interval<> () = 100U // millisecs
implement
gtkcairotimer_mydraw<> (cr, width, height) = mydraw_clock (cr, width, height)
//
val ((*void*)) = gtkcairotimer_main ((*void*))
//
in
  // nothing
end // end of [main0]

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

(* end of [quicksort_anim2.dats] *)

//
// Animating Quicksort
//
(* ****** ****** *)
//
#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/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_chain.sats"
//
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_chain.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/testing/SATS/randgen.sats"
staload _ =
"{$LIBATSHWXI}/testing/DATS/randgen.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/teaching/BUCS/DATS/BUCS.dats"
//
(* ****** ****** *)

#define MYMAX 100

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

typedef int2 = (int, int)

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

local

val theExchlst =
  ref<List0(int2)> (list_nil)

in (* in-of-local *)

fun theExchlst_add
  (i1: int, i2: int): void =
(
  !theExchlst := cons ((i1, i2), !theExchlst)
)
fun
theExchlst_get_all
(
// argumentlst
) : List0(int2) = let
  val xys = !theExchlst
  val ((*void*)) = !theExchlst := nil ()
in
  list_vt2t (list_reverse (xys))
end // end of [theExchlst_get_all]

end // end of [local]

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

extern
fun{
a:t@ype
} array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

implement
{a}(*tmp*)
array0_swap
  (A, i, j) =
{
  val tmp = A[i]
  val () = A[i] := A[j]
  val () = A[j] := tmp
  val () = theExchlst_add (sz2i(i), sz2i(j))
}

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

extern
fun{
a:t@ype
} quicksort (A: array0 (a)): void

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

extern
fun{
a:t@ype
} quicksort2
(
  A: array0 (a), st: size_t, len: size_t
) : void // end of [quicksort2]

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

extern
fun{a:t@ype}
qsort_partition
(
  A: array0 (a), st: size_t, len: size_t
) : size_t // end of [qsort_partition]

(* ****** ****** *)
//
implement
{a}(*tmp*)
quicksort (A) =
  quicksort2 (A, i2sz(0), A.size)
//
(* ****** ****** *)

implement
{a}(*tmp*)
quicksort2 (A, st, len) =
(
if
len >= 2
then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = quicksort2<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = quicksort2<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end // end of [then]
else () // end of [else]
//
) (* end of [qsort] *)

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

implement
{a}(*tmp*)
qsort_partition
  (A, st, len) = let
//
val len = g1ofg0 (len)
val () = assertloc (len > 0)
val last = pred (st + len)
val pind = st + i2sz(randint(sz2i(len)))
val () = array0_swap (A, pind, last)
val pivot = A[last]
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else k1 // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

local

implement
randgen_val<int> () = randint (MYMAX)

in (* in-of-local *)

fun
genScript{n:int}
(
  out: FILEref, asz: size_t(n)
) :
(
  array0 (int), List0(int2)
) = let
//
val A =
randgen_arrayref<int> (asz)
//
val A = array0 (A, asz)
val A2 = array0_copy (A)
//
val () = quicksort (A2)
//
(*
val () = fprint (out, A, asz)
val () = fprint_newline (out)
val () = fprint (out, A2, asz)
val () = fprint_newline (out)
*)
//
in
  (A, theExchlst_get_all ())
end (* end of [genScript] *)

end // end of [local]

(* ****** ****** *)
//
staload "{$CAIRO}/SATS/cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw.sats"
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw_cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_bargraph.dats"
//
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw.dats"
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_cairo.dats"
//
(* ****** ****** *)
//
staload "{$LIBATSHWXI}/teaching/myGTK/SATS/gtkcairotimer.sats"
staload "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_toplevel.dats"
//
staload CP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/ControlPanel.dats"
staload DP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/DrawingPanel.dats"
staload MAIN = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_main.dats"
staload TIMER = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_timer.dats"
//
(* ****** ****** *)

dynload "./gtkcairotimer_toplevel.dats"

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

local
//
val () = srandom_with_time ()
//
val xy0 = ref<int2> ((~1, 0))
//
val (A0, xys0) =
  genScript (stdout_ref, i2sz(96))
//
val theExchlst2 = ref<List0(int2)> (xys0)
//
in (* in-of-local *)

val ASZ = array0_copy (A0)

extern
fun
ASZ_reset (): void
implement
ASZ_reset () = {
//
val () = srandom_with_time ()
//
var i: size_t
val () = !xy0 := ((~1, 0))
val () = for (i := i2sz(0); i < A0.size; i := succ(i)) ASZ[i] := A0[i]
val () = !theExchlst2 := xys0
//
} (* end of [ASZ_reset] *)

extern
fun
ASZ_update (): void
implement
ASZ_update () = let
//
  val ij = !xy0
  val xys = !theExchlst2
//
  val () = (
    case+ xys of
    | nil () => !xy0 := ((~1, 0))
    | cons (xy, xys) => (!xy0 := xy; !theExchlst2 := xys)
  ) (* end of [val] *)
//
  val i = ij.0 and j = ij.1
//
in
  if i >= 0 then array0_interchange (ASZ, g0i2u(i), g0i2u(j))
end (* end of [ASZ_update] *)

end // end of [local]

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

implement
the_timer_reset_after<> () = ASZ_reset ()

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

extern
fun
cairo_draw_array0
(
  cr: !cairo_ref1
, point, point, point, point, array0(int)
) : void // end-of-fun

(* ****** ****** *)
//
extern
fun
colorgen (x: int): color
//
implement
colorgen (x) = let
//
  val x = $UN.cast{uint32}(x)
  val hval = $extfcall (uint32, "atslib_inthash_jenkins", x)
  val hval = $UN.cast{uint}(hval)
//
  val r = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val g = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val b = $UN.cast{int}(hval mod 256u)
//
in
  color_make (r/256.0, g/256.0, b/256.0)
end // end of [colorgen]
//
(* ****** ****** *)

implement
cairo_draw_array0
(
  cr, p1, p2, p3, p4, ASZ
) = let
//
val p_cr = ptrcast (cr)
//
implement
mydraw_get0_cairo<> () = let
//
extern
castfn __cast {l:addr} (ptr(l)): vttakeout (void, cairo_ref(l))
//
in
  __cast (p_cr)
end // end of [mydraw_get0_cairo]
//
implement
mydraw_bargraph$color<> (i) = colorgen (ASZ[i])

implement
mydraw_bargraph$height<> (i) = 1.0 * (ASZ[i]+1) / MYMAX
//
val asz = ASZ.size
val asz = sz2i (asz)
val asz = ckastloc_gintGt (asz, 0)
//
in
  mydraw_bargraph (asz, p1, p2, p3, p4)
end // end of [cairo_draw_array0]

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

extern
fun
mydraw_clock
  (cr: !cairo_ref1, width: int, height: int) : void
// end of [mydraw_clock]

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

implement
mydraw_clock
  (cr, W, H) = let
//
val W =
g0int2float_int_double(W)
and H =
g0int2float_int_double(H)
//
val WH = min (W, H)
//
val xm = (W - WH) / 2
val ym = (H - WH) / 2
//
val v0 = vector_make (xm, ym)
//
val p1 = point_make (0. , WH) + v0
val p2 = point_make (WH , WH) + v0
val p3 = point_make (WH , 0.) + v0
val p4 = point_make (0. , 0.) + v0
//
val () =
if the_timer_is_running () then ASZ_update ()
//
val (pf | ()) = cairo_save (cr)
val () = cairo_draw_array0 (cr, p1, p2, p3, p4, ASZ)
val ((*void*)) = cairo_restore (pf | cr)
//
in
  // nothing
end // [mydraw_clock]

(* ****** ****** *)
//
%{^
typedef char **charptrptr ;
%} ;
abstype charptrptr = $extype"charptrptr"
//
(* ****** ****** *)

implement
main0{n}
(
  argc, argv
) = let
//
var argc: int = argc
var argv: charptrptr = $UN.castvwtp1{charptrptr}(argv)
//
val () = $extfcall (void, "gtk_init", addr@(argc), addr@(argv))
//
implement
gtkcairotimer_title<> () = stropt_some"InsertionSort"
implement
gtkcairotimer_timeout_interval<> () = 100U // millisecs
implement
gtkcairotimer_mydraw<> (cr, width, height) = mydraw_clock (cr, width, height)
//
val ((*void*)) = gtkcairotimer_main ((*void*))
//
in
  // nothing
end // end of [main0]

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

(* end of [insertsort_anim2.dats] *)