Updating: very minorly improving

Updating: very minorly improving

(*
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
** OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
** NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
** HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
** WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
** OTHER DEALINGS IN THE SOFTWARE.
*)

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

(*
** A library for
** parsing combinators in CPS-stype
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: December, 2015
//
(* ****** ****** *)
//
abstype
kparser_type(a:t@ype+) = ptr
//
typedef
kparser(a:t@ype) = kparser_type(a)
//
(* ****** ****** *)
//
typedef
cfun1(a:t@ype, b:t@ype) = (a) -<cloref1> b
typedef
cfun2(a1:t@ype, a2:t@ype, b:t@ype) = (a1, a2) -<cloref1> b
typedef
cfun3(a1:t@ype, a2:t@ype, a3:t@ype, b:t@ype) = (a1, a2, a3) -<cloref1> b
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_fail(): kparser(a)
//
extern
fun
{a:t@ype}
kparser_just(x: a): kparser(a)
//
(* ****** ****** *)

extern
fun
{a:t@ype}
kparser_satisfy
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(a) // end-of-fun

(* ****** ****** *)
//
extern
fun
{a1
,a2:t@ype}
kparser_join2
(
  kparser(INV(a1)), kparser(INV(a2))
) : kparser(@(a1, a2)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype}
kparser_join3
(
  kparser(INV(a1)), kparser(INV(a2)), kparser(INV(a3))
) : kparser(@(a1, a2, a3)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
{b:t@ype}
kparser_fmap
  (kparser(INV(a)), fopr: cfun1(a, b)) : kparser(b)
//
extern
fun
{a1
,a2:t@ype
}{b:t@ype}
kparser_fmap2
(
  kparser(INV(a1)), kparser(INV(a2)), fopr: cfun2(a1, a2, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2:t@ype
} kparser_first
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a1)
//
extern
fun{
a1,a2:t@ype
} kparser_second
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a2)
//
overload << with kparser_first
overload >> with kparser_second
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype
}{b:t@ype}
kparser_fmap3
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
, fopr: cfun3(a1, a2, a3, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2,a3:t@ype
} kparser_middle
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
) : kparser(a2) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_orelse
  (kp1: kparser(INV(a)), kp2: kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_cloref
  (((*void*)) -<cloref1> kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_repeat0(kp: kparser(INV(a))): kparser(List0(a))
extern
fun
{a:t@ype}
kparser_repeat1(kp: kparser(INV(a))): kparser(List1(a))
//
(* ****** ****** *)
//
// HX-2015-12
// For parsing sequences of chars
//
(* ****** ****** *)
//
// HX-2015-12:
// This one remains abstract
//
extern
fun{}
kparser_char((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_alpha((*void*)): kparser(char)
extern
fun{}
kparser_alnum((*void*)): kparser(char)
extern
fun{}
kparser_digit((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_litchar(c0: char): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_literal(lit: string): kparser(int)
//
(* ****** ****** *)
//
abstype
parinp_type = ptr
abstype
parout_type = ptr
//
typedef parinp = parinp_type
typedef parout = parout_type
//
(* ****** ****** *)
//
typedef
parcont(a:t@ype) =
  (a, parinp) -<cloref1> parout
//
(* ****** ****** *)

exception ParFailExn of ((*void*))

(* ****** ****** *)
//
typedef
parinp_nullify
  (a:t@ype) =
  (parinp, parcont(a)) -<cloref1> parout
//
(* ****** ****** *)
//
extern
castfn
kparser_encode
  {a:t@ype}(parinp_nullify(a)): kparser(a)
//
extern
castfn
kparser_decode
  {a:t@ype}(kp: kparser(a)): parinp_nullify(a)
//
(* ****** ****** *)
//
extern
fun{}
parcont_fail(inp: parinp): parout
//
implement
{}(*tmp*)
parcont_fail(inp) = $raise ParFailExn()
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
kparser_fail() =
kparser_encode
  (lam(inp, kont) => parcont_fail(inp))
//
implement
{a}(*tmp*)
kparser_just(x) =
  kparser_encode(lam(inp, kont) => kont(x, inp))
//
(* ****** ****** *)

implement
{a}(*tmp*)
kparser_satisfy
  (kpar, test) = let
//
val kpar = kparser_decode(kpar)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kpar
( inp
, lam(x, inp) =>
  if test(x) then kont(x, inp) else parcont_fail(inp)
)
//
) (* kparser_encode *)
//
end // end of [kparser_satisfy]

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

implement
{a1,a2}
kparser_join2
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(@(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_join2]

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

implement
{a1,a2,a3}
kparser_join3
  (kp1, kp2, kp3) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(@(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_join3]

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

implement
{a}{b}
kparser_fmap
  (kp, fopr) = let
//
val kp = kparser_decode(kp)
//
in
//
kparser_encode(
//
lam(inp, kont) => kp(inp, lam(x, inp) => kont(fopr(x), inp))
//
) (* kparser_encode *)
//
end // end of [kparser_fmap]

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

implement
{a1,a2}{b}
kparser_fmap2
  (kp1, kp2, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(fopr(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap2]

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

implement
{a1,a2,a3}{b}
kparser_fmap3
  (kp1, kp2, kp3, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(fopr(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap3]

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

implement
{a1,a2}
kparser_first
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x1, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_first]

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

implement
{a1,a2}
kparser_second
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x2, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_second]

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

implement
{a}(*tmp*)
kparser_orelse
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
  try kp1(inp, kont) with ~ParFailExn() => kp2(inp, kont)
//
) (* kparser_encode *)
//
end // end of [kparser_orelse]

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

implement
{a}(*tmp*)
kparser_cloref
  (fkp) = let
(*
val () =
println! ("kparser_cloref")
*)
in
//
kparser_encode(
//
lam(inp, kont) =>
  let val kp = kparser_decode(fkp()) in kp(inp, kont) end
//
) (* kparser_encode *)
//
end // end of [kparser_cloref]

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

implement
{a}(*tmp*)
kparser_repeat0
  (kpar) = let
//
val kpar = kparser_decode(kpar)
//
fun
kaux
( inp: parinp, kont: parcont(List0(a))
) : parout = let
//
in
//
try
kpar
( inp
, lam(x, inp) =>
  kaux
  ( inp
  , lam(xs, inp) => kont(cons(x, xs), inp)
  )
)
with ~ParFailExn() => kont(list_nil(), inp)
//
end // end of [aux]
//
in
  kparser_encode(lam(inp, kont) => kaux(inp, kont))
end // end of [kparser_repeat0]

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

implement
{a}(*tmp*)
kparser_repeat1
  (kpar) = let
(*
val () = println! ("kparser_repeat1")
*)
in
//
kparser_fmap2<a,List0(a)><List1(a)>
  (kpar, kparser_repeat0<a>(kpar), lam(x, xs) => cons(x, xs))
//
end // end of [kparser_repeat1]

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

(*
//
// HX-2015-12-25:
// this one works, too!
//
implement{a}
kparser_repeat0(kp) =
kparser_orelse(
  kparser_cloref<List0(a)>(lam() => kparser_repeat1<a>(kp)), kparser_just<List0(a)>(list_nil())
) (* kparser_orelse *)
)
//
*)

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

implement
{}(*tmp*)
kparser_alpha
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalpha(c))
end // end of [kparser_alpha]

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

implement
{}(*tmp*)
kparser_alnum
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalnum(c))
end // end of [kparser_alnum]

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

implement
{}(*tmp*)
kparser_digit
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isdigit(c))
end // end of [kparser_digit]

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

implement
{}(*tmp*)
kparser_litchar
  (c0) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c1) => c0 = c1)
end // end of [kparser_litchar]

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

implement
{}(*tmp*)
kparser_literal
  (lit) = let
//
val
[n:int]
lit = g1ofg0(lit)
//
val
ncs = sz2i(string_length(lit))
//
fun
loop(i: natLte(n)): kparser(int) =
if i < ncs
  then kparser_litchar(lit[i]) >> loop(i+1) else kparser_just(0)
// end of [if]
//
in
  loop(0)
end // end of [kparser_literal]

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

#ifdef
PARINP_EQ_LIST_CHAR
//
local
//
assume
parinp_type =
List0(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ inp of
  | list_cons(c, inp2) => kont(c, inp2) | list_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_LIST_CHAR

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

#ifdef
PARINP_EQ_STREAM_CHAR
//
local
//
assume
parinp_type =
stream(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ !inp of
  | stream_cons(c, inp2) => kont(c, inp2) | stream_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_STREAM_CHAR

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

(* end of [kparcomb.hats] *)

(*
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
** OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
** NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
** HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
** WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
** OTHER DEALINGS IN THE SOFTWARE.
*)

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

(*
** A library for
** parsing combinators in CPS-stype
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: December, 2015
//
(* ****** ****** *)
//
abstype
kparser_type(a:t@ype+) = ptr
//
typedef
kparser(a:t@ype) = kparser_type(a)
//
(* ****** ****** *)
//
typedef
cfun1(a:t@ype, b:t@ype) = (a) -<cloref1> b
typedef
cfun2(a1:t@ype, a2:t@ype, b:t@ype) = (a1, a2) -<cloref1> b
typedef
cfun3(a1:t@ype, a2:t@ype, a3:t@ype, b:t@ype) = (a1, a2, a3) -<cloref1> b
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_fail(): kparser(a)
//
extern
fun
{a:t@ype}
kparser_just(x: a): kparser(a)
//
(* ****** ****** *)

extern
fun
{a:t@ype}
kparser_satisfy
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(a) // end-of-fun

(* ****** ****** *)
//
extern
fun
{a1
,a2:t@ype}
kparser_join2
(
  kparser(INV(a1)), kparser(INV(a2))
) : kparser(@(a1, a2)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype}
kparser_join3
(
  kparser(INV(a1)), kparser(INV(a2)), kparser(INV(a3))
) : kparser(@(a1, a2, a3)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
{b:t@ype}
kparser_fmap
  (kparser(INV(a)), fopr: cfun1(a, b)) : kparser(b)
//
extern
fun
{a1
,a2:t@ype
}{b:t@ype}
kparser_fmap2
(
  kparser(INV(a1)), kparser(INV(a2)), fopr: cfun2(a1, a2, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2:t@ype
} kparser_first
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a1)
//
extern
fun{
a1,a2:t@ype
} kparser_second
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a2)
//
overload << with kparser_first
overload >> with kparser_second
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype
}{b:t@ype}
kparser_fmap3
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
, fopr: cfun3(a1, a2, a3, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2,a3:t@ype
} kparser_middle
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
) : kparser(a2) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_orelse
  (kp1: kparser(INV(a)), kp2: kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_cloref
  (((*void*)) -<cloref1> kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_repeat0(kp: kparser(INV(a))): kparser(List0(a))
extern
fun
{a:t@ype}
kparser_repeat1(kp: kparser(INV(a))): kparser(List1(a))
//
(* ****** ****** *)
//
// HX-2015-12
// For parsing sequences of chars
//
(* ****** ****** *)
//
// HX-2015-12:
// This one remains abstract
//
extern
fun{}
kparser_char((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_alpha((*void*)): kparser(char)
extern
fun{}
kparser_alnum((*void*)): kparser(char)
extern
fun{}
kparser_digit((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_litchar(c0: char): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_literal(lit: string): kparser(int)
//
(* ****** ****** *)

(* end of [kparcomb.sats] *)

(* ****** ****** *)
//
abstype
parinp_type = ptr
abstype
parout_type = ptr
//
typedef parinp = parinp_type
typedef parout = parout_type
//
(* ****** ****** *)
//
typedef
parcont(a:t@ype) =
  (a, parinp) -<cloref1> parout
//
(* ****** ****** *)

exception ParFailExn of ((*void*))

(* ****** ****** *)
//
typedef
parinp_nullify
  (a:t@ype) =
  (parinp, parcont(a)) -<cloref1> parout
//
(* ****** ****** *)
//
extern
castfn
kparser_encode
  {a:t@ype}(parinp_nullify(a)): kparser(a)
//
extern
castfn
kparser_decode
  {a:t@ype}(kp: kparser(a)): parinp_nullify(a)
//
(* ****** ****** *)
//
extern
fun{}
parcont_fail(inp: parinp): parout
//
implement
{}(*tmp*)
parcont_fail(inp) = $raise ParFailExn()
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
kparser_fail() =
kparser_encode
  (lam(inp, kont) => parcont_fail(inp))
//
implement
{a}(*tmp*)
kparser_just(x) =
  kparser_encode(lam(inp, kont) => kont(x, inp))
//
(* ****** ****** *)

implement
{a}(*tmp*)
kparser_satisfy
  (kpar, test) = let
//
val kpar = kparser_decode(kpar)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kpar
( inp
, lam(x, inp) =>
  if test(x) then kont(x, inp) else parcont_fail(inp)
)
//
) (* kparser_encode *)
//
end // end of [kparser_satisfy]

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

implement
{a1,a2}
kparser_join2
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(@(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_join2]

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

implement
{a1,a2,a3}
kparser_join3
  (kp1, kp2, kp3) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(@(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_join3]

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

implement
{a}{b}
kparser_fmap
  (kp, fopr) = let
//
val kp = kparser_decode(kp)
//
in
//
kparser_encode(
//
lam(inp, kont) => kp(inp, lam(x, inp) => kont(fopr(x), inp))
//
) (* kparser_encode *)
//
end // end of [kparser_fmap]

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

implement
{a1,a2}{b}
kparser_fmap2
  (kp1, kp2, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(fopr(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap2]

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

implement
{a1,a2,a3}{b}
kparser_fmap3
  (kp1, kp2, kp3, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(fopr(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap3]

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

implement
{a1,a2}
kparser_first
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x1, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_first]

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

implement
{a1,a2}
kparser_second
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x2, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_second]

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

implement
{a}(*tmp*)
kparser_orelse
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
  try kp1(inp, kont) with ~ParFailExn() => kp2(inp, kont)
//
) (* kparser_encode *)
//
end // end of [kparser_orelse]

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

implement
{a}(*tmp*)
kparser_cloref
  (fkp) = let
(*
val () =
println! ("kparser_cloref")
*)
in
//
kparser_encode(
//
lam(inp, kont) =>
  let val kp = kparser_decode(fkp()) in kp(inp, kont) end
//
) (* kparser_encode *)
//
end // end of [kparser_cloref]

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

implement
{a}(*tmp*)
kparser_repeat0
  (kpar) = let
//
val kpar = kparser_decode(kpar)
//
fun
kaux
( inp: parinp, kont: parcont(List0(a))
) : parout = let
//
in
//
try
kpar
( inp
, lam(x, inp) =>
  kaux
  ( inp
  , lam(xs, inp) => kont(cons(x, xs), inp)
  )
)
with ~ParFailExn() => kont(list_nil(), inp)
//
end // end of [aux]
//
in
  kparser_encode(lam(inp, kont) => kaux(inp, kont))
end // end of [kparser_repeat0]

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

implement
{a}(*tmp*)
kparser_repeat1
  (kpar) = let
(*
val () = println! ("kparser_repeat1")
*)
in
//
kparser_fmap2<a,List0(a)><List1(a)>
  (kpar, kparser_repeat0<a>(kpar), lam(x, xs) => cons(x, xs))
//
end // end of [kparser_repeat1]

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

(*
//
// HX-2015-12-25:
// this one works, too!
//
implement{a}
kparser_repeat0(kp) =
kparser_orelse(
  kparser_cloref<List0(a)>(lam() => kparser_repeat1<a>(kp)), kparser_just<List0(a)>(list_nil())
) (* kparser_orelse *)
)
//
*)

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

implement
{}(*tmp*)
kparser_alpha
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalpha(c))
end // end of [kparser_alpha]

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

implement
{}(*tmp*)
kparser_alnum
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalnum(c))
end // end of [kparser_alnum]

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

implement
{}(*tmp*)
kparser_digit
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isdigit(c))
end // end of [kparser_digit]

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

implement
{}(*tmp*)
kparser_litchar
  (c0) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c1) => c0 = c1)
end // end of [kparser_litchar]

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

implement
{}(*tmp*)
kparser_literal
  (lit) = let
//
val
[n:int]
lit = g1ofg0(lit)
//
val
ncs = sz2i(string_length(lit))
//
fun
loop(i: natLte(n)): kparser(int) =
if i < ncs
  then kparser_litchar(lit[i]) >> loop(i+1) else kparser_just(0)
// end of [if]
//
in
  loop(0)
end // end of [kparser_literal]

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

(* end of [kparcomb.hats] *)


Updating: very very minorly

Updating: very very minorly

(*
** libatscc-common
*)

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

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

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

#define nil0 list0_nil
#define cons0 list0_cons
#define sing0(x) list0_cons(x, list0_nil)

(* ****** ****** *)
//
fun{}
list0_sing{a:t0p}(x: a): list0(a)
//
(* ****** ****** *)
//
fun{}
list0_is_nil
  {a:t0p}(xs: list0(INV(a))): bool
//
fun{}
list0_is_cons
  {a:t0p}(xs: list0(INV(a))): bool
//
(* ****** ****** *)

overload iseqz with list0_is_nil
overload isneqz with list0_is_cons

(* ****** ****** *)
//
fun
list0_head_opt
  {a:t0p}
  (list0(INV(a))): Option_vt(a) = "mac#%"
//
overload .head_opt with list0_head_opt
//
(* ****** ****** *)
//
fun
list0_tail_opt
  {a:t0p}
  (list0(INV(a))): Option_vt(list0(a)) = "mac#%"
//
overload .tail_opt with list0_tail_opt
//
(* ****** ****** *)
//
fun
list0_length
  {a:t0p}(list0(a)): intGte(0) = "mac#%"
//
overload length with list0_length of 100
//
(* ****** ****** *)
//
fun
list0_last_opt
  {a:t0p}
  (xs: list0(INV(a))): Option(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_get_at_opt
  {a:t0p}
  (list0(INV(a)), intGte(0)): Option(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_make_intrange_2
  (l: int, r: int): list0(int) = "mac#%"
fun
list0_make_intrange_3
  (l: int, r: int, d: int): list0(int) = "mac#%"
//
symintr list0_make_intrange
//
overload
list0_make_intrange with list0_make_intrange_2
overload
list0_make_intrange with list0_make_intrange_3
//
(* ****** ****** *)
//
fun
{a:t0p}
print_list0
  (xs: list0(INV(a))): void = "mac#%"
fun
{a:t0p}
print_list0_sep
  (xs: list0(INV(a)), sep: string): void = "mac#%"
//
overload
print with print_list0 of 100
//
(* ****** ****** *)
//
fun
list0_snoc
  {a:t0p}
  (list0(INV(a)), x0: a): list0(a)= "mac#%"
//
fun
list0_extend
  {a:t0p}
  (list0(INV(a)), x0: a): list0(a)= "mac#%"
//
(* ****** ****** *)
//
fun
list0_append
  {a:t0p}
(
  xs: list0(INV(a)), ys: list0(a)
) : list0(a) = "mac#%" // end-of-fun
//
overload + with list0_append of 100 // infix
//
(* ****** ****** *)
//
fun
list0_reverse
  {a:t0p}
  (xs: list0(INV(a))): list0(a) = "mac#%"
fun
list0_reverse_append
  {a:t0p}
  (xs: list0(INV(a)), ys: list0(a)): list0(a) = "mac#%"
//
overload reverse with list0_reverse of 100
overload revappend with list0_reverse_append of 100
//
(* ****** ****** *)
//
fun
list0_concat
  {a:t0p}(xs: list0(list0(a))): list0(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_remove_at_opt
  {a:t0p}
  (list0(INV(a)), i: intGte(0)): Option(list0(a)) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_exists
  {a:t0p}
  (list0(INV(a)), pred: cfun(a, bool)): bool = "mac#%"
fun
list0_exists_method
  {a:t0p}
  (list0(INV(a)))(pred: cfun(a, bool)): bool = "mac#%"
//
overload .exists with list0_exists_method
//
fun
list0_iexists
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iexists]
fun
list0_iexists_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iexists]
//
overload .iexists with list0_iexists_method
//
(* ****** ****** *)
//
fun
list0_forall
  {a:t0p}
  (list0(INV(a)), pred: cfun(a, bool)): bool = "mac#%"
fun
list0_forall_method
  {a:t0p}
  (list0(INV(a)))(pred: cfun(a, bool)): bool = "mac#%"
//
overload .forall with list0_forall_method
//
fun
list0_iforall
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iforall]
fun
list0_iforall_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iforall]
//
overload .iforall with list0_iforall_method
//
(* ****** ****** *)
//
fun
list0_app
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
fun
list0_foreach
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
fun
list0_foreach_method
  {a:t0p}
(
  xs: list0(INV(a)))(fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
//
overload .foreach with list0_foreach_method
//
(* ****** ****** *)
//
fun
list0_iforeach
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(int, a, void)
) : void = "mac#%" // end-of-function
fun
list0_iforeach_method
  {a:t0p}
(
  xs: list0(INV(a)))(fwork: cfun(int, a, void)
) : void = "mac#%" // end-of-function
//
overload .iforeach with list0_iforeach_method
//
(* ****** ****** *)
//
fun
list0_rforeach
  {a:t0p}
  (xs: list0(INV(a)), fwork: cfun(a, void)): void = "mac#%"
fun
list0_rforeach_method
  {a:t0p}
  (xs: list0(INV(a)))(fwork: cfun(a, void)): void = "mac#%"
//
overload .rforeach with list0_rforeach_method
//
(* ****** ****** *)
//
fun
list0_filter
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(a, bool)
) : list0(a) = "mac#%" // end-of-function
fun
list0_filter_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(a, bool)
) : list0(a) = "mac#%" // end-of-function
//
overload .filter with list0_filter_method
//
(* ****** ****** *)
//
fun
list0_map
  {a:t0p}{b:t0p}
  (list0(INV(a)), fopr: cfun(a, b)): list0(b) = "mac#%"
fun
list0_map_method
  {a:t0p}{b:t0p}
  (list0(INV(a)), TYPE(b))(fopr: cfun(a, b)): list0(b) = "mac#%"
//
overload .map with list0_map_method
//
(* ****** ****** *)
//
fun
list0_mapcons
  {a:t0p}
  (x0: a, xss: list0(list0(INV(a)))): list0(list0(a)) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_find_opt
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(a, bool)
) : Option_vt(a) = "mac#%" // end-of-fun
fun
list0_find_opt_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(a, bool)
) : Option_vt(a) = "mac#%" // end-of-fun
//
overload .find_opt with list0_find_opt_method
//
(* ****** ****** *)
//
fun
list0_zip
  {a1,a2:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2))
) :<> list0($tup(a1, a2)) = "mac#%" // end-of-fun
//
fun
list0_zipwith
  {a1,a2:t0p}{b:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2)), fopr: cfun(a1, a2, b)
) :<1> list0(b) = "mac#%" // end of [list0_zipwith]
//
fun
list0_zipwith_method
  {a1,a2:t0p}{b:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2)))(fopr: cfun(a1, a2, b)
) :<1> list0(b) = "mac#%" // end of [list0_zipwith_method]
//
overload .map2 with list0_zipwith_method
overload .zipwith with list0_zipwith_method
//
(* ****** ****** *)

fun
list0_foldleft
  {res:t0p}{a:t0p}
(
  list0(INV(a)), init: res, fopr: cfun(res, a, res)
) : res = "mac#%" // end-of-function
fun
list0_foldright
  {a:t0p}{res:t0p}
(
  list0(INV(a)), fopr: cfun(a, res, res), sink: res
) : res = "mac#%" // end-of-function

(* ****** ****** *)
//
fun
{a:t0p}
list0_sort_1
  (list0(INV(a))): list0(a) = "mac#%"
//
fun
list0_sort_2
  {a:t0p}
(
  list0(INV(a)), cmp: (a, a) -<cloref1> int
) : list0(a) = "mac#%"
//
symintr list0_sort
overload list0_sort with list0_sort_1 of 100
overload list0_sort with list0_sort_2 of 100
//
(* ****** ****** *)
//
fun
streamize_list0_zip
  {a,b:t0p}
(
  xs: list0(INV(a))
, ys: list0(INV(b))
) :<>
  stream_vt($tup(a,b)) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
streamize_list0_cross
  {a,b:t0p}
(
  xs: list0(INV(a))
, ys: list0(INV(b))
) :<>
  stream_vt($tup(a,b)) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
streamize_list0_nchoose
  {a:t0p}
(
  xs: list0(INV(a)), n: intGte(0)
) :<> stream_vt(list0(a)) = "mac#%" // end-of-fun
fun
streamize_list0_nchoose_rest
  {a:t0p}
(
  xs: list0(INV(a)), n: intGte(0)
) :<> stream_vt($tup(list0(a), list0(a))) = "mac#%"
//
(* ****** ****** *)

(* end of [list0.sats] *)

(*
** libatscc-common
*)

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

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

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

#define nil0 list0_nil
#define cons0 list0_cons
#define sing0(x) list0_cons(x, list0_nil)

(* ****** ****** *)
//
fun{}
list0_sing{a:t0p}(x: a): list0(a)
//
(* ****** ****** *)
//
fun{}
list0_is_nil
  {a:t0p}(xs: list0(INV(a))): bool
//
fun{}
list0_is_cons
  {a:t0p}(xs: list0(INV(a))): bool
//
(* ****** ****** *)

overload iseqz with list0_is_nil
overload isneqz with list0_is_cons

(* ****** ****** *)
//
fun
list0_head_opt
  {a:t0p}
  (list0(INV(a))): Option_vt(a) = "mac#%"
//
overload .head_opt with list0_head_opt
//
(* ****** ****** *)
//
fun
list0_tail_opt
  {a:t0p}
  (list0(INV(a))): Option_vt(list0(a)) = "mac#%"
//
overload .tail_opt with list0_tail_opt
//
(* ****** ****** *)
//
fun
list0_length
  {a:t0p}(list0(a)): intGte(0) = "mac#%"
//
overload length with list0_length of 100
//
(* ****** ****** *)
//
fun
list0_last_opt
  {a:t0p}
  (xs: list0(INV(a))): Option(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_get_at_opt
  {a:t0p}
  (list0(INV(a)), intGte(0)): Option(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_make_intrange_2
  (l: int, r: int): list0(int) = "mac#%"
fun
list0_make_intrange_3
  (l: int, r: int, d: int): list0(int) = "mac#%"
//
symintr list0_make_intrange
//
overload
list0_make_intrange with list0_make_intrange_2
overload
list0_make_intrange with list0_make_intrange_3
//
(* ****** ****** *)
//
fun
{a:t0p}
print_list0
  (xs: list0(INV(a))): void = "mac#%"
fun
{a:t0p}
print_list0_sep
  (xs: list0(INV(a)), sep: string): void = "mac#%"
//
overload
print with print_list0 of 100
//
(* ****** ****** *)
//
fun
list0_snoc
  {a:t0p}
  (list0(INV(a)), x0: a): list0(a)= "mac#%"
//
fun
list0_extend
  {a:t0p}
  (list0(INV(a)), x0: a): list0(a)= "mac#%"
//
(* ****** ****** *)
//
fun
list0_append
  {a:t0p}
(
  xs: list0(INV(a)), ys: list0(a)
) : list0(a) = "mac#%" // end-of-fun
//
overload + with list0_append of 100 // infix
//
(* ****** ****** *)
//
fun
list0_reverse
  {a:t0p}
  (xs: list0(INV(a))): list0(a) = "mac#%"
fun
list0_reverse_append
  {a:t0p}
  (xs: list0(INV(a)), ys: list0(a)): list0(a) = "mac#%"
//
overload reverse with list0_reverse of 100
overload revappend with list0_reverse_append of 100
//
(* ****** ****** *)
//
fun
list0_concat
  {a:t0p}(xs: list0(list0(a))): list0(a) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_remove_at_opt
  {a:t0p}
  (list0(INV(a)), i: intGte(0)): Option(list0(a)) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_exists
  {a:t0p}
  (list0(INV(a)), pred: cfun(a, bool)): bool = "mac#%"
fun
list0_exists_method
  {a:t0p}
  (list0(INV(a)))(pred: cfun(a, bool)): bool = "mac#%"
//
overload .exists with list0_exists_method
//
fun
list0_iexists
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iexists]
fun
list0_iexists_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iexists]
//
overload .iexists with list0_iexists_method
//
(* ****** ****** *)
//
fun
list0_forall
  {a:t0p}
  (list0(INV(a)), pred: cfun(a, bool)): bool = "mac#%"
fun
list0_forall_method
  {a:t0p}
  (list0(INV(a)))(pred: cfun(a, bool)): bool = "mac#%"
//
overload .forall with list0_forall_method
//
fun
list0_iforall
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iforall]
fun
list0_iforall_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(intGte(0), a, bool)
) : bool = "mac#%" // end of [list0_iforall]
//
overload .iforall with list0_iforall_method
//
(* ****** ****** *)
//
fun
list0_app
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
fun
list0_foreach
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
fun
list0_foreach_method
  {a:t0p}
(
  xs: list0(INV(a)))(fwork: cfun(a, void)
) : void = "mac#%" // end-of-function
//
overload .foreach with list0_foreach_method
//
(* ****** ****** *)
//
fun
list0_iforeach
  {a:t0p}
(
  xs: list0(INV(a)), fwork: cfun(int, a, void)
) : void = "mac#%" // end-of-function
fun
list0_iforeach_method
  {a:t0p}
(
  xs: list0(INV(a)))(fwork: cfun(int, a, void)
) : void = "mac#%" // end-of-function
//
overload .iforeach with list0_iforeach_method
//
(* ****** ****** *)
//
fun
list0_rforeach
  {a:t0p}
  (xs: list0(INV(a)), fwork: cfun(a, void)): void = "mac#%"
fun
list0_rforeach_method
  {a:t0p}
  (xs: list0(INV(a)))(fwork: cfun(a, void)): void = "mac#%"
//
overload .rforeach with list0_rforeach_method
//
(* ****** ****** *)
//
fun
list0_filter
  {a:t0p}
(
  xs: list0(INV(a)), pred: cfun(a, bool)
) : list0(a) = "mac#%" // end-of-function
fun
list0_filter_method
  {a:t0p}
(
  xs: list0(INV(a)))(pred: cfun(a, bool)
) : list0(a) = "mac#%" // end-of-function
//
overload .filter with list0_filter_method
//
(* ****** ****** *)
//
fun
list0_map
  {a:t0p}{b:t0p}
  (list0(INV(a)), fopr: cfun(a, b)): list0(b) = "mac#%"
fun
list0_map_method
  {a:t0p}{b:t0p}
  (list0(INV(a)), TYPE(b))(fopr: cfun(a, b)): list0(b) = "mac#%"
//
overload .map with list0_map_method
//
(* ****** ****** *)
//
fun
list0_mapcons
  {a:t0p}
  (x0: a, xss: list0(list0(INV(a)))): list0(list0(a)) = "mac#%"
//
(* ****** ****** *)
//
fun
list0_zip
  {a1,a2:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2))
) :<> list0($tup(a1, a2)) = "mac#%" // end-of-fun
//
fun
list0_zipwith
  {a1,a2:t0p}{b:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2)), fopr: cfun(a1, a2, b)
) :<1> list0(b) = "mac#%" // end of [list0_zipwith]
//
fun
list0_zipwith_method
  {a1,a2:t0p}{b:t0p}
(
  xs: list0(INV(a1)), ys: list0(INV(a2)))(fopr: cfun(a1, a2, b)
) :<1> list0(b) = "mac#%" // end of [list0_zipwith_method]
//
overload .map2 with list0_zipwith_method
overload .zipwith with list0_zipwith_method
//
(* ****** ****** *)

fun
list0_foldleft
  {res:t0p}{a:t0p}
(
  list0(INV(a)), init: res, fopr: cfun(res, a, res)
) : res = "mac#%" // end-of-function
fun
list0_foldright
  {a:t0p}{res:t0p}
(
  list0(INV(a)), fopr: cfun(a, res, res), sink: res
) : res = "mac#%" // end-of-function

(* ****** ****** *)
//
fun
{a:t0p}
list0_sort_1
  (list0(INV(a))): list0(a) = "mac#%"
//
fun
list0_sort_2
  {a:t0p}
(
  list0(INV(a)), cmp: (a, a) -<cloref1> int
) : list0(a) = "mac#%"
//
symintr list0_sort
overload list0_sort with list0_sort_1 of 100
overload list0_sort with list0_sort_2 of 100
//
(* ****** ****** *)
//
fun
streamize_list0_zip
  {a,b:t0p}
(
  xs: list0(INV(a))
, ys: list0(INV(b))
) :<>
  stream_vt($tup(a,b)) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
streamize_list0_cross
  {a,b:t0p}
(
  xs: list0(INV(a))
, ys: list0(INV(b))
) :<>
  stream_vt($tup(a,b)) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
streamize_list0_nchoose
  {a:t0p}
(
  xs: list0(INV(a)), n: intGte(0)
) :<> stream_vt(list0(a)) = "mac#%" // end-of-fun
fun
streamize_list0_nchoose_rest
  {a:t0p}
(
  xs: list0(INV(a)), n: intGte(0)
) :<> stream_vt($tup(list0(a), list0(a))) = "mac#%"
//
(* ****** ****** *)

(* end of [list0.sats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** HX-2014-11-07:
** This is adapted from
** some code by William Blair
*)

(* ****** ****** *)
//
%{^
typedef
void
*voilatile_voidptr;
%}
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload "{$AVR}/basics.sats"
//
staload "{$AVR}/SATS/avr/io.sats"
staload "{$AVR}/SATS/avr/iom328p.sats"
//
staload "{$AVR}/SATS/util/delay.sats"
//
(* ****** ****** *)

#define NDELAY 250.0

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

extern
fun
main (): int = "main"

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

implement
main () = 0 where
{
//
(*
val () =
println! ("Hello from Blink!")
*)
//
val () = DDRB[DDB3] := 1
//
val () =
while(true)
{
  val () = PORTB[PORTB3] := 1
  val () = _delay_ms (NDELAY)
  val () = PORTB[PORTB3] := 0
  val () = _delay_ms (NDELAY)
}
//
} (* end of [main] *)

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

(* end of [Blink/main.dats] *)

(*
** HX-2014-11-07:
** This is adapted from
** some code by William Blair
*)

(* ****** ****** *)
//
%{^
typedef
void
*voilatile_voidptr;
%}
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload "{$AVR}/basics.sats"
//
staload "{$AVR}/SATS/avr/io.sats"
staload "{$AVR}/SATS/avr/iom328p.sats"
//
staload "{$AVR}/SATS/util/delay.sats"
//
(* ****** ****** *)

#define NDELAY 250.0

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

extern
fun
main (): int = "main"

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

implement
main () = 0 where
{
//
val () = DDRB[DDB3] := 1
//
val () =
while(true)
{
  val () = PORTB[PORTB3] := 1
  val () = _delay_ms (NDELAY)
  val () = PORTB[PORTB3] := 0
  val () = _delay_ms (NDELAY)
}
//
} (* end of [main] *)

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

(* end of [Blink/main.dats] *)


Use ->

Use ->

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

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

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

extern fun c_delay_ms: (double) -> void = "mac#_delay_ms"

implement main0 () = {
  fun loop () = {
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = loop ()
  }
  val () = $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT)
  val () = loop ()
}

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

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

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

extern fun c_delay_ms (ms: double): void = "mac#_delay_ms"

implement main0 () = {
  fun loop (): void = {
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = loop ()
  }
  val () = $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT)
  val () = loop ()
}


Updating: very very minorly

Updating: very very minorly

(*
** Implementing the doublet game
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload
"libats/ML/SATS/basis.sats"
staload
"libats/ML/SATS/strarr.sats"
//
(* ****** ****** *)

staload "./doublet.sats"

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

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

(* ****** ****** *)
//
extern
fun
word_get_friends_at
  (w0: word, i: size_t): List0_vt (word)
//
(* ****** ****** *)

implement
word_get_friends_at
  (w0, i0) = let
//
vtypedef
res = List0_vt(word)
//
val n0 = g1ofg0(length(w0))
val c0 = strarr_get_at(w0, i0)
//
fun aux1
(
  c: char, res: res
) : res =
  if c < c0 then let
    val w = w where
    {
      val f =
      lam (i: size_t)
        : char =<cloref1> if i != i0 then w0[i] else c
      val w = strarr_tabulate(n0, f)
      val () = cloptr_free ($UN.castvwtp0{cloptr(void)}(f))
    }
    val res = aux1 (int2char0(char2int0(c)+1), res)
  in
    if word_is_legal(w) then list_vt_cons (w, res) else res
  end else res // end of [if]
//
fun aux2
(
  c: char, res: res
) : res =
  if c > c0 then let
    val w = w where
    {
      val f =
      lam (i: size_t)
        : char =<cloref1> if i != i0 then w0[i] else c
      val w = strarr_tabulate (n0, f)
      val () = cloptr_free ($UN.castvwtp0{cloptr(void)}(f))
    }
    val ans = word_is_legal (w)
    val res =
    (
      if word_is_legal(w) then list_vt_cons (w, res) else res
    ) : res // end of [val]
  in
    aux2 (int2char0(char2int0(c)-1), res)
  end else (res) // end of [if]
//
in
  aux1 ('a', aux2 ('z', list_vt_nil(*void*)))
end // end of [word_get_friends_at]

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

implement
word_get_friends
  (w0) = let
//
val n0 = length (w0)
val n0 = g1ofg0 (n0)
val wss =
list_tabulate_cloref<wordlst_vt>
  (sz2i(n0), lam (i) => word_get_friends_at (w0, i2sz(i)))
//
in
  list_vt_concat (wss)
end // end of [word_get_friends]

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

(* end of [doublet_word.dats] *)

(*
** Implementing the doublet game
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload
"libats/ML/SATS/basis.sats"
staload
"libats/ML/SATS/strarr.sats"
//
(* ****** ****** *)

staload "./doublet.sats"

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

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

(* ****** ****** *)
//
extern
fun
word_get_friends_at
  (w0: word, i: size_t): List0_vt (word)
//
(* ****** ****** *)

implement
word_get_friends_at
  (w0, i0) = let
//
vtypedef res = List0_vt (word)
//
val n0 = length (w0)
val c0 = strarr_get_at (w0, i0)
//
fun aux1
(
  c: char, res: res
) : res =
  if c < c0 then let
    val w = w where
    {
      val f =
      lam (i: size_t)
        : char =<cloref1> if i != i0 then w0[i] else c
      val w = strarr_tabulate (n0, f)
      val () = cloptr_free ($UN.castvwtp0{cloptr(void)}(f))
    }
    val res = aux1 (int2char0(char2int0(c)+1), res)
  in
    if word_is_legal(w) then list_vt_cons (w, res) else res
  end else res // end of [if]
//
fun aux2
(
  c: char, res: res
) : res =
  if c > c0 then let
    val w = w where
    {
      val f =
      lam (i: size_t)
        : char =<cloref1> if i != i0 then w0[i] else c
      val w = strarr_tabulate (n0, f)
      val () = cloptr_free ($UN.castvwtp0{cloptr(void)}(f))
    }
    val ans = word_is_legal (w)
    val res =
    (
      if word_is_legal(w) then list_vt_cons (w, res) else res
    ) : res // end of [val]
  in
    aux2 (int2char0(char2int0(c)-1), res)
  end else (res) // end of [if]
//
in
  aux1 ('a', aux2 ('z', list_vt_nil(*void*)))
end // end of [word_get_friends_at]

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

implement
word_get_friends
  (w0) = let
//
val n0 = length (w0)
val n0 = g1ofg0 (n0)
val wss =
list_tabulate_cloref<wordlst_vt>
  (sz2i(n0), lam (i) => word_get_friends_at (w0, i2sz(i)))
//
in
  list_vt_concat (wss)
end // end of [word_get_friends]

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

(* end of [doublet_word.dats] *)


update coin exchange with simple tracing

// Compile with `patscc -o ce coint_exchange.dats`
// Run with `./ce`
// To remove all ATS2 `tmp` files `rm -fv *_[sd]ats.[co]`

// If you forget:

// SPC-c-C and puts `patscc -o ce coint_exchange.dats && ./ce` to setup compilation
// SPC-c-r to recompile

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

//
typedef
int4 = (int, int, int, int)
//
val theCoins = (1, 5, 10, 25): int4
//
fun coin_get
  (n: int): int =
(
  if n = 0 then theCoins.0
  else if n = 1 then theCoins.1
  else if n = 2 then theCoins.2
  else if n = 3 then theCoins.3
  else ~1 (* erroneous value *)
) (* end of [coin_get] *)
//
fun coin_change
  (sum: int): int = let
  fun aux (sum: int, n: int): int = let
       val () = print("sum=")
       val () = print(sum)
       val () = print(" n=")
       val () = print(n)
       val () = print("\n")
  in
      if sum > 0 then
       (if n >= 0 then aux (sum, n-1) + aux (sum-coin_get(n), n) else 0)
      else (if sum < 0 then 0 else 1)
    // end of [aux]
  end
in
  aux (sum, 3)
end // end of [coin_change]
//

implement main0() = begin
  print(coin_change(5))
end

// Compile with `patscc -o ce coint_exchange.dats`
// Run with `./ce`
// To remove all ATS2 `tmp` files `rm -fv *_[sd]ats.[co]`

// If you forget:

// SPC-c-C and puts `patscc -o ce coint_exchange.dats && ./ce` to setup compilation
// SPC-c-r to recompile

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

//
typedef
int4 = (int, int, int, int)
//
val theCoins = (1, 5, 10, 25): int4
//
fun coin_get
  (n: int): int =
(
  if n = 0 then theCoins.0
  else if n = 1 then theCoins.1
  else if n = 2 then theCoins.2
  else if n = 3 then theCoins.3
  else ~1 (* erroneous value *)
) (* end of [coin_get] *)
//
fun coin_change
  (sum: int): int = let
  fun aux (sum: int, n: int): int =
    if sum > 0 then
     (if n >= 0 then aux (sum, n-1) + aux (sum-coin_get(n), n) else 0)
    else (if sum < 0 then 0 else 1)
  // end of [aux]
in
  aux (sum, 3)
end // end of [coin_change]
//

implement main0() = begin
  print(coin_change(5))
end


Updating: adding bouncing-ball2

Updating: adding bouncing-ball2

(*
** Bouncing ball: attemp 2
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTedu
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
staload
"libats/DATS/Number/real_double.dats"
//
(* ****** ****** *)

sortdef mode = int
sortdef time = real

(* ****** ****** *)
//
absprop INF(t:time)
//
extern
praxi
lemma_inf_gte
  {t0,t1:time | t0 >= t1}(INF(t0), real(t1)): INF(t1)
//
(* ****** ****** *)

stacst g : real

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

stadef m1 = 1 and m2 = 2

(* ****** ****** *)
//
stacst x
  : (mode, time) -> real
stacst v
  : (mode, time) -> real
//
(* ****** ****** *)

stadef x1(t:time) = x(m1, t)
stadef x2(t:time) = x(m2, t)
stadef v1(t:time) = v(m1, t)
stadef v2(t:time) = v(m2, t)

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

absvtype state(mode, time)

vtypedef state1(t) = state(m1, t)
vtypedef state2(t) = state(m2, t)

(* ****** ****** *)
//
stacst
deriv :
(
  time -> real, time(*t*), time(*dt*)
) -> real
//
(* ****** ****** *)
//
extern
praxi
state1_eqn1
  {t,dt:time}
(
  INF(dt) | !state1(t)
) : [deriv(x1,t,dt) == v1(t)] void
extern
praxi
state1_eqn2
  {t,dt:time}
  (INF(dt) | !state1(t)): [deriv(v1,t,dt) == ~g] void
//
(* ****** ****** *)
//
extern
praxi
state2_eqn2
  {t,dt:time}
(
  INF(dt) | !state(m2, t)
) : [deriv(x2,t,dt) == v2(t)] void
extern
praxi
state2_eqn2
  {t,dt:time}
  (INF(dt) | !state(m2, t)): [deriv(v2,t,dt) == ~g] void
//
(* ****** ****** *)
//
extern
fun
state_get_t
  {m:mode}{t:time}(!state(m, t)): real(t)
extern
fun
state_get_x
  {m:mode}{t:time}(!state(m, t)): real(x(m, t))
extern
fun
state_get_v
  {m:mode}{t:time}(!state(m, t)): real(v(m, t))
//
(* ****** ****** *)
//
extern
fun
state1_flow
{ t,dt:time
| x1(t+dt) >= 0
}
(INF(dt)|state1(t), real(dt)): state1(t+dt)
//
extern
fun
state1_jump
{
  t:time
| x1(t) == 0
} (state1(t))
: [x2(t) == 0; v2(t) == ~v1(t)] state(m2, t)
//
(* ****** ****** *)
//
extern
fun
state2_flow
{ t,dt:time
| v2(t+dt) >= 0
} (INF(dt) | state(m2, t), real(dt)): state(m2, t+dt)
//
extern
fun
state2_jump
{
  t:time
| v2(t) == 0
} (state2(t)): [x1(t) == x2(t); v1(t) == 0] state1(t)
//
(* ****** ****** *)

extern
fun
delta_x1
  {t,dt:time}
(
  pf: INF(dt) | !state1(t), dt: real(dt)
) : real(x1(t+dt))

extern
fun
delta_v2
  {t,dt:time}
(
  pf: INF(dt) | !state2(t), dt: real(dt)
) : real(v2(t+dt))

(* ****** ****** *)
//
extern
fun
x1_midval
{ r:real
; t0,t1:time
| x1(t0) >= r ; r >= x1(t1)
}
(
  real(x1(t0)), real(r), real(x1(t1))
) : [t:time | t0 >= t; t >= t1; x1(t)==0] real(t)
//
(* ****** ****** *)
//
extern
fun
v2_midval
{ r:real
; t0,t1:time
| v2(t0) >= r ; r >= v2(t1)
}
(
  real(v2(t0)), real(r), real(v2(t1))
) : [t:time | t0 >= t; t >= t1; v2(t)==0] real(t)
//
(* ****** ****** *)

extern
fun
state1_loop
{t,dt:time}
(
  pf: INF(dt) | st: state1(t), dt: real(dt)
) : void // end-of-function
extern
fun
state2_loop
{t,dt:time}
(
  pf: INF(dt) | st: state2(t), dt: real(dt)
) : void // end-of-function

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

val _0_ = int2real(0)

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

implement
state1_loop
  (pf | st, dt) = let
//
  val t_0 = state_get_t(st)
  val x1_0 = state_get_x(st)
  val x1_dx = delta_x1(pf | st, dt)
//
in
//
  if x1_dx >= 0
    then let
      val st_1 =
      state1_flow(pf | st, dt)
    in
      state1_loop(pf | st_1, dt)
    end // end of [then]
    else let
        val t_1 =
          x1_midval(x1_0, _0_, x1_dx)
        // end of [val]
        val dt_1 = t_1 - t_0
      prval pf_1 = lemma_inf_gte(pf, dt_1)
        val st_1 = state1_flow(pf_1 | st, dt_1)
    in
      state2_loop(pf | state1_jump(st_1), dt)
    end // end of [else]
//
end // end of [state1_loop]

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

implement
state2_loop
  (pf | st, dt) = let
//
  val t_0 = state_get_t(st)
  val v2_0 = state_get_v(st)
  val v2_dv = delta_v2(pf | st, dt)
//
in
//
  if v2_dv >= 0
    then let
      val st_1 =
      state2_flow(pf | st, dt)
    in
      state2_loop(pf | st_1, dt)
    end // end of [then]
    else let
        val t_1 =
          v2_midval(v2_0, _0_, v2_dv)
        // end of [val]
        val dt_1 = t_1 - t_0
      prval pf_1 = lemma_inf_gte(pf, dt_1)
        val st_1 = state2_flow(pf_1 | st, dt_1)
    in
      state1_loop(pf | state2_jump(st_1), dt)
    end // end of [else]
//
end // end of [state_loop2]

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

(* end of [bouncing_ball2.dats] *)

(*
** Bouncing ball
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTedu
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
staload
"libats/DATS/Number/real_double.dats"
//
(* ****** ****** *)
//
extern
fun{}
gte_real_int
  {x:real;i:int}
  (real(x), int(i)):<> bool(x >= i)
//
overload >= with gte_real_int of 10
//
(* ****** ****** *)

sortdef mode = int
sortdef time = real

(* ****** ****** *)
//
absprop INF(t:time)
//
extern
praxi
lemma_inf_gte
  {t0,t1:time | t0 >= t1}(INF(t0), real(t1)): INF(t1)
//
(* ****** ****** *)

stacst g : real

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

stadef m1 = 1 and m2 = 2

(* ****** ****** *)
//
stacst x
  : (mode, time) -> real
stacst v
  : (mode, time) -> real
//
(* ****** ****** *)

stadef x1(t:time) = x(m1, t)
stadef x2(t:time) = x(m2, t)
stadef v1(t:time) = v(m1, t)
stadef v2(t:time) = v(m2, t)

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

absvtype state(mode, time)

vtypedef state1(t) = state(m1, t)
vtypedef state2(t) = state(m2, t)

(* ****** ****** *)
//
stacst
deriv :
(
  time -> real, time(*t*), time(*dt*)
) -> real
//
(* ****** ****** *)
//
extern
praxi
state1_eqn1
  {t,dt:time}
(
  INF(dt) | !state1(t)
) : [deriv(x1,t,dt) == v1(t)] void
extern
praxi
state1_eqn2
  {t,dt:time}
  (INF(dt) | !state1(t)): [deriv(v1,t,dt) == ~g] void
//
(* ****** ****** *)
//
extern
praxi
state2_eqn2
  {t,dt:time}
(
  INF(dt) | !state(m2, t)
) : [deriv(x2,t,dt) == v2(t)] void
extern
praxi
state2_eqn2
  {t,dt:time}
  (INF(dt) | !state(m2, t)): [deriv(v2,t,dt) == ~g] void
//
(* ****** ****** *)
//
extern
fun
state_get_t
  {m:mode}{t:time}(!state(m, t)): real(t)
extern
fun
state_get_x
  {m:mode}{t:time}(!state(m, t)): real(x(m, t))
extern
fun
state_get_v
  {m:mode}{t:time}(!state(m, t)): real(v(m, t))
//
(* ****** ****** *)
//
extern
fun
state1_flow
{ t,dt:time
| x1(t+dt) >= 0
}
(INF(dt)|state1(t), real(dt)): state1(t+dt)
//
extern
fun
state1_jump
{
  t:time
| x1(t) == 0
} (state1(t))
: [x2(t) == 0; v2(t) == ~v1(t)] state(m2, t)
//
(* ****** ****** *)
//
extern
fun
state2_flow
{ t,dt:time
| v2(t+dt) >= 0
} (INF(dt) | state(m2, t), real(dt)): state(m2, t+dt)
//
extern
fun
state2_jump
{
  t:time
| v2(t) == 0
} (state2(t)): [x1(t) == x2(t); v1(t) == 0] state1(t)
//
(* ****** ****** *)

extern
fun
delta_x1
  {t,dt:time}
(
  pf: INF(dt) | !state1(t), dt: real(dt)
) : real(x1(t+dt))

extern
fun
delta_v2
  {t,dt:time}
(
  pf: INF(dt) | !state2(t), dt: real(dt)
) : real(v2(t+dt))

(* ****** ****** *)
//
extern
fun
x1_midval
{ r:real
; t0,t1:time
| x1(t0) >= r ; r >= x1(t1)
}
(
  real(x1(t0)), real(r), real(x1(t1))
) : [t:time | t0 >= t; t >= t1; x1(t)==0] real(t)
//
(* ****** ****** *)
//
extern
fun
v2_midval
{ r:real
; t0,t1:time
| v2(t0) >= r ; r >= v2(t1)
}
(
  real(v2(t0)), real(r), real(v2(t1))
) : [t:time | t0 >= t; t >= t1; v2(t)==0] real(t)
//
(* ****** ****** *)

extern
fun
state1_loop
{t,dt:time}
(
  pf: INF(dt) | st: state1(t), dt: real(dt)
) : void // end-of-function
extern
fun
state2_loop
{t,dt:time}
(
  pf: INF(dt) | st: state2(t), dt: real(dt)
) : void // end-of-function

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

val _0_ = int2real(0)

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

implement
state1_loop
  (pf | st, dt) = let
//
  val t_0 = state_get_t(st)
  val x1_0 = state_get_x(st)
  val x1_dx = delta_x1(pf | st, dt)
//
in
//
  if x1_dx >= 0
    then let
      val st_1 =
      state1_flow(pf | st, dt)
    in
      state1_loop(pf | st_1, dt)
    end // end of [then]
    else let
        val t_1 =
          x1_midval(x1_0, _0_, x1_dx)
        // end of [val]
        val dt_1 = t_1 - t_0
      prval pf_1 = lemma_inf_gte(pf, dt_1)
        val st_1 = state1_flow(pf_1 | st, dt_1)
    in
      state2_loop(pf | state1_jump(st_1), dt)
    end // end of [else]
//
end // end of [state1_loop]

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

implement
state2_loop
  (pf | st, dt) = let
//
  val t_0 = state_get_t(st)
  val v2_0 = state_get_v(st)
  val v2_dv = delta_v2(pf | st, dt)
//
in
//
  if v2_dv >= 0
    then let
      val st_1 =
      state2_flow(pf | st, dt)
    in
      state2_loop(pf | st_1, dt)
    end // end of [then]
    else let
        val t_1 =
          v2_midval(v2_0, _0_, v2_dv)
        // end of [val]
        val dt_1 = t_1 - t_0
      prval pf_1 = lemma_inf_gte(pf, dt_1)
        val st_1 = state2_flow(pf_1 | st, dt_1)
    in
      state1_loop(pf | state2_jump(st_1), dt)
    end // end of [else]
//
end // end of [state_loop2]

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

(* end of [bouncing_ball2.dats] *)


Updating: improving ats2cpp/libats/STL

Updating: improving ats2cpp/libats/STL

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

(*
** A linear stack
** implementation based on STL:vector
*)

(* ****** ****** *)
(*
** 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
// Authoremal: gmhwxiATgmailDOTcom
// Start Time: December, 2016
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

%{^
//
#ifndef \
ATS2CPP_LIBATS_STL_VECTOR_STACK_DATS
#define \
ATS2CPP_LIBATS_STL_VECTOR_STACK_DATS
//
/* ****** ****** */
//
#include <vector>
//
#define \
fvectorptr(elt) std::vector<elt>*
//
#define \
fvectorptr_new(elt) new std::vector<int>()
#define \
fvectorptr_free(elt, p0) \
delete(static_cast<std::vector<elt>*>(p0))
//
#define \
fvectorptr_get_at(elt, p0, i) \
  (*(static_cast<std::vector<elt>*>(p0)))[i]
//
#define \
fvectorptr_back(elt, p0) \
  (static_cast<std::vector<elt>*>(p0))->back()
//
#define \
fvectorptr_push_back(elt, p0, x0) \
  (static_cast<std::vector<elt>*>(p0))->push_back(x0)
//
/* ****** ****** */
//
#endif // end of ifndef(ATS2CPP_LIBATS_STL_VECTOR_STACK_DATS)
//
%} // end of [%{^]

(* ****** ****** *)
//
absvtype
stack_vtype
(a:vt@ype+, n:int) = $extype"fvectorptr"(a)
//
stadef stack = stack_vtype
//
vtypedef
stack(a:vt@ype) = [n:int] stack_vtype(a, n)
//
(* ****** ****** *)
//
extern
fun
{a:vt@ype}
stack_make_nil(): stack(a, 0)
extern
fun
{a:vt@ype}
stack_free_nil(stack(a, 0)): void
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
stack_length
  {n:int}(stk: stack(a, n)): int(n) = "mac#%"
//
(* ****** ****** *)
//
extern
fun
{a:vt0p}
stack_insert
  {n:int}
(
  stk: !stack(a, n) >> stack(a, n+1), x0: a
) : void = "mac#%" // end-of-function
//
extern
fun
{a:vt0p}
stack_takeout
  {n:int | n > 0}
  (stk: !stack(a, n) >> stack(a, n-1)): a = "mac#%"
//
(* ****** ****** *)
//
// HX-2016-12:
// externally template-based implmentation
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
stack_make_nil
(
// argumentless
) =
$extfcall
(
  stack(a, 0), "fvectorptr_new", $tyrep(a)
) (* stack_make_nil *)
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
stack_free_nil
(
  p0
) = let
//
val p0 = $UN.castvwtp0{ptr}(p0)
//
in
//
$extfcall
  (void, "fvectorptr_free", $tyrep(a), p0)
//
end // end of [stack_free_nil]
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
stack_insert
  (p0, x0) = let
//
val x0 = $UN.castvwtp0{a?}(x0)
val p0 = $UN.castvwtp2void(p0)
val p0 = $UN.castvwtp1{ptr}(p0)
//
in
//
$extfcall
( void,
  "fvectorptr_push_back", $tyrep(a), p0, x0
) (* $extfcall *)
//
end // end of [stack_insert]
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
stack_takeout
  (p0) = let
//
val p0 = $UN.castvwtp2void(p0)
val p0 = $UN.castvwtp1{ptr}(p0)
//
in
  $extfcall(a, "fvectorptr_back", $tyrep(a), p0)
end // end of [stack_insert]
//
(* ****** ****** *)

(* end of [vector_stack.dats] *)

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

(*
** A linear stack
** implementation based on STL:vector
*)

(* ****** ****** *)
(*
** 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
// Authoremal: gmhwxiATgmailDOTcom
// Start Time: December, 2016
//
(* ****** ****** *)

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

(* end of [vector_stack.dats] *)


Updating: very minorly improving

Updating: very minorly improving

/*
** For sending code over to the server
** and then receiving the output from the server
*/

/* ****** ****** */
//
#include
"share/atspre_define.hats"
//
/* ****** ****** */
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/Ajax/Ajax.sats"
//
/* ****** ****** */
//
extern
fun
patsopt_atscc2js
  (code: string): void = "mac#"
//
extern
fun
patsopt_waiting(msg: string): void = "mac#"
extern
fun
patsopt_atscc2js_do_response(resp: string): void = "mac#"
//
/* ****** ****** */

implement
patsopt_atscc2js
  (code) = let
//
val () = patsopt_waiting("Waiting for the server...")
//
val xmlhttp =
  XMLHttpRequest_new()
val ((*void*)) =
xmlhttp.onreadystatechange
(
  lam((*void*)) =>
    if xmlhttp.is_ready_okay()
      then patsopt_atscc2js_do_response (xmlhttp.responseText())
  // end of [lam]
)
//
val ((*void*)) =
  xmlhttp.open("POST","patsopt-atscc2js.php", true)
val ((*void*)) =
  xmlhttp.setRequestHeader("Content-type", "application/x-www-form-urlencoded")
//
val () = xmlhttp.send("program_input=" + encodeURIComponent(code))
//
in
  // nothing
end // end of [patsopt_atscc2js]

/* ****** ****** */

/* end of [inputform_process.dats] */

/*
** For sending code over to the server
** and then receiving the output from the server
*/

/* ****** ****** */
//
#include
"share/atspre_define.hats"
//
/* ****** ****** */
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/SATS/Ajax/Ajax.sats"
//
/* ****** ****** */
//
extern
fun
patsopt_atscc2js
  (code: string): void = "mac#"
//
extern
fun
patsopt_waiting(msg: string): void = "mac#"
extern
fun
patsopt_atscc2js_do_response(resp: string): void = "mac#"
//
/* ****** ****** */

implement
patsopt_atscc2js
  (code) = let
//
val () = patsopt_waiting("Waiting for the server...")
//
val xmlhttp =
  XMLHttpRequest_new()
val ((*void*)) =
xmlhttp.onreadystatechange
(
  lam((*void*)) =>
    if xmlhttp.is_ready_okay()
      then patsopt_atscc2js_do_response (xmlhttp.responseText)
  // end of [lam]
)
//
val ((*void*)) =
  xmlhttp.open("POST","patsopt-atscc2js.php", true)
val ((*void*)) =
  xmlhttp.setRequestHeader("Content-type", "application/x-www-form-urlencoded")
//
val () = xmlhttp.send("program_input=" + encodeURIComponent(code))
//
in
  // nothing
end // end of [patsopt_atscc2js]

/* ****** ****** */

/* end of [inputform_process.dats] */


Updating: very minorly improving

Updating: very minorly improving

(*
** Poorman's Drawing
** Sierpinski triangles
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
//
#define
ATS_DYNLOADNAME
"Sierpinski_3angle_txt__dynload"
//
#define
ATS_STATIC_PREFIX "Sierpinski_3angle_txt__"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/print.sats"
//
staload
_ = "{$LIBATSCC2JS}/DATS/print.dats"
//
(* ****** ****** *)

#define NROW 48
#define NCOL 80

(* ****** ****** *)
//
val
theCanvas =
matrixref_make_elt{int}(NROW, NCOL, 0)
//
(* ****** ****** *)
//
fun
theCanvas_clear() =
matrixref_foreach_cloref
  (theCanvas, NROW, NCOL, lam(i, j) => (theCanvas[i,NCOL,j] := 0))
//
(* ****** ****** *)
//
fun
theCanvas_print() =
matrixref_foreach_cloref
(
  theCanvas
, NROW, NCOL
, lam(i, j) =>
  let
    val x = theCanvas[i,NCOL,j]
  in
    print_string(if x = 0 then " " else "*"); if j=NCOL-1 then print_newline()
  end // end of [let]
) (* end of [matrixref_foreach] *)
//
(* ****** ****** *)
//
extern
fun
draw_point(x: int, y: int): void
//
implement
draw_point(x, y) = let
//
val x = g1ofg0(x) and y = g1ofg0(y)
//
(*
val () = println! ("draw_point: x = ", x)
val () = println! ("draw_point: y = ", y)
*)
//
in
  if x < 0 then ()
  else if y < 0 then ()
  else if x >= NCOL then ()
  else if y >= NROW then ()
  else (theCanvas[y, NCOL, x] := 1)
end // end of [draw_point]
//
(* ****** ****** *)

typedef
point = $tup(int, int)

(* ****** ****** *)
//
extern
fun
midpoint(p1: point, p2: point): point
//
(* ****** ****** *)

implement
midpoint(p1, p2) = $tup((p1.0+p2.0)/2, (p1.1+p2.1)/2)

(* ****** ****** *)
//
extern
fun
draw_hline
  (x1: int, x2: int, y: int): void
//
(* ****** ****** *)

implement
draw_hline
  (x1, x2, y) = let
//
fun loop (x1: int): void =
  if x1 <= x2
    then (draw_point(x1, y); loop(x1+1)) else ()
  // end of [if]
//
in
  loop (x1)
end // end of [draw_hline]
//
(* ****** ****** *)
//
extern
fun
draw_triangle_0
  (p1: point, p2: point, p3: point): void
extern
fun
draw_triangle_1
  (p1: point, p2: point, p3: point): void
//
(* ****** ****** *)

implement
draw_triangle_0
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_point(x2, y2)
val () = draw_point(x3, y2)
//
in
  if y1 != y2
    then loop(x2+1, x3-1, y2+dir) else ()
  // end of [if]
end // end of [loop]
//
in
  draw_hline(x2+1, x3-1, y2); loop (x2, x3, y2)
end // end of [draw_triangle_0]

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

implement
draw_triangle_1
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_hline(x2, x3, y2)
//
in
  if y1 != y2 then loop(x2+1, x3-1, y2+dir) else ()
end // end of [loop]
//
in
  loop (x2, x3, y2)
end // end of [draw_triangle_1]

(* ****** ****** *)
//
extern
fun
draw_sierpinski
  (p1: point, p2: point, p3: point, n: int): void
extern
fun
draw_sierpinski_aux
  (p1: point, p2: point, p3: point, n: int): void
//
(* ****** ****** *)

implement
draw_sierpinski
  (p1, p2, p3, n) =
(
  if n > 0
    then draw_sierpinski_aux(p1, p2, p3, n)
    else ()
  // end of [if]
) (* end of [draw_sierpinski] *)

implement
draw_sierpinski_aux
  (p1, p2, p3, n) = let
//
  val p12 = midpoint(p1, p2)
  val p23 = midpoint(p2, p3)
  val p31 = midpoint(p3, p1)
//
  val () = draw_triangle_1(p23, p12, p31)
  val () = draw_sierpinski(p1, p12, p31, n-1)
  val () = draw_sierpinski(p12, p2, p23, n-1)
  val () = draw_sierpinski(p31, p23, p3, n-1)
//
in
  // nothing
end // end of [draw_sierpinski_aux]

(* ****** ****** *)
//
extern
fun
draw_sierpinski_demo
  (level: int): void = "mac#"
//
(* ****** ****** *)

implement
draw_sierpinski_demo
  (level) = let
//
val p1 = $tup(32, 0 )
val p2 = $tup(0 , 32)
val p3 = $tup(64, 32)
//
val () = theCanvas_clear()
val () = draw_triangle_0(p1, p2, p3)
val () = draw_sierpinski(p1, p2, p3, level)
val () = theCanvas_print()
//
in
  // nothing
end // end of [draw_sierpinski_demo]

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

%{$
//
var theLevel = 0;
var theLevelMax = 5;

function
draw2_sierpinski_demo()
{
//
var
level = theLevel;
//
theLevel = (level+1)%theLevelMax;
//
var _ =
ats2jspre_the_print_store_clear();
//
var _ = draw_sierpinski_demo(level);
//
document.getElementById("theDrawingString").innerHTML = ats2jspre_the_print_store_join();
//
setTimeout(draw2_sierpinski_demo, 1000);
//
return;
//
} // end of [draw2_sierpinski_demo]
//
jQuery(document).ready(function(){Sierpinski_3angle_txt__dynload(); draw2_sierpinski_demo();});
//
%} // end of [%{$]

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

(* end of [Sierpinski_3angle_txt.dats] *)

(*
** Poorman's Drawing
** Sierpinski triangles
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
//
#define
ATS_DYNLOADNAME
"Sierpinski_3angle_txt__dynload"
//
#define
ATS_STATIC_PREFIX "Sierpinski_3angle_txt__"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/print.sats"
//
staload
_ = "{$LIBATSCC2JS}/DATS/print.dats"
//
(* ****** ****** *)

#define NROW 48
#define NCOL 80

(* ****** ****** *)
//
val
theCanvas =
matrixref_make_elt{int}(NROW, NCOL, 0)
//
(* ****** ****** *)
//
fun
theCanvas_clear() =
matrixref_foreach_cloref
  (theCanvas, NROW, NCOL, lam(i, j) => (theCanvas[i,NCOL,j] := 0))
//
(* ****** ****** *)
//
fun
theCanvas_print() =
matrixref_foreach_cloref
(
  theCanvas
, NROW, NCOL
, lam(i, j) =>
  let
    val x = theCanvas[i,NCOL,j]
  in
    print_string(if x = 0 then " " else "X"); if j=NCOL-1 then print_newline()
  end // end of [let]
) (* end of [matrixref_foreach] *)
//
(* ****** ****** *)
//
extern
fun
draw_point(x: int, y: int): void
//
implement
draw_point(x, y) = let
//
val x = g1ofg0(x) and y = g1ofg0(y)
//
(*
val () = println! ("draw_point: x = ", x)
val () = println! ("draw_point: y = ", y)
*)
//
in
  if x < 0 then ()
  else if y < 0 then ()
  else if x >= NCOL then ()
  else if y >= NROW then ()
  else (theCanvas[y, NCOL, x] := 1)
end // end of [draw_point]
//
(* ****** ****** *)

typedef
point = $tup(int, int)

(* ****** ****** *)
//
extern
fun
midpoint(p1: point, p2: point): point
//
(* ****** ****** *)

implement
midpoint(p1, p2) = $tup((p1.0+p2.0)/2, (p1.1+p2.1)/2)

(* ****** ****** *)
//
extern
fun
draw_hline
  (x1: int, x2: int, y: int): void
//
(* ****** ****** *)

implement
draw_hline
  (x1, x2, y) = let
//
fun loop (x1: int): void =
  if x1 <= x2
    then (draw_point(x1, y); loop(x1+1)) else ()
  // end of [if]
//
in
  loop (x1)
end // end of [draw_hline]
//
(* ****** ****** *)
//
extern
fun
draw_triangle_0
  (p1: point, p2: point, p3: point): void
extern
fun
draw_triangle_1
  (p1: point, p2: point, p3: point): void
//
(* ****** ****** *)

implement
draw_triangle_0
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_point(x2, y2)
val () = draw_point(x3, y2)
//
in
  if y1 != y2
    then loop(x2+1, x3-1, y2+dir) else ()
  // end of [if]
end // end of [loop]
//
in
  draw_hline(x2+1, x3-1, y2); loop (x2, x3, y2)
end // end of [draw_triangle_0]

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

implement
draw_triangle_1
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_hline(x2, x3, y2)
//
in
  if y1 != y2 then loop(x2+1, x3-1, y2+dir) else ()
end // end of [loop]
//
in
  loop (x2, x3, y2)
end // end of [draw_triangle_1]

(* ****** ****** *)
//
extern
fun
draw_sierpinski
  (p1: point, p2: point, p3: point, n: int): void
extern
fun
draw_sierpinski_aux
  (p1: point, p2: point, p3: point, n: int): void
//
(* ****** ****** *)

implement
draw_sierpinski
  (p1, p2, p3, n) =
(
  if n > 0
    then draw_sierpinski_aux(p1, p2, p3, n)
    else ()
  // end of [if]
) (* end of [draw_sierpinski] *)

implement
draw_sierpinski_aux
  (p1, p2, p3, n) = let
//
  val p12 = midpoint(p1, p2)
  val p23 = midpoint(p2, p3)
  val p31 = midpoint(p3, p1)
//
  val () = draw_triangle_1(p23, p12, p31)
  val () = draw_sierpinski(p1, p12, p31, n-1)
  val () = draw_sierpinski(p12, p2, p23, n-1)
  val () = draw_sierpinski(p31, p23, p3, n-1)
//
in
  // nothing
end // end of [draw_sierpinski_aux]

(* ****** ****** *)
//
extern
fun
draw_sierpinski_demo
  (level: int): void = "mac#"
//
(* ****** ****** *)

implement
draw_sierpinski_demo
  (level) = let
//
val p1 = $tup(32, 0 )
val p2 = $tup(0 , 32)
val p3 = $tup(64, 32)
//
val () = theCanvas_clear()
val () = draw_triangle_0(p1, p2, p3)
val () = draw_sierpinski(p1, p2, p3, level)
val () = theCanvas_print()
//
in
  // nothing
end // end of [draw_sierpinski_demo]

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

%{$
//
var theLevel = 0;
var theLevelMax = 5;

function
draw2_sierpinski_demo()
{
//
var
level = theLevel;
//
theLevel = (level+1)%theLevelMax;
//
var _ =
ats2jspre_the_print_store_clear();
//
var _ = draw_sierpinski_demo(level);
//
document.getElementById("theDrawingString").innerHTML = ats2jspre_the_print_store_join();
//
setTimeout(draw2_sierpinski_demo, 1000);
//
return;
//
} // end of [draw2_sierpinski_demo]
//
jQuery(document).ready(function(){Sierpinski_3angle_txt__dynload(); draw2_sierpinski_demo();});
//
%} // end of [%{$]

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

(* end of [Sierpinski_3angle_txt.dats] *)


Updating; minorly improving

Updating; minorly improving

(*
** The Great Computer Language Shootout
** http://shootout.alioth.debian.org/
**
** contributed by Hongwei Xi (gmhwxiATgmailDOTcom)
*)

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

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

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

staload "libc/SATS/string.sats"

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

implement
fileref_get_line_string$bufsize<> () = 64

(* ****** ****** *)
//
extern
fun
fileref_get_rest (inp: FILEref): Strptr0
//
implement
fileref_get_rest
  (inp) = let
//
vtypedef
res = List0_vt(Strptr1)
//
fun loop
  (lines: res): res = let
in
  if fileref_isnot_eof (inp) then let
    val line = fileref_get_line_string (inp)
    val lines = list_vt_cons (line, lines)
  in
    loop (lines)
  end else lines // end of [if]
end // end of [loop]
//
val lines = loop (list_vt_nil)
val lines = list_vt_reverse (lines)
//
in
  strptrlst_concat (lines)
end // end of [fileref_get_rest]
//
(* ****** ****** *)
//
extern
fun
fileref_get_three (inp: FILEref): Strptr0
//
implement
fileref_get_three
  (inp) = let
//
val line =
fileref_get_line_string(inp)
val sgn0 = strncmp ($UN.strptr2string(line), ">THREE", i2sz(6))
val ((*void*)) = free (line)
//
in
  if sgn0 != 0 then fileref_get_three (inp) else fileref_get_rest (inp)
end // end of [fileref_get_three]

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

%{^
//
static
int C__mychar2int[256] = { 0 } ;
static
char C__myint2char[4] = {'A', 'C', 'T', 'G'} ;
//
%} // end of [%{^]

extern
fun
C__mychar2int_initize (): void
implement
C__mychar2int_initize () =
{
//
  val p0 = $extval(ptr, "C__mychar2int")
//
  val A = char2u2int0 ('A')
  val ()= $UN.ptr0_set_at<int> (p0, A, 0)
  val C = char2u2int0 ('C')
  val ()= $UN.ptr0_set_at<int> (p0, C, 1)
  val T = char2u2int0 ('T')
  val ()= $UN.ptr0_set_at<int> (p0, T, 2)
  val G = char2u2int0 ('G')
  val ()= $UN.ptr0_set_at<int> (p0, G, 3)
} (* end of [C__mychar2int_initize] *)

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

extern
fun
mychar2int (c: char): int
implement
mychar2int (c) = let
  val i = char2u2int0 (c)
in
  $UN.ptr0_get_at($extval(ptr, "C__mychar2int"), i)
end // end of [myint2char]

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

extern
fun
myint2char (int: natLt(4)): char
implement
myint2char (i) = $UN.ptr0_get_at($extval(ptr, "C__myint2char"), i)

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

abstype dna = ptr
absvtype symtbl (a:t@ype) = ptr

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

extern
fun{
a:t@ype
} symbol_lsl (key: a, k: Nat): a

implement
symbol_lsl<uint32> (key, k) = key << k
implement
symbol_lsl<uint64> (key, k) = key << k

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

extern
fun{
a:t@ype
} symbol_lnot (key: a): a

implement
symbol_lnot<uint32> (key) = ~key
implement
symbol_lnot<uint64> (key) = ~key

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

extern
fun{
a:t@ype
} symbol_lor (key1: a, key2: a): a

implement
symbol_lor<uint32> (key1, key2) = key1 lor key2
implement
symbol_lor<uint64> (key1, key2) = key1 lor key2

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

extern
fun{
a:t@ype
} symbol_land (key1: a, key2: a): a

implement
symbol_land<uint32> (key1, key2) = key1 land key2
implement
symbol_land<uint64> (key1, key2) = key1 land key2

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

extern
fun{
a:t@ype
} string2symbol (key: string): a

implement
{a}(*tmp*)
string2symbol
  (key) = let
//
val key = g1ofg0 (key)
//
fun
loop{n:nat} .<n>.
(
  key: string(n), res: a
) : a = let
in
//
if string_isnot_empty (key)
  then loop (key.tail, symbol_lor (symbol_lsl (res, 2), $UN.cast{a}(mychar2int(key[0])))) else res
//
end // end of [if]
//
in
  loop (key, $UN.cast{a}(0))
end // end of [string2symbol]

(* ****** ****** *)
//
extern
fun{
a:t@ype
} print_symbol (key: a, k: int): void
//
extern
fun
print_symbol32 (key: uint32, k: int): void
extern
fun
print_symbol64 (key: uint64, k: int): void
//
(* ****** ****** *)
//
implement
print_symbol32
  (key, k) = let
in
//
if
k > 0
then let
  val key2 = key >> 2
  val ((*void*)) = print_symbol32 (key2, k-1)
in
  print_char(myint2char($UN.cast{natLt(4)}(key land $UN.cast{uint32}(0x3))))
end // end of [then]
else () // end of [else]
//
end // end of [print_symbol32]

implement
print_symbol<uint32> = print_symbol32

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

extern
fun{
a:t@ype
} symtbl_make (cap: intGte(1)): symtbl(a)

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

extern
fun{a:t@ype} symtbl_free (tbl: symtbl(a)): void

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

extern
fun{
a:t@ype
} symtbl_incby1
  (tbl: !symtbl(a), key: a): void

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

extern
fun{
a:t@ype
} symtbl_get_count
  (tbl: !symtbl(a), key: a): (int)
extern
fun{
a:t@ype
} symtbl_get_total (tbl: !symtbl(a)): (int)

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

extern
fun{
a:t@ype
} symtbl_listize
  (tbl: symtbl(a)): List0_vt @(a, int)

(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_linprb.sats"
//
staload _(*anon*) = "libats/DATS/hashfun.dats"
(*
staload _(*anon*) = "libats/DATS/linmap_list.dats"
*)
staload _(*anon*) = "libats/DATS/hashtbl_linprb.dats"
//
implement
hashtbl_linprb_keyitm_is_null<uint32,int> (kx) = (kx.1 = 0)
implement
hashtbl_linprb_keyitm_is_null<uint64,int> (kx) = (kx.1 = 0)
//
local

assume
symtbl (a:t@ype) = hashtbl (a, int)

in (*in-of-local*)

implement
{a}(*tmp*)
symtbl_make (cap) =
  hashtbl_make_nil<a,int> (i2sz(cap))

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

implement
{a}(*tmp*)
symtbl_free (tbl) = hashtbl_free<a,int> (tbl)

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

implement
{a}(*tmp*)
symtbl_incby1
  (tbl, key) = let
//
val cp =
hashtbl_search_ref<a,int> (tbl, key)
val isnot = isneqz (cp)
//
in
//
if
isnot
then let
  val (
    pf, fpf | p
  ) = $UN.cptr_vtake (cp)
  val ((*void*)) = !p := succ (!p)
  prval ((*void*)) = fpf (pf)
in
  // nothing
end // end of [then]
else let
  val-~None_vt() =
    hashtbl_insert_opt<a,int> (tbl, key, 1)
  // end of [val]
in
  // nothing
end // end of [else]
//
end // end of [symtbl_incby1]

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

implement
{a}(*tmp*)
symtbl_get_count
  (tbl, key) = let
//
val opt =
  hashtbl_search_opt<a,int> (tbl, key)
//
in
//
case+ opt of ~Some_vt (n) => n | ~None_vt () => 0
//
end // end of [symtbl_get_count]

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

implement
{a}(*tmp*)
symtbl_get_total
  (tbl) = let
//
implement
hashtbl_foreach$fwork<a,int><int>
  (key, cnt, total) = total := total + cnt
//
var total: int = 0
val ((*void*)) =
  hashtbl_foreach_env<a,int><int> (tbl, total)
//
in
  total
end // end of [symtbl_get_total]

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

implement
{a}(*tmp*)
symtbl_listize (tbl) = hashtbl_listize<a,int> (tbl)

end // end of [local]

(* ****** ****** *)
//
extern
fun{
a:t@ype
} symbol_extend (key: a, c: char): a
//
extern
fun{
a:t@ype
} dna_count
  {n,k:nat | k <= n}
  (dna: dna, tbl: !symtbl(a), n: int n, k: int k): void
//
implement
{a}(*tmp*)
dna_count
(
  dna, tbl, n, k
) = let
//
val mask = $UN.cast{a}(~1)
val mask = symbol_lsl<a> (mask, 2*k)
val mask = symbol_lnot<a> (mask)
//
implement
symbol_extend<a>
  (key, c) = let
  val key = symbol_lsl<a> (key, 2)
  val key = symbol_land<a> (mask, key)
in
  symbol_lor<a> (key, $UN.cast{a}(mychar2int(c)))
end // end of [symbol_extend]
//
fun aux0
(
  p: ptr, k: int, key: &a >> _
) : ptr =
(
if k > 0
  then let
    val c =
      $UN.ptr0_get<char> (p)
    // end of [val]
    val () = key := symbol_extend (key, c)
  in
    aux0 (ptr_succ<char> (p), k - 1, key)
  end // end of [then]
  else (p) // end of [else]
)
//
var key: a
prval () =
__assert (view@key) where
{
  extern
  praxi __assert(pf: !(a?)@key >> (a)@key): void
}
//
val p0 = $UN.cast2ptr(dna)
val p1 = aux0 (p0, k, key)
val () = symtbl_incby1 (tbl, key)
val key = key
//
fun aux1
(
  tbl: !symtbl(a), p: ptr, nk: int, key: a
) : void =
(
if
nk > 0
then let
  val c =
    $UN.ptr0_get<char> (p)
  // end of [val]
  val key = symbol_extend (key, c)
  val () = symtbl_incby1 (tbl, key)
in
  aux1 (tbl, ptr_succ<char> (p), nk-1, key)
end // end of [then]
else () // end of [else]
)
//
val () = aux1 (tbl, p1, n - k, key)
//
in
  // nothing
end // end of [dna_count]

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

extern
fun{
a:t@ype
} print_keyfrequencies
  (kfs: List0_vt @(a, float), k: int): void

implement
{a}(*tmp*)
print_keyfrequencies
  (kfs, k) = let
in
//
case+ kfs of
| ~list_vt_nil () => ()
| ~list_vt_cons (kf, kfs) =>
  {
    val () = print_symbol<a> (kf.0, k)
    val () = $extfcall (void, "printf", " %.3f\n", kf.1)
    val () = print_keyfrequencies<a> (kfs, k)
  }
//
end // end of [print_keyfrequencies]

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

extern
fun{
a:t@ype
} write_frequencies
  {n,k:nat}
(
  dna: dna, n: int n, k: int k
) : void // end of [write_frequencies]

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

implement
{a}(*tmp*)
write_frequencies
  (dna, n, k) = let
//
val () = assertloc (n >= k)
//
val tbl = symtbl_make<a> (1024)
val ((*void*)) = dna_count (dna, tbl, n, k)
//
val ftotal =
  $UN.cast{float}(symtbl_get_total<a> (tbl))
//
val kxs = symtbl_listize<a> (tbl)
//
typedef ki = (a, int) and kf = (a, float)
//
local
implement
list_vt_mapfree$fopr<ki><kf>
  (kx) = (kx.0, 100.0f*kx.1/ftotal)
in(*in-of-local*)
val kfs = list_vt_mapfree<ki><kf> (kxs)
end // end of [local]
//
local
implement
list_vt_mergesort$cmp<kf>
  (kf1, kf2) = compare (kf2.1, kf1.1)
in(*in-of-local*)
val kfs = list_vt_mergesort<kf> (kfs)
end // end of [local]
//
in
  print_keyfrequencies (kfs, k)
end // end of [write_frequencies]

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

%{^
typedef char *charptr ;
%} ;
abstype charptr = $extype"charptr"

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

extern
fun{
a:t@ype
} write_count
  {n:nat}
(
  dna: dna, n: int n, key: string
) : void // end of [write_frequencies]

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

implement
{a}(*tmp*)
write_count
  (dna, n, key) = let
//
val k = length(key)
val k = g1ofg0_uint (k)
val k = g1uint2int_size_int (k)
val () = assertloc (n >= k)
//
val tbl = symtbl_make<a> (1024*1024)
val ((*void*)) = dna_count (dna, tbl, n, k)
//
val key2 = string2symbol<a> (key)
val cnt = symtbl_get_count (tbl, key2)
val ((*void*)) = symtbl_free (tbl)
//
in
  $extfcall (void, "printf", "%d\t%s\n", cnt, $UN.cast{charptr}(key))
end // end of [write_frequencies]

(* ****** ****** *)
//
implement
hash_key<uint32> (x) =
  $UN.cast{ulint}(inthash_jenkins(x))
implement
hash_key<uint64> (x) =
  $UN.cast{ulint}(inthash_jenkins($UN.cast{uint32}(x)))
//
implement
gequal_val<uint32> (x1, x2) = (x1 = x2)
implement
gequal_val<uint64> (x1, x2) = (x1 = x2)
//
(* ****** ****** *)

implement
main0 () = () where
{
//
val () = C__mychar2int_initize ()
//
(*
val i = 0
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 1
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 2
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 3
val () = println! ("myint2char(", i, ") = ", myint2char(i))
*)
//
(*
val c = 'A'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'C'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'T'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'G'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
*)
//
val dna =
fileref_get_three(stdin_ref)
val () = assertloc(ptrcast(dna) > 0)
val dna = strptr2strnptr(dna)
prval () = lemma_strnptr_param (dna)
//
local
implement(env)
strnptr_foreach$fwork<env>
  (c, env) =
(
  c := $UN.cast{charNZ}(toupper(c))
) (* end of [strnptr_foreach$fwork] *)
in (*in-of-local*)
val dna_len = strnptr_foreach<> (dna)
end // end of [local]
//
val dna = $UN.castvwtp0{dna}(dna)
val dna_len = g1uint2int_size_int (dna_len)
//
(*
val () = println! ("dna_len = ", dna_len)
*)
//
val () =
write_frequencies<uint32> (dna, dna_len, 1)
val () = print_newline ()
val () =
write_frequencies<uint32> (dna, dna_len, 2)
val () = print_newline ()
//
val () = write_count<uint32> (dna, dna_len, "GGT")
val () = write_count<uint32> (dna, dna_len, "GGTA")
val () = write_count<uint32> (dna, dna_len, "GGTATT")
val () = write_count<uint32> (dna, dna_len, "GGTATTTTAATT")
val () = write_count<uint64> (dna, dna_len, "GGTATTTTAATTTATAGT")
//
} (* end of [main0] *)

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

local
//
#include "prelude/DATS/filebas.dats"
//
in (* nothing *) end // end of [local]

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

(* end of [k-nucleotide.dats] *)

(*
** The Great Computer Language Shootout
** http://shootout.alioth.debian.org/
**
** contributed by Hongwei Xi (gmhwxiATgmailDOTcom)
*)

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

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

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

staload "libc/SATS/string.sats"

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

implement
fileref_get_line_string$bufsize<> () = 64

(* ****** ****** *)
//
extern
fun
fileref_get_rest (inp: FILEref): Strptr0
//
implement
fileref_get_rest
  (inp) = let
//
vtypedef
res = List0_vt(Strptr1)
//
fun loop
  (lines: res): res = let
in
  if fileref_isnot_eof (inp) then let
    val line = fileref_get_line_string (inp)
    val lines = list_vt_cons (line, lines)
  in
    loop (lines)
  end else lines // end of [if]
end // end of [loop]
//
val lines = loop (list_vt_nil)
val lines = list_vt_reverse (lines)
//
in
  strptrlst_concat (lines)
end // end of [fileref_get_rest]
//
(* ****** ****** *)
//
extern
fun
fileref_get_three (inp: FILEref): Strptr0
//
implement
fileref_get_three
  (inp) = let
//
val line =
fileref_get_line_string(inp)
val sgn0 = strncmp ($UN.strptr2string(line), ">THREE", i2sz(6))
val ((*void*)) = free (line)
//
in
  if sgn0 != 0 then fileref_get_three (inp) else fileref_get_rest (inp)
end // end of [fileref_get_three]

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

%{^
//
static
int C__mychar2int[256] = { 0 } ;
static
char C__myint2char[4] = {'A', 'C', 'T', 'G'} ;
//
%} // end of [%{^]

extern
fun
C__mychar2int_initize (): void
implement
C__mychar2int_initize () =
{
//
  val p0 = $extval(ptr, "C__mychar2int")
//
  val A = char2u2int0 ('A')
  val ()= $UN.ptr0_set_at<int> (p0, A, 0)
  val C = char2u2int0 ('C')
  val ()= $UN.ptr0_set_at<int> (p0, C, 1)
  val T = char2u2int0 ('T')
  val ()= $UN.ptr0_set_at<int> (p0, T, 2)
  val G = char2u2int0 ('G')
  val ()= $UN.ptr0_set_at<int> (p0, G, 3)
} (* end of [C__mychar2int_initize] *)

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

extern
fun
mychar2int (c: char): int
implement
mychar2int (c) = let
  val i = char2u2int0 (c)
in
  $UN.ptr0_get_at($extval(ptr, "C__mychar2int"), i)
end // end of [myint2char]

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

extern
fun
myint2char (int: natLt(4)): char
implement
myint2char (i) = $UN.ptr0_get_at($extval(ptr, "C__myint2char"), i)

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

abstype dna = ptr
absvtype symtbl (a:t@ype) = ptr

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

extern
fun{
a:t@ype
} symbol_lsl (key: a, k: Nat): a

implement
symbol_lsl<uint32> (key, k) = key << k
implement
symbol_lsl<uint64> (key, k) = key << k

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

extern
fun{
a:t@ype
} symbol_lnot (key: a): a

implement
symbol_lnot<uint32> (key) = ~key
implement
symbol_lnot<uint64> (key) = ~key

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

extern
fun{
a:t@ype
} symbol_lor (key1: a, key2: a): a

implement
symbol_lor<uint32> (key1, key2) = key1 lor key2
implement
symbol_lor<uint64> (key1, key2) = key1 lor key2

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

extern
fun{
a:t@ype
} symbol_land (key1: a, key2: a): a

implement
symbol_land<uint32> (key1, key2) = key1 land key2
implement
symbol_land<uint64> (key1, key2) = key1 land key2

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

extern
fun{
a:t@ype
} string2symbol (key: string): a

implement
{a}(*tmp*)
string2symbol
  (key) = let
//
val key = g1ofg0 (key)
//
fun
loop{n:nat} .<n>.
(
  key: string(n), res: a
) : a = let
in
//
if string_isnot_empty (key)
  then loop (key.tail, symbol_lor (symbol_lsl (res, 2), $UN.cast{a}(mychar2int(key[0])))) else res
//
end // end of [if]
//
in
  loop (key, $UN.cast{a}(0))
end // end of [string2symbol]

(* ****** ****** *)
//
extern
fun{
a:t@ype
} print_symbol (key: a, k: int): void
//
extern
fun
print_symbol32 (key: uint32, k: int): void
extern
fun
print_symbol64 (key: uint64, k: int): void
//
(* ****** ****** *)
//
implement
print_symbol32
  (key, k) = let
in
//
if
k > 0
then let
  val key2 = key >> 2
  val ((*void*)) = print_symbol32 (key2, k-1)
in
  print_char(myint2char($UN.cast{natLt(4)}(key land $UN.cast{uint32}(0x3))))
end // end of [then]
else () // end of [else]
//
end // end of [print_symbol32]

implement
print_symbol<uint32> = print_symbol32

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

extern
fun{
a:t@ype
} symtbl_make (cap: intGte(1)): symtbl(a)

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

extern
fun{a:t@ype} symtbl_free (tbl: symtbl(a)): void

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

extern
fun{
a:t@ype
} symtbl_incby1
  (tbl: !symtbl(a), key: a): void

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

extern
fun{
a:t@ype
} symtbl_get_count
  (tbl: !symtbl(a), key: a): (int)
extern
fun{
a:t@ype
} symtbl_get_total (tbl: !symtbl(a)): (int)

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

extern
fun{
a:t@ype
} symtbl_listize
  (tbl: symtbl(a)): List0_vt @(a, int)

(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_linprb.sats"
//
staload _(*anon*) = "libats/DATS/hashfun.dats"
(*
staload _(*anon*) = "libats/DATS/linmap_list.dats"
*)
staload _(*anon*) = "libats/DATS/hashtbl_linprb.dats"
//
implement
hashtbl_linprb_keyitm_is_null<uint32,int> (kx) = (kx.1 = 0)
implement
hashtbl_linprb_keyitm_is_null<uint64,int> (kx) = (kx.1 = 0)
//
local

assume
symtbl (a:t@ype) = hashtbl (a, int)

in (*in-of-local*)

implement
{a}(*tmp*)
symtbl_make (cap) =
  hashtbl_make_nil<a,int> (i2sz(cap))

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

implement
{a}(*tmp*)
symtbl_free (tbl) = hashtbl_free<a,int> (tbl)

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

implement
{a}(*tmp*)
symtbl_incby1
  (tbl, key) = let
//
val cp =
hashtbl_search_ref<a,int> (tbl, key)
val isnot = isneqz (cp)
//
in
//
if
isnot
then let
  val (
    pf, fpf | p
  ) = $UN.cptr_vtake (cp)
  val ((*void*)) = !p := succ (!p)
  prval ((*void*)) = fpf (pf)
in
  // nothing
end // end of [then]
else let
  val-~None_vt() =
    hashtbl_insert_opt<a,int> (tbl, key, 1)
  // end of [val]
in
  // nothing
end // end of [else]
//
end // end of [symtbl_incby1]

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

implement
{a}(*tmp*)
symtbl_get_count
  (tbl, key) = let
//
val opt =
  hashtbl_search_opt<a,int> (tbl, key)
//
in
//
case+ opt of ~Some_vt (n) => n | ~None_vt () => 0
//
end // end of [symtbl_get_count]

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

implement
{a}(*tmp*)
symtbl_get_total
  (tbl) = let
//
implement
hashtbl_foreach$fwork<a,int><int>
  (key, cnt, total) = total := total + cnt
//
var total: int = 0
val ((*void*)) =
  hashtbl_foreach_env<a,int><int> (tbl, total)
//
in
  total
end // end of [symtbl_get_total]

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

implement
{a}(*tmp*)
symtbl_listize (tbl) = hashtbl_listize<a,int> (tbl)

end // end of [local]

(* ****** ****** *)
//
extern
fun{
a:t@ype
} symbol_extend (key: a, c: char): a
//
extern
fun{
a:t@ype
} dna_count
  {n,k:nat | k <= n}
  (dna: dna, tbl: !symtbl(a), n: int n, k: int k): void
//
implement
{a}(*tmp*)
dna_count
(
  dna, tbl, n, k
) = let
//
val mask = $UN.cast{a}(~1)
val mask = symbol_lsl<a> (mask, 2*k)
val mask = symbol_lnot<a> (mask)
//
implement
symbol_extend<a>
  (key, c) = let
  val key = symbol_lsl<a> (key, 2)
  val key = symbol_land<a> (mask, key)
in
  symbol_lor<a> (key, $UN.cast{a}(mychar2int(c)))
end // end of [symbol_extend]
//
fun aux0
(
  p: ptr, k: int, key: &a >> _
) : ptr =
(
if k > 0
  then let
    val c =
      $UN.ptr0_get<char> (p)
    // end of [val]
    val () = key := symbol_extend (key, c)
  in
    aux0 (ptr_succ<char> (p), k - 1, key)
  end // end of [then]
  else (p) // end of [else]
)
//
var key: a
prval () =
__assert (view@key) where
{
  extern
  praxi __assert(pf: !(a?)@key >> (a)@key): void
}
//
val p0 = $UN.cast2ptr(dna)
val p1 = aux0 (p0, k, key)
val () = symtbl_incby1 (tbl, key)
val key = key
//
fun aux1
(
  tbl: !symtbl(a), p: ptr, nk: int, key: a
) : void =
(
if
nk > 0
then let
  val c =
    $UN.ptr0_get<char> (p)
  // end of [val]
  val key = symbol_extend (key, c)
  val () = symtbl_incby1 (tbl, key)
in
  aux1 (tbl, ptr_succ<char> (p), nk-1, key)
end // end of [then]
else () // end of [else]
)
//
val () = aux1 (tbl, p1, n - k, key)
//
in
  // nothing
end // end of [dna_count]

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

extern
fun{
a:t@ype
} print_keyfrequencies
  (kfs: List0_vt @(a, float), k: int): void

implement
{a}(*tmp*)
print_keyfrequencies
  (kfs, k) = let
in
//
case+ kfs of
| ~list_vt_nil () => ()
| ~list_vt_cons (kf, kfs) =>
  {
    val () = print_symbol<a> (kf.0, k)
    val () = $extfcall (void, "printf", " %.3f\n", kf.1)
    val () = print_keyfrequencies<a> (kfs, k)
  }
//
end // end of [print_keyfrequencies]

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

extern
fun{
a:t@ype
} write_frequencies
  {n,k:nat}
(
  dna: dna, n: int n, k: int k
) : void // end of [write_frequencies]

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

implement
{a}(*tmp*)
write_frequencies
  (dna, n, k) = let
//
val () = assertloc (n >= k)
//
val tbl = symtbl_make<a> (1024)
val ((*void*)) = dna_count (dna, tbl, n, k)
//
val ftotal =
  $UN.cast{float}(symtbl_get_total<a> (tbl))
//
val kxs = symtbl_listize<a> (tbl)
//
typedef ki = (a, int) and kf = (a, float)
//
local
implement
list_vt_mapfree$fopr<ki><kf>
  (kx) = (kx.0, 100.0f*kx.1/ftotal)
in(*in-of-local*)
val kfs = list_vt_mapfree<ki><kf> (kxs)
end // end of [local]
//
local
implement
list_vt_mergesort$cmp<kf>
  (kf1, kf2) = compare (kf2.1, kf1.1)
in(*in-of-local*)
val kfs = list_vt_mergesort<kf> (kfs)
end // end of [local]
//
in
  print_keyfrequencies (kfs, k)
end // end of [write_frequencies]

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

%{^
typedef char *charptr ;
%} ;
abstype charptr = $extype"charptr"

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

extern
fun{
a:t@ype
} write_count
  {n:nat}
(
  dna: dna, n: int n, key: string
) : void // end of [write_frequencies]

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

implement
{a}(*tmp*)
write_count
  (dna, n, key) = let
//
val k = length(key)
val k = g1ofg0_uint (k)
val k = g1uint2int_size_int (k)
val () = assertloc (n >= k)
//
val tbl = symtbl_make<a> (1024*1024)
val ((*void*)) = dna_count (dna, tbl, n, k)
//
val key2 = string2symbol<a> (key)
val cnt = symtbl_get_count (tbl, key2)
val ((*void*)) = symtbl_free (tbl)
//
in
  $extfcall (void, "printf", "%d\t%s\n", cnt, $UN.cast{charptr}(key))
end // end of [write_frequencies]

(* ****** ****** *)
//
implement
hash_key<uint32> (x) =
  $UN.cast{ulint}(inthash_jenkins(x))
implement
hash_key<uint64> (x) =
  $UN.cast{ulint}(inthash_jenkins($UN.cast{uint32}(x)))
//
implement
gequal_val<uint32> (x1, x2) = (x1 = x2)
implement
gequal_val<uint64> (x1, x2) = (x1 = x2)
//
(* ****** ****** *)

implement
main0 () = () where
{
//
val () = C__mychar2int_initize ()
//
(*
val i = 0
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 1
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 2
val () = println! ("myint2char(", i, ") = ", myint2char(i))
val i = 3
val () = println! ("myint2char(", i, ") = ", myint2char(i))
*)
//
(*
val c = 'A'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'C'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'T'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
val c = 'G'
val () = println! ("mychar2int(", c, ") = ", mychar2int(c))
*)
//
val dna =
fileref_get_three(stdin_ref)
val () = assertloc(ptrcast(dna) > 0)
val dna = strptr2strnptr(dna)
prval () = lemma_strnptr_param (dna)
local
implement(env)
strnptr_foreach$fwork<env>
  (c, env) = (c := $UN.cast{charNZ}(toupper(c)))
in(*in-of-local*)
val dna_len = strnptr_foreach<> (dna)
end // end of [local]
//
val dna = $UN.castvwtp0{dna}(dna)
val dna_len = g1uint2int_size_int (dna_len)
//
(*
val () = println! ("dna_len = ", dna_len)
*)
//
val () =
write_frequencies<uint32> (dna, dna_len, 1)
val () = print_newline ()
val () =
write_frequencies<uint32> (dna, dna_len, 2)
val () = print_newline ()
//
val () = write_count<uint32> (dna, dna_len, "GGT")
val () = write_count<uint32> (dna, dna_len, "GGTA")
val () = write_count<uint32> (dna, dna_len, "GGTATT")
val () = write_count<uint32> (dna, dna_len, "GGTATTTTAATT")
val () = write_count<uint64> (dna, dna_len, "GGTATTTTAATTTATAGT")
//
} (* end of [main0] *)

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

local
//
#include "prelude/DATS/filebas.dats"
//
in (* nothing *) end // end of [local]

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

(* end of [k-nucleotide.dats] *)