(*
Jakub Pierewoj
1575643
solved all non-stretch exercises
*)

(** * Maps: Total and Partial Maps *)

(** _A lot of text needs written here_... *)

(** Maps (aka dictionaries) are ubiquitous data structures in software
    construction in general and, in particular, in the theory of
    programming languages.  We're going to need them in many places in
    the coming chapters.  They also make a nice case study using
    several of the ideas we've seen in previous chapters, including
    building data structures out of higher-order functions (from
    [Basics] and [Poly]) and the use of reflection in proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist in the map, and _partial_ maps, which return an
    [option].  The latter is defined in terms of the former (using
    [None] as the default element). *)

(* ###################################################################### *)
(** * Coq's Standard Library *)

(** One small digression before we start.  Unlike the chapters we have
    seen so far, this one is not going to [Import] the chapter before
    it (and, transitively, all the earlier chapters).  Instead, in
    this chapter and from now, on we're going to import the
    definitions and theorems we need directly from Coq's standard
    library stuff.  You should not notice much difference, though,
    because we've been careful to name our own definitions and
    theorems consistently with their counterparts in the standard
    library. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/. *)
(**  What's the best way to search for things in the library?
 *)

(* ###################################################################### *)
(** * Identifiers *)

(** First, we need a type of keys for our maps.  We repeat the
    definition of [id]s from the [Lists] chapter, plus the equality
    comparison function for [id]s and its fundamental property: *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

(** The following useful property of [beq_id] follows from a similar
    lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

(** (Note that [beq_nat_true_iff] was not proved above; it can be
    found in the standard library.) *)

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** Now this useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ###################################################################### *)
(** * Total Maps *)

(** Our main job in this chapter is to build a definition of partial
    maps that is similar in behavior to the one we saw in the [Poly]
    chapter, plus accompanying lemmas about their behavior.  This time
    around, though, we're going to use _functions_ rather than lists
    of key-value pairs to build maps.  The advantage of this
    representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element, which always returns the default element when applied to
    any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

(** To reason about maps in later chapters, we need to establish
    several fundamental facts about how they behave.  (Even if you
    don't work the following exercises, make sure you thoroughly
    understand the statements of the lemmas!)  Some of the proofs will
    require the functional extensionality axiom discussed in the
    [Logic] chapter. *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** First, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x1] with a value [v1] and then
    update again with the same key [x1] and another value [x2], then
    the resulting map behaves the same (i.e., it gives the same result
    whwn applied to any key [x2]) as the simpler map obtained by
    performing just the second [update] on [m]: *)

(* !!! *)
Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros. simpl. apply functional_extensionality. intros.  unfold t_update.
  destruct (beq_id x x0).
  - reflexivity.
  - reflexivity.
Qed.

(** [] *)

(** For the final two lemmas about total maps, it is convenient to use
    the reflection idioms that we introduced in chapter [IndProp].  We
    begin by proving a fundamental _reflection lemma_ relating the
    equality proposition on [id]s with the boolean function
    [beq_id]. *)

(** **** Exercise: 2 stars (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Partial maps *)

(** Finally, we can define _partial maps_ on top of total maps.  A
    partial map with elements of type [A] is simply a total map with
    elements of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2015-12-11 17:17:29 -0500 (Fri, 11 Dec 2015) $ *)


Set Implicit Arguments.

Require Import Common.Types.
Require Import Coq.Lists.List.
Require Import Network.NetworkPacket.
Require Import Word.WordInterface.
Require Import Pattern.Pattern.

Local Open Scope list_scope.

Definition Classifier (A : Type) := list (pattern * A) %type.

Fixpoint scan {A : Type} (default : A) (classifier : Classifier A)  (pt : portId)
  (pk : packet) :=
  match classifier with
    | nil => default
    | (pat,a) :: rest =>
      match Pattern.match_packet pt pk pat with
        | true => a
        | false => scan default rest pt pk
      end
  end.

Definition inter_entry {A : Type} {B : Type} (f : A -> A -> B)
  (cl : Classifier A) (v : pattern * A) :=
  let (pat, act) := v in
    fold_right (fun (v' : pattern * A) acc =>
      let (pat', act') := v' in
        (Pattern.inter pat pat', f act act') :: acc)
    nil cl.

Definition inter {A : Type} {B : Type} (f : A -> A -> B) (cl1 cl2 : Classifier A) :=
  fold_right (fun v acc => inter_entry f cl2 v ++ acc)
  nil cl1.

Definition union {A : Type} (f : A -> A -> A) (cl1 cl2 : Classifier A) :=
  inter f cl1 cl2 ++ cl1 ++ cl2.

(** Why so baroque? Filtering the tail of the list is not structurally
   recursive.
 *)
Fixpoint elim_shadowed_helper {A : Type} (prefix : Classifier A)
  (cf : Classifier A) :=
  match cf with
    | nil => prefix
    | (pat,act) :: cf' =>
      match existsb
        (fun (entry : pattern * A) =>
          let (pat', act) := entry in
            if Pattern.beq pat pat' then true else false)
        prefix with
        | true => elim_shadowed_helper prefix cf'
        | false => elim_shadowed_helper (prefix ++ [(pat,act)]) cf'
      end
  end.

Definition elim_shadowed {A : Type} (cf : Classifier A) :=
  elim_shadowed_helper nil cf.

Fixpoint prioritize
  {A : Type}
  (prio : nat)
  (lst : Classifier A) : list (nat * pattern *A) :=
  match lst with
    | nil => nil
    | (pat, act) :: lst' => (prio, pat, act) :: (prioritize (pred prio) lst')
  end.


(* generated by Ott 0.31, locally-nameless lngen from: ../spec/rules.ott ../spec/reduction.ott *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition typevar : Set := var.
Definition termvar : Set := var.
Definition label : Set := nat.
Definition int : Set := nat.

Inductive typ : Set :=  (*r types *)
 | t_tvar_b (_:nat) (*r type variable *)
 | t_tvar_f (X:typevar) (*r type variable *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top type *)
 | t_bot : typ (*r bottom type *)
 | t_forall (A:typ) (B:typ) (*r universal type *)
 | t_arrow (A:typ) (B:typ) (*r function type *)
 | t_and (A:typ) (B:typ) (*r intersection *)
 | t_rcd (l:label) (A:typ) (*r record *).

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variable *)
 | e_var_f (x:termvar) (*r variable *)
 | e_top : exp (*r top *)
 | e_lit (i:int) (*r lit *)
 | e_abs (A:typ) (e:exp) (*r abstraction with argument annotation *)
 | e_fixpoint (A:typ) (e:exp) (*r fixpoint *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_merge (e1:exp) (e2:exp) (*r merge *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_rcd (l:label) (e:exp) (*r record *)
 | e_proj (e:exp) (l:label) (*r projection *)
 | e_tabs (e:exp) (*r type abstractions *)
 | e_tapp (e:exp) (A:typ) (*r type applications *).

Definition tctx : Set := list ( atom * typ ).

Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

Inductive arg : Set :=  (*r arguments (expression or projection label or type) *)
 | arg_exp (v:exp)
 | arg_la (l:label)
 | arg_typ (A:typ).

Definition ctx : Set := list ( atom * typ ).

Inductive inla : Set :=  (*r index or label *)
 | inla_arrow : inla
 | inla_forall : inla
 | inla_label (l:label).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_typ_wrt_typ_rec (k:nat) (A5:typ) (A_6:typ) {struct A_6}: typ :=
  match A_6 with
  | (t_tvar_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => t_tvar_b nat
        | inleft (right _) => A5
        | inright _ => t_tvar_b (nat - 1)
      end
  | (t_tvar_f X) => t_tvar_f X
  | t_int => t_int
  | t_top => t_top
  | t_bot => t_bot
  | (t_forall A B) => t_forall (open_typ_wrt_typ_rec k A5 A) (open_typ_wrt_typ_rec (S k) A5 B)
  | (t_arrow A B) => t_arrow (open_typ_wrt_typ_rec k A5 A) (open_typ_wrt_typ_rec k A5 B)
  | (t_and A B) => t_and (open_typ_wrt_typ_rec k A5 A) (open_typ_wrt_typ_rec k A5 B)
  | (t_rcd l A) => t_rcd l (open_typ_wrt_typ_rec k A5 A)
end.

Fixpoint open_exp_wrt_typ_rec (k:nat) (A5:typ) (e_5:exp) {struct e_5}: exp :=
  match e_5 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i) => e_lit i
  | (e_abs A e) => e_abs (open_typ_wrt_typ_rec k A5 A) (open_exp_wrt_typ_rec k A5 e)
  | (e_fixpoint A e) => e_fixpoint (open_typ_wrt_typ_rec k A5 A) (open_exp_wrt_typ_rec k A5 e)
  | (e_app e1 e2) => e_app (open_exp_wrt_typ_rec k A5 e1) (open_exp_wrt_typ_rec k A5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_typ_rec k A5 e1) (open_exp_wrt_typ_rec k A5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_typ_rec k A5 e) (open_typ_wrt_typ_rec k A5 A)
  | (e_rcd l e) => e_rcd l (open_exp_wrt_typ_rec k A5 e)
  | (e_proj e l) => e_proj (open_exp_wrt_typ_rec k A5 e) l
  | (e_tabs e) => e_tabs (open_exp_wrt_typ_rec (S k) A5 e)
  | (e_tapp e A) => e_tapp (open_exp_wrt_typ_rec k A5 e) (open_typ_wrt_typ_rec k A5 A)
end.

Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i) => e_lit i
  | (e_abs A e) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e)
  | (e_fixpoint A e) => e_fixpoint A (open_exp_wrt_exp_rec (S k) e_5 e)
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
  | (e_rcd l e) => e_rcd l (open_exp_wrt_exp_rec k e_5 e)
  | (e_proj e l) => e_proj (open_exp_wrt_exp_rec k e_5 e) l
  | (e_tabs e) => e_tabs (open_exp_wrt_exp_rec k e_5 e)
  | (e_tapp e A) => e_tapp (open_exp_wrt_exp_rec k e_5 e) A
end.

Definition open_arg_wrt_typ_rec (k:nat) (A5:typ) (arg5:arg) : arg :=
  match arg5 with
  | (arg_exp v) => arg_exp (open_exp_wrt_typ_rec k A5 v)
  | (arg_la l) => arg_la l
  | (arg_typ A) => arg_typ (open_typ_wrt_typ_rec k A5 A)
end.

Definition open_arg_wrt_exp_rec (k:nat) (e5:exp) (arg5:arg) : arg :=
  match arg5 with
  | (arg_exp v) => arg_exp (open_exp_wrt_exp_rec k e5 v)
  | (arg_la l) => arg_la l
  | (arg_typ A) => arg_typ A
end.

Definition open_arg_wrt_typ A5 arg5 := open_arg_wrt_typ_rec 0 arg5 A5.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

Definition open_arg_wrt_exp e5 arg5 := open_arg_wrt_exp_rec 0 arg5 e5.

Definition open_exp_wrt_typ A5 e_5 := open_exp_wrt_typ_rec 0 e_5 A5.

Definition open_typ_wrt_typ A5 A_6 := open_typ_wrt_typ_rec 0 A_6 A5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_typ *)
Inductive lc_typ : typ -> Prop :=    (* defn lc_typ *)
 | lc_t_tvar_f : forall (X:typevar),
     (lc_typ (t_tvar_f X))
 | lc_t_int :
     (lc_typ t_int)
 | lc_t_top :
     (lc_typ t_top)
 | lc_t_bot :
     (lc_typ t_bot)
 | lc_t_forall : forall (A B:typ),
     (lc_typ A) ->
      ( forall X , lc_typ  ( open_typ_wrt_typ B (t_tvar_f X) )  )  ->
     (lc_typ (t_forall A B))
 | lc_t_arrow : forall (A B:typ),
     (lc_typ A) ->
     (lc_typ B) ->
     (lc_typ (t_arrow A B))
 | lc_t_and : forall (A B:typ),
     (lc_typ A) ->
     (lc_typ B) ->
     (lc_typ (t_and A B))
 | lc_t_rcd : forall (l:label) (A:typ),
     (lc_typ A) ->
     (lc_typ (t_rcd l A)).

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:termvar),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i:int),
     (lc_exp (e_lit i))
 | lc_e_abs : forall (A:typ) (e:exp),
     (lc_typ A) ->
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e))
 | lc_e_fixpoint : forall (A:typ) (e:exp),
     (lc_typ A) ->
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint A e))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_typ A) ->
     (lc_exp (e_anno e A))
 | lc_e_rcd : forall (l:label) (e:exp),
     (lc_exp e) ->
     (lc_exp (e_rcd l e))
 | lc_e_proj : forall (e:exp) (l:label),
     (lc_exp e) ->
     (lc_exp (e_proj e l))
 | lc_e_tabs : forall (e:exp),
      ( forall X , lc_exp  ( open_exp_wrt_typ e (t_tvar_f X) )  )  ->
     (lc_exp (e_tabs e))
 | lc_e_tapp : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_typ A) ->
     (lc_exp (e_tapp e A)).

(* defns LC_arg *)
Inductive lc_arg : arg -> Prop :=    (* defn lc_arg *)
 | lc_arg_exp : forall (v:exp),
     (lc_exp v) ->
     (lc_arg (arg_exp v))
 | lc_arg_la : forall (l:label),
     (lc_arg (arg_la l))
 | lc_arg_typ : forall (A:typ),
     (lc_typ A) ->
     (lc_arg (arg_typ A)).
(** free variables *)
Fixpoint typefv_typ (A5:typ) : vars :=
  match A5 with
  | (t_tvar_b nat) => {}
  | (t_tvar_f X) => {{X}}
  | t_int => {}
  | t_top => {}
  | t_bot => {}
  | (t_forall A B) => (typefv_typ A) \u (typefv_typ B)
  | (t_arrow A B) => (typefv_typ A) \u (typefv_typ B)
  | (t_and A B) => (typefv_typ A) \u (typefv_typ B)
  | (t_rcd l A) => (typefv_typ A)
end.

Fixpoint termfv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | e_top => {}
  | (e_lit i) => {}
  | (e_abs A e) => (termfv_exp e)
  | (e_fixpoint A e) => (termfv_exp e)
  | (e_app e1 e2) => (termfv_exp e1) \u (termfv_exp e2)
  | (e_merge e1 e2) => (termfv_exp e1) \u (termfv_exp e2)
  | (e_anno e A) => (termfv_exp e)
  | (e_rcd l e) => (termfv_exp e)
  | (e_proj e l) => (termfv_exp e)
  | (e_tabs e) => (termfv_exp e)
  | (e_tapp e A) => (termfv_exp e)
end.

Fixpoint typefv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {}
  | e_top => {}
  | (e_lit i) => {}
  | (e_abs A e) => (typefv_typ A) \u (typefv_exp e)
  | (e_fixpoint A e) => (typefv_typ A) \u (typefv_exp e)
  | (e_app e1 e2) => (typefv_exp e1) \u (typefv_exp e2)
  | (e_merge e1 e2) => (typefv_exp e1) \u (typefv_exp e2)
  | (e_anno e A) => (typefv_exp e) \u (typefv_typ A)
  | (e_rcd l e) => (typefv_exp e)
  | (e_proj e l) => (typefv_exp e)
  | (e_tabs e) => (typefv_exp e)
  | (e_tapp e A) => (typefv_exp e) \u (typefv_typ A)
end.

Definition termfv_arg (arg5:arg) : vars :=
  match arg5 with
  | (arg_exp v) => (termfv_exp v)
  | (arg_la l) => {}
  | (arg_typ A) => {}
end.

Definition typefv_arg (arg5:arg) : vars :=
  match arg5 with
  | (arg_exp v) => (typefv_exp v)
  | (arg_la l) => {}
  | (arg_typ A) => (typefv_typ A)
end.

(** substitutions *)
Fixpoint typsubst_typ (A5:typ) (X5:typevar) (A_6:typ) {struct A_6} : typ :=
  match A_6 with
  | (t_tvar_b nat) => t_tvar_b nat
  | (t_tvar_f X) => (if eq_var X X5 then A5 else (t_tvar_f X))
  | t_int => t_int
  | t_top => t_top
  | t_bot => t_bot
  | (t_forall A B) => t_forall (typsubst_typ A5 X5 A) (typsubst_typ A5 X5 B)
  | (t_arrow A B) => t_arrow (typsubst_typ A5 X5 A) (typsubst_typ A5 X5 B)
  | (t_and A B) => t_and (typsubst_typ A5 X5 A) (typsubst_typ A5 X5 B)
  | (t_rcd l A) => t_rcd l (typsubst_typ A5 X5 A)
end.

Fixpoint typsubst_exp (A5:typ) (X5:typevar) (e_5:exp) {struct e_5} : exp :=
  match e_5 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i) => e_lit i
  | (e_abs A e) => e_abs (typsubst_typ A5 X5 A) (typsubst_exp A5 X5 e)
  | (e_fixpoint A e) => e_fixpoint (typsubst_typ A5 X5 A) (typsubst_exp A5 X5 e)
  | (e_app e1 e2) => e_app (typsubst_exp A5 X5 e1) (typsubst_exp A5 X5 e2)
  | (e_merge e1 e2) => e_merge (typsubst_exp A5 X5 e1) (typsubst_exp A5 X5 e2)
  | (e_anno e A) => e_anno (typsubst_exp A5 X5 e) (typsubst_typ A5 X5 A)
  | (e_rcd l e) => e_rcd l (typsubst_exp A5 X5 e)
  | (e_proj e l) => e_proj (typsubst_exp A5 X5 e) l
  | (e_tabs e) => e_tabs (typsubst_exp A5 X5 e)
  | (e_tapp e A) => e_tapp (typsubst_exp A5 X5 e) (typsubst_typ A5 X5 A)
end.

Fixpoint subst_exp (e_5:exp) (x5:termvar) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | e_top => e_top
  | (e_lit i) => e_lit i
  | (e_abs A e) => e_abs A (subst_exp e_5 x5 e)
  | (e_fixpoint A e) => e_fixpoint A (subst_exp e_5 x5 e)
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_merge e1 e2) => e_merge (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | (e_rcd l e) => e_rcd l (subst_exp e_5 x5 e)
  | (e_proj e l) => e_proj (subst_exp e_5 x5 e) l
  | (e_tabs e) => e_tabs (subst_exp e_5 x5 e)
  | (e_tapp e A) => e_tapp (subst_exp e_5 x5 e) A
end.

Definition typsubst_arg (A5:typ) (X5:typevar) (arg5:arg) : arg :=
  match arg5 with
  | (arg_exp v) => arg_exp (typsubst_exp A5 X5 v)
  | (arg_la l) => arg_la l
  | (arg_typ A) => arg_typ (typsubst_typ A5 X5 A)
end.

Definition subst_arg (e5:exp) (x5:termvar) (arg5:arg) : arg :=
  match arg5 with
  | (arg_exp v) => arg_exp (subst_exp e5 x5 v)
  | (arg_la l) => arg_la l
  | (arg_typ A) => arg_typ A
end.

(** definitions *)

(* defns TypeWellformedness *)
Inductive TWell : tctx -> typ -> Prop :=    (* defn TWell *)
 | TW_top : forall (D:tctx),
     TWell D t_top
 | TW_bot : forall (D:tctx),
     TWell D t_bot
 | TW_int : forall (D:tctx),
     TWell D t_int
 | TW_var : forall (D:tctx) (X:typevar) (A:typ),
      binds  X A D  ->
     TWell D (t_tvar_f X)
 | TW_rcd : forall (D:tctx) (l:label) (A:typ),
     TWell D A ->
     TWell D (t_rcd l A)
 | TW_arrow : forall (D:tctx) (A B:typ),
     TWell D A ->
     TWell D B ->
     TWell D (t_arrow A B)
 | TW_and : forall (D:tctx) (A B:typ),
     TWell D A ->
     TWell D B ->
     TWell D (t_and A B)
 | TW_all : forall (L:vars) (D:tctx) (A B:typ),
     TWell D A ->
      ( forall X , X \notin  L  -> TWell  (cons ( X , A )  D )   ( open_typ_wrt_typ B (t_tvar_f X) )  )  ->
     TWell D (t_forall A B).

(* defns TermContextWellformedness *)
Inductive CWell : tctx -> ctx -> Prop :=    (* defn CWell *)
 | CW_empty : forall (D:tctx),
     CWell D  nil
 | CW_cons : forall (D:tctx) (G:ctx) (x:termvar) (A:typ),
     CWell D G ->
     TWell D A ->
     CWell D  (cons ( x , A )  G ) .

(* defns TypeContextWellformedness *)
Inductive TCWell : tctx -> Prop :=    (* defn TCWell *)
 | TCW_empty :
     TCWell  nil
 | TCW_cons : forall (D:tctx) (X:typevar) (A:typ),
     TCWell D ->
     TWell D A ->
      uniq   (cons ( X , A )  D )   ->
     TCWell  (cons ( X , A )  D ) .

(* defns BotLikeType *)
Inductive botLike : typ -> Prop :=    (* defn botLike *)
 | BL_bot :
     botLike t_bot
 | BL_andl : forall (A B:typ),
     lc_typ B ->
     botLike A ->
     botLike (t_and A B)
 | BL_andr : forall (A B:typ),
     lc_typ A ->
     botLike B ->
     botLike (t_and A B).

(* defns TopLikeType *)
Inductive topLike : tctx -> typ -> Prop :=    (* defn topLike *)
 | TL_top : forall (D:tctx),
     TCWell D ->
     topLike D t_top
 | TL_and : forall (D:tctx) (A B:typ),
     topLike D A ->
     topLike D B ->
     topLike D (t_and A B)
 | TL_arrow : forall (D:tctx) (A B:typ),
     TWell D A ->
     topLike D B ->
     topLike D (t_arrow A B)
 | TL_rcd : forall (D:tctx) (l:label) (B:typ),
     topLike D B ->
     topLike D (t_rcd l B)
 | TL_all : forall (L:vars) (D:tctx) (A B:typ),
      ( forall X , X \notin  L  -> topLike  (cons ( X , A )  D )   ( open_typ_wrt_typ B (t_tvar_f X) )  )  ->
     topLike D (t_forall A B)
 | TL_var : forall (D:tctx) (X:typevar) (A:typ),
     TCWell D ->
      binds  X A D  ->
     botLike A ->
     topLike D (t_tvar_f X).

(* defns NotTopLikeType *)
Inductive notTopLike : tctx -> typ -> Prop :=    (* defn notTopLike *)
 | NTL : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
      not ( topLike D A )  ->
     notTopLike D A.

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_var : forall (X:typevar),
     ord (t_tvar_f X)
 | O_top :
     ord t_top
 | O_bot :
     ord t_bot
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     lc_typ A ->
     ord B ->
     ord (t_arrow A B)
 | O_all : forall (L:vars) (A B:typ),
     lc_typ A ->
      ( forall X , X \notin  L  -> ord  ( open_typ_wrt_typ B (t_tvar_f X) )  )  ->
     ord (t_forall A B)
 | O_rcd : forall (l:label) (B:typ),
     ord B ->
     ord (t_rcd l B).

(* defns SplitType *)
Inductive spl : typ -> typ -> typ -> Prop :=    (* defn spl *)
 | Sp_arrow : forall (A B C1 C2:typ),
     lc_typ A ->
     spl B C1 C2 ->
     spl (t_arrow A B) (t_arrow A C1) (t_arrow A C2)
 | Sp_all : forall (L:vars) (A B C1 C2:typ),
     lc_typ A ->
      ( forall X , X \notin  L  -> spl  ( open_typ_wrt_typ B (t_tvar_f X) )   ( open_typ_wrt_typ C1 (t_tvar_f X) )   ( open_typ_wrt_typ C2 (t_tvar_f X) )  )  ->
     spl (t_forall A B) (t_forall A C1) (t_forall A C2)
 | Sp_rcd : forall (l:label) (B C1 C2:typ),
     spl B C1 C2 ->
     spl (t_rcd l B) (t_rcd l C1) (t_rcd l C2)
 | Sp_and : forall (A B:typ),
     lc_typ A ->
     lc_typ B ->
     spl (t_and A B) A B.

(* defns DeclarativeSubtyping *)
Inductive sub : tctx -> typ -> typ -> Prop :=    (* defn sub *)
 | DS_refl : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     sub D A A
 | DS_trans : forall (D:tctx) (A C B:typ),
     sub D A B ->
     sub D B C ->
     sub D A C
 | DS_top : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     sub D A t_top
 | DS_bot : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     sub D t_bot A
 | DS_and : forall (D:tctx) (A B C:typ),
     sub D A B ->
     sub D A C ->
     sub D A (t_and B C)
 | DS_andl : forall (D:tctx) (A B:typ),
     TCWell D ->
     TWell D (t_and A B) ->
     sub D (t_and A B) A
 | DS_andr : forall (D:tctx) (A B:typ),
     TCWell D ->
     TWell D (t_and A B) ->
     sub D (t_and A B) B
 | DS_arr : forall (D:tctx) (A1 B1 A2 B2:typ),
     sub D A2 A1 ->
     sub D B1 B2 ->
     sub D (t_arrow A1 B1) (t_arrow A2 B2)
 | DS_distArrow : forall (D:tctx) (A B C:typ),
     TCWell D ->
     TWell D (t_arrow A (t_and B C)) ->
     sub D (t_and  (t_arrow A B)   (t_arrow A C) ) (t_arrow A (t_and B C))
 | DS_topArrow : forall (D:tctx),
     TCWell D ->
     sub D t_top (t_arrow t_top t_top)
 | DS_rcd : forall (D:tctx) (l:label) (A B:typ),
     sub D A B ->
     sub D (t_rcd l A) (t_rcd l B)
 | DS_distRcd : forall (D:tctx) (l:label) (A B:typ),
     TCWell D ->
     TWell D (t_rcd l (t_and A B)) ->
     sub D (t_and (t_rcd l A) (t_rcd l B)) (t_rcd l (t_and A B))
 | DS_topRcd : forall (D:tctx) (l:label),
     TCWell D ->
     sub D t_top (t_rcd l t_top)
 | DS_all : forall (L:vars) (D:tctx) (A1 B1 A2 B2:typ),
     sub D A2 A1 ->
      ( forall X , X \notin  L  -> sub  (cons ( X , A2 )  D )   ( open_typ_wrt_typ B1 (t_tvar_f X) )   ( open_typ_wrt_typ B2 (t_tvar_f X) )  )  ->
     sub D (t_forall A1 B1) (t_forall A2 B2)
 | DS_distAll : forall (D:tctx) (A B1 B2:typ),
     TCWell D ->
     TWell D (t_forall A  (t_and B1 B2) ) ->
     sub D (t_and  (t_forall A B1)   (t_forall A B2) ) (t_forall A  (t_and B1 B2) )
 | DS_topAll : forall (D:tctx),
     TCWell D ->
     sub D t_top (t_forall t_top t_top)
 | DS_topVar : forall (D:tctx) (X:typevar) (A:typ),
      binds  X A D  ->
     sub D A t_bot ->
     sub D t_top (t_tvar_f X).

(* defns AlgorithmicSubtyping *)
Inductive algo_sub : tctx -> typ -> typ -> Prop :=    (* defn algo_sub *)
 | S_var : forall (D:tctx) (X:typevar),
     TCWell D ->
     TWell D (t_tvar_f X) ->
     algo_sub D (t_tvar_f X) (t_tvar_f X)
 | S_int : forall (D:tctx),
     TCWell D ->
     algo_sub D t_int t_int
 | S_top : forall (D:tctx) (A B:typ),
     TWell D A ->
     ord B ->
     topLike D B ->
     algo_sub D A B
 | S_bot : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     ord A ->
     algo_sub D t_bot A
 | S_andl : forall (D:tctx) (A B C:typ),
     TWell D B ->
     ord C ->
     algo_sub D A C ->
     algo_sub D (t_and A B) C
 | S_andr : forall (D:tctx) (A B C:typ),
     TWell D A ->
     ord C ->
     algo_sub D B C ->
     algo_sub D (t_and A B) C
 | S_arrow : forall (D:tctx) (A1 B1 A2 B2:typ),
     ord B2 ->
     algo_sub D A2 A1 ->
     algo_sub D B1 B2 ->
     algo_sub D (t_arrow A1 B1) (t_arrow A2 B2)
 | S_all : forall (L:vars) (D:tctx) (A1 A2 B1 B2:typ),
      ( forall X , X \notin  L  -> ord  ( open_typ_wrt_typ B2 (t_tvar_f X) )  )  ->
     algo_sub D B1 A1 ->
      ( forall X , X \notin  L  -> algo_sub  (cons ( X , B1 )  D )   ( open_typ_wrt_typ A2 (t_tvar_f X) )   ( open_typ_wrt_typ B2 (t_tvar_f X) )  )  ->
     algo_sub D (t_forall A1 A2) (t_forall B1 B2)
 | S_rcd : forall (D:tctx) (l:label) (A B:typ),
     ord B ->
     algo_sub D A B ->
     algo_sub D (t_rcd l A) (t_rcd l B)
 | S_and : forall (D:tctx) (A B B1 B2:typ),
     spl B B1 B2 ->
     algo_sub D A B1 ->
     algo_sub D A B2 ->
     algo_sub D A B.

(* defns ModularSubtyping *)
Inductive msub : tctx -> typ -> typ -> Prop :=    (* defn msub *)
 | MS_refl : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     msub D A A
 | MS_top : forall (D:tctx) (A B:typ),
     TWell D A ->
     topLike D B ->
     msub D A B
 | MS_bot : forall (D:tctx) (A:typ),
     TCWell D ->
     TWell D A ->
     msub D t_bot A
 | MS_andl : forall (D:tctx) (A B C:typ),
     TWell D B ->
     msub D A C ->
     msub D (t_and A B) C
 | MS_andr : forall (D:tctx) (A B C:typ),
     TWell D A ->
     msub D B C ->
     msub D (t_and A B) C
 | MS_arrow : forall (D:tctx) (A1 B1 A2 B2:typ),
     msub D A2 A1 ->
     msub D B1 B2 ->
     msub D (t_arrow A1 B1) (t_arrow A2 B2)
 | MS_rcd : forall (D:tctx) (l:label) (A B:typ),
     msub D A B ->
     msub D (t_rcd l A) (t_rcd l B)
 | MS_and : forall (D:tctx) (A B B1 B2:typ),
     spl B B1 B2 ->
     msub D A B1 ->
     msub D A B2 ->
     msub D A B
 | MS_all : forall (L:vars) (D:tctx) (A1 A2 B1 B2:typ),
     msub D B1 A1 ->
      ( forall X , X \notin  L  -> msub  (cons ( X , B1 )  D )   ( open_typ_wrt_typ A2 (t_tvar_f X) )   ( open_typ_wrt_typ B2 (t_tvar_f X) )  )  ->
     msub D (t_forall A1 A2) (t_forall B1 B2).

(* defns DisjointnessAxiom *)
Inductive disjoint_axiom : typ -> typ -> Prop :=    (* defn disjoint_axiom *)
 | Dax_intArrow : forall (A1 A2:typ),
     lc_typ A1 ->
     lc_typ A2 ->
     disjoint_axiom t_int (t_arrow A1 A2)
 | Dax_intRcd : forall (l:label) (A:typ),
     lc_typ A ->
     disjoint_axiom t_int (t_rcd l A)
 | Dax_intAll : forall (A B:typ),
     lc_typ A ->
     lc_typ (t_forall A B) ->
     disjoint_axiom t_int (t_forall A B)
 | Dax_arrowRcd : forall (A1 A2:typ) (l:label) (A:typ),
     lc_typ A1 ->
     lc_typ A2 ->
     lc_typ A ->
     disjoint_axiom (t_arrow A1 A2) (t_rcd l A)
 | Dax_arrowAll : forall (A1 A2 A B:typ),
     lc_typ A1 ->
     lc_typ A2 ->
     lc_typ A ->
     lc_typ (t_forall A B) ->
     disjoint_axiom (t_arrow A1 A2) (t_forall A B)
 | Dax_rcdAll : forall (l:label) (C A B:typ),
     lc_typ C ->
     lc_typ A ->
     lc_typ (t_forall A B) ->
     disjoint_axiom (t_rcd l C) (t_forall A B)
 | Dax_arrowInt : forall (A1 A2:typ),
     lc_typ A1 ->
     lc_typ A2 ->
     disjoint_axiom (t_arrow A1 A2) t_int
 | Dax_rcdInt : forall (l:label) (A:typ),
     lc_typ A ->
     disjoint_axiom (t_rcd l A) t_int
 | Dax_allInt : forall (A B:typ),
     lc_typ A ->
     lc_typ (t_forall A B) ->
     disjoint_axiom (t_forall A B) t_int
 | Dax_rcdArrow : forall (l:label) (A A1 A2:typ),
     lc_typ A ->
     lc_typ A1 ->
     lc_typ A2 ->
     disjoint_axiom (t_rcd l A) (t_arrow A1 A2)
 | Dax_allArrow : forall (A B A1 A2:typ),
     lc_typ A ->
     lc_typ (t_forall A B) ->
     lc_typ A1 ->
     lc_typ A2 ->
     disjoint_axiom (t_forall A B) (t_arrow A1 A2)
 | Dax_allRcd : forall (A B:typ) (l:label) (C:typ),
     lc_typ A ->
     lc_typ (t_forall A B) ->
     lc_typ C ->
     disjoint_axiom (t_forall A B) (t_rcd l C)
 | Dax_rcdNeq : forall (l1:label) (A:typ) (l2:label) (B:typ),
     lc_typ A ->
     lc_typ B ->
      l1  <>  l2  ->
     disjoint_axiom (t_rcd l1 A) (t_rcd l2 B).

(* defns TypeDisjointness *)
Inductive disjoint : tctx -> typ -> typ -> Prop :=    (* defn disjoint *)
 | D_ax : forall (D:tctx) (A B:typ),
     TCWell D ->
     TWell D A ->
     TWell D B ->
     disjoint_axiom A B ->
     disjoint D A B
 | D_topl : forall (D:tctx) (A B:typ),
     TWell D B ->
     topLike D A ->
     disjoint D A B
 | D_topr : forall (D:tctx) (A B:typ),
     TWell D A ->
     topLike D B ->
     disjoint D A B
 | D_arrow : forall (D:tctx) (A1 A2 B1 B2:typ),
     TWell D (t_arrow A1 A2) ->
     TWell D (t_arrow B1 B2) ->
     disjoint D A2 B2 ->
     disjoint D (t_arrow A1 A2) (t_arrow B1 B2)
 | D_rcdEq : forall (D:tctx) (l:label) (A B:typ),
     disjoint D A B ->
     disjoint D (t_rcd l A) (t_rcd l B)
 | D_all : forall (L:vars) (D:tctx) (A1 B1 A2 B2:typ),
     TWell D A1 ->
     TWell D A2 ->
      ( forall X , X \notin  L  -> disjoint  (cons ( X , (t_and A1 A2) )  D )   ( open_typ_wrt_typ B1 (t_tvar_f X) )   ( open_typ_wrt_typ B2 (t_tvar_f X) )  )  ->
     disjoint D (t_forall A1 B1) (t_forall A2 B2)
 | D_varl : forall (D:tctx) (X:typevar) (B A:typ),
      binds  X A D  ->
     algo_sub D A B ->
     disjoint D (t_tvar_f X) B
 | D_varr : forall (D:tctx) (B:typ) (X:typevar) (A:typ),
      binds  X A D  ->
     algo_sub D A B ->
     disjoint D B (t_tvar_f X)
 | D_andl : forall (D:tctx) (A B A1 A2:typ),
     spl A A1 A2 ->
     disjoint D A1 B ->
     disjoint D A2 B ->
     disjoint D A B
 | D_andr : forall (D:tctx) (A B B1 B2:typ),
     spl B B1 B2 ->
     disjoint D A B1 ->
     disjoint D A B2 ->
     disjoint D A B.

(* defns IsomorphicSubtyping *)
Inductive subsub : typ -> typ -> Prop :=    (* defn subsub *)
 | IS_refl : forall (A:typ),
     lc_typ A ->
     subsub A A
 | IS_and : forall (A1 A2 B B1 B2:typ),
     spl B B1 B2 ->
     subsub A1 B1 ->
     subsub A2 B2 ->
     subsub (t_and A1 A2) B.

(* defns DuplicatedType *)
Inductive DuplicatedType : typ -> typ -> Prop :=    (* defn DuplicatedType *)
 | DT_refl : forall (A:typ),
     lc_typ A ->
     DuplicatedType A A
 | DT_copy : forall (A B C:typ),
     DuplicatedType A C ->
     DuplicatedType B C ->
     DuplicatedType (t_and A B) C
 | DT_and : forall (A' B' A B:typ),
     DuplicatedType A' A ->
     DuplicatedType B' B ->
     DuplicatedType (t_and A' B') (t_and A B).

(* defns ApplicativeDistribution *)
Inductive appDist : typ -> typ -> Prop :=    (* defn appDist *)
 | AD_andArrow : forall (A1 A2 B1 B2 C1 C2:typ),
     appDist A1 (t_arrow B1 C1) ->
     appDist A2 (t_arrow B2 C2) ->
     appDist (t_and A1 A2) (t_arrow (t_and B1 B2) (t_and C1 C2))
 | AD_andRcd : forall (A1 A2:typ) (l:label) (B1 B2:typ),
     appDist A1 (t_rcd l B1) ->
     appDist A2 (t_rcd l B2) ->
     appDist (t_and A1 A2) (t_rcd l (t_and B1 B2))
 | AD_andAll : forall (A1 A2 B1 B2 C1 C2:typ),
     appDist A1 (t_forall B1 C1) ->
     appDist A2 (t_forall B2 C2) ->
     appDist (t_and A1 A2) (t_forall (t_and B1 B2)  (t_and C1 C2) )
 | AD_refl : forall (A:typ),
     lc_typ A ->
     appDist A A.

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | V_unit :
     value e_top
 | V_lit : forall (i:int),
     value (e_lit i)
 | V_abs : forall (A:typ) (e:exp) (B:typ),
     lc_typ A ->
     lc_exp (e_abs A e) ->
     lc_typ B ->
     value (e_anno  ( (e_abs A e) )  B)
 | V_bareAbs : forall (A:typ) (e:exp),
     lc_typ A ->
     lc_exp (e_abs A e) ->
     value  ( (e_abs A e) )
 | V_tabs : forall (e:exp) (B:typ),
     lc_exp (e_tabs e) ->
     lc_typ B ->
     value (e_anno  ( (e_tabs e) )  B)
 | V_bareTabs : forall (e:exp),
     lc_exp (e_tabs e) ->
     value  ( (e_tabs e) )
 | V_rcd : forall (l:label) (e:exp) (B:typ),
     lc_exp e ->
     lc_typ B ->
     value (e_anno (e_rcd l e) B)
 | V_bareRcd : forall (l:label) (e:exp),
     lc_exp e ->
     value (e_rcd l e)
 | V_merge : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (e_merge v1 v2).

(* defns Casting *)
Inductive casting : exp -> typ -> exp -> Prop :=    (* defn casting *)
 | Cast_int : forall (i:int),
     casting (e_lit i) t_int (e_lit i)
 | Cast_top : forall (v:exp),
      lc_exp  v  ->
     casting v t_top e_top
 | Cast_topArrow : forall (v:exp) (A1 A2:typ),
      lc_exp  v  ->
     ord (t_arrow A1 A2) ->
     topLike  nil  (t_arrow A1 A2) ->
     casting v (t_arrow A1 A2) (e_anno  ( (e_abs t_top e_top) )  (t_arrow A1 A2))
 | Cast_topAll : forall (v:exp) (A1 A2:typ),
      lc_exp  v  ->
     ord (t_forall A1 A2) ->
     topLike  nil  (t_forall A1 A2) ->
     casting v (t_forall A1 A2) (e_anno  ( (e_tabs e_top) )  (t_forall A1 A2))
 | Cast_topRcd : forall (v:exp) (l:label) (A:typ),
      lc_exp  v  ->
     ord (t_rcd l A) ->
     topLike  nil  (t_rcd l A) ->
     casting v (t_rcd l A) (e_anno (e_rcd l e_top) (t_rcd l A))
 | Cast_anno : forall (e:exp) (A B:typ),
     lc_exp e ->
     ord B ->
     notTopLike  nil  B ->
     algo_sub  nil  A B ->
     casting (e_anno e A) B (e_anno e B)
 | Cast_mergel : forall (v1 v2:exp) (A:typ) (v1':exp),
     lc_exp v2 ->
     ord A ->
     casting v1 A v1' ->
     casting (e_merge v1 v2) A v1'
 | Cast_merger : forall (v1 v2:exp) (A:typ) (v2':exp),
     lc_exp v1 ->
     ord A ->
     casting v2 A v2' ->
     casting (e_merge v1 v2) A v2'
 | Cast_and : forall (v:exp) (A:typ) (v1 v2:exp) (B C:typ),
     spl A B C ->
     casting v B v1 ->
     casting v C v2 ->
     casting v A (e_merge v1 v2).

(* defns ExpressionWrapping *)
Inductive wrapping : exp -> typ -> exp -> Prop :=    (* defn wrapping *)
 | EW_top : forall (e:exp),
     lc_exp e ->
     wrapping e t_top e_top
 | EW_topArrow : forall (e:exp) (A1 A2:typ),
     lc_exp e ->
     ord (t_arrow A1 A2) ->
     topLike  nil  (t_arrow A1 A2) ->
     wrapping e (t_arrow A1 A2) (e_anno  ( (e_abs t_top e_top) )  (t_arrow A1 A2))
 | EW_topAll : forall (e:exp) (A1 A2:typ),
     lc_exp e ->
     ord (t_forall A1 A2) ->
     topLike  nil  (t_forall A1 A2) ->
     wrapping e (t_forall A1 A2) (e_anno  ( (e_tabs e_top) )  (t_forall A1 A2))
 | EW_topRcd : forall (e:exp) (l:label) (A:typ),
     lc_exp e ->
     ord (t_rcd l A) ->
     topLike  nil  (t_rcd l A) ->
     wrapping e (t_rcd l A) (e_anno (e_rcd l e_top) (t_rcd l A))
 | EW_anno : forall (e:exp) (A:typ),
     lc_exp e ->
     ord A ->
     notTopLike  nil  A ->
     wrapping e A (e_anno e A)
 | EW_and : forall (e:exp) (A:typ) (e1 e2:exp) (B C:typ),
     spl A B C ->
     wrapping e B e1 ->
     wrapping e C e2 ->
     wrapping e A (e_merge e1 e2).

(* defns ParallelApplication *)
Inductive papp : exp -> arg -> exp -> Prop :=    (* defn papp *)
 | PApp_abs : forall (A:typ) (e1:exp) (B:typ) (e2 e2':exp) (C2 C1:typ),
     lc_exp (e_abs A e1) ->
     appDist B (t_arrow C1 C2) ->
     wrapping e2 A e2' ->
     papp (e_anno  ( (e_abs A e1) )  B) (arg_exp e2) (e_anno  (  (open_exp_wrt_exp  e1 e2' )  )  C2)
 | PApp_tabs : forall (e:exp) (A C B2 B1:typ),
     lc_exp (e_tabs e) ->
     lc_typ C ->
     appDist A (t_forall B1 B2) ->
     papp (e_anno  ( (e_tabs e) )  A) (arg_typ C) (e_anno  (  (open_exp_wrt_typ  e C )  )    (open_typ_wrt_typ  B2 C )  )
 | PApp_proj : forall (l:label) (e:exp) (A B:typ),
     lc_exp e ->
     appDist A (t_rcd l B) ->
     papp (e_anno (e_rcd l e) A) (arg_la l) (e_anno e B)
 | PApp_merge : forall (v1 v2:exp) (arg5:arg) (e1 e2:exp),
     papp v1 arg5 e1 ->
     papp v2 arg5 e2 ->
     papp (e_merge v1 v2) arg5 (e_merge e1 e2).

(* defns PreValues *)
Inductive prevalue : exp -> Prop :=    (* defn prevalue *)
 | PV_int : forall (i:int),
     prevalue (e_lit i)
 | PV_top :
     prevalue e_top
 | PV_anno : forall (e:exp) (A:typ),
     lc_exp e ->
     lc_typ A ->
     prevalue (e_anno e A)
 | PV_merge : forall (u1 u2:exp),
     prevalue u1 ->
     prevalue u2 ->
     prevalue (e_merge u1 u2).

(* defns PrincipalType *)
Inductive pType : exp -> typ -> Prop :=    (* defn pType *)
 | PT_top :
     pType e_top t_top
 | PT_int : forall (i:int),
     pType (e_lit i) t_int
 | PT_anno : forall (e:exp) (A:typ),
     lc_exp e ->
     lc_typ A ->
     pType  ( (e_anno e A) )  A
 | PT_merge : forall (u1 u2:exp) (A B:typ),
     pType u1 A ->
     pType u2 B ->
     pType  ( (e_merge u1 u2) )   (t_and A B) .

(* defns Consistent *)
Inductive consistent : exp -> exp -> Prop :=    (* defn consistent *)
 | C_lit : forall (i:int),
     consistent (e_lit i) (e_lit i)
 | C_anno : forall (e:exp) (A B:typ),
     lc_typ A ->
     lc_exp e ->
     lc_typ B ->
     consistent (e_anno e A) (e_anno e B)
 | C_disjoint : forall (u1 u2:exp) (A B:typ),
     pType u1 A ->
     pType u2 B ->
     disjoint  nil  A B ->
     prevalue u1 ->
     prevalue u2 ->
     consistent u1 u2
 | C_mergel : forall (u1 u2 u:exp),
     consistent u1 u ->
     consistent u2 u ->
     consistent (e_merge u1 u2) u
 | C_merger : forall (u u1 u2:exp),
     consistent u u1 ->
     consistent u u2 ->
     consistent u (e_merge u1 u2).

(* defns BidirectionalTyping *)
Inductive Typing : tctx -> ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_top : forall (D:tctx) (G:ctx),
     TCWell D ->
     CWell D G ->
      uniq  G  ->
     Typing D G e_top Inf t_top
 | Typ_lit : forall (D:tctx) (G:ctx) (i:int),
     TCWell D ->
     CWell D G ->
      uniq  G  ->
     Typing D G (e_lit i) Inf t_int
 | Typ_var : forall (D:tctx) (G:ctx) (x:termvar) (A:typ),
     TCWell D ->
     CWell D G ->
      binds  x A G  ->
      uniq  G  ->
     Typing D G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (D:tctx) (G:ctx) (A:typ) (e:exp) (B1 B2:typ),
      algo_sub D B1 A  ->
      ( forall x , x \notin  L  -> Typing D  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B2 )  ->
     Typing D G (e_abs A e) Chk (t_arrow B1 B2)
 | Typ_app : forall (D:tctx) (G:ctx) (e1 e2:exp) (C A B:typ),
     Typing D G e1 Inf A ->
      appDist A (t_arrow B C)  ->
     Typing D G e2 Chk B ->
     Typing D G (e_app e1 e2) Inf C
 | Typ_tabs : forall (L:vars) (D:tctx) (G:ctx) (e:exp) (A B:typ),
     CWell D G ->
      ( forall X , X \notin  L  -> Typing  (cons ( X , A )  D )  G  ( open_exp_wrt_typ e (t_tvar_f X) )  Chk  ( open_typ_wrt_typ B (t_tvar_f X) )  )  ->
     Typing D G (e_tabs e) Chk (t_forall A B)
 | Typ_tapp : forall (D:tctx) (G:ctx) (e:exp) (A C2 B C1:typ),
     Typing D G e Inf B ->
      appDist B (t_forall C1 C2)  ->
      disjoint D A C1  ->
     Typing D G (e_tapp e A) Inf  (open_typ_wrt_typ  C2 A )
 | Typ_proj : forall (D:tctx) (G:ctx) (e:exp) (l:label) (C A:typ),
     Typing D G e Inf A ->
      appDist A (t_rcd l C)  ->
     Typing D G (e_proj e l) Inf C
 | Typ_rcd : forall (D:tctx) (G:ctx) (l:label) (e:exp) (A:typ),
     Typing D G e Chk A ->
     Typing D G (e_rcd l e) Chk (t_rcd l A)
 | Typ_merge : forall (D:tctx) (G:ctx) (e1 e2:exp) (A B:typ),
     Typing D G e1 Inf A ->
     Typing D G e2 Inf B ->
      disjoint D A B  ->
     Typing D G (e_merge e1 e2) Inf (t_and A B)
 | Typ_inter : forall (D:tctx) (G:ctx) (e:exp) (A B:typ),
     Typing D G e Chk A ->
     Typing D G e Chk B ->
     Typing D G e Chk (t_and A B)
 | Typ_anno : forall (D:tctx) (G:ctx) (e:exp) (A:typ),
     Typing D G e Chk A ->
     Typing D G  ( (e_anno e A) )  Inf A
 | Typ_fix : forall (L:vars) (D:tctx) (G:ctx) (A:typ) (e:exp),
      ( forall x , x \notin  L  -> Typing D  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk A )  ->
     Typing D G (e_fixpoint A e) Inf A
 | Typ_mergev : forall (D:tctx) (G:ctx) (u1 u2:exp) (A B:typ),
     TCWell D ->
     CWell D G ->
      uniq  G  ->
     Typing  nil   nil  u1 Inf A ->
     Typing  nil   nil  u2 Inf B ->
      consistent u1 u2  ->
     Typing D G (e_merge u1 u2) Inf (t_and A B)
 | Typ_sub : forall (D:tctx) (G:ctx) (e:exp) (B A:typ),
     Typing D G e Inf A ->
      algo_sub D A B  ->
     Typing D G e Chk B.

(* defns Reduction *)
Inductive step : exp -> exp -> Prop :=    (* defn step *)
 | Step_papp : forall (v e e':exp),
     value v ->
     papp v (arg_exp e) e' ->
     step (e_app v e) e'
 | Step_pproj : forall (v:exp) (l:label) (e:exp),
     value v ->
     papp v (arg_la l) e ->
     step (e_proj v l) e
 | Step_ptapp : forall (v:exp) (A:typ) (e:exp),
     value v ->
     papp v (arg_typ A) e ->
     step (e_tapp v A) e
 | Step_annov : forall (v:exp) (A:typ) (v':exp),
     value v ->
     prevalue v ->
     casting v A v' ->
     step (e_anno v A) v'
 | Step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_app e1 e2) (e_app e1' e2)
 | Step_merge : forall (e1 e2 e1' e2':exp),
     step e1 e1' ->
     step e2 e2' ->
     step (e_merge e1 e2) (e_merge e1' e2')
 | Step_mergel : forall (e1 v2 e1':exp),
     value v2 ->
     step e1 e1' ->
     step (e_merge e1 v2) (e_merge e1' v2)
 | Step_merger : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_merge v1 e2) (e_merge v1 e2')
 | Step_anno : forall (e:exp) (A:typ) (e':exp),
     lc_typ A ->
     step e e' ->
     step (e_anno e A) (e_anno e' A)
 | Step_fix : forall (A:typ) (e:exp),
     lc_exp (e_fixpoint A e) ->
     lc_typ A ->
     step (e_fixpoint A e) (e_anno  (open_exp_wrt_exp  e (e_fixpoint A e) )  A)
 | Step_proj : forall (e:exp) (l:label) (e':exp),
     step e e' ->
     step (e_proj e l) (e_proj e' l)
 | Step_tapp : forall (e:exp) (A:typ) (e':exp),
     lc_typ A ->
     step e e' ->
     step (e_tapp e A) (e_tapp e' A).

(** infrastructure *)
Hint Constructors TWell CWell TCWell botLike topLike notTopLike ord spl sub algo_sub msub disjoint_axiom disjoint subsub DuplicatedType appDist value casting wrapping papp prevalue pType consistent Typing step lc_typ lc_exp lc_arg : core.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Import BinInt DoubleBase.

Open Scope Z_scope.

(** * ZSig *)

(** Interface of a rich structure about integers.
    Specifications are written via translation to Z.
*)

Module Type ZType.

 Parameter t : univ_of_cycles.

 Parameter to_Z : t -> Z.
 Local Notation "[ x ]" := (to_Z x).

 Definition eq x y := [x] = [y].
 Definition lt x y := [x] < [y].
 Definition le x y := [x] <= [y].

 Parameter of_Z : Z -> t.
 Parameter spec_of_Z: forall x, to_Z (of_Z x) = x.

 Parameter compare : t -> t -> comparison.
 Parameter eqb : t -> t -> bool.
 Parameter ltb : t -> t -> bool.
 Parameter leb : t -> t -> bool.
 Parameter min : t -> t -> t.
 Parameter max : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter two : t.
 Parameter minus_one : t.
 Parameter succ : t -> t.
 Parameter add  : t -> t -> t.
 Parameter pred : t -> t.
 Parameter sub : t -> t -> t.
 Parameter opp : t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter pow_pos : t -> positive -> t.
 Parameter pow_N : t -> N -> t.
 Parameter pow : t -> t -> t.
 Parameter sqrt : t -> t.
 Parameter log2 : t -> t.
 Parameter div_eucl : t -> t -> t * t.
 Parameter div : t -> t -> t.
 Parameter modulo : t -> t -> t.
 Parameter quot : t -> t -> t.
 Parameter rem : t -> t -> t.
 Parameter gcd : t -> t -> t.
 Parameter sgn : t -> t.
 Parameter abs : t -> t.
 Parameter even : t -> bool.
 Parameter odd : t -> bool.
 Parameter testbit : t -> t -> bool.
 Parameter shiftr : t -> t -> t.
 Parameter shiftl : t -> t -> t.
 Parameter land : t -> t -> t.
 Parameter lor : t -> t -> t.
 Parameter ldiff : t -> t -> t.
 Parameter lxor : t -> t -> t.
 Parameter div2 : t -> t.

 Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]).
 Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]).
 Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]).
 Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]).
 Parameter spec_min : forall x y, [min x y] = Z.min [x] [y].
 Parameter spec_max : forall x y, [max x y] = Z.max [x] [y].
 Parameter spec_0: [zero] = 0.
 Parameter spec_1: [one] = 1.
 Parameter spec_2: [two] = 2.
 Parameter spec_m1: [minus_one] = -1.
 Parameter spec_succ: forall n, [succ n] = [n] + 1.
 Parameter spec_add: forall x y, [add x y] = [x] + [y].
 Parameter spec_pred: forall x, [pred x] = [x] - 1.
 Parameter spec_sub: forall x y, [sub x y] = [x] - [y].
 Parameter spec_opp: forall x, [opp x] = - [x].
 Parameter spec_mul: forall x y, [mul x y] = [x] * [y].
 Parameter spec_square: forall x, [square x] = [x] *  [x].
 Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n.
 Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n.
 Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n].
 Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x].
 Parameter spec_log2: forall x, [log2 x] = Z.log2 [x].
 Parameter spec_div_eucl: forall x y,
   let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y].
 Parameter spec_div: forall x y, [div x y] = [x] / [y].
 Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y].
 Parameter spec_quot: forall x y, [quot x y] = [x] ÷ [y].
 Parameter spec_rem: forall x y, [rem x y] = Z.rem [x] [y].
 Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b].
 Parameter spec_sgn : forall x, [sgn x] = Z.sgn [x].
 Parameter spec_abs : forall x, [abs x] = Z.abs [x].
 Parameter spec_even : forall x, even x = Z.even [x].
 Parameter spec_odd : forall x, odd x = Z.odd [x].
 Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p].
 Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p].
 Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p].
 Parameter spec_land: forall x y, [land x y] = Z.land [x] [y].
 Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
 Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
 Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
 Parameter spec_div2: forall x, [div2 x] = Z.div2 [x].

End ZType.

Module Type ZType_Notation (Import Z:ZType).
 Notation "[ x ]" := (to_Z x).
 Infix "=="  := eq (at level 70).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "2" := two.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Infix "^" := pow.
 Notation "- x" := (opp x).
 Infix "<=" := le.
 Infix "<" := lt.
End ZType_Notation.

Module Type ZType' := ZType <+ ZType_Notation.


Set Warnings "-notation-overridden".

Require Import Program.
From Coq Require Import ssreflect.
From mathcomp.ssreflect Require Import ssrnat ssrbool bigop fintype finfun eqtype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Export Category.Theory.
Require Import Category.Lib.
Require Export Category.Theory.Category.
Require Import Category.Structure.Monoidal.
Require Import Category.Structure.Monoidal.Symmetric.
Require Export CatQM.Dagger.
Require Import CatQM.Monoidal.
Require Import CatQM.Biproduct.
Require Import CatQM.Superposition.
Require Import CatQM.Zero.

Section BigOps.
Context {C : Category}.
Context `{_ : @Monoidal C} `{S' : @Superposition C} `{Z : @Zero C} `{_ : @Biproduct C S' Z}.

Lemma ordinal_equality {k a : nat} (p q : ltn a (S k)) : (Ordinal p) = (Ordinal q).
Proof. by apply/val_inj. Defined.

Lemma ord0_fin1 (k : ordinal 1) : k = ord0.
Proof.
  destruct k; unfold ord0.
  have Q : m = 0%N by move: m i; case.
  move: i; rewrite Q.
  symmetry; by apply ordinal_equality.
Qed.

Definition ord_widen_succ (a : nat) (b : ordinal a) : ordinal (S a).
Proof. case: b => m i; construct. exact (S m). exact i. Defined.

Program Fixpoint biprodN' {n : nat} (X : ordinal (n.+1) -> obj[C]) : obj[C] :=
    match n with
    | O => (X ord0)
    | S n' => (X ord0) ⨁ (@biprodN' n' (fun k => X (ord_widen_succ k)))
    end.

Definition biprodN (n : nat) (X : obj[C]) := @biprodN' n (fun _ => X).

Lemma biprodN_succ {X : obj[C]} {n : nat} : (X ⨁ (biprodN n X))%object = (biprodN (S n) X).
Proof. reflexivity. Qed.

Lemma biprod0 {X : obj[C]} : X = biprodN 0 X.
Proof. reflexivity. Qed.

Lemma biprod0' {X : ordinal 1 -> obj[C]} : (X ord0) = biprodN' (n:=0) X.
Proof. reflexivity. Qed.

Fixpoint inj_n' {maxn : nat} {X : ordinal (maxn.+1) -> obj[C]} {n : ordinal (maxn.+1)} : (X n) ~> biprodN' (n:=maxn) X.
Proof.
    move: X n.
    case: maxn => [X n //=|maxn X].
    - case: n => [m H']; rewrite (ord0_fin1 (Ordinal H')); exact id.
    - case; case => [i //=|n i].
      + rewrite /ord0 (ordinal_equality i (ltn0Sn (S maxn))); exact inj_l.
      + simpl; have P : (ltn n (S maxn)) by [].
        have -> : (Ordinal i) = (ord_widen_succ (Ordinal P)) by rewrite /ord_widen_succ ordinal_equality.
        exact (inj_r ∘ (@inj_n' maxn (fun k => X (ord_widen_succ k)) (Ordinal P))).
Defined.
Definition inj_n {maxn : nat} {X} := @inj_n' maxn (fun _ => X).

Fixpoint proj_n' {maxn : nat} {X : ordinal (maxn.+1) -> obj[C]} {n : ordinal (maxn.+1)} : biprodN' (n:=maxn) X ~> (X n).
Proof.
    move: X n.
    case: maxn => [X n //=|maxn X].
    - case: n => [m H']; rewrite (ord0_fin1 (Ordinal H')); exact id.
    - case; case => [i //=|n i].
      + rewrite /ord0 (ordinal_equality i (ltn0Sn (S maxn))); exact proj_l.
      + simpl; have P : (ltn n (S maxn)) by [].
        have -> : (Ordinal i) = (ord_widen_succ (Ordinal P)) by rewrite /ord_widen_succ ordinal_equality.
        exact ((@proj_n' maxn (fun k => X (ord_widen_succ k)) (Ordinal P)) ∘ proj_r).
Defined.
Definition proj_n {maxn : nat} {X} := @proj_n' maxn (fun _ => X).

Ltac done := cat_simpl.

Definition bigsum {maxn : nat} {A : obj[C]} {B : forall x : (ordinal (maxn.+1)), obj[C]}
    (f : forall n : (ordinal (maxn.+1)), A ~> (@B n)) : A ~> biprodN' B :=
    \big[sum/through_zero]_ (i < (maxn.+1)) (inj_n' ∘ (f i)).
End BigOps.


From VST Require Import floyd.proofauto floyd.sublist.
From VSTArrayProgs Require Import binary_search_theory binary_search.

Ltac do_compute_expr_warning::=idtac.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition binary_search_spec :=
 DECLARE _binary_search
  WITH a: val, sh : share, contents : list Z, len : Z, key : Z
  PRE [ tptr tint, tint, tint ]
    PROP (readable_share sh;
          Zlength contents <= Int.max_signed;
          len = Zlength contents;
          Int.min_signed <= key <= Int.max_signed;
          Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents;
          sorted contents)
    PARAMS (a; Vint (Int.repr len); Vint (Int.repr key))
    SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
     PROP (if in_dec Z.eq_dec key contents then Znth i contents = key
           else insertion_point (-i - 1) contents key 0 (Zlength contents))
     RETURN (Vint (Int.repr i))
     SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition binary_search_while_spec a sh contents len key :=
EX low : Z, EX high : Z,
 PROP (0 <= low <= len;
  Int.min_signed <= high < len;
  In key contents -> In key (sublist low (high + 1) contents);
  ~ In key contents ->
   Forall (fun x => x < key) (sublist 0 low contents) /\
   Forall (fun x => key < x) (sublist (high + 1) len contents))
 LOCAL (temp _a a; temp _key (Vint (Int.repr key));
        temp _low (Vint (Int.repr low)); temp _high (Vint (Int.repr high)))
 SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs := ltac:(with_library prog [binary_search_spec; main_spec]).

Lemma body_binary_search: semax_body Vprog Gprog f_binary_search binary_search_spec.
Proof.
start_function.
forward.
forward.
forward_while (binary_search_while_spec a sh contents len key).
- entailer!.
  Exists 0; Exists (Zlength contents - 1).
  entailer!.
  split; intros; [|split]; autorewrite with sublist in *.
  * assumption.
  * apply Forall_nil.
  * apply Forall_nil.
- entailer!.
- assert (Hle: low <= high) by lia.
  pose proof (mean_le _ _  Hle) as Hdle.
  assert (Heq: Int.signed (Int.divs (Int.repr (high - low)) (Int.repr 2)) = (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia; [rewrite Zquot.Zquot_Zdiv_pos by lia; reflexivity|].
    rewrite !Int.signed_repr; try rep_lia.
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rep_lia.
  assert (Heq': Int.unsigned (Int.add (Int.repr low) (Int.divs (Int.repr (high - low)) (Int.repr 2))) = low + (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia.
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rewrite add_repr.
    rewrite !Int.unsigned_repr; auto.
    rep_lia.
  assert (Heq'': Int.signed (Int.add (Int.repr low) (Int.divs (Int.repr (high - low)) (Int.repr 2))) = low + (high - low) / 2).
    unfold Int.divs; rewrite !Int.signed_repr; try rep_lia.
    rewrite add_repr.
    rewrite !Int.signed_repr; [rewrite Zquot.Zquot_Zdiv_pos by lia; reflexivity|].
    rewrite Zquot.Zquot_Zdiv_pos by lia.
    rep_lia.
  forward.
  * entailer!.
    destruct H0.
    unfold Int.mone in H11.
    apply repr_inj_signed in H11; [congruence|unfold repable_signed|unfold repable_signed]; rep_lia.
  * forward.
    forward_if.
    + forward.
      entailer!.
      Exists ((low + ((high - low)/2)) + 1,high).
      entailer!.
      split; [lia|]; rewrite !Int.signed_repr in H8; [rewrite Heq' in H8|rewrite Heq']; [split;[|split]|].
      -- intro H0; specialize (H6 H0).
         eapply In_sorted_gt; eauto; lia.
      -- intro H0; specialize (H7 H0).
         destruct H7 as [Hlow Hhigh].
         split; [|assumption].
         apply Forall_forall; intros.
         eapply Znth_lt_sublist_lt; eauto; lia.
      -- f_equal.
         unfold Int.add at 1.
         f_equal.
         rewrite <- Heq'.
         rewrite !Int.unsigned_repr; rep_lia.
      -- assert (Hin: In (Znth (low + (high - low) / 2) contents) contents) by (eapply Znth_In; eauto; lia).
         pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
         simpl in HFA.
         destruct HFA as [HFA1 HFA2].
         apply (HFA1 H2 _ Hin).
    + forward_if.
      -- forward.
         entailer!.
         Exists (low,(low + ((high - low)/2)) - 1).
         entailer!.
         autorewrite with sublist in *.
         split; [rep_lia|]; rewrite !Int.signed_repr in H9; [rewrite Heq' in H9|rewrite Heq']; [split;[|split]|].
         ** intro H0.
            specialize (H6 H0).
            eapply (In_sorted_lt _ _ _ _ _ (high + 1)); eauto; lia.
         ** intro H0.
            specialize (H7 H0).
            destruct H7 as [Hl Hh].
            split; [assumption|].
            apply Forall_forall; intros.
            revert H7.
            apply Znth_gt_sublist_gt; auto.
            lia.
         ** f_equal.
            unfold Int.sub.
            f_equal.
            rewrite !Int.unsigned_repr; [|rep_lia].
            rewrite Heq'; reflexivity.
         ** assert (Hin: In (Znth (low + (high - low) / 2) contents) contents) by (eapply Znth_In; eauto; lia).
            pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
            simpl in HFA.
            destruct HFA as [HFA1 HFA2].
            apply (HFA1 H2 _ Hin).
      -- forward.
         Exists (low + ((high - low) / 2)).
         entailer!.
         revert H8 H9.
         rewrite Heq'.
         rewrite !Int.signed_repr.
         ** intros H8 H9.
           assert (Hkey: Znth (low + (high - low) / 2) contents = key) by lia.
           case (in_dec _ _); intro; [split|]; auto.
           ++ f_equal.
             unfold Int.add.
             f_equal.
             rewrite !Int.unsigned_repr; [|rep_lia].
             unfold Int.divs; rewrite !Int.signed_repr; try rep_lia.
             rewrite !Int.unsigned_repr; rewrite Zquot.Zquot_Zdiv_pos; rep_lia.
           ++ contradict n.
             assert (Hin: In (Znth (low + (high - low) / 2) contents) contents) by (eapply Znth_In; eauto; lia).
             rewrite Hkey in Hin; assumption.
         ** assert (Hin: In (Znth (low + (high - low) / 2) contents) contents) by (eapply Znth_In; eauto; lia).
            pose proof (Forall_forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) contents) as HFA.
            simpl in HFA.
            destruct HFA as [HFA1 HFA2].
            apply (HFA1 H2 _ Hin).
- forward.
  + entailer!.
    set (j := Int.signed Int.zero) in *; compute in j; subst j.
    rep_lia.
  + Exists (-low - 1).
    entailer!.
    case (in_dec _ _); intro.
    * specialize (H6 i).
      contradict H6.
      assert (Hlow: high + 1 <= low) by lia.
      rewrite sublist_nil1; auto.
    * unfold insertion_point.
      assert (Hl: - (- low - 1) - 1 = low) by lia.
      rewrite Hl.
      specialize (H7 n).
      destruct H7.
      split; [lia|].
      split; auto.
      assert (Hle: high + 1 <= low) by lia.
      eapply Forall_sublist_overlap; eauto.
Qed.

Definition four_contents := [1; 2; 3; 4].

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  forward_call (gv _four,Ews,four_contents,4,3).
  { split. auto.
    change (Zlength four_contents) with 4.
    repeat constructor; computable.
  }
  Intro r; forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_binary_search.
semax_func_cons body_main.
Qed.


Require Import Strings.String.
Require Import List.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* Errors & Conversion -------------------------------------------------- *)

Inductive Var := a | b | c.
Scheme Equality for Var.

(* Tip suplimentar de date care pe langa contructorul de tip numere naturale (nat), mai contine si o valoare de tip eroare *)
Inductive ErrorNat :=
 | errnat : ErrorNat
 | num : nat -> ErrorNat.
Definition EnvNat := Var -> ErrorNat.
Coercion num: nat >-> ErrorNat.

Inductive ErrorBool :=
| errbool : ErrorBool
| btrueE : ErrorBool
| bfalseE : ErrorBool
| boolean : bool -> ErrorBool.
Coercion boolean: bool >-> ErrorBool.

Definition bTObool(b : bool) : ErrorBool :=
match b with
| true => btrueE
| false => bfalseE
end.

Inductive ErrorString :=
| errstringing : ErrorString
| str : string -> ErrorString.
Coercion str: string >-> ErrorString.

Inductive ErrorAddr :=
| erraddr : ErrorAddr
| addr : string -> ErrorAddr.
Coercion addr : string >-> ErrorAddr.

Inductive ErrorVec :=
| errvec : ErrorVec
| natvec : list ErrorNat -> ErrorVec
| boolvec : list ErrorBool -> ErrorVec
| strvec : list ErrorString -> ErrorVec
| vect : string -> ErrorVec.

(* -------------------------------------------------- Errors & Conversion *)

(* Data types & Expresions -------------------------------------------------- *)

(* Definirea unui tip de date pentru expresi aritmetrice *)
Inductive AExp :=
| anum : nat -> AExp
| avar : ErrorNat -> AExp
| anat : ErrorNat -> AExp
| aadd : AExp -> AExp -> AExp
| asub : AExp -> AExp -> AExp
| amul : AExp -> AExp -> AExp
| adiv : AExp -> AExp -> AExp
| amod : AExp -> AExp -> AExp
| natTOvec : string -> nat -> AExp
| boolTOnat : ErrorBool -> AExp.

Coercion anum : nat >-> AExp.
Coercion avar : ErrorNat >-> AExp.

Notation "A +' B" := (aadd A B) (at level 60, right associativity).
Notation "A -' B" := (asub A B) (at level 60, right associativity).
Notation "A *' B" := (amul A B) (at level 58, left associativity).
Notation "A /' B" := (adiv A B) (at level 58, left associativity).
Notation "A %' B" := (amod A B) (at level 58, left associativity).

(* Definirea unui tip de date pentru expresi booleene *)
Inductive BExp :=
| bvar : ErrorBool -> BExp
| bbool : ErrorBool -> BExp
| btrue : BExp
| bfalse : BExp
| bnot : BExp -> BExp
| bor : BExp -> BExp -> BExp
| band : BExp -> BExp -> BExp
| bless : AExp -> AExp -> BExp
| blessequal : AExp -> AExp -> BExp
| bequal : AExp -> AExp -> BExp
| bnotequal : AExp -> AExp -> BExp
| bmore : AExp -> AExp -> BExp
| bmoreequal : AExp -> AExp -> BExp
| boolTOvec : string -> nat -> BExp
| natTObool : ErrorNat -> BExp.

Notation "A <' B" := (bless A B) (at level 70).
Notation "A <=' B" := (blessequal A B) (at level 70).
Notation "A =' B" := (bequal A B) (at level 70).
Notation "A !=' B" := (bnotequal A B) (at level 70).
Notation "A >' B" := (bmore A B) (at level 70).
Notation "A >=' B" := (bmoreequal A B) (at level 70).

Notation "!" := bnot (at level 75).  (* Se poate folosi si : Notation "! A" := (bnot A) (at level 75) *)
Infix "or'" := bor (at level 80).    (* Se poate folosi si : Notation "A 'or'' B" := (bor A B) (at level 80). sau Se poate folosi si : Infix "||" := bor (at level 80). dar este luat deja de Coq la nivelul 50 *)
Infix "and'" := band (at level 80).  (* Se poate folosi si : Notation "A 'and'' B" := (band A B) (at level 80). sau Se poate folosi si : Infix "&&" := band (at level 80). dar este luat deja de Coq la nivelul 40*)

(* Definirea unui tip de date pentru cateva instructiuni *)
Require Import String.
Inductive Stmt :=
| assigmanment : string -> AExp -> Stmt
| errstmt : Stmt
| sequence : Stmt -> Stmt -> Stmt
| iforelse : BExp -> Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
| valTOvec : string -> nat -> Stmt.

Notation "X ::= A" := (assigmanment X A) (at level 80).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 98, left associativity).
Notation "'if' ( A ) 'else' (  B )":= (iforelse A B)(at level 85).
Notation "'while' ( A ) (  B )":= (while A B)(at level 85).
(* Daca nu sunt puse parantezele de la ( A ) ( B ), va da eroare constructor operator level 200*)

(* Manipulare de stringuri *)
Inductive SExp :=
| svar : string -> SExp
| scat : SExp -> SExp -> SExp
| scpy : SExp -> SExp -> SExp
| stringTOvec : string -> nat -> SExp.

Notation "S <concat> T" := (scat S T) (at level 55).
Notation "S <cpy> T" := (scpy S T) (at level 55).

(*
| slen : SExp -> AExp
| scmp : SExp -> SExp -> Axp
| schr : SExp -> SExp -> SExp (* Pointer *)
| sstr : SExp -> SExp -> SExp (* Pointer *).

Notation "S <len>" := (slen S ) (at level 55).
Notation "S <cmp> T" := (scmp S T) (at level 55).
Notation "S <chr> T" := (schr S T (at level 55).
Notation "S <str> T" := (scat S T) (at level 55).
*)

Inductive ValueV :=
| defaultv : ValueV
| decnat : string -> ValueV
| decbool : string -> ValueV
| decstring : string -> ValueV
| decstmt : Stmt -> ValueV.

Inductive Addr :=
| addrvar : string -> Addr.

Inductive Exp :=
| EAExp : AExp -> Exp
| EBExp : BExp -> Exp
| ESExp : SExp -> Exp.

Inductive Edec :=
| Enat : ErrorNat -> Edec
| Ebool : ErrorBool -> Edec
| Estring : ErrorString -> Edec.

(* -------------------------------------------------- Data types & Expresions *)

(* Other convertions & Error cases -------------------------------------------------- *)

Definition natCONVbool (x : ErrorNat) : ErrorBool :=
match x with
| num 0 => bfalseE
| errnat => errbool
| _ => btrueE
end.

Definition boolCONVnat (x : ErrorBool) : ErrorNat :=
match x with
| btrueE => 1
| _ => 0
end.

(* Tipurile de variabile de la errori / default *)
Inductive NatE :=
| erronat : NatE
| valnat : nat -> NatE.

Inductive BoolE :=
| errobool : BoolE
| truebool : BoolE
| falsebool : BoolE.

Inductive StringE :=
| errostring : StringE
| valstring : string -> StringE.

Inductive AddrE :=
| erroaddr : AddrE
| valaddr : string -> AddrE.

Inductive VecE :=
| errovec : VecE
| erronats : list NatE -> VecE
| errobools : list BoolE -> VecE
| errostrings : list StringE -> VecE.

(* -------------------------------------------------- Other convertions & Cases *)

(* Declarations & Notations -------------------------------------------------- *)

Inductive Dec :=
| Decint : string -> Dec
| Decintexp : string -> AExp -> Dec
| Decintvec : string -> nat -> Dec
| DecintvecI : string -> nat -> list NatE -> Dec
| Decintmat : string -> nat -> nat -> Dec
| Decintpoint : string -> Dec
| DecintpointI : string -> AddrE -> Dec
| Decbool : string -> Dec
| Decboolexp : string -> BExp -> Dec
| Decboolvec : string -> nat -> Dec
| DecboolvecI : string -> nat -> list BoolE -> Dec
| Decboolmat : string -> nat -> nat -> Dec
| Decboolpoint : string -> Dec
| DecboolpointI : string -> AddrE -> Dec
| Decstring : string -> Dec
| Decstringexp : string -> SExp -> Dec
| Decstringvec : string -> nat -> Dec
| DecstringvecI : string -> nat -> list StringE -> Dec
| Decstringmat : string -> nat -> nat -> Dec
| Decstringpoint : string -> Dec
| DecstringpointI : string -> AddrE -> Dec
| Decstruct: string -> list Dec -> Dec.

Notation "'int' X " := (Decint AExp)(at level 50).
Notation "'int' X ~> V" := (Decintexp AExp)(at level 50).
Notation "'int' X ~> V [ nr ]" := (Decintvec V nr)(at level 50).
Notation "'int' X ~> V [ nu ] [ nt ]" := (Decintmat V nu nt)(at level 50).
Notation "'int*' X ~> P" := (Decintpoint AExp)(at level 50).
Notation "'bool' X " := (Decbool BExp)(at level 50).
Notation "'bool' X ~> V" := (Decboolexp BExp)(at level 50).
Notation "'bool*' X ~> P" := (Decboolpoint BExp)(at level 50).
Notation "'bool' X ~> V [ nr ]" := (Decboolvec V nr)(at level 50).
Notation "'bool' X ~> V [ nu ] [ nt ]" := (Decboolmat V nu nt)(at level 50).
Notation "'char' X " := (Decstring SExp)(at level 50).
Notation "'char' X ~> V" := (Decstringexp SExp)(at level 50).
Notation "'char*' X ~> P" := (Decstringpoint SExp)(at level 50).
Notation "'char' X ~> V [ nr ]" := (Decstringvec V nr)(at level 50).
Notation "'char' X ~> V [ nu ] [ nt ]" := (Decstringmat V nu nt)(at level 50).
Notation "'struct'' S '{'' D1 ; D2 ; .. ; Dn '}''" := (Decstruct S (cons D1 ( cons D2 .. (cons Dn nil) .. ) ) )(at level 50).
Notation "(int) X" := (boolTOnat X) (at level 50).
Notation "(bool) Y" := (natTObool Y) (at level 50).

(*
| DecmatintI : string ~ nat ~ nat ~ list NatE ~ list NatE ~ Dec
| DecmatboolI : string ~ nat ~ nat ~ list BoolE ~ list BoolE ~ Dec
| DecmatstringI : string ~ nat ~ nat ~ list StringE ~ list StringE ~ Dec

Notation "'int*' A ~ AD" := (DecpointintI A AD) (at level 50).
Notation "'int' V [ nr ] ~ '{'' E1 , E2 , .. , En '}''" := (DecvectintI V nr (cons E1 ( cons E2 .. (cons En nil) .. ) ) ) (at level 50).
Notation "'bool*' B ~ AD" := (DecpointboolI B AD) (at level 50).
Notation "'bool' V [ nr ] ~ '{'' E1 , E2 , .. , En '}''" := (DecvectboolI V nr (cons E1 ( cons E2 .. (cons En nil) .. ) ) ) (at level 50).
Notation "'string*' S ~ AD" := (DecpointstringI S AD) (at level 50).
Notation "'string' V [ nr ]" := ( Decvectstring V nr) (at level 50).
Notation "'string' V [ nr ] ~ '{'' E1 , E2 , .. , En '}''" := (DecvectstringI V nr (cons E1 ( cons E2 .. (cons En nil) .. ) ) ) (at level 50).
Notation "'string' V [ nr ][ nt ]" := ( Decvectstring V nr nt) (at level 50).
*)

(* -------------------------------------------------- Declarations & Notations *)

(* Memory mapping & Cases -------------------------------------------------- *)

(*  La declarare de variabile ar trebui sa avem un tip general de date, o colectie de valori pe care le adaug eu *)
Inductive Value :=
(* Valoare nu este declarata / assigmanata *)
| default : Value
| errunass : Value
| errundec : Value
| errunini : Value
| nums : ErrorNat -> Value
| bools : ErrorBool -> Value
| strs : ErrorString -> Value
| addrs : ErrorAddr -> Value
| param : list Dec -> Stmt -> Value
| paramS : string -> Stmt -> Value
| vecs : ErrorVec -> Value
| NatP : ErrorNat -> Value
| BoolP : ErrorBool -> Value
| StringP : ErrorString -> Value.

Definition NatV (x : Value) : ErrorNat :=
match x with
| nums n => n
| _ => errnat
end.
Coercion nums : ErrorNat >-> Value.

Definition BoolV (x : Value) : ErrorBool :=
match x with
| bools n => n
| _ => errbool
end.
Coercion bools : ErrorBool >-> Value.

Definition StringV (x : Value) : ErrorString :=
match x with
| strs n => n
| _ => errstringing
end.
Coercion strs : ErrorString >-> Value.

Definition AddrV (x : Value) : ErrorAddr :=
match x with
| addrs n => n
| _ => erraddr
end.
Coercion addrs : ErrorAddr >-> Value.

Inductive Memap :=
| defmem : Memap
| mem: nat -> Memap.

Definition Env := string -> Memap.
Definition Memory := Memap -> Value.

Definition env : Env :=
fun x => defmem.

(* -------------------------------------------------- Memory mapping & Cases *)

(* Environments & Operations -------------------------------------------------- *)

Definition EnvS := string -> Value.

Definition envS : EnvS := fun x => default.

Definition UpdateV (envS : EnvS) (s : string) (x : Value) : EnvS :=
  fun t =>
    if (string_dec t s)
    then x
    else (envS t).

Definition Update (envS : EnvS) (s : string) : EnvS := (UpdateV envS s errunini).
Definition envS0 := fun( var : string ) => errundec. Check envS0.
Definition envS1 := (UpdateV envS0 "n" "XXXXX").
Definition envS2 := (Update envS1 "s").

 Compute envS1 "n".

Definition natG (x : Value) : ErrorNat :=
match x with
| num n => n
| _ => errnat
end.

Definition boolG (x : Value) : ErrorBool :=
match x with
| boolean n => n
| _ => errbool
end.

Definition strG (x : Value) : ErrorString :=
match x with
|  str n => n
| _ => errstringing
end.

Definition addrG (x : Value) : ErrorAddr :=
match x with
| addr n => n
| _ => erraddr
end.

Fixpoint NatvecG (l : list ErrorNat) (n : nat) : ErrorNat :=
match n, l with
| O, x::l1 => x
| S m, nil => errnat
| S m, x :: l2 => (NatvecG l2 m)
| _, _ => errnat
end.

Fixpoint BoolvecG (l : list ErrorBool) (n : nat) : ErrorBool :=
match n, l with
| O, x::l1 => x
| S m, nil => errbool
| S m, x::l2 => (BoolvecG l2 m)
| _, _ => errbool
end.

Fixpoint StrvecG (l : list ErrorString) (n : nat) : ErrorString :=
match n, l with
| O, x::l1 => x
| S m, nil => errstringing
| S m, x::l2 => (StrvecG l2 m)
| _, _ => errstringing
end.

(* Operatii aritmetrice *)
Definition Natadd (a b : ErrorNat) : ErrorNat :=
match a, b with
| errnat, _ => errnat
| _ ,errnat => errnat
| num n, num m => num (n + m)
end.

Definition Natsub (a b : ErrorNat) : ErrorNat :=
match a, b with
| errnat, _ => errnat
| _ ,errnat => errnat
| num n, num m => n - m
end.

Definition Natmul (a b : ErrorNat) : ErrorNat :=
match a, b with
| errnat, _ => errnat
| _ ,errnat => errnat
| num n, num m => n * m
end.

Definition Natdiv (a b : ErrorNat) : ErrorNat :=
match a, b with
| errnat, _ => errnat
| _ ,errnat => errnat
| num n, num m => Nat.div n m
end.

Definition Natmod (a b : ErrorNat) : ErrorNat :=
match a, b with
| errnat, _ => errnat
| _ ,errnat => errnat
| num n, num m => Nat.modulo n m
end.

Definition Boolless(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (Nat.ltb n m)
end.

Definition Boollessequal(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (Nat.leb n m)
end.

Definition Boolequal(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (Nat.eqb n m)
end.

Definition Boolnotequal(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (negb (Nat.eqb n m))
end.

Definition Boolmore(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (Nat.ltb m n) (* sau : (negb (Nat.leb n m)) *)
end.

Definition Boolmoreequal(a b : ErrorNat) : ErrorBool :=
match a, b with
| _, errnat => errbool
| errnat, _ => errbool
| num n, num m => bTObool (Nat.leb m n) (* sau : (negb (Nat.ltb n m)) *)
end.

Fixpoint UpdateVs ( sigma : EnvS ) (p : list Dec) ( l : list Value ) : EnvS :=
match l with
| nil => sigma
| x::l' => match x, p with
           | NatP n, y::l'' => match y with
                                    | Decint nt => UpdateVs (UpdateV sigma nt n) l'' l'
                                    | Decbool bt => UpdateVs (UpdateV sigma bt n) l'' l'
                                    | Decstring st => UpdateVs (UpdateV sigma st n) l'' l'
                                    | _ => sigma
                                    end
           | _, _ => sigma
           end
end.

Definition call (sigma : EnvS ) ( v : string) ( x : Value ) (l' : Value) : EnvS :=
match x with
| paramS l st => UpdateV sigma l l'
| _ => sigma
end.

Definition get_st (x : Value) : Stmt :=
match x with
| paramS l st => st
| _ => errstmt
end.

(* -------------------------------------------------- Environments & Operations *)

(*

Reserved Notation "A =[ S ]=> N" (at level 60).
Inductive aeval : AExp -> EnvS -> ErrorNat -> Prop :=
| constE : forall n sigma, anat n =[ sigma ]=> n

| avarE : forall n sigma, avar n =[ sigma ]=> (natG (sigma n))

| addE : forall a b i j sigma n,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    n =  Natadd i j ->
    a +' b =[sigma]=> n

| subE : forall a b i j sigma n,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    n =  Natsub i j ->
    a -' b =[sigma]=> n

| mulE : forall a b i j sigma n,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    n = Natmul i j ->
    a *' b =[sigma]=> n

| divE : forall a b i j sigma n,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    n =  Natdiv i j ->
    a /' b =[sigma]=> n

| modE : forall a b i j sigma n,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    n =  Natmod i j ->
    a %' b =[sigma]=> n
| boolTOnatE : forall c sigma, a_bool_to_nat c =[ sigma ]=> conv_bool_nat c

| e_aget_vect_valE : forall v1 v2 n sigma,
  v2 = (sigma v1) ->
  a_get_vect_val v1 n =[ sigma ]=> natG (get_element v2 n)
where "a =[ sigma ]=> n" := (aeval a sigma n).

Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive beval : Bexp -> EnvS -> ErrorBool -> Prop :=
| trueE : forall sigma, btrueE ={ sigma }=> btrueE
| falseE : forall sigma, bfalseE ={ sigma }=> bfalseE

| bvarE : forall v sigma, bvar v ={ sigma }=> boolG (sigma v)

| lessE : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = less_than (natG i) (natG j) ->
    a <' b ={ sigma }=> r

| lessequalE : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = less_equal_than (natG i) (natG j) ->
    a <=' b ={ sigma }=> r

| equal : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = equality i j ->
    a ==' b ={ sigma }=> r

| notequal : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = different i j ->
    a ==' b ={ sigma }=> r

| greaterE : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = greater_than (natG i) (natG j) ->
    a <' b ={ sigma }=> r

| graterequalE : forall a b i j sigma r,
    a =[ sigma ]=> i ->
    b =[ sigma ]=> j ->
    r = less_equal_than i j->
    a <=' b ={ sigma }=> r

| nottrue : forall r sigma,
    r ={ sigma }=> trueE ->
    !'r ={ sigma }=> falseE

| notfalse : forall r sigma,
    r ={ sigma }=> falseE ->
    !'r ={ sigma }=> trueE

| andtrue : forall u t sigma t,
    u ={ sigma }=> trueE ->
    t ={ sigma }=> t ->
    u &&' t ={ sigma }=> t
| andfalse : forall u t sigma,
    u ={ sigma }=> falseE ->
    u &&' t ={ sigma }=> falseE

| ortrue : forall u t sigma,
    u ={ sigma }=> trueE ->
    u ||' t ={ sigma }=> trueE

| orfalse : forall u t sigma t,
    u ={ sigma }=> falseE ->
    t ={ sigma }=> t ->
    u ||' t ={ sigma }=> t

| natTOboolE : forall a sigma,  natTOboolB a ={ sigma }=> natCONVbool a

| boolTOvecE : forall v1 v2 n sigma,
  v2 = (sigma v1) ->
 boolTOvec v1 n ={ sigma }=> boolE (get_element v2 n)

where "B ={ S }=> B'" := (beval B S B').

Reserved Notation "B  =< S >=> B'" (at level 80).
Inductive streval : STRexp -> Env -> String -> Prop :=
| svar : forall v sigma, s_var v =< sigma >=> strG (sigma v)
| str_const : forall v sigma, s_str v =< sigma >=> v
| concat : forall s1 s2 i j sigma s,
    s1 =< sigma >=> i->
    s2 =< sigma >=> j ->
    s = concatenate i j ->
    s1 <--> s2 =< sigma >=> s

| e_sget_vect_val : forall v1 v2 n sigma,
  v2 = (sigma v1) ->
  s_get_vect_val v1 n =< sigma >=> strG (get_element v2 n)

where "B =< S >=> B'" := (streval B S B').

Definition conca(s t : ErrorString) : ErrorString :=
match s, t with
  |_, errstring => errstring
  |errstring, _ => errstring
  |str s, str t => str (s ++ t)
end.

*)


From Coq Require Import
  List.
From DEZ Require Export
  Init.
From DEZ.Is Require Import
  Setoid.
From DEZ.ShouldHave Require Import
  EquivalenceNotations.

Section Context.

Context {A : Type} `{is_setoid : IsSetoid A}.

Definition option_eqv (xs ys : option A) : Prop :=
  match xs, ys with
  | Some x, Some y => x == y
  | None, None => True
  | _, _ => False
  end.

Global Instance option_has_eqv : HasEqv (option A) := option_eqv.

Global Instance option_is_reflexive : IsReflexive option_eqv := {}.
Proof. intros [x |]. hnf. reflexivity. reflexivity. Qed.

Global Instance option_is_symmetric : IsSymmetric option_eqv := {}.
Proof. intros [x |] [y |] H; hnf. symmetry; auto.
  inversion H. inversion H. constructor. Qed.

Global Instance option_is_transitive : IsTransitive option_eqv := {}.
Proof. intros [x |] [y |] [z |] Hxy Hyz; hnf. all: try etransitivity; eauto.
  all: inversion Hxy || inversion Hyz. Unshelve. apply x. Qed.

Global Instance option_is_setoid : IsSetoid option_eqv := {}.

End Context.


Require Import Undecidability.TM.Util.TM_facts.
Require Import Undecidability.L.Prelim.LoopSum.

Definition loopSumM {Σ : finType} {n} {M : TM Σ n} (c : mconfig Σ (state M) n) : nat -> option (mconfig Σ (state M) n) :=
  fun i =>
  loopSum i (fun cfg => if haltConf cfg then inr cfg else inl (step cfg)) c.

Lemma loopSumM_loopM_iff (Σ : finType) n (M : TM Σ n) c1 c2 i :
  loopM (M := M) c1 i = Some c2 <-> loopSumM (M := M) c1 (S i) = Some c2.
Proof.
  induction i in c1, c2 |- *; cbn.
  - cbn. destruct haltConf; reflexivity.
  - destruct haltConf. 1: reflexivity.
    rewrite IHi. reflexivity.
Qed.

Lemma TM_loopsum_iff (Σ : finType) n (M : TM Σ n) q t q' t' :
  TM.eval M q t q' t' <-> exists n, loopSumM (M := M) (mk_mconfig q t) n = Some (mk_mconfig q' t').
Proof.
  rewrite TM_eval_iff.
  setoid_rewrite loopSumM_loopM_iff.
  split; intros [i H]; eauto.
  destruct i. inv H. eauto.
Qed.