Revised the reduce function to something that looked more like fold.

(***********************************************************************)
(*                                                                     *)
(*                         Applied Type System                         *)
(*                                                                     *)
(***********************************************************************)

(*
** ATS/Postiats - Unleashing the Potential of Types!
** Copyright (C) 2011-20?? Hongwei Xi, ATS Trustful Software, Inc.
** All rights reserved
**
** ATS is free software;  you can  redistribute it and/or modify it under
** the terms of  the GNU GENERAL PUBLIC LICENSE (GPL) as published by the
** Free Software Foundation; either version 3, or (at  your  option)  any
** later version.
**
** ATS is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without  even  the  implied  warranty  of MERCHANTABILITY or
** FITNESS FOR A PARTICULAR PURPOSE.  See the  GNU General Public License
** for more details.
**
** You  should  have  received  a  copy of the GNU General Public License
** along  with  ATS;  see the  file COPYING.  If not, please write to the
** Free Software Foundation,  51 Franklin Street, Fifth Floor, Boston, MA
** 02110-1301, USA.
*)

(* ****** ****** *)
//
// Author: Will Blair (wdblair AT cs DOT bu DOT edu)
// Start Time: May, 2013
//
(* ****** ****** *)

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

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

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

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

staload "constraint.sats"
staload "solving/error.sats"
staload "solving/solver.sats"

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

staload SMT = "solving/smt.sats"

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

staload _ = "solving/stack.dats"
staload _ = "libats/DATS/linmap_randbst.dats"
staload _ = "libats/DATS/linset_listord.dats"

staload _ = "solving/solver_s2varmap.dats"

staload Map = "libats/SATS/linmap_randbst.sats"
staload Set = "libats/SATS/linset_listord.sats"

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

viewtypedef solver = $SMT.solver
viewtypedef formula = $SMT.formula
viewtypedef sort = $SMT.sort

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

staload "solving/error.sats"

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

extern fun {a:vt0p}{b:vt0p}
list_vt_fold$init (a): b

extern fun {a:vt0p}{b:vt0p}
list_vt_fold$foper (x: a, res: b): b

fun {a:vt0p}{b:vt0p}
list_vt_fold {n:pos} (xs: list_vt (a, n)): b = let
  val ~list_vt_cons (x, xss) = xs
  fun loop {m:int} (xs: list_vt(a, m), res: b): b =
    case+ xs of
      | ~list_vt_cons (x, xss) =>
        loop (xss, list_vt_fold$foper (x, res))
      | ~list_vt_nil () => res
in
  loop (xss, list_vt_fold$init(x))
end

//
(* ****** ****** *)

local

  implement
  s2varmap_element_free<formula> (x) =
    $SMT.formula_free (x)

  implement
  s2varmap_element_copy<formula> (x) =
    $SMT.formula_dup (x)

  viewtypedef smtenv_struct = @{
    smt= solver,
    variables= @{
      statics= s2varmap (formula)
    },
    err= int,
    verbose= bool
  }

  assume smtenv_viewt0ype = smtenv_struct

in

  implement
  smtenv_nil (env) = begin
    env.smt := $SMT.make_solver ();
    s2varmap_nil (env.variables.statics);
    env.err := 0;
    env.verbose := false
  end

  implement
  smtenv_free (env) = begin
      s2varmap_delete (env.variables.statics);
      $SMT.delete_solver (env.smt);
  end

  implement
  smtenv_push (env) = (pf | ()) where {
    val _ = if env.verbose then println! ("(push 1)")
    val _ = $SMT.push (env.smt)
    val _ = s2varmap_push (env.variables.statics)
    prval pf = __push () where {
      extern praxi __push (): smtenv_push_v
    }
  } // end of [smtenv_push]

  implement
  smtenv_pop (pf | env) = {
    val _ = if env.verbose then println! ("(pop 1)")
    val _ = $SMT.pop (env.smt)
    val _ = s2varmap_pop (env.variables.statics)
    prval _ = __pop (pf) where {
      extern praxi __pop (pf: smtenv_push_v): void
    }
  } // end of [smtenv_pop]

  implement
  smtenv_get_solver (env)= let
    val slv = $SMT.solver_dup (env.smt)
  in
    slv
  end // end of [smtenv_get_solver]

  implement
  smtenv_set_verbose (env, verbose) = {
    val () = env.verbose := verbose
  }

  implement
  smtenv_add_svar (env, s2v) = let
    val type = s2var_get_srt (s2v)
    val () = if env.verbose then
      fprintln! (stdout_ref, "Adding svar: ", s2v, " type: ", type)
    //
    val smt_type = sort_make (type)
    //
    val stamp = s2var_get_stamp (s2v)
    val id = stamp_get_int (stamp)
    val () = if env.verbose then
      println! ("Variables: ",
        s2varmap_size (env.variables.statics)
    )
    //
    val fresh = $SMT.make_int_constant (id, smt_type)
    val () = $SMT.sort_free (smt_type)
    val opt =
      s2varmap_add (
        env.variables.statics, s2v, fresh
      )
  in
    case+ opt of
      | ~Some_vt (res) => $SMT.formula_free (res)
      | ~None_vt () => ()
  end

  implement
  smtenv_get_var_exn (env, s2v) = let
    val opt = s2varmap_find (env.variables.statics, s2v)
  in
    case+ opt of
      | ~None_vt () => let
        val () = smtenv_add_svar (env, s2v)
      in
        smtenv_get_var_exn (env, s2v)
      end
      | ~Some_vt (f) => f
  end

  implement
  smtenv_load_scripts (env, scripts) = let
    val () = $SMT.init_scripting (env.smt)
    //
    fun loop (env: &smtenv, scs: List0(string)): void =
      case+ scs of
        | list_nil () => ()
        | list_cons (sc, scss) => let
          val () = $SMT.load_user_script (env.smt, sc)
          val () = println! ("Loading script!", sc)
        in
          loop (env, scss)
        end
    //
  in
    loop (env, scripts)
  end

  implement
  sort_make (type) =
    if s2rt_is_int (type) || s2rt_is_addr (type) then
      $SMT.make_int_sort ()
    else if s2rt_is_rat (type) then
      $SMT.make_real_sort ()
    else if s2rt_is_bitvec (type) then let
        val width = s2rt_bitvec_get_width (type)
        val () = assertloc (width > 0)
      in
        $SMT.make_bitvec_sort (width)
      end
    else if s2rt_is_array (type) then
      $SMT.make_array_sort ()
    else if s2rt_is_t0ype (type) then
      $SMT.make_abstract_sort ("t@ype")
    else if s2rt_is_bool (type) then
      $SMT.make_bool_sort ()
    else let
      (**
        fprintln! (stderr_ref, "Could not handle sort: ", type)
      *)
    in
      $SMT.make_bool_sort ()
    end

  implement
  formula_make (env, s2e) = let
    val err = stderr_ref
  in
    case+ s2e.s2exp_node of
      | S2Eint i => let
        val type = $SMT.make_int_sort ()
        val I = $SMT.make_numeral (i, type)
      in
        $SMT.sort_free (type);
        I
      end
      //
      | S2Eintinf i => let
        val type= $SMT.make_int_sort ()
        val I = $SMT.make_numeral (i, type)
      in
        $SMT.sort_free (type);
        I
      end
      //
      | S2Evar s2v => smtenv_get_var_exn (env, s2v)
      | S2EVar s2V => let
        (**
          There may be a size expression stored in a unification
          variable. If we pull it out, it could be to our advantage.
        *)
        val szexp = s2Var_get_szexp (s2V)
      in
        case+ szexp of
          | S2ZEvar (s2v) => let
              val srt = s2var_get_srt (s2v)
              val s2ev = s2exp_make_node (srt, S2Evar(s2v))
            in
              formula_make (env, s2ev)
            end
          | _ => let
            (**
              TODO: make this "i don't know" behavior into its own function
            *)
            val srt = s2e.s2exp_srt
            val smt_sort = sort_make (srt)
            val stub = $SMT.make_fresh_constant (smt_sort)
          in
            $SMT.sort_free(smt_sort);
            stub
          end
       end // end of [S2EVar]
      | S2Ecst s2c => (case+ s2c of
        | _ when
            equal_string_s2cst ("null_addr", s2c) => let
              val type = $SMT.make_int_sort ()
              val null = $SMT.make_numeral (0, type)
            in
              $SMT.sort_free (type);
              null
            end
        //
        | _ when
            equal_string_s2cst ("true_bool", s2c) =>
              $SMT.make_true ()
        | _ when
            equal_string_s2cst ("false_bool", s2c) =>
              $SMT.make_false ()
        | _ => let
          val ats_srt = s2cst_get_srt (s2c)
          val smt_srt = sort_make (ats_srt)
          val stamp = s2cst_get_stamp (s2c)
          val id    = stamp_get_int (stamp)
          val c = $SMT.make_int_constant (id, smt_srt)
        in
          $SMT.sort_free (smt_srt);
          c
        end
      )
      | S2Eeqeq (l, r) => let
        val lhs = formula_make (env, l)
        val rhs = formula_make (env, r)
      in
        $SMT.make_eq (lhs, rhs)
      end
      | S2Eapp
          (s2e1, s2es2) => (
            case+ s2e1.s2exp_node of
              | S2Ecst s2c1 => let
               in
                formula_make_s2cst_s2explst (env, s2c1, s2es2)
               end
              //
              | _ => abort () where {
                val _ = fprintln! (err, "formula_make: Invalid application ", s2e)
              }
          ) // end of [S2Eapp]
      | S2Emetdec (met, bound) => let
        val pairs = list_zip (met, bound)
        //
        val () = assertloc (length(pairs) > 0)
        //
        implement list_vt_map$fopr<@(s2exp,s2exp)><formula>(x) = let
          val (pf, fpf | Env) = $UN.ptr1_vtake{smtenv}(addr@ env)
          val met = formula_make (!Env, x.0)
          val bound = formula_make (!Env, x.1)
          prval () =  fpf (pf)
          val srt = x.0.s2exp_srt
        in
          if s2rt_is_bitvec (srt) then
            $SMT.make_bv_ult (met, bound)
          else
            $SMT.make_lt (met, bound)
        end
        //
        val assertions =
          list_vt_mapfree<(s2exp,s2exp)><formula> (pairs)
        //
        implement
        list_vt_fold$init<formula><formula> (x) = x

        implement
        list_vt_fold$foper<formula><formula> (x, res) =
          $SMT.make_or2 (x, res)
      in
        list_vt_fold<formula><formula> (assertions)
      end // end of [S2Emetdec]
      | S2Esizeof (s2exp) => let
        #define :: list_vt_cons
        #define nil list_vt_nil
        val a = $SMT.make_abstract_sort ("t@ype")
        val sizeof = $SMT.make_func_decl ("sizeof", a :: nil, $SMT.make_int_sort())
        val args = formula_make (env, s2exp)
      in
        $SMT.make_app (sizeof, args :: nil)
      end // end of [S2Esizeof]
      | S2Etop (knd, s2e) => formula_make (env, s2e)
      // end of [S2Etop]
      | _ => let
        val srt = s2e.s2exp_srt
        val smt_sort = sort_make (srt)
        val stub = $SMT.make_fresh_constant (smt_sort)
        (* TODO: Make this error mean something to calling functions *)
        val _ = env.err := env.err + 1
        (**
          val _ = fprintln! (out, "warning(3): formula_make: s2e =:", s2e)
        *)
      in
        $SMT.sort_free (smt_sort);
        stub
      end // end of [_]
   end // end of [formula_make]

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

  implement make_true (env) = $SMT.make_true ()

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

  implement smtenv_assert_sbexp (env, prop) = let
    val assumption = formula_make (env, prop)
    val _ = if env.verbose then println! (
      "(assert ", $SMT.string_of_formula (assumption) ,")"
    )
  in
    $SMT.assert (env.smt, assumption)
  end

  implement smtenv_formula_is_valid (env, wff) = let
    val () = if env.verbose then
      println! ("(is-valid", $SMT.string_of_formula (wff), ")")
  in
    $SMT.is_valid (env.smt, wff)
  end

end // end of [local]

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

local

staload "solving/smt_ML.sats"

(**
  Define some convenient fixity rules.
*)
postfix 62 ^ // copy or duplicate
infixl ( && ) And
infixl ( || ) Or
infix 30 ==>

in

  #define :: list_cons

  implement f_identity (env, s2es) = let
    val- s2e1 ::  _  = s2es
  in
    formula_make (env, s2e1)
  end // end of [f_identity]

  implement  f_neg_bool (env, s2es) = let
    val- s2e :: _ = s2es
    val boole = formula_make (env, s2e)
  in
    Not (boole)
  end // end of [f_neg_bool]

  implement f_add_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val b0 = formula_make (env, s2e1)
    val b1 = formula_make (env, s2e2)
  in
    (b0 Or b1)
  end // end of [f_add_bool_bool]

  implement f_mul_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _  = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    (fbe1 And fbe2)
  end // end of [f_mul_bool_bool]

  implement f_eq_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 = fbe2
  end // end of [f_eq_bool_bool]

  implement f_neq_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    Not (fbe1 = fbe2)
  end // end of [f_neq_bool_bool]

  implement f_neg_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val n = formula_make (env, s2e1)
  in
    ~n
  end // end of [f_neg_int]

  implement f_add_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 + fbe2
  end // end of [f_add_int_int]

  implement f_sub_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 - fbe2
  end // end of [f_sub_int_int]

  implement f_mul_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p * q
  end // end of [f_mul_int_int]

  implement f_ndiv_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_ndiv_int_int]

  implement f_idiv_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_idiv_int_int]

  implement f_rat_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val n = formula_make (env, s2e1)
  in
    $SMT.make_real_from_int (n)
  end // end of [f_rat_int]

  implement f_rat_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p / q
  end // end of [f_rat_int_int]

  implement f_mul_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p * q
  end // end of [f_mul_rat_rat]

  implement f_div_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_div_rat_rat]

  implement f_add_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val b = formula_make (env, s2e2)
  in
    a + b
  end // end of [f_add_rat_rat]

  implement f_sub_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val b = formula_make (env, s2e2)
  in
    a - b
  end // end of [f_sub_rat_rat]

  implement f_lt_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val small = formula_make (env, s2e1)
    val great = formula_make (env, s2e2)
  in
    small < great
  end // end of [f_lt_int_int]

  implement f_lte_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val small = formula_make (env, s2e1)
    val great = formula_make (env, s2e2)
  in
    small <= great
  end // end of [f_lte_int_int]

  implement f_gt_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great > small
  end // end of [f_gt_int_int]

  implement f_gte_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great >= small
  end // end of [f_gte_int_int]

  implement f_eq_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val lhs = formula_make (env, s2e1)
    val rhs = formula_make (env, s2e2)
  in
    lhs = rhs
  end // end of [f_eq_int_int]

  implement f_neq_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val lhs = formula_make (env, s2e1)
    val rhs = formula_make (env, s2e2)
  in
    Not (lhs = rhs)
  end // end of [f_neq_int_int]

  implement f_is_int_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val num = formula_make (env, s2e1)
  in
    $SMT.is_int (num)
  end // end of [f_is_int_int]

  implement f_gte_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great >= small
  end // end of [f_gte_rat_rat]

  implement f_abs_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val i = formula_make (env, s2e1)
  in
    If (i^ < Int(0), ~(i^), i)
  end

  implement f_sgn_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val i = formula_make (env, s2e1)
  in
    If (i^ < Int (0), Int (~1),
      If ( i = Int (0), Int (0), Int (1)))
  end // end of [f_sgn_int]

  implement f_max_int_int (env, s2es) = let
    val- s2e1 :: s2e2 ::  _ = s2es
    val i = formula_make (env, s2e1)
    val j  = formula_make (env, s2e2)
  in
    If (i^ >= j^, i, j)
  end // end of [f_max_int_int]

  implement f_min_int_int (env, s2es) = let
    val- s2e1 :: s2e2 ::  _ = s2es
    //
    val i = formula_make (env, s2e1)
    val j = formula_make (env, s2e2)
  in
    If (i^ <= j^, i, j)
  end // end of [f_min_int_int]

  implement f_ifint_bool_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 ::  _ = s2es
    //
    val cond = formula_make (env, s2e1)
    val T = formula_make (env, s2e2)
    val F = formula_make (env, s2e3)
    //
  in
    If (cond, T, F)
  end // end of [f_ifint_bool_int_int]

  implement
  f_bv8_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (8, i)
  end // end of [f_bv8_of_int]

  implement
  f_bv16_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (16, i)
  end // end of [f_bv16_of_int]

  implement
  f_bv32_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (32, i)
  end // end of [f_bv32_of_int]

  implement
  f_int_of_bv32 (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_int_from_bv (i)
  end // end of [f_int_of_bv32]

  implement
  f_signed_int_of_bv32 (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_signed_int_from_bv (i)
  end // end of [f_signed_int_of_bv32]

  implement
  f_add_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_add (l, r)
  end // end of [f_add_bv_bv]

  implement
  f_sub_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_sub (l, r)
  end // end of [f_sub_bv_bv]

  implement
  f_mul_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_mul (l, r)
  end // end of [f_mul_bv_bv]

  implement
  f_div_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_div (l, r)
  end // end of [f_div_bv_bv]

  implement
  f_udiv_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_udiv (l, r)
  end // end of [f_udiv_bv_bv]

  implement
  f_neg_bv (env, s2es) = let
    val- s2e1 :: _ = s2es
    val l = formula_make (env, s2e1)
  in
    $SMT.make_bv_neg (l)
  end // end of [f_neg_bv]

  implement
  f_land_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_land (l, r)
  end // end of [f_land_bv_bv]

  implement
  f_lor_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lor (l, r)
  end // end of [f_lor_bv_bv]

  implement
  f_lxor_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lxor (l, r)
  end // end of [f_lxr_bv_bv]

  implement
  f_lnot_bv (env, s2es) = let
    val- s2e1 :: _ = s2es
    val l = formula_make (env, s2e1)
  in
    $SMT.make_bv_lnot (l)
  end // end of [f_neg_bv]

  implement
  f_lshl_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_lshl (bv, i)
  end

  implement
  f_lshr_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_lshr (bv, i)
  end

  implement
  f_ashr_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_ashr (bv, i)
  end

  implement
  f_eq_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_eq (l, r)
  end // end of [f_eq_bv_bv]

  implement
  f_gt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_gt (l, r)
  end // end of [f_gt_bv_bv]

  implement
  f_gte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ge (l, r)
  end // end of [f_gte_bv_bv]

  implement
  f_lte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_le (l, r)
  end // end of [f_lte_bv_bv]

  implement
  f_lt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lt (l, r)
  end // end of [f_lt_bv_bv]

  implement
  f_ugt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ugt (l, r)
  end // end of [f_ugt_bv_bv]

  implement
  f_ugte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_uge (l, r)
  end // end of [f_ugte_bv_bv]

  implement
  f_ulte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ule (l, r)
  end // end of [f_ulte_bv_bv]

  implement
  f_ult_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ult (l, r)
  end // end of [f_ult_bv_bv]

  implement
  f_array_select (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    Select (a, i)
  end // end of [f_array_select]

  implement
  f_array_store (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
    val v = formula_make (env, s2e3)
  in
    a[i] = v
  end // end of [f_array_store]

  implement
  f_partitioned_array (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: s2e4 :: _ = s2es
    val a     = formula_make (env, s2e1)
    val start = formula_make (env, s2e2)
    val p     = formula_make (env, s2e3)
    val stop  = formula_make (env, s2e4)
    //
    val i = Int ("i"); val j = Int ("j")
  in
    ForAll (i^, j^,
      ((start <= i^) And (i^ <= p^) And (p^ <= j^)
        And (j^ <= stop)) ==>
          ((Select(a^,i) <= Select(a^,p^)) And (Select(a^, p) <= Select(a,j))))
  end // end of [f_partitioned_array]

  local

    fun
    Sorted (a: formula, start: formula, stop: formula): formula = let
      val i = Int ("i")
      val j = Int("j")
    in
      ForAll (i^, j^,
        ((start <= i^) And (i^ <= j^) And (j^ <= stop)) ==>
          (Select (a^, i) <= Select (a, j))
        )
    end // end of [Sorted]

  in

  implement
  f_sorted_array (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a     = formula_make (env, s2e1)
    val len  = formula_make (env, s2e2)
    //
  in
    Sorted (a, Int(0), len - Int(1))
  end // End of [f_sorted_array]

  end // end of [local]

  implement
  f_array_swap (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
    val j = formula_make (env, s2e3)
    //
    val b = Store(a^,j^, Select(a^, i^))

  in
    Store(b, i, Select(a, j))
  end

  implement
  f_lte_stamp_stampseq (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val stmp = formula_make (env, s2e1)
    val seq  = formula_make (env, s2e2)
    val n    = formula_make (env, s2e3)
    //
    val i = Int("i")
  in
    ForAll (i^,
      ((Int(0) <= i^) And (i^ < n)) ==>
        (stmp <= seq[i]))
  end

  implement
  f_lte_stamp_stampseq_range (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: s2e4 :: _ = s2es
    val stmp = formula_make (env, s2e1)
    val seq = formula_make (env, s2e2)
    val i = formula_make (env, s2e3)
    val n = formula_make (env, s2e4)
    //
    val j = Int("j")
  in
    ForAll(j^,
      ((i <= j^) And (j^ < n)) ==>
        (stmp <= seq[j]))
  end

  implement
  f_lte_stampseq_stamp (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val seq  = formula_make (env, s2e1)
    val n    = formula_make (env, s2e2)
    val stmp = formula_make (env, s2e3)
    //
    val i = Int("i")
  in
    ForAll (i^,
      ((Int(0) <= i^) And (i^ < n)) ==>
        (seq[i] <= stmp))
  end

  implement
  f_lte_cls_cls (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
  in
    case+ (s2e1.s2exp_node, s2e2.s2exp_node) of
      | (S2Ecst (s2c1), S2Ecst (s2c2)) =>
        Bool(s2cst_lte_cls_cls (s2c1, s2c2))
      | (_, _) => Bool(false)
  end

end // end of [local]

(***********************************************************************)
(*                                                                     *)
(*                         Applied Type System                         *)
(*                                                                     *)
(***********************************************************************)

(*
** ATS/Postiats - Unleashing the Potential of Types!
** Copyright (C) 2011-20?? Hongwei Xi, ATS Trustful Software, Inc.
** All rights reserved
**
** ATS is free software;  you can  redistribute it and/or modify it under
** the terms of  the GNU GENERAL PUBLIC LICENSE (GPL) as published by the
** Free Software Foundation; either version 3, or (at  your  option)  any
** later version.
**
** ATS is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without  even  the  implied  warranty  of MERCHANTABILITY or
** FITNESS FOR A PARTICULAR PURPOSE.  See the  GNU General Public License
** for more details.
**
** You  should  have  received  a  copy of the GNU General Public License
** along  with  ATS;  see the  file COPYING.  If not, please write to the
** Free Software Foundation,  51 Franklin Street, Fifth Floor, Boston, MA
** 02110-1301, USA.
*)

(* ****** ****** *)
//
// Author: Will Blair (wdblair AT cs DOT bu DOT edu)
// Start Time: May, 2013
//
(* ****** ****** *)

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

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

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

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

staload "constraint.sats"
staload "solving/error.sats"
staload "solving/solver.sats"

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

staload SMT = "solving/smt.sats"

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

staload _ = "solving/stack.dats"
staload _ = "libats/DATS/linmap_randbst.dats"
staload _ = "libats/DATS/linset_listord.dats"

staload _ = "solving/solver_s2varmap.dats"

staload Map = "libats/SATS/linmap_randbst.sats"
staload Set = "libats/SATS/linset_listord.sats"

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

viewtypedef solver = $SMT.solver
viewtypedef formula = $SMT.formula
viewtypedef sort = $SMT.sort

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

staload "solving/error.sats"

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

extern fun {a:vt0p}{b:vt0p} list_vt_reduce$init (): b
extern fun {a:vt0p}{b:vt0p} list_vt_reduce$foper (x: a, res: b): b
//
fun {a:vt0p}{b:vt0p} list_vt_reduce {n:int} (xs: list_vt (a, n)): b = let
  fun loop {m:int} (xs: list_vt(a, m), res: b): b =
    case+ xs of
      | ~list_vt_cons (x, xss) =>
        loop (xss, list_vt_reduce$foper (x, res))
      | ~list_vt_nil () => res
    in
      loop (xs, list_vt_reduce$init<a>())
    end
//
(* ****** ****** *)

local

  implement
  s2varmap_element_free<formula> (x) =
    $SMT.formula_free (x)

  implement
  s2varmap_element_copy<formula> (x) =
    $SMT.formula_dup (x)

  viewtypedef smtenv_struct = @{
    smt= solver,
    variables= @{
      statics= s2varmap (formula)
    },
    err= int,
    verbose= bool
  }

  assume smtenv_viewt0ype = smtenv_struct

in

  implement
  smtenv_nil (env) = begin
    env.smt := $SMT.make_solver ();
    s2varmap_nil (env.variables.statics);
    env.err := 0;
    env.verbose := false
  end

  implement
  smtenv_free (env) = begin
      s2varmap_delete (env.variables.statics);
      $SMT.delete_solver (env.smt);
  end

  implement
  smtenv_push (env) = (pf | ()) where {
    val _ = if env.verbose then println! ("(push 1)")
    val _ = $SMT.push (env.smt)
    val _ = s2varmap_push (env.variables.statics)
    prval pf = __push () where {
      extern praxi __push (): smtenv_push_v
    }
  } // end of [smtenv_push]

  implement
  smtenv_pop (pf | env) = {
    val _ = if env.verbose then println! ("(pop 1)")
    val _ = $SMT.pop (env.smt)
    val _ = s2varmap_pop (env.variables.statics)
    prval _ = __pop (pf) where {
      extern praxi __pop (pf: smtenv_push_v): void
    }
  } // end of [smtenv_pop]

  implement
  smtenv_get_solver (env)= let
    val slv = $SMT.solver_dup (env.smt)
  in
    slv
  end // end of [smtenv_get_solver]

  implement
  smtenv_set_verbose (env, verbose) = {
    val () = env.verbose := verbose
  }

  implement
  smtenv_add_svar (env, s2v) = let
    val type = s2var_get_srt (s2v)
    val () = if env.verbose then
      fprintln! (stdout_ref, "Adding svar: ", s2v, " type: ", type)
    //
    val smt_type = sort_make (type)
    //
    val stamp = s2var_get_stamp (s2v)
    val id = stamp_get_int (stamp)
    val () = if env.verbose then
      println! ("Variables: ",
        s2varmap_size (env.variables.statics)
    )
    //
    val fresh = $SMT.make_int_constant (id, smt_type)
    val () = $SMT.sort_free (smt_type)
    val opt =
      s2varmap_add (
        env.variables.statics, s2v, fresh
      )
  in
    case+ opt of
      | ~Some_vt (res) => $SMT.formula_free (res)
      | ~None_vt () => ()
  end

  implement
  smtenv_get_var_exn (env, s2v) = let
    val opt = s2varmap_find (env.variables.statics, s2v)
  in
    case+ opt of
      | ~None_vt () => let
        val () = smtenv_add_svar (env, s2v)
      in
        smtenv_get_var_exn (env, s2v)
      end
      | ~Some_vt (f) => f
  end

  implement
  smtenv_load_scripts (env, scripts) = let
    val () = $SMT.init_scripting (env.smt)
    //
    fun loop (env: &smtenv, scs: List0(string)): void =
      case+ scs of
        | list_nil () => ()
        | list_cons (sc, scss) => let
          val () = $SMT.load_user_script (env.smt, sc)
          val () = println! ("Loading script!", sc)
        in
          loop (env, scss)
        end
    //
  in
    loop (env, scripts)
  end

  implement
  sort_make (type) =
    if s2rt_is_int (type) || s2rt_is_addr (type) then
      $SMT.make_int_sort ()
    else if s2rt_is_rat (type) then
      $SMT.make_real_sort ()
    else if s2rt_is_bitvec (type) then let
        val width = s2rt_bitvec_get_width (type)
        val () = assertloc (width > 0)
      in
        $SMT.make_bitvec_sort (width)
      end
    else if s2rt_is_array (type) then
      $SMT.make_array_sort ()
    else if s2rt_is_t0ype (type) then
      $SMT.make_abstract_sort ("t@ype")
    else if s2rt_is_bool (type) then
      $SMT.make_bool_sort ()
    else let
      (**
        fprintln! (stderr_ref, "Could not handle sort: ", type)
      *)
    in
      $SMT.make_bool_sort ()
    end

  implement
  formula_make (env, s2e) = let
    val err = stderr_ref
  in
    case+ s2e.s2exp_node of
      | S2Eint i => let
        val type = $SMT.make_int_sort ()
        val I = $SMT.make_numeral (i, type)
      in
        $SMT.sort_free (type);
        I
      end
      //
      | S2Eintinf i => let
        val type= $SMT.make_int_sort ()
        val I = $SMT.make_numeral (i, type)
      in
        $SMT.sort_free (type);
        I
      end
      //
      | S2Evar s2v => smtenv_get_var_exn (env, s2v)
      | S2EVar s2V => let
        (**
          There may be a size expression stored in a unification
          variable. If we pull it out, it could be to our advantage.
        *)
        val szexp = s2Var_get_szexp (s2V)
      in
        case+ szexp of
          | S2ZEvar (s2v) => let
              val srt = s2var_get_srt (s2v)
              val s2ev = s2exp_make_node (srt, S2Evar(s2v))
            in
              formula_make (env, s2ev)
            end
          | _ => let
            (**
              TODO: make this "i don't know" behavior into its own function
            *)
            val srt = s2e.s2exp_srt
            val smt_sort = sort_make (srt)
            val stub = $SMT.make_fresh_constant (smt_sort)
          in
            $SMT.sort_free(smt_sort);
            stub
          end
       end // end of [S2EVar]
      | S2Ecst s2c => (case+ s2c of
        | _ when
            equal_string_s2cst ("null_addr", s2c) => let
              val type = $SMT.make_int_sort ()
              val null = $SMT.make_numeral (0, type)
            in
              $SMT.sort_free (type);
              null
            end
        //
        | _ when
            equal_string_s2cst ("true_bool", s2c) =>
              $SMT.make_true ()
        | _ when
            equal_string_s2cst ("false_bool", s2c) =>
              $SMT.make_false ()
        | _ => let
          val ats_srt = s2cst_get_srt (s2c)
          val smt_srt = sort_make (ats_srt)
          val stamp = s2cst_get_stamp (s2c)
          val id    = stamp_get_int (stamp)
          val c = $SMT.make_int_constant (id, smt_srt)
        in
          $SMT.sort_free (smt_srt);
          c
        end
      )
      | S2Eeqeq (l, r) => let
        val lhs = formula_make (env, l)
        val rhs = formula_make (env, r)
      in
        $SMT.make_eq (lhs, rhs)
      end
      | S2Eapp
          (s2e1, s2es2) => (
            case+ s2e1.s2exp_node of
              | S2Ecst s2c1 => let
               in
                formula_make_s2cst_s2explst (env, s2c1, s2es2)
               end
              //
              | _ => abort () where {
                val _ = fprintln! (err, "formula_make: Invalid application ", s2e)
              }
          ) // end of [S2Eapp]
      | S2Emetdec (met, bound) => let
        val pairs = list_of_list_vt (
          list_zip (met, bound)
        )
        //
        implement list_map$fopr<@(s2exp,s2exp)><formula>(x) = let
          val (pf, fpf | Env) = $UN.ptr1_vtake{smtenv}(addr@ env)
          val met = formula_make (!Env, x.0)
          val bound = formula_make (!Env, x.1)
          prval () =  fpf (pf)
          val srt = x.0.s2exp_srt
        in
          if s2rt_is_bitvec (srt) then
            $SMT.make_bv_ult (met, bound)
          else
            $SMT.make_lt (met, bound)
        end
        //
        val assertions =
          list_map<(s2exp,s2exp)><formula> (pairs)
        //
        implement list_vt_reduce$init<formula><formula> () =
          $SMT.make_false ()
        implement list_vt_reduce$foper<formula><formula> (x, res) =
          $SMT.make_or2 (x, res)
      in
        list_vt_reduce<formula><formula> (assertions)
      end // end of [S2Emetdec]
      | S2Esizeof (s2exp) => let
        #define :: list_vt_cons
        #define nil list_vt_nil
        val a = $SMT.make_abstract_sort ("t@ype")
        val sizeof = $SMT.make_func_decl ("sizeof", a :: nil, $SMT.make_int_sort())
        val args = formula_make (env, s2exp)
      in
        $SMT.make_app (sizeof, args :: nil)
      end // end of [S2Esizeof]
      | S2Etop (knd, s2e) => formula_make (env, s2e)
      // end of [S2Etop]
      | _ => let
        val srt = s2e.s2exp_srt
        val smt_sort = sort_make (srt)
        val stub = $SMT.make_fresh_constant (smt_sort)
        (* TODO: Make this error mean something to calling functions *)
        val _ = env.err := env.err + 1
        (**
          val _ = fprintln! (out, "warning(3): formula_make: s2e =:", s2e)
        *)
      in
        $SMT.sort_free (smt_sort);
        stub
      end // end of [_]
   end // end of [formula_make]

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

  implement make_true (env) = $SMT.make_true ()

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

  implement smtenv_assert_sbexp (env, prop) = let
    val assumption = formula_make (env, prop)
    val _ = if env.verbose then println! (
      "(assert ", $SMT.string_of_formula (assumption) ,")"
    )
  in
    $SMT.assert (env.smt, assumption)
  end

  implement smtenv_formula_is_valid (env, wff) = let
    val () = if env.verbose then
      println! ("(is-valid", $SMT.string_of_formula (wff), ")")
  in
    $SMT.is_valid (env.smt, wff)
  end

end // end of [local]

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

local

staload "solving/smt_ML.sats"

(**
  Define some convenient fixity rules.
*)
postfix 62 ^ // copy or duplicate
infixl ( && ) And
infixl ( || ) Or
infix 30 ==>

in

  #define :: list_cons

  implement f_identity (env, s2es) = let
    val- s2e1 ::  _  = s2es
  in
    formula_make (env, s2e1)
  end // end of [f_identity]

  implement  f_neg_bool (env, s2es) = let
    val- s2e :: _ = s2es
    val boole = formula_make (env, s2e)
  in
    Not (boole)
  end // end of [f_neg_bool]

  implement f_add_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val b0 = formula_make (env, s2e1)
    val b1 = formula_make (env, s2e2)
  in
    (b0 Or b1)
  end // end of [f_add_bool_bool]

  implement f_mul_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _  = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    (fbe1 And fbe2)
  end // end of [f_mul_bool_bool]

  implement f_eq_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 = fbe2
  end // end of [f_eq_bool_bool]

  implement f_neq_bool_bool (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    Not (fbe1 = fbe2)
  end // end of [f_neq_bool_bool]

  implement f_neg_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val n = formula_make (env, s2e1)
  in
    ~n
  end // end of [f_neg_int]

  implement f_add_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 + fbe2
  end // end of [f_add_int_int]

  implement f_sub_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val fbe1 = formula_make (env, s2e1)
    val fbe2 = formula_make (env, s2e2)
  in
    fbe1 - fbe2
  end // end of [f_sub_int_int]

  implement f_mul_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p * q
  end // end of [f_mul_int_int]

  implement f_ndiv_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_ndiv_int_int]

  implement f_idiv_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_idiv_int_int]

  implement f_rat_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val n = formula_make (env, s2e1)
  in
    $SMT.make_real_from_int (n)
  end // end of [f_rat_int]

  implement f_rat_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p / q
  end // end of [f_rat_int_int]

  implement f_mul_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val p = formula_make (env, s2e1)
    val q = formula_make (env, s2e2)
  in
    p * q
  end // end of [f_mul_rat_rat]

  implement f_div_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val n = formula_make (env, s2e1)
    val d = formula_make (env, s2e2)
  in
    n / d
  end // end of [f_div_rat_rat]

  implement f_add_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val b = formula_make (env, s2e2)
  in
    a + b
  end // end of [f_add_rat_rat]

  implement f_sub_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val b = formula_make (env, s2e2)
  in
    a - b
  end // end of [f_sub_rat_rat]

  implement f_lt_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val small = formula_make (env, s2e1)
    val great = formula_make (env, s2e2)
  in
    small < great
  end // end of [f_lt_int_int]

  implement f_lte_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val small = formula_make (env, s2e1)
    val great = formula_make (env, s2e2)
  in
    small <= great
  end // end of [f_lte_int_int]

  implement f_gt_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great > small
  end // end of [f_gt_int_int]

  implement f_gte_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great >= small
  end // end of [f_gte_int_int]

  implement f_eq_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val lhs = formula_make (env, s2e1)
    val rhs = formula_make (env, s2e2)
  in
    lhs = rhs
  end // end of [f_eq_int_int]

  implement f_neq_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val lhs = formula_make (env, s2e1)
    val rhs = formula_make (env, s2e2)
  in
    Not (lhs = rhs)
  end // end of [f_neq_int_int]

  implement f_is_int_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val num = formula_make (env, s2e1)
  in
    $SMT.is_int (num)
  end // end of [f_is_int_int]

  implement f_gte_rat_rat (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val great = formula_make (env, s2e1)
    val small = formula_make (env, s2e2)
  in
    great >= small
  end // end of [f_gte_rat_rat]

  implement f_abs_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val i = formula_make (env, s2e1)
  in
    If (i^ < Int(0), ~(i^), i)
  end

  implement f_sgn_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    val i = formula_make (env, s2e1)
  in
    If (i^ < Int (0), Int (~1),
      If ( i = Int (0), Int (0), Int (1)))
  end // end of [f_sgn_int]

  implement f_max_int_int (env, s2es) = let
    val- s2e1 :: s2e2 ::  _ = s2es
    val i = formula_make (env, s2e1)
    val j  = formula_make (env, s2e2)
  in
    If (i^ >= j^, i, j)
  end // end of [f_max_int_int]

  implement f_min_int_int (env, s2es) = let
    val- s2e1 :: s2e2 ::  _ = s2es
    //
    val i = formula_make (env, s2e1)
    val j = formula_make (env, s2e2)
  in
    If (i^ <= j^, i, j)
  end // end of [f_min_int_int]

  implement f_ifint_bool_int_int (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 ::  _ = s2es
    //
    val cond = formula_make (env, s2e1)
    val T = formula_make (env, s2e2)
    val F = formula_make (env, s2e3)
    //
  in
    If (cond, T, F)
  end // end of [f_ifint_bool_int_int]

  implement
  f_bv8_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (8, i)
  end // end of [f_bv8_of_int]

  implement
  f_bv16_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (16, i)
  end // end of [f_bv16_of_int]

  implement
  f_bv32_of_int (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_bv_from_int (32, i)
  end // end of [f_bv32_of_int]

  implement
  f_int_of_bv32 (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_int_from_bv (i)
  end // end of [f_int_of_bv32]

  implement
  f_signed_int_of_bv32 (env, s2es) = let
    val- s2e1 :: _ = s2es
    //
    val i = formula_make (env, s2e1)
  in
    $SMT.make_signed_int_from_bv (i)
  end // end of [f_signed_int_of_bv32]

  implement
  f_add_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_add (l, r)
  end // end of [f_add_bv_bv]

  implement
  f_sub_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_sub (l, r)
  end // end of [f_sub_bv_bv]

  implement
  f_mul_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_mul (l, r)
  end // end of [f_mul_bv_bv]

  implement
  f_div_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_div (l, r)
  end // end of [f_div_bv_bv]

  implement
  f_udiv_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_udiv (l, r)
  end // end of [f_udiv_bv_bv]

  implement
  f_neg_bv (env, s2es) = let
    val- s2e1 :: _ = s2es
    val l = formula_make (env, s2e1)
  in
    $SMT.make_bv_neg (l)
  end // end of [f_neg_bv]

  implement
  f_land_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_land (l, r)
  end // end of [f_land_bv_bv]

  implement
  f_lor_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lor (l, r)
  end // end of [f_lor_bv_bv]

  implement
  f_lxor_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lxor (l, r)
  end // end of [f_lxr_bv_bv]

  implement
  f_lnot_bv (env, s2es) = let
    val- s2e1 :: _ = s2es
    val l = formula_make (env, s2e1)
  in
    $SMT.make_bv_lnot (l)
  end // end of [f_neg_bv]

  implement
  f_lshl_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_lshl (bv, i)
  end

  implement
  f_lshr_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_lshr (bv, i)
  end

  implement
  f_ashr_bv_int (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val bv = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    $SMT.make_bv_ashr (bv, i)
  end

  implement
  f_eq_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_eq (l, r)
  end // end of [f_eq_bv_bv]

  implement
  f_gt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_gt (l, r)
  end // end of [f_gt_bv_bv]

  implement
  f_gte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ge (l, r)
  end // end of [f_gte_bv_bv]

  implement
  f_lte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_le (l, r)
  end // end of [f_lte_bv_bv]

  implement
  f_lt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_lt (l, r)
  end // end of [f_lt_bv_bv]

  implement
  f_ugt_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ugt (l, r)
  end // end of [f_ugt_bv_bv]

  implement
  f_ugte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_uge (l, r)
  end // end of [f_ugte_bv_bv]

  implement
  f_ulte_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ule (l, r)
  end // end of [f_ulte_bv_bv]

  implement
  f_ult_bv_bv (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val l = formula_make (env, s2e1)
    val r = formula_make (env, s2e2)
  in
    $SMT.make_bv_ult (l, r)
  end // end of [f_ult_bv_bv]

  implement
  f_array_select (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
  in
    Select (a, i)
  end // end of [f_array_select]

  implement
  f_array_store (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
    val v = formula_make (env, s2e3)
  in
    a[i] = v
  end // end of [f_array_store]

  implement
  f_partitioned_array (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: s2e4 :: _ = s2es
    val a     = formula_make (env, s2e1)
    val start = formula_make (env, s2e2)
    val p     = formula_make (env, s2e3)
    val stop  = formula_make (env, s2e4)
    //
    val i = Int ("i"); val j = Int ("j")
  in
    ForAll (i^, j^,
      ((start <= i^) And (i^ <= p^) And (p^ <= j^)
        And (j^ <= stop)) ==>
          ((Select(a^,i) <= Select(a^,p^)) And (Select(a^, p) <= Select(a,j))))
  end // end of [f_partitioned_array]

  local

    fun
    Sorted (a: formula, start: formula, stop: formula): formula = let
      val i = Int ("i")
      val j = Int("j")
    in
      ForAll (i^, j^,
        ((start <= i^) And (i^ <= j^) And (j^ <= stop)) ==>
          (Select (a^, i) <= Select (a, j))
        )
    end // end of [Sorted]

  in

  implement
  f_sorted_array (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
    val a     = formula_make (env, s2e1)
    val len  = formula_make (env, s2e2)
    //
  in
    Sorted (a, Int(0), len - Int(1))
  end // End of [f_sorted_array]

  end // end of [local]

  implement
  f_array_swap (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val a = formula_make (env, s2e1)
    val i = formula_make (env, s2e2)
    val j = formula_make (env, s2e3)
    //
    val b = Store(a^,j^, Select(a^, i^))

  in
    Store(b, i, Select(a, j))
  end

  implement
  f_lte_stamp_stampseq (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val stmp = formula_make (env, s2e1)
    val seq  = formula_make (env, s2e2)
    val n    = formula_make (env, s2e3)
    //
    val i = Int("i")
  in
    ForAll (i^,
      ((Int(0) <= i^) And (i^ < n)) ==>
        (stmp <= seq[i]))
  end

  implement
  f_lte_stamp_stampseq_range (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: s2e4 :: _ = s2es
    val stmp = formula_make (env, s2e1)
    val seq = formula_make (env, s2e2)
    val i = formula_make (env, s2e3)
    val n = formula_make (env, s2e4)
    //
    val j = Int("j")
  in
    ForAll(j^,
      ((i <= j^) And (j^ < n)) ==>
        (stmp <= seq[j]))
  end

  implement
  f_lte_stampseq_stamp (env, s2es) = let
    val- s2e1 :: s2e2 :: s2e3 :: _ = s2es
    val seq  = formula_make (env, s2e1)
    val n    = formula_make (env, s2e2)
    val stmp = formula_make (env, s2e3)
    //
    val i = Int("i")
  in
    ForAll (i^,
      ((Int(0) <= i^) And (i^ < n)) ==>
        (seq[i] <= stmp))
  end

  implement
  f_lte_cls_cls (env, s2es) = let
    val- s2e1 :: s2e2 :: _ = s2es
  in
    case+ (s2e1.s2exp_node, s2e2.s2exp_node) of
      | (S2Ecst (s2c1), S2Ecst (s2c2)) =>
        Bool(s2cst_lte_cls_cls (s2c1, s2c2))
      | (_, _) => Bool(false)
  end

end // end of [local]


minor fix for including vertical check

minor fix for including vertical check

(*
** The M-N-K-game
*)

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

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

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

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

fun
pid2char (id: int): char =
(
case+ id of
| 0 => ' ' | 1 => 'X' | 2 => 'O' | _ => '#'
) (* end of [pid2char] *)

(* ****** ****** *)
//
implement
fprint_board
  (out, board) = let
//
implement
fprint_val<int>
  (out, id) = fprint (out, pid2char(id))
//
val () = fprint (out, "|")
val () = fprint_mtrxszref_sep (out, board, "|", "|\n|")
val () = fprint (out, "|")
//
in
  // nothing
end // end of [fprint_board]
//
(* ****** ****** *)

datatype dir = E | W | N | S | NE | SE | NW | SW

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

fun
dirnext
(
  dir: dir, i: int, j: int
): @(int, int) =
(
case+ dir of
| E ()  => (i+1, j  )
| W ()  => (i-1, j  )
| N ()  => (i  , j+1)
| S ()  => (i  , j-1)
| NE () => (i+1, j+1)
| SE () => (i+1, j-1)
| NW () => (i-1, j+1)
| SW () => (i-1, j-1)
) (* end of [dirnext] *)

(* ****** ****** *)
//
// HX-2014-05:
// This one is a bit technical: starting
// at the position (i, j), find the maximal
// number of pieces along the direction dir
// that are of the given kind pid.
//
extern
fun
board_dirmax
(
  board, pid: int, dir: dir, i: int, j: int
) : intGte(0)

implement
board_dirmax
(
  board, pid, dir, i, j
) = let
//
var nseq: int = 0
val p_nseq = addr@nseq
//
fun loop
(
  i: int, j: int
) : void = let
//
val pid2 = board[i, j]
//
in
  if pid = pid2
    then let
      val n = $UN.ptr1_get<int> (p_nseq)
      val () = $UN.ptr1_set<int> (p_nseq, n + 1)
      val (i, j) = dirnext (dir, i, j)
    in
      loop (i, j)
    end // end of [then]
  // end of [if]
end // end of [loop]
//
// HX-2014-05:
// [ptr_volatile] does nothing;
// gcc/clang -O1 bug is triggered if the
val () = ptr_volatile (p_nseq) // line is omitted
//
val () = try loop (i, j) with ~MatrixSubscriptExn () => ()
//
in
  $UN.cast{intGte(0)}(nseq)
end // end of [board_dirmax]

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

local
//
exception FoundExn of ((*void*))
//
in (*in-of-local*)

implement
board_check_at
  (board, i, j) =
(
try let
//
val K =
  game_conf_get_k ()
//
val pid = board[i,j]
//
val nseq =
  board_dirmax (board, pid, N, i, j)
+ board_dirmax (board, pid, S, i, j)
val () = if nseq > K then $raise FoundExn ()
//
val nseq =
  board_dirmax (board, pid, E, i, j)
+ board_dirmax (board, pid, W, i, j)
val () = if nseq > K then $raise FoundExn ()
//
val nseq =
  board_dirmax (board, pid, NE, i, j)
+ board_dirmax (board, pid, SW, i, j)
val () = if nseq > K then $raise FoundExn ()
//
val nseq =
  board_dirmax (board, pid, SE, i, j)
+ board_dirmax (board, pid, NW, i, j)
val () = if nseq > K then $raise FoundExn ()
//
in
  false
end with
 | ~FoundExn () => true
 | ~MatrixSubscriptExn () => false
// end of [try]
) (* end of [board_check_at] *)

end // end of [local]

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

(*
val () = // testing code
{
//
val () =
println! ("TESTING(game_board):")
//
val () =
println! ("TESTING(fprint_board): beg")
val board = board_make (3, 3)
val ((*void*)) = board[0,2] := 1
val ((*void*)) = board[1,1] := 1
val ((*void*)) = board[2,0] := 1
val ((*void*)) = fprint_board (stdout_ref, board)
val ((*void*)) = fprint_newline (stdout_ref)
val () =
println! ("TESTING(fprint_board): end")
//
val () = println! ("board_check_at (0, 0) = ", board_check_at (board, 0, 0))
val () = println! ("board_check_at (1, 1) = ", board_check_at (board, 1, 1))
val () = println! ("board_check_at (2, 2) = ", board_check_at (board, 2, 2))
val () = println! ("board_check_at (3, 3) = ", board_check_at (board, 3, 3))
//
} (* end of [val] *)
*)

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

(* end of [game_board.dats] *)

(*
** The M-N-K-game
*)

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

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

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

staload "./game.sats"

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

assume
board_type = mtrxszref (int)

(* ****** ****** *)
//
implement
board_make (m, n) =
  mtrxszref_make_elt<int> (i2sz(m), i2sz(n), 0)
//
(* ****** ****** *)

fun
pid2char (id: int): char =
(
case+ id of
| 0 => ' ' | 1 => 'X' | 2 => 'O' | _ => '#'
) (* end of [pid2char] *)

(* ****** ****** *)
//
implement
fprint_board
  (out, board) = let
//
implement
fprint_val<int>
  (out, id) = fprint (out, pid2char(id))
//
val () = fprint (out, "|")
val () = fprint_mtrxszref_sep (out, board, "|", "|\n|")
val () = fprint (out, "|")
//
in
  // nothing
end // end of [fprint_board]
//
(* ****** ****** *)

datatype dir = E | W | N | S | NE | SE | NW | SW

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

fun
dirnext
(
  dir: dir, i: int, j: int
): @(int, int) =
(
case+ dir of
| E ()  => (i+1, j  )
| W ()  => (i-1, j  )
| N ()  => (i  , j+1)
| S ()  => (i  , j-1)
| NE () => (i+1, j+1)
| SE () => (i+1, j-1)
| NW () => (i-1, j+1)
| SW () => (i-1, j-1)
) (* end of [dirnext] *)

(* ****** ****** *)
//
// HX-2014-05:
// This one is a bit technical: starting
// at the position (i, j), find the maximal
// number of pieces along the direction dir
// that are of the given kind pid.
//
extern
fun
board_dirmax
(
  board, pid: int, dir: dir, i: int, j: int
) : intGte(0)

implement
board_dirmax
(
  board, pid, dir, i, j
) = let
//
var nseq: int = 0
val p_nseq = addr@nseq
//
fun loop
(
  i: int, j: int
) : void = let
//
val pid2 = board[i, j]
//
in
  if pid = pid2
    then let
      val n = $UN.ptr1_get<int> (p_nseq)
      val () = $UN.ptr1_set<int> (p_nseq, n + 1)
      val (i, j) = dirnext (dir, i, j)
    in
      loop (i, j)
    end // end of [then]
  // end of [if]
end // end of [loop]
//
// HX-2014-05:
// [ptr_volatile] does nothing;
// gcc/clang -O1 bug is triggered if the
val () = ptr_volatile (p_nseq) // line is omitted
//
val () = try loop (i, j) with ~MatrixSubscriptExn () => ()
//
in
  $UN.cast{intGte(0)}(nseq)
end // end of [board_dirmax]

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

local
//
exception FoundExn of ((*void*))
//
in (*in-of-local*)

implement
board_check_at
  (board, i, j) =
(
try let
//
val K =
  game_conf_get_k ()
//
val pid = board[i,j]
//
val nseq =
  board_dirmax (board, pid, E, i, j)
+ board_dirmax (board, pid, W, i, j)
val () = if nseq > K then $raise FoundExn ()
//
val nseq =
  board_dirmax (board, pid, NE, i, j)
+ board_dirmax (board, pid, SW, i, j)
val () = if nseq > K then $raise FoundExn ()
//
val nseq =
  board_dirmax (board, pid, SE, i, j)
+ board_dirmax (board, pid, NW, i, j)
val () = if nseq > K then $raise FoundExn ()
//
in
  false
end with
 | ~FoundExn () => true
 | ~MatrixSubscriptExn () => false
// end of [try]
) (* end of [board_check_at] *)

end // end of [local]

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

(*
val () = // testing code
{
//
val () =
println! ("TESTING(game_board):")
//
val () =
println! ("TESTING(fprint_board): beg")
val board = board_make (3, 3)
val ((*void*)) = board[0,2] := 1
val ((*void*)) = board[1,1] := 1
val ((*void*)) = board[2,0] := 1
val ((*void*)) = fprint_board (stdout_ref, board)
val ((*void*)) = fprint_newline (stdout_ref)
val () =
println! ("TESTING(fprint_board): end")
//
val () = println! ("board_check_at (0, 0) = ", board_check_at (board, 0, 0))
val () = println! ("board_check_at (1, 1) = ", board_check_at (board, 1, 1))
val () = println! ("board_check_at (2, 2) = ", board_check_at (board, 2, 2))
val () = println! ("board_check_at (3, 3) = ", board_check_at (board, 3, 3))
//
} (* end of [val] *)
*)

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

(* end of [game_board.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** ATS-extsolve:
** For solving ATS-constraints
** with external SMT-solvers
*)

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

(*
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
*)

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

implement
h3ypo_make_node
  (loc, node) = '{
  h3ypo_loc= loc, h3ypo_node= node
} (* end of [h3ypo_make_node] *)

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

implement
fprint_h3ypo
  (out, h3p) =
(
//
case
h3p.h3ypo_node
of // case+
//
| H3YPOprop(s2e) =>
    fprint! (out, "H3YPOprop(", s2e, ")")
//
| H3YPObind(s2v1, s2e2) =>
    fprint! (out, "H3YPObind(", s2v1, " -> ", s2e2, ")")
//
| H3YPOeqeq(s2e1, s2e2) =>
    fprint! (out, "H3YPObind(", s2e1, " == ", s2e2, ")")
//
) (* end of [fprint_h3ypo] *)

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

(* end of [patsolve_cnstrnt_h3ypo.dats] *)

(*
** ATS-extsolve:
** For solving ATS-constraints
** with external SMT-solvers
*)

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

(*
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
*)

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

implement
h3ypo_make_node
  (loc, node) = '{
  h3ypo_loc= loc, h3ypo_node= node
} (* end of [h3ypo_make_node] *)

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

implement
fprint_h3ypo
  (out, h3p) =
(
//
case
h3p.h3ypo_node
of // case+
//
| H3YPOprop(s2e) =>
    fprintln! (out, "H3YPOprop(", s2e, ")")
//
| H3YPObind(s2v1, s2e2) =>
    fprintln! (out, "H3YPObind(", s2v1, " -> ", s2e2, ")")
//
| H3YPOeqeq(s2e1, s2e2) =>
    fprintln! (out, "H3YPObind(", s2e1, " == ", s2e2, ")")
//
) (* end of [fprint_h3ypo] *)

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

(* end of [patsolve_cnstrnt_h3ypo.dats] *)


Updating: adding bouncing-ball2

Updating: adding bouncing-ball2

(*
** Bouncing ball: attemp 2
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTedu
//
(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "bouncing_ball2_anim_"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "bouncing_ball2_anim_dynload"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/DATS/Number/real_double.dats"
//
(* ****** ****** *)

sortdef mode = int
sortdef time = real

typedef mode(mode) = int(mode)

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

stacst g : real

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

#define m1 1; #define 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)
*)
//
datatype
state(m: mode, t:time) =
| STATE(m, t) of
    (mode(m), real(t), real(x(m,t)), real(v(m,t)))
  // end of [STATE]
//
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}
  (st: state(m, t)): real(t)
extern
fun
state_get_x
  {m:mode}{t:time}
  (st: state(m, t)): real(x(m, t))
extern
fun
state_get_v
  {m:mode}{t:time}
  (st: state(m, t)): real(v(m, t))
//
overload .t with state_get_t
overload .x with state_get_x
overload .v with state_get_v
//
(* ****** ****** *)
//
implement
state_get_t(STATE(m, t, x, v)) = t
implement
state_get_x(STATE(m, t, x, v)) = x
implement
state_get_v(STATE(m, t, x, v)) = v
//
(* ****** ****** *)
//
(*
extern
fun
jump_x1
{t:time|x1(t)==0}(state1(t)): [x2(t)==0] void
extern
fun
jump_v1
{t:time|x1(t)==0}(state1(t)): [v2(t)==(~v1(t))] void
*)
//
extern
fun
step_x1
  {t,dt:time}
(
  pf: INF(dt) | state1(t), dt: real(dt)
) : real(x1(t+dt))
extern
fun
step_v1
  {t,dt:time}
(
  pf: INF(dt) | state1(t), dt: real(dt)
) : real(v1(t+dt))
//
extern
fun
step_x2
  {t,dt:time}
(
  pf: INF(dt) | state2(t), dt: real(dt)
) : real(x2(t+dt))
extern
fun
step_v2
  {t,dt:time}
(
  pf: INF(dt) | state2(t), dt: real(dt)
) : real(v2(t+dt))
//
(* ****** ****** *)
//
val g = $UN.cast{real(g)}(9.8)
//
implement
step_x1(pf | st, dt) =
  $UN.cast(st.x() + st.v() * dt)
implement
step_v1(pf | st, dt) = $UN.cast(st.v() - g * dt)
//
implement
step_x2(pf | st, dt) =
  $UN.cast(st.x() + st.v() * dt)
implement
step_v2(pf | st, dt) = $UN.cast(st.v() - g * dt)
//
(* ****** ****** *)

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)): state2(t)
//
(* ****** ****** *)
//
implement
state1_flow
  (pf | st, dt) = let
//
val t_dt = st.t() + dt
val x1_dt = step_x1(pf|st,dt)
val v1_dt = step_v1(pf|st,dt)
//
in
  STATE(m1, t_dt, x1_dt, v1_dt)
end // end of [state1_flow]
//
implement
state1_jump
  (st as STATE(m, t, x, v)) =
  STATE(m2, t, $UN.cast(x), $UN.cast(~v))
//
(* ****** ****** *)
//
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)): state1(t)
//
(* ****** ****** *)
//
implement
state2_flow
  (pf | st, dt) = let
//
val t_dt = st.t() + dt
val x2_dt = step_x2(pf|st,dt)
val v2_dt = step_v2(pf|st,dt)
//
in
  STATE(m2, t_dt, x2_dt, v2_dt)
end // end of [state1_flow]
//
implement
state2_jump
  (st as STATE(m, t, x, v)) =
  STATE(m1, t, $UN.cast(x), $UN.cast( v ))
//
(* ****** ****** *)
//
extern
fun
x1_midval
{ r:real
; t,dt:time
| x1(t) >= 0 ; x1(t+dt) <= 0
}
( INF(dt)
| state1(t)
, real(x1(t)), real(x1(t+dt))
) : [t1:time | t <= t1; t1 <= t+dt; x1(t1)==0] real(t1)
//
(* ****** ****** *)
//
implement
x1_midval
  (pf | st, x1_0, _) = $UN.cast(st.t()-(x1_0/st.v()))
//
(* ****** ****** *)
//
extern
fun
v2_midval
{ r:real
; t,dt:time
| v2(t) >= 0 ; v2(t+dt) <= 0
}
( INF(dt)
| state2(t)
, real(v2(t)), real(v2(t+dt))
) : [t1:time | t <= t1; t1 <= t+dt; v2(t1)==0] real(t)
//
(* ****** ****** *)
//
implement
v2_midval
  (pf | st, v2_0, _) = $UN.cast(st.t() + (v2_0 / (g)))
//
(* ****** ****** *)

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 = step_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(pf | st, x1_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 = step_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(pf | st, v2_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_anim.dats] *)

(*
** Bouncing ball: attemp 2
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTedu
//
(* ****** ****** *)
//
#define
ATS_STATIC_PREFIX "bouncing_ball2_anim_"
//
(* ****** ****** *)

#define ATS_MAINATSFLAG 1
#define ATS_DYNLOADNAME "bouncing_ball2_anim_dynload"

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
staload
"{$LIBATSCC2JS}/DATS/Number/real_double.dats"
//
(* ****** ****** *)

sortdef mode = int
sortdef time = real

typedef mode(mode) = int(mode)

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

stacst g : real

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

#define m1 1; #define 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)
*)
//
datatype
state(m: mode, t:time) =
| STATE(m, t) of
    (mode(m), real(t), real(x(m,t)), real(v(m,t)))
  // end of [STATE]
//
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}
  (st: state(m, t)): real(t)
extern
fun
state_get_x
  {m:mode}{t:time}
  (st: state(m, t)): real(x(m, t))
extern
fun
state_get_v
  {m:mode}{t:time}
  (st: state(m, t)): real(v(m, t))
//
overload .t with state_get_t
overload .x with state_get_x
overload .v with state_get_v
//
(* ****** ****** *)
//
implement
state_get_t(STATE(m, t, x, v)) = t
implement
state_get_x(STATE(m, t, x, v)) = x
implement
state_get_v(STATE(m, t, x, v)) = v
//
(* ****** ****** *)
//
(*
extern
fun
jump_x1
{t:time|x1(t)==0}(state1(t)): [x2(t)==0] void
extern
fun
jump_v1
{t:time|x1(t)==0}(state1(t)): [v2(t)==(~v1(t))] void
*)
//
extern
fun
step_x1
  {t,dt:time}
(
  pf: INF(dt) | state1(t), dt: real(dt)
) : real(x1(t+dt))
extern
fun
step_v1
  {t,dt:time}
(
  pf: INF(dt) | state1(t), dt: real(dt)
) : real(v1(t+dt))
//
extern
fun
step_x2
  {t,dt:time}
(
  pf: INF(dt) | state2(t), dt: real(dt)
) : real(x2(t+dt))
extern
fun
step_v2
  {t,dt:time}
(
  pf: INF(dt) | state2(t), dt: real(dt)
) : real(v2(t+dt))
//
(* ****** ****** *)

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)): state2(t)
//
(* ****** ****** *)
//
implement
state1_flow
  (pf | st, dt) = let
//
val t_dt = st.t() + dt
val x1_dt = step_x1(pf|st,dt)
val v1_dt = step_v1(pf|st,dt)
//
in
  STATE(m1, t_dt, x1_dt, v1_dt)
end // end of [state1_flow]
//
implement
state1_jump
  (st as STATE(m, t, x, v)) =
  STATE(m2, t, $UN.cast(x), $UN.cast(~v))
//
(* ****** ****** *)
//
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)): state1(t)
//
(* ****** ****** *)
//
implement
state2_flow
  (pf | st, dt) = let
//
val t_dt = st.t() + dt
val x2_dt = step_x2(pf|st,dt)
val v2_dt = step_v2(pf|st,dt)
//
in
  STATE(m2, t_dt, x2_dt, v2_dt)
end // end of [state1_flow]
//
implement
state2_jump
  (st as STATE(m, t, x, v)) =
  STATE(m1, t, $UN.cast(x), $UN.cast( v ))
//
(* ****** ****** *)
//
extern
fun
x1_midval
{ r:real
; t,dt:time
| x1(t) >= r ; r >= x1(t+dt)
}
( INF(dt)
| state1(t)
, real(x1(t)), real(r), real(x1(t+dt))
) : [t1:time | t <= t1; t1 <= t+dt; x1(t1)==0] real(t1)
//
(* ****** ****** *)
//
implement
x1_midval
  (pf | st, x1_0, r, x1_1) = $UN.cast(st.t()-(x1_0/st.v()))
//
(* ****** ****** *)
//
extern
fun
v2_midval
{ r:real
; t,dt:time
| v2(t) >= r ; r >= v2(t+dt)
}
( INF(dt)
| state2(t)
, real(v2(t)), real(r), real(v2(t+dt))
) : [t1:time | t <= t1; t1 <= t+dt; v2(t1)==0] real(t)
//
(* ****** ****** *)
//
val g = $UN.cast{real(g)}(9.8)
//
implement
v2_midval
  (pf | st, v2_0, r, v2_1) = $UN.cast(st.t() + (v2_0 / (g)))
//
(* ****** ****** *)

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 = step_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(pf | st, 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 = step_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(pf | st, 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_anim.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)
//
// Following a Promela-example in
// (Spin Model Checker Primer Reference)
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype chnil
abstype chcons(x:vt@ype, xs:type)

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

stadef :: = chcons

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

abstype chanref(a:vtype)

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

absvtype chanptr(a:vtype)

(* ****** ****** *)
//
absvtype channel0
//
absvtype chanpos1(ss:vtype)
absvtype channeg1(ss:vtype)
//
(* ****** ****** *)
//
extern
fun
channel0_create
  (cap: intGte(0)): channel0
//
extern
fun channel0_destroy(channel0): void
//
(* ****** ****** *)
//
extern
fun
channel0_split{ss:vtype}
  (chan: !channel0 >> chanpos1(ss)): channeg1(ss)
//
(* ****** ****** *)
//
extern
prfun
channeg1_nil_close (channeg1(chnil)): void
extern
prfun
chanpos1_nil_close (!chanpos1(chnil) >> channel0): void
//
(* ****** ****** *)

extern
fun
chanpos1_recv
{x:vt@ype}{xs:type}
(
  chan: !chanpos1(x::xs) >> chanpos1(xs)
) : x // end of [chanpos1_recv]

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

extern
fun
channeg1_send
{x:vt@ype}{xs:type}
(
  chan: !channeg1(x::xs) >> channeg1(xs), x: (x)
) : void // end of [channeg1_send]

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

datavtype
ss_client =
  | DENY of (chnil)
  | DENY of (channeg1(chnil), chnil)
  | HOLD of (channeg1(chnil), ss_client)
  | GRANT of (channeg1(ss_grant), chnil)
//
and ss_grant = RETURN1 of (chnil)
//
(* ****** ****** *)
//
datavtype
ClientOpt(ss:vtype) =
  | DENY(chnil) of ()
  | DENY(chnil) of channeg1(chnil)
  | HOLD(ss_client) of channeg1(chnil)
  | GRANT(chnil) of (channeg1(ss_grant))
//
datatype
AgentGrantOpt(ss:vtype) = RETURN1(chnil) of ()
//
(* ****** ****** *)
//
extern
fun
chanref_recv
  {a:vtype}(chan: chanref(a)): (a)
extern
fun
chanref_send
  {a:vtype}(chan: chanref(a), x: (a)): void
//
(* ****** ****** *)
//
extern
fun
chanptr_recv
  {a:vtype}(chan: !chanptr(a)): (a)
extern
fun
chanptr_send
  {a:vtype}(chan: !chanptr(a), x: (a)): void
//
(* ****** ****** *)
//
extern
fun
channeg1_client{ss:vtype}
  (chan: !channeg1(ss_client) >> channeg1(ss), x: ClientOpt(ss)): void
extern
fun
chanpos1_client
  (chan: !chanpos1(ss_client) >> chanpos1(ss)): #[ss:vtype] ClientOpt(ss)
//
(* ****** ****** *)
//
extern
fun
channeg1_grant{ss:vtype}
  (chan: !channeg1(ss_grant) >> channeg1(ss), x: AgentGrantOpt(ss)): void
extern
fun
chanpos1_grant
  (chan: !chanpos1(ss_grant) >> chanpos1(ss)): #[ss:vtype] AgentGrantOpt(ss)
//
(* ****** ****** *)

extern val RANDOM : int

(* ****** ****** *)
//
datavtype
ServerOpt =
  | RETURN0 of (channel0)
  | REQUEST0 of (channeg1(ss_client))
//
(* ****** ****** *)

extern
val
theServer : chanref(ServerOpt)

(* ****** ****** *)
//
extern
fun Server((*void*)): void
extern
fun Client((*void*)): void
//
extern
fun
Agent
(
  agent: channel0
, client: channeg1(ss_client)
) : void // end of [Agent]
//
(* ****** ****** *)
//
extern
fun
chanptr_create
  {a:vtype}
  (cap: intGte(0)): chanptr(a)
//
extern
fun
chanptr_is_empty
  : {a:vtype} (!chanptr(a)) -> bool
extern
fun
chanptr_isnot_empty
  : {a:vtype} (!chanptr(a)) -> bool
//
(* ****** ****** *)

implement
Server() = let
//
fun
loop
(
  pool: chanptr(channel0)
) : void = let
//
val
opt = chanref_recv(theServer)
//
in
//
case+ opt of
| ~RETURN0(agent) => let
    val () =
    chanptr_send(pool, agent)
  in
    loop(pool)
  end // end of [RETURN0]
| ~REQUEST0(client) =>
  if chanptr_isnot_empty(pool)
    then let
      val agent =
        chanptr_recv(pool)
      // end of [val]
      val () = Agent(agent, client)
    in
      loop(pool)
    end // end of [then]
    else let
      val () =
      channeg1_client(client, DENY())
      val () = channeg1_nil_close(client)
    in
      loop(pool)
    end // end of [else]
//
end // end of [loop]
//
val
pool = chanptr_create(5)
//
in
  loop(pool)
end // end of [Server]
//
(* ****** ****** *)

implement
Agent(agent, client) = let
//
fun
loop
( agent: !channel0
, client: channeg1(ss_client)
) : void = (
//
case
RANDOM of
| 0 => let
    val
    agent2 =
    channel0_split{chnil}(agent)
    val () =
    channeg1_client(client, HOLD(agent2))
    val ((*void*)) = chanpos1_nil_close(agent)
  in
    loop(agent, client)
  end // end of [_]
| 1 => let
    val
    agent2 =
    channel0_split{chnil}(agent)
    val () =
    channeg1_client(client, DENY(agent2))
    val ((*void*)) = chanpos1_nil_close(agent)
    val ((*void*)) = channeg1_nil_close(client)
  in
    // break
  end // end of [1]
| _ => let
    val
    agent2 =
    channel0_split{ss_grant}(agent)
    val () =
    channeg1_client(client, GRANT(agent2))
    val+RETURN1() = chanpos1_grant(agent)
    val ((*void*)) = chanpos1_nil_close(agent)
    val ((*void*)) = channeg1_nil_close(client)
  in
    // break
  end // end of [_]
//
) (* end of [loop] *)
//
val () = loop(agent, client)
//
in
  chanref_send(theServer, RETURN0(agent))
end // end of [Agent]
//
(* ****** ****** *)
//
implement
Client() = let
//
fun
loop
(
  client: channel0
) : void =
(
//
case+
RANDOM
of // case
| _ => let
    val
    client2 =
    channel0_split{ss_client}(client)
    val () =
    chanref_send(theServer, REQUEST0(client2))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: chanpos1(ss_client)
) : void = let
//
val opt = chanpos1_client(client)
//
in
//
case+ opt of
| ~DENY() =>
  {
    val () =
    chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
| ~DENY(agent) =>
  {
    val () =
    channeg1_nil_close(agent)
    val () =
    chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
| ~HOLD(agent) =>
  loop2(client) where
  {
    val () = channeg1_nil_close(agent)
  }
//
| ~GRANT(agent) =>
  {
    val () =
    channeg1_grant(agent, RETURN1())
    val () = channeg1_nil_close(agent)
    val () = chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
//
end // end of [loop2]
//
in
  loop(channel0_create(0))
end // end of [Client]

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

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

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)
//
// Following a Promela-example in
// (Spin Model Checker Primer Reference)
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype chnil
abstype chcons(x:vt@ype, xs:type)

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

stadef :: = chcons

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

abstype chanref(a:vtype)

(* ****** ****** *)
//
absvtype channel0
//
absvtype chanpos1(ss:vtype)
absvtype channeg1(ss:vtype)
//
(* ****** ****** *)
//
extern
fun
channel0_create
  (cap: intGte(0)): channel0
//
extern
fun channel0_destroy(channel0): void
//
(* ****** ****** *)
//
extern
fun
channel0_split{ss:vtype}
  (chan: !channel0 >> chanpos1(ss)): channeg1(ss)
//
(* ****** ****** *)
//
extern
prfun
channeg1_nil_close (channeg1(chnil)): void
extern
prfun
chanpos1_nil_close (!chanpos1(chnil) >> channel0): void
//
(* ****** ****** *)

extern
fun
chanpos1_recv
{x:vt@ype}{xs:type}
(
  chan: !chanpos1(x::xs) >> chanpos1(xs)
) : x // end of [chanpos1_recv]

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

extern
fun
channeg1_send
{x:vt@ype}{xs:type}
(
  chan: !channeg1(x::xs) >> channeg1(xs), x: (x)
) : void // end of [channeg1_send]

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

datavtype
ss_client =
  | DENY of (chnil)
  | DENY of (channeg1(chnil), chnil)
  | HOLD of (channeg1(chnil), ss_client)
  | GRANT of (channeg1(ss_grant), chnil)
//
and ss_grant = RETURN1 of (chnil)
//
(* ****** ****** *)
//
datavtype
ClientOpt(ss:vtype) =
  | DENY(chnil) of ()
  | DENY(chnil) of channeg1(chnil)
  | HOLD(ss_client) of channeg1(chnil)
  | GRANT(chnil) of (channeg1(ss_grant))
//
datatype
AgentGrantOpt(ss:vtype) = RETURN1(chnil) of ()
//
(* ****** ****** *)
//
extern
fun
chanref_recv
  {a:vtype}(chan: chanref(a)): (a)
extern
fun
chanref_send
  {a:vtype}(chan: chanref(a), x: (a)): void
//
(* ****** ****** *)
//
extern
fun
channeg1_client{ss:vtype}
  (chan: !channeg1(ss_client) >> channeg1(ss), x: ClientOpt(ss)): void
extern
fun
chanpos1_client
  (chan: !chanpos1(ss_client) >> chanpos1(ss)): #[ss:vtype] ClientOpt(ss)
//
(* ****** ****** *)
//
extern
fun
channeg1_grant{ss:vtype}
  (chan: !channeg1(ss_grant) >> channeg1(ss), x: AgentGrantOpt(ss)): void
extern
fun
chanpos1_grant
  (chan: !chanpos1(ss_grant) >> chanpos1(ss)): #[ss:vtype] AgentGrantOpt(ss)
//
(* ****** ****** *)

extern val RANDOM : int

(* ****** ****** *)
//
datavtype
ServerOpt =
  | RETURN0 of (channel0)
  | REQUEST0 of (channeg1(ss_client))
//
(* ****** ****** *)

extern
val
theServer : chanref(ServerOpt)

(* ****** ****** *)
//
extern
fun Server((*void*)): void
extern
fun Client((*void*)): void
//
extern
fun
Agent
(
  agent: channel0
, client: channeg1(ss_client)
) : void // end of [Agent]
//
(* ****** ****** *)
//
extern
fun
chanref_create
  {a:vtype}
  (cap: intGte(0)): chanref(a)
//
extern
fun
chanref_is_empty
  : {a:vtype} chanref(a) -> bool
extern
fun
chanref_isnot_empty
  : {a:vtype} chanref(a) -> bool
//
(* ****** ****** *)

implement
Server() = let
//
fun
loop
(
  pool: chanref(channel0)
) : void = let
//
val
opt = chanref_recv(theServer)
//
in
//
case+ opt of
| ~RETURN0(agent) => let
    val () =
    chanref_send(pool, agent)
  in
    loop(pool)
  end // end of [RETURN0]
| ~REQUEST0(client) =>
  if chanref_isnot_empty(pool)
    then let
      val agent =
        chanref_recv(pool)
      // end of [val]
      val () = Agent(agent, client)
    in
      loop(pool)
    end // end of [then]
    else let
      val () =
      channeg1_client(client, DENY())
      val () = channeg1_nil_close(client)
    in
      loop(pool)
    end // end of [else]
//
end // end of [loop]
//
val
pool = chanref_create(5)
//
in
  loop(pool)
end // end of [Server]
//
(* ****** ****** *)

implement
Agent(agent, client) = let
//
fun
loop
( agent: !channel0
, client: channeg1(ss_client)
) : void = (
//
case
RANDOM of
| 0 => let
    val
    agent2 =
    channel0_split{chnil}(agent)
    val () =
    channeg1_client(client, HOLD(agent2))
    val ((*void*)) = chanpos1_nil_close(agent)
  in
    loop(agent, client)
  end // end of [_]
| 1 => let
    val
    agent2 =
    channel0_split{chnil}(agent)
    val () =
    channeg1_client(client, DENY(agent2))
    val ((*void*)) = chanpos1_nil_close(agent)
    val ((*void*)) = channeg1_nil_close(client)
  in
    // break
  end // end of [1]
| _ => let
    val
    agent2 =
    channel0_split{ss_grant}(agent)
    val () =
    channeg1_client(client, GRANT(agent2))
    val+RETURN1() = chanpos1_grant(agent)
    val ((*void*)) = chanpos1_nil_close(agent)
    val ((*void*)) = channeg1_nil_close(client)
  in
    // break
  end // end of [_]
//
) (* end of [loop] *)
//
val () = loop(agent, client)
//
in
  chanref_send(theServer, RETURN0(agent))
end // end of [Agent]
//
(* ****** ****** *)
//
implement
Client() = let
//
fun
loop
(
  client: channel0
) : void =
(
//
case+
RANDOM
of // case
| _ => let
    val
    client2 =
    channel0_split{ss_client}(client)
    val () =
    chanref_send(theServer, REQUEST0(client2))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: chanpos1(ss_client)
) : void = let
//
val opt = chanpos1_client(client)
//
in
//
case+ opt of
| ~DENY() =>
  {
    val () =
    chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
| ~DENY(agent) =>
  {
    val () =
    channeg1_nil_close(agent)
    val () =
    chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
| ~HOLD(agent) =>
  loop2(client) where
  {
    val () = channeg1_nil_close(agent)
  }
//
| ~GRANT(agent) =>
  {
    val () =
    channeg1_grant(agent, RETURN1())
    val () = channeg1_nil_close(agent)
    val () = chanpos1_nil_close(client)
    val () = channel0_destroy(client)
  }
//
end // end of [loop2]
//
in
  loop(channel0_create(0))
end // end of [Client]

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

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