(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import ZArith.
Require Import List.
Require Import Arith.
Require Import EquivDec.
Require Import Utils.
Require Import DataRuntime.
Require Import SQLPPRuntime.
Require Import NRAEnvRuntime.
Require Import SQLtoNRAEnv.

Section SQLPPtoNRAEnv.
  Context {fruntime:foreign_runtime}.

(* Translate two expressions and build the binary equality comparison (used as a subroutine for the SPSimpleCase clause) *)
Definition sqlpp_to_nraenv_SPEq sqlpp_to_nraenv (e1 e2:sqlpp_expr) : nraenv
  := NRAEnvBinop OpEqual (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2).

(* Indicates that expected functionality is not yet implemented.  *)
Definition sqlpp_to_nraenv_not_implemented (what : string) : nraenv :=
	NRAEnvConst (dstring ("NRAEnv translation not Implemented: " ++ what)).

(* Central translation function *)
Fixpoint sqlpp_to_nraenv (q:sqlpp) : nraenv :=
  	match q with
	| SPPositive expr
		=> NRAEnvBinop (OpNatBinary NatPlus) (NRAEnvConst (dnat 0)) (sqlpp_to_nraenv expr)
	| SPNegative expr
        => NRAEnvBinop (OpNatBinary NatMinus) (NRAEnvConst (dnat 0)) (sqlpp_to_nraenv expr)
  	| SPExists expr
        => NRAEnvUnop OpNeg (NRAEnvBinop OpLe (NRAEnvUnop OpCount (sqlpp_to_nraenv expr)) (NRAEnvConst (dnat 0)))
  	| SPNot expr
  		=> NRAEnvUnop OpNeg (sqlpp_to_nraenv expr)
 	(* TODO: Our internal data model has null but not 'missing' (unless we add a new convention).  For now, both are translated
	   to null.  Also, we should really be using sum types to get around type problems like comparing a number to null. *)
  	| SPIsNull expr
  	| SPIsMissing expr
  	| SPIsUnknown expr
		=> NRAEnvBinop OpEqual (sqlpp_to_nraenv expr) (NRAEnvConst dunit)
	| SPPlus e1 e2
        => NRAEnvBinop (OpNatBinary NatPlus) (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPMinus  e1 e2
        => NRAEnvBinop (OpNatBinary NatMinus) (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPMult e1 e2
        => NRAEnvBinop (OpNatBinary NatMult) (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPDiv e1 e2
        => NRAEnvBinop (OpNatBinary NatDiv) (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPMod e1 e2
        => NRAEnvBinop (OpNatBinary NatRem) (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPExp e1 e2
		=> sqlpp_to_nraenv_not_implemented "exp operator" (* TODO.  We either need our own binary exponent operator, or we need to
		      program out the logic (convert to floating point, perform operation then convert back depending on the expected type).
		      A possibly adequate "good enough for now" solution would be to define the operation when e1 and e2 are floating point
		      and not otherwise. *)
  	| SPConcat e1 e2
        => NRAEnvBinop OpStringConcat (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPIn e1 e2
        => NRAEnvBinop OpContains (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPEq  e1 e2
  	| SPFuzzyEq e1 e2 (* TODO.  We don't currently have "fuzzy equals" so translating as Eq for now *)
  		=> sqlpp_to_nraenv_SPEq sqlpp_to_nraenv e1 e2
  	| SPNeq  e1 e2
        => NRAEnvUnop OpNeg (NRAEnvBinop OpEqual (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2))
  	| SPLt  e1 e2
  		=> NRAEnvBinop OpLt (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPGt  e1 e2
  		=> NRAEnvBinop OpLt (sqlpp_to_nraenv e2) (sqlpp_to_nraenv e1)
  	| SPLe  e1 e2
  		=> NRAEnvBinop OpLe (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPGe  e1 e2
  		=> NRAEnvBinop OpLe (sqlpp_to_nraenv e2) (sqlpp_to_nraenv e1)
  	| SPLike  e s
  		=> NRAEnvUnop (OpLike s) (sqlpp_to_nraenv e)
  	| SPAnd  e1 e2
  		=> NRAEnvBinop OpAnd (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
  	| SPOr  e1 e2
  		=> NRAEnvBinop OpOr (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e2)
	| SPBetween  e1 e2 e3
  		=> NRAEnvBinop OpAnd (NRAEnvBinop OpLe (sqlpp_to_nraenv e2) (sqlpp_to_nraenv e1))
                         (NRAEnvBinop OpLe (sqlpp_to_nraenv e1) (sqlpp_to_nraenv e3))
	| SPSimpleCase value whenthens deflt
	  =>
           let last := match deflt with
	                   | Some dflt => sqlpp_to_nraenv dflt
	                   | None => NRAEnvConst dunit
	                   end
           in
	   List.fold_right (fun wt acc =>
                              match
                                wt
                              with
                                SPWhenThen whn thn =>
                                nraenv_if (sqlpp_to_nraenv_SPEq sqlpp_to_nraenv whn value) (sqlpp_to_nraenv thn) acc
                              end)
		           last whenthens
	| SPSearchedCase whenthens deflt
		=> let last := match deflt with
	                   | Some dflt => sqlpp_to_nraenv dflt
	                   | None => NRAEnvConst dunit
	                   end
           in
		   List.fold_right (fun wt acc => match wt with SPWhenThen w t => nraenv_if (sqlpp_to_nraenv w) (sqlpp_to_nraenv t) acc end)
		     last whenthens
    (* TODO: deferring translation of quantified expressions until select is translated since some of the infrastructure can be
       reused *)
	| SPSome  _ _
    | SPEvery _ _
    	=> sqlpp_to_nraenv_not_implemented "quantified expressions (SOME | EVERY)"
	| SPDot  expr name
		=> NRAEnvUnop (OpDot name) (sqlpp_to_nraenv expr)
    (* TODO: the index operation has no obvious translation since our internal data model has only bags, not ordered lists.  We could
      implement IndexAny without fixing this since order doesn't matter in a random selection, but we would have to tackle the issue
      of how to achieve randomness in Coq *)
	| SPIndex  _ _
	| SPIndexAny _
    	=> sqlpp_to_nraenv_not_implemented "indexing expressions"
	| SPLiteral d
		=> NRAEnvConst d
	(* TODO: Our internal data model has null but not 'missing' (unless we add a new convention).  For now, both are translated
	   to null *)
  	| SPNull
  	| SPMissing
  		=> NRAEnvConst dunit
	| SPVarRef name
		=> NRAEnvUnop (OpDot name) NRAEnvID
	| SPFunctionCall name args
		=> match name with
		| SPFget_year
		| SPFget_month
		| SPFget_day
		| SPFget_hour
		| SPFget_minute
		| SPFget_second
		| SPFget_millisecond
		| SPFavg
		| SPFmin
		| SPFmax
		| SPFcount
		| SPFsum
		| SPFcoll_avg
		| SPFcoll_min
		| SPFcoll_max
		| SPFcoll_count
		| SPFcoll_sum
		| SPFarray_avg
		| SPFarray_min
		| SPFarray_max
		| SPFarray_count
		| SPFarray_sum
		| SPFsqrt
		| SPFsubstring
		| SPFregexp_contains
		| SPFcontains
		(* TODO: none of these are implemented yet.  The intent is to eventually implement (only) those in the explicit list of
		 well-known built-in functions above. Calls involving names not on the list are screened in the front-end and won't reach
		 this function. *)
    	=> sqlpp_to_nraenv_not_implemented "function call expressions"
    	end
	(* Note: we don't have ordered lists in our data model so the distinction between array and bag isn't obvious.  We construct what our
	  data model calls a bag in both cases.  Because the elements of the constructor can be arbitrary expressions, we have to
	  construct the list programmatically.  Perhaps we should have a special case for when the elements are all constants, in which case
	  the resulting expression can be bag constant.  *)
	| SPArray items
	| SPBag items
		=> List.fold_right (fun expr acc => NRAEnvBinop OpBagUnion (sqlpp_to_nraenv expr) acc) (NRAEnvConst (dcoll nil)) items
	| SPObject items (*Note: we only support objects whose field names are literals. *)
        => List.fold_right (fun (item : (string * sqlpp)) acc => let (name , expr) := item in
			NRAEnvBinop OpRecConcat (NRAEnvUnop (OpRec name) (sqlpp_to_nraenv expr)) acc) (NRAEnvConst (drec nil)) items
	| SPQuery stmt
		=> sqlpp_to_nraenv_not_implemented "select"
	end.

(* External entry point. *)
Definition sqlpp_to_nraenv_top := sqlpp_to_nraenv.

End SQLPPtoNRAEnv.


Require Import Stlc.SpecEvaluation.
Require Import Stlc.SpecTyping.

Lemma can_form_tarr {Γ t τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ ⊢ t : tarr τ₁ τ₂ ⟫) :
  ∃ t₂,
    t = abs τ₁ t₂ ∧
    ⟪ Γ ▻ τ₁ ⊢ t₂ : τ₂ ⟫.
Proof. depind wt; try contradiction; eauto. Qed.

Lemma can_form_tunit {Γ t}
  (v: Value t) (wt: ⟪ Γ ⊢ t : tunit ⟫) :
    t = unit.
Proof. depind wt; try contradiction; eauto. Qed.

Lemma can_form_tbool {Γ t}
  (v: Value t) (wt: ⟪ Γ ⊢ t : tbool ⟫) :
    t = true ∨ t = false.
Proof. depind wt; try contradiction; eauto. Qed.

Lemma can_form_tprod {Γ t τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ ⊢ t : tprod τ₁ τ₂ ⟫) :
  ∃ t₁ t₂,
    t = pair t₁ t₂ ∧
    ⟪ Γ ⊢ t₁ : τ₁ ⟫ ∧
    ⟪ Γ ⊢ t₂ : τ₂ ⟫.
Proof. depind wt; try contradiction; eauto. Qed.

Lemma can_form_tsum {Γ t τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ ⊢ t : tsum τ₁ τ₂ ⟫) :
    (∃ t₁, t = inl t₁ ∧ ⟪  Γ ⊢ t₁ : τ₁ ⟫) ∨
    (∃ t₂, t = inr t₂ ∧ ⟪  Γ ⊢ t₂ : τ₂ ⟫).
Proof. depind wt; try contradiction; eauto. Qed.

Ltac stlcCanForm1 :=
  match goal with
    | [ wt: ⟪ _ ⊢ ?t : tarr _ _ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tarr vt wt); subst; clear wt
    | [ wt: ⟪ _ ⊢ ?t : tunit ⟫, vt: Value ?t |- _ ] =>
      pose proof (can_form_tunit vt wt); subst; clear wt
    | [ wt: ⟪ _ ⊢ ?t : tbool ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tbool vt wt); subst; clear wt
    | [ wt: ⟪ _ ⊢ ?t : tprod _ _ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tprod vt wt) as (? & ? & ? & ? & ?); subst; clear wt
    | [ wt: ⟪ _ ⊢ ?t : tsum _ _ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tsum vt wt) as [[? [? ?]]|[? [? ?]]]; subst; clear wt; simpl in vt
  end.

Ltac stlcCanForm :=
  repeat stlcCanForm1.


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Psatz.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import vars.
Require Import env.
Require Import tactics.
Require Import qualifiers.
Require Import lambda_star.

Require Import NatSets.
Require Import setfacts.
Import NatSet.F.

Import OpeningNotations.
Local Open Scope opening.

Import QualNotations.
Local Open Scope qualifiers.

(* ### Infrastructure for examples file ### *)

(* iterating over each hypothesis once, inspired by https://stackoverflow.com/a/46536938: *)
(* marker for iterating over hypotheses *)
Inductive ltac_Mark : Type :=
| ltac_mark : ltac_Mark.

(* apply tac over all the premises in the goal until the marker*)
Ltac repeat_until_mark tac :=
  lazymatch goal with
  | [ |- ltac_Mark -> _ ] => intros _
  | [ |- _ ] => tac (); repeat_until_mark tac
  end.

(* apply tac on each hypothesis exactly once *)
Ltac for_each_hyp tac :=
  (* prepend the marker to the goal *)
  generalize (ltac_mark : ltac_Mark);
  repeat match goal with (* move all hypotheses from the context to the goal *)
  | [ H : _ |- _ ] => revert H
  end;
  (* successively move each hypothesis back into the context, applying tac on the way *)
  repeat_until_mark ltac:(fun _ => lazymatch goal with
                                   | [ |- ?F -> _ ] => intro; tac F
                                   | _ => intro
                                   end).

(* if an encountered hypothesis is a closed_qual, then invert it *)
Ltac try_invert_closed_qual F :=
  match F with
  | closed_qual _ _ _ _ =>
    match goal with
    | [ H : F |- _ ] => inversion H; subst
    end
  | _ => idtac
  end.

(* invert all the closed_qual hypotheses, exposing the bounds *)
Ltac closed_qual_invert := for_each_hyp try_invert_closed_qual.

Ltac set_simpl :=
  match goal with
  | [ |- context[union {}N ?s] ] => rewrite (@empty_union_left s); try set_simpl
  | [ |- context[union ?s {}N] ] => rewrite (@empty_union_right s); try set_simpl
  | [ H :  context[union {}N ?s] |- _ ] => rewrite (@empty_union_left s) in H; try set_simpl
  | [ H :  context[union ?s {}N] |- _ ] => rewrite (@empty_union_right s) in H; try set_simpl
  | [ |- context[inter {}N ?s] ] => rewrite (@inter_empty_left s); try set_simpl
  | [ |- context[inter ?s {}N] ] => rewrite (@inter_empty_right s); try set_simpl
  | [ H :  context[inter {}N ?s] |- _ ] => rewrite (@inter_empty_left s) in H; try set_simpl
  | [ H :  context[inter ?s {}N] |- _ ] => rewrite (@inter_empty_right s) in H; try set_simpl
  | [ |-  context[inter (singleton ?x) (singleton ?x)]  ] => rewrite (@inter_singleton_eq x); try set_simpl
  | [ |-  context[inter (singleton ?x) (singleton ?y)]  ] => rewrite (@inter_singleton_neq x y); try set_simpl
  | [ H : context[inter (singleton ?x) (singleton ?x)] |- _ ] => rewrite (@inter_singleton_eq x) in H; try set_simpl
  | [ H : context[inter (singleton ?x) (singleton ?y)] |- _ ] => rewrite (@inter_singleton_neq x y) in H; try set_simpl
  | [ |-  context[inter ?s (singleton ?y)] ] => erewrite (@bound_disjoint s y); eauto; try set_simpl
  | [ |- context[remove ?n (singleton ?n)] ] => rewrite (@remove_singleton_empty n); try set_simpl
  | [ H : context[remove ?n (singleton ?n)] |- _ ] => rewrite (@remove_singleton_empty n) in H; try set_simpl
  | [ |- context[remove ?n (singleton ?m)] ] => try (rewrite (@remove_singleton_inv n m); auto); try set_simpl
  | [ H : context[remove ?n (singleton ?m)] |- _ ] => try (rewrite (@remove_singleton_inv n m) in H; auto); try set_simpl
  | [ |- context[remove ?n {}N] ] => rewrite (@remove_empty n); try set_simpl
  | [ H : context[remove ?n {}N] |- _ ] => rewrite (@remove_empty n) in H; try set_simpl
  | [ H : context[remove ?n (union ?s1 ?s2)] |- _ ] => rewrite (@remove_union_dist n s1 s2) in H; try set_simpl
  | [ |- context[remove ?n (union ?s1 ?s2)] ] => rewrite (@remove_union_dist n s1 s2); try set_simpl
  end.

Ltac bound_simpl := try set_simpl;
  match goal with
  | [ |- context[bound (union _ _)] ] => rewrite union_bound_max'; try bound_simpl
  | [ |- context[bound (singleton _)] ] => rewrite bound_singleton; try bound_simpl
  | [ |- context[bound {}N] ] => rewrite bound_empty; try bound_simpl
  end.

Ltac closed_qual_solve :=
  match goal with
  | [ |- closed_qual _ _ _ ∅ ] => try solve [constructor; bound_simpl; lia]
  | [ |- closed_qual _ _ _ (_ ⋓ _) ] => try solve [apply closed_qual_qqplus; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊔ _) ] => try solve [apply closed_qual_qlub; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⋒ _) ] => try solve [apply closed_qual_qqcap; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊓ _) ] => try solve [apply closed_qual_qqcap; closed_qual_solve]
  | [ |- closed_qual _ _ _ (_ ⊕ _) ] => try solve [apply closed_qual_qplus; simpl; try lia; closed_qual_solve]
  | [ |- closed_qual _ _ _ (just_fv _) ] => try solve [apply just_fv_closed; simpl; lia | closed_qual_solve]
  | [ H : closed_qual _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [simpl in *; eapply closed_qual_monotone; eauto; try lia | (closed_qual_solve)]
  | [ H : has_type _ ?q _ _ _ _ |- closed_qual _ _ _ ?q  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : has_type _ _ _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : stp _ _ _ ?q _ _ |- closed_qual _ _ _ ?q  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : stp _ _ _ _ _ ?q |- closed_qual _ _ _ ?q  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : qstp _ _ ?q _  |- closed_qual _ _ _ ?q  ] => try solve [apply qstp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H : qstp _ _ _ ?q  |- closed_qual _ _ _ ?q  ] => try solve [apply qstp_closed in H; intuition; simpl in *; eapply closed_qual_monotone; eauto | (closed_qual_solve)]
  | [ H1 : ?q ⊑ ?q', H2 : closed_qual _ _ _ ?q' |- closed_qual _ _ _ ?q ] => try solve [apply (closed_qual_sub H2 H1)]
  | [ |- closed_qual _ _ _ _ ] => try solve [simpl; constructor; bound_simpl; lia]
  end.

Ltac closed_ty_solve :=
  match goal with
  | [ H : closed_ty _ _ _ ?T |- closed_ty _ _ _ ?T  ] => try solve [simpl in *; eapply closed_ty_monotone; eauto; try lia | (closed_ty_solve)]
  | [ H : has_type _ _ _ _ ?T _ |- closed_ty _ _ _ ?T  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ H : stp _ _ ?T _ _ _ |- closed_ty _ _ _ ?T  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ H : stp _ _ _ _ ?T _ |- closed_ty _ _ _ ?T  ] => try solve [apply stp_closed in H; intuition; simpl in *; eapply closed_ty_monotone; eauto | (closed_ty_solve)]
  | [ |- closed_ty _ _ _ (TFun _ _ _ _) ] => try solve [simpl; constructor; try closed_qual_solve; closed_ty_solve]
  | [ |- closed_ty _ _ _ (TRef _) ] => try solve [simpl; constructor; try closed_qual_solve; closed_ty_solve]
  | [ |- closed_ty _ _ _ _ ] => try solve [simpl; constructor; try closed_qual_solve]
  end.

Ltac closed_tm_solve :=
  match goal with
  | [ H : closed_tm _ _ _ ?T |- closed_tm _ _ _ ?T  ] => try solve [simpl in *; eapply closed_tm_monotone; eauto; try lia | (closed_tm_solve)]
  | [ H : has_type _ _ _ ?T _ _ |- closed_tm _ _ _ ?T  ] => try solve [apply has_type_closed in H; intuition; simpl in *; eapply closed_tm_monotone; eauto | (closed_tm_solve)]
  | [ |- closed_tm _ _ _ (tabs _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tapp _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tref _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tderef _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ (tassign _ _) ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  | [ |- closed_tm _ _ _ _ ] => try solve [simpl; constructor; try lia; closed_tm_solve]
  end.

Lemma open_qual_empty_id : forall k q, [[ k ~> q]]ᵈ ∅ = ∅.
  intros. destruct q. compute. rewrite NatSetFacts.empty_b. auto.
Qed.

Lemma has_type_open_tm_id : forall {Γ φ Σ t T d k t'}, has_type Γ φ Σ t T d -> open_rec_tm k t' t = t.
  intros. apply has_type_closed in H. intuition. eapply closed_tm_open_id; eauto. lia.
Qed.

Lemma has_type_open_ty_id : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_rec_ty k q T = T.
  intros. apply has_type_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma has_type_open_qual_id1 : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_qual k q φ = φ.
  intros. apply has_type_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma has_type_open_qual_id2 : forall {Γ φ Σ t T d k q}, has_type Γ φ Σ t T d -> open_qual k q d = d.
  intros. apply has_type_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma stp_open_ty_id1 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_rec_ty k q' S = S.
  intros. apply stp_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma stp_open_ty_id2 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_rec_ty k q' T = T.
  intros. apply stp_closed in H. intuition. eapply closed_ty_open_id; eauto. lia.
Qed.

Lemma stp_open_qual_id1 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_qual k q' q = q.
  intros. apply stp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma stp_open_qual_id2 : forall {Γ Σ T d S q k q'}, stp Γ Σ S q T d -> open_qual k q' d = d.
  intros. apply stp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma qstp_open_qual_id1 : forall {Γ Σ d q k q'}, qstp Γ Σ q d -> open_qual k q' q = q.
  intros. apply qstp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma qstp_open_qual_id2 : forall {Γ Σ d q k q'}, qstp Γ Σ q d -> open_qual k q' d = d.
  intros. apply qstp_closed in H. intuition. eapply closed_qual_open_id; eauto. lia.
Qed.

Lemma mem_singleton' : forall {n}, mem n (singleton n) = true.
  intros. rewrite mem_singleton. rewrite <- beq_nat_refl. auto.
Qed.

Lemma mem_singleton_neq : forall {m n}, m <> n -> mem n (singleton m) = false.
  intros. rewrite mem_singleton. rewrite Nat.eqb_neq. auto.
Qed.

Lemma unopen_subqual : forall {x q2 df l}, closed_qual 2 x l q2 -> closed_qual 0 x l df ->
  openq (just_fv x) (just_fv (S x)) q2 ⊑ df ⊔ (just_fv (S x)) -> openq ∅ ∅ q2 ⊑ df.
  intros. unfold openq in *. destruct q2. destruct df. simpl in *.
  inversion H. subst. inversion H0. subst.
  assert (H8' : bound t0 <= S x). lia.
  assert (H11' : bound t3 <= S x). lia. clear H8. clear H11. rename H8' into H8. rename H11' into H11.
  apply bound_le_mem_false in H8, H11, H9.
  destruct (NatSet.F.mem 0 t1) eqn:Hmem; simpl in *; intuition.
  destruct (mem 1 (union (remove 0 t1) {}N)) eqn:Hmem'; rewrite <- NatSetFacts.not_mem_iff in H8, H11, H9.
  * rewrite <- NatSetFacts.mem_iff in Hmem'. repeat rewrite empty_union_right in *.
    repeat rewrite empty_union_right in H1. simpl in *; intuition.
    intros z Hz. assert (Hz' : In z (union (union t0 (singleton x)) (singleton (S x)))). fnsetdec.
    apply H2 in Hz'. apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst.
    contradiction.
  * simpl in H1. intuition. repeat rewrite empty_union_right in *.
    rewrite empty_union_right in H1. simpl. intuition; fnsetdec.
  * destruct (mem 1 t1) eqn:Hmem1; simpl in *.
    ** repeat rewrite empty_union_right in *. intuition; try fnsetdec.
       intros z Hz. assert (Hz' : In z (union t0 (singleton (S x)))). fnsetdec.
       apply H2 in Hz'. apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst.
       rewrite <- NatSetFacts.not_mem_iff in H8. contradiction.
    ** intuition; try fnsetdec. rewrite <- NatSetFacts.not_mem_iff in H11, H8.
       intros z Hz. assert (Hz' : In z (union t3 (singleton (S x))) ). fnsetdec.
       apply union_1 in Hz'. intuition. apply NatSetFacts.singleton_iff in H3. subst. contradiction.
Qed.

Lemma saturated_singleton : forall {x Γ Σ b T}, indexr x Γ = Some (b, T, ∅) -> saturated Γ Σ (just_fv x).
  intros. unfold saturated. intros y Hmem. rewrite just_fv_mem_iff in Hmem. subst.
  econstructor; eauto.
Qed.

Ltac opening :=
  match goal with
  | [ H : closed_tm 0 _ _ ?t |- context[@open_tm' _ ?G ?t] ] => erewrite @closed_tm_open'_id with (t:=t); eauto; try opening
  | [ H : closed_ty 0 _ _ ?t |- context[@open_ty' _ _ ?t] ] => erewrite @closed_ty_open'_id with (T:=t); eauto; try opening
  | [ H : closed_qual 0 _ _ ?q |- context[@openq' _ ?G ?q] ] => erewrite @closed_qual_open'_id with (d:=q); eauto; try opening
  | [ |- context[@open_tm' ?T ?G (tvar (varB 0))] ] => rewrite (open_tm'_bv0 T G); try opening
  (* | [ |- context[@open_tm' ?T ?G (tvar (varB 1))] ] => rewrite (open_tm'_bv1 T G); try opening *)
  | [ |- context[@openq' ?T ?G (qset ?X (singleton 0) ?Y)] ] => rewrite (openq'_bv0 T G X Y); try opening
  (* | [ |- context[@openq' ?T ?G (qset ?X (singleton 1) ?Y)] ] => rewrite (openq'_bv1 T G X Y); try opening *)
  | [ |- context[@openq' _ _ _] ] => unfold openq'; unfold openq; try opening
  | [ |- context[@openq _ _] ] => unfold openq; try opening
  | [ |- context[@open_tm' _ _ _] ] => unfold open_tm'; try opening
  | [ |- context[@open_ty' _ _ _] ] => unfold open_ty'; unfold open_ty; try opening
  | [ |- context[@open_ty _ _] ] => unfold open_ty; try opening
  | [ |- context[open_qual _ _ (_ ⋓ _)] ] => rewrite open_qual_qqplus_dist; try opening
  | [ |- context[open_qual _ _ (_ ⊔ _)] ] => rewrite open_qual_qlub_dist; try opening
  | [ |- context[open_qual ?i ?d (just_fv ?x)] ] => rewrite (open_qual_just_fv i d x); try opening
  | [ |- context[open_qual ?i ?d (just_loc ?x)] ] => rewrite (open_qual_just_loc i d x); try opening
  | [ H : closed_qual 0 _ _ ?q |- context[open_qual _ _ ?q] ] => erewrite @closed_qual_open_id with (d:=q); eauto; try opening
  | [ H : has_type _ ?q _ _ _ _ |- context[open_qual _ _ ?q] ] => erewrite @has_type_open_qual_id1 with (φ:=q); eauto; try opening
  | [ H : has_type _ _ _ _ _ ?q |- context[open_qual _ _ ?q] ] => erewrite @has_type_open_qual_id2 with (d:=q); eauto; try opening
  | [ H : stp _ _ _ ?q _ _  |- context[open_qual _ _ ?q] ] => erewrite @stp_open_qual_id1 with (q:=q); eauto; try opening
  | [ H : stp _ _ _ _ _ ?q  |- context[open_qual _ _ ?q] ] => erewrite @stp_open_qual_id2 with (d:=q); eauto; try opening
  | [ H : qstp _ _ ?q _  |- context[open_qual _ _ ?q] ] => erewrite @qstp_open_qual_id1 with (q:=q); eauto; try opening
  | [ H : qstp _ _ _ ?q  |- context[open_qual _ _ ?q] ] => erewrite @qstp_open_qual_id2 with (d:=q); eauto; try opening
  | [ |- context[open_qual ?i ?d (just_bv ?i)] ] => try rewrite (@open_qual_just_bv i d); try opening
  | [ |- context[open_qual ?j ?d (just_bv ?i)] ] => try rewrite (@open_qual_just_bv_skip i j d); try lia; try opening
  | [ |- context[open_qual ?j ?d ∅] ] => try rewrite (@open_qual_empty_id j d); try lia; try opening
  (* | [ |- context[open_qual _ _ _] ] => simpl; try opening *)
  | [ H : closed_ty 0 _ _ ?x |- context[open_rec_ty _ _ ?x] ] => erewrite @closed_ty_open_id with (T:=x); eauto; try lia; try opening
  | [ H : has_type _ _ _ _ ?x _ |- context[open_rec_ty _ _ ?x] ] => erewrite @has_type_open_ty_id with (T:=x); eauto; try lia; try opening
  | [ H : stp _ _ ?x _ _ _ |- context[open_rec_ty _ _ ?x] ] => erewrite @stp_open_ty_id1 with (S:=x); eauto; try lia; try opening
  | [ H : stp _ _ _ _ ?x _ |- context[open_rec_ty _ _ ?x] ] => erewrite @stp_open_ty_id2 with (T:=x); eauto; try lia; try opening
  | [ |- context[open_rec_ty _ _ (TFun _ _ _ _)] ] => simpl; try opening
  | [ |- context[open_rec_ty _ _ (TRef _)] ] => simpl; try opening
  | [ |- context[open_rec_ty _ _ _] ] => simpl
  | [ H : closed_tm 0 _ _ ?x |- context[open_rec_tm _ _ ?x] ] => erewrite @closed_tm_open_id with (t:=x); eauto; try lia; try opening
  | [ H : has_type _ _ _ ?x _ _  |- context[open_rec_tm _ _ ?x] ] => erewrite @has_type_open_tm_id with (t:=x); eauto; try lia; try opening
  | [ |- context[open_rec_tm ?i ?x (tvar (varB ?i))] ] => rewrite (open_rec_tm_bv i x); try opening
  | [ |- context[open_rec_tm ?j ?x (tvar (varB ?i))] ] => rewrite (open_rec_tm_bv_skip j i x); try opening
  | [ |- context[open_rec_tm _ _ (tabs _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tapp _ _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tref _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tderef _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ (tassign _ _)] ] => simpl; try opening
  | [ |- context[open_rec_tm _ _ _] ] => simpl
  end.

Ltac qual_destruct :=
  match goal with
  | [ H : qual |- _ ] => destruct H; try clear H; try qual_destruct
  (* | [ H : closed_qual _ _ _ (qset _ _ _) |- _ ] => destruct H; try qual_destruct *)
  end.

Ltac subqual :=
  match goal with
  | [ |- openq _ _ _ ⊑ _ ] => try solve [try opening; try qual_destruct; simpl in *; try set_simpl; intuition; try fnsetdec]
  | [ |- _ ⊑ _ ] => try solve [try qual_destruct; simpl in *; try set_simpl; intuition; try fnsetdec]
  end.

Ltac set_bool_simpl :=
  match goal with
  |  [ |- context[mem ?n {}N] ] => rewrite (NatSetFacts.empty_b n); try set_bool_simpl
  |  [ |- context[mem ?n (singleton ?n)] ] => rewrite mem_singleton'; try set_bool_simpl
  |  [ |- context[mem ?n (singleton ?m)] ] => try (rewrite mem_singleton_neq; auto); try set_bool_simpl
  |  [ |- context[mem ?n (union ?s1 ?s2)]] => rewrite (NatSetProperties.FM.union_b s1 s2 n); try set_bool_simpl
  |  [ |- context[mem ?n (remove ?x ?s)]]  => rewrite (NatSetFacts.remove_b s x n); try set_bool_simpl
  |  [ |- context[NatSetFacts.eqb ?n ?x]]  => rewrite (@natset_eqb x n); try set_bool_simpl
  end.

Ltac lookup_solve :=
  match goal with
  | [ |- (if (beq_nat ?n ?n) then _ else _) = _ ] => rewrite <- beq_nat_refl; auto; try lookup_solve
  | [ |- (if (beq_nat ?n ?m) then _ else _) = _ ] =>
      let H := fresh "H" in
      destruct (beq_nat n m) eqn:H;
      try apply beq_nat_true in H;
      try apply beq_nat_false in H;
      try lia; lookup_solve
  | [ |- Some (_, _, _) = Some (_,_,_) ] => try solve [repeat f_equal; auto; qual_destruct; closed_qual_invert; simpl; f_equal; try set_simpl; try fnsetdec; try bound_simpl; try lia]
  end.

Ltac lookup :=
  match goal with
  | [ |- (@indexr _ _ _) = _ ] => try solve [lookup_solve | simpl; lookup_solve]
  end.

Ltac saturated_solve :=
  match goal with
  | [ |- saturated _ _ (just_loc _) ]                      => apply saturated_just_loc
  | [ |- saturated _ _ ∅ ]                               => apply saturated_empty
  | [ |- saturated [] _ _ ]                                => try solve [apply saturated_empty_tenv; closed_qual_solve]
  | [ H : saturated ?G ?S ?q |- saturated ?G ?S ?q ]       => apply H
  | [ H : saturated ?G ?S ?q |- saturated (_ :: _) ?S ?q ] => try solve [apply saturated_cons; saturated_solve]
  | [ H : saturated ?G ?S ?q |- saturated (_ ++ _) ?S ?q ] => try solve [apply saturated_app; saturated_solve]
  | [ |- saturated _ _ (just_fv _) ]                       => try solve [eapply saturated_singleton; lookup]
  | [ |- saturated _ _ (_ ⊔ _) ]                           => try solve [apply saturated_qqplus; saturated_solve]
  | [ |- saturated _ _ (_ ⋓ _) ]                           => try solve [apply saturated_qqplus; saturated_solve]
  | [ |- saturated _ _ (_ ⊓ _) ]                           => try solve [apply saturated_qqcap; saturated_solve]
  | [ |- saturated _ _ (_ ⋒ _) ]                           => try solve [apply saturated_qqcap; saturated_solve]
  | [ |- saturated _ _ (_ ⊕ _)]                            => try solve [eapply saturated_qplus; try lookup; try closed_qual_solve; saturated_solve]
  | [ |- saturated _ _ (openq _ _ ∅)]                    => try solve [opening; apply saturated_empty]
  | [ |- saturated _ _ (openq _ _ _)]                      => try solve [apply saturated_openq; try closed_qual_solve; saturated_solve]
  | [ |- saturated _ _ ([[_ ~> _ ]]ᵈ ([[_ ~> _ ]]ᵈ ∅))]  => try solve [opening; apply saturated_empty]
  | [ |- saturated _ _ ([[_ ~> _ ]]ᵈ _)]                   => try solve [apply saturated_open_qual; saturated_solve]
  end.

Ltac subtyping k :=
  match goal with
  | [ |- (stp _ _ _ _ _ _) ] => try solve [repeat (constructor ; k () )]
  end.

Ltac cleanup := repeat (try set_simpl; try opening; try set_bool_simpl; simpl).

Ltac crush :=
  try solve [closed_qual_solve];
  try solve [closed_ty_solve];
  try solve [closed_tm_solve];
  try solve [subqual];
  try solve [simpl; qdec];
  try solve [simpl; fnsetdec];
  try solve [lookup];
  try solve [saturated_solve];
  try solve [subtyping ltac:(fun _ => repeat crush; try cleanup)];
  try solve intuition;
  try solve lia.

Ltac ccrush := repeat (crush; try cleanup).

Ltac unfold_open :=
  try unfold openq'; try unfold openq; try unfold open_tm'; try unfold open_ty'; try unfold open_ty.

Tactic Notation "unfold_open" "in" hyp(H) :=
  try unfold openq' in H; try unfold openq in H; try unfold open_tm' in H; try unfold open_ty' in H; try unfold open_ty in *.

(* Deal with cases where applying t_var might stumble. (Seems not needed in lambda_star_lazy systems) *)
(* Ltac TVAR :=
  match goal with
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (_ ⊕ ?x) ] => apply t_var
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (qset (singleton ?x) {}N {}N) ] => replace (qset (singleton x) {}N {}N) with (∅ ⊕ x); try TVAR
  | [ |- has_type _ _ _ (tvar (varF ?x)) _ (just_fv ?x) ] => rewrite <- qplus_empty; try TVAR
  end. *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * rZ

Pierre Letouzey & Laurent Thery

We define signed variable as follows:

We first define [rNat] as an abbreviation for positive (from fast_integer)
and [rZ] as an inductive type with 2 constructors:

- [rZPlus: rNat ->rZ]
- [rZMinus: rNat ->rZ]

We define usual operations on [rZ], i.e., equality, comparison, etc.

At the end we define functional arrays that will be used in implementation
*)

From Stalmarck Require Import sTactic.
From Coq Require Import Relation_Definitions.
From Coq Require Import ZArith.
From Coq Require Import Inverse_Image.
From Coq Require Import Inclusion.
From Coq Require Import Wf_nat.
From Coq Require Import List.

Definition rNat := positive.

Definition zero := 1%positive.

Definition rnext : rNat -> rNat := Pos.succ.

(** rZ are signed rNat *)
Inductive rZ : Set :=
  | rZPlus : rNat -> rZ
  | rZMinus : rNat -> rZ.

(** We single out zero as being intepreted as True *)
Definition rZTrue := rZPlus zero.

Definition rZFalse := rZMinus zero.

(** Complementary *)
Definition rZComp (r : rZ) : rZ :=
  match r with
  | rZPlus m => rZMinus m
  | rZMinus m => rZPlus m
  end.

Theorem rZCompInv : forall m : rZ, rZComp (rZComp m) = m.
Proof.
intros m; case m; simpl in |- *; auto with stalmarck.
Qed.

(** Comparison function *)
Definition rlt (a b : rNat) : Prop :=
  Pcompare a b Datatypes.Eq = Datatypes.Lt.

(** Decidability over rNat *)
Definition rNatDec : forall n m : rNat, {n = m} + {n <> m}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; left; auto with stalmarck.
intros H' H'0 H'1; right; red in |- *; intros H1;
 absurd (nat_of_P n < nat_of_P m); auto with stalmarck.
rewrite <- H1; auto with arith stalmarck.
intros H' H'0 H'1; right; red in |- *; intros H1;
 absurd (nat_of_P n > nat_of_P m); auto with stalmarck.
rewrite <- H1; auto with arith stalmarck.
Defined.

(** Order is decidable *)
Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; right; right; auto with stalmarck.
intros H' H'0 H'1; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
intros H' H'0 H'1; right; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
apply H'0; auto with stalmarck.
Defined.

(** An alternative version *)
Definition rltEDec : forall m n : rNat, {rlt m n} + {rlt n m} + {m = n}.
intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
 generalize (nat_of_P_gt_Gt_compare_morphism n m);
 generalize (Pcompare_Eq_eq n m); case (Pcompare n m Datatypes.Eq).
intros H' H'0 H'1; right; auto with stalmarck.
intros H' H'0 H'1; left; left; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
intros H' H'0 H'1; left; right; unfold rlt in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism; auto with stalmarck.
apply H'0; auto with stalmarck.
Defined.

(** Some properties of rlt *)
Theorem rltDef2 : forall m n : rNat, rlt m n -> m <> n.
Proof.
unfold rlt in |- *; intros m n H'; red in |- *; intros H'0;
 rewrite <- H'0 in H'; rewrite Pcompare_refl in H';
 discriminate.
Qed.

Theorem rltTrans : transitive rNat rlt.
Proof.
red in |- *; unfold rlt in |- *; intros x y z H1 H2.
apply nat_of_P_lt_Lt_compare_complement_morphism.
apply Nat.lt_trans with (nat_of_P y); apply nat_of_P_lt_Lt_compare_morphism; auto with stalmarck.
Qed.

Theorem rltNotRefl : forall a : rNat, ~ rlt a a.
Proof.
intros a; unfold rlt in |- *; rewrite Pcompare_refl; red in |- *; intros;
 discriminate.
Qed.

#[export] Hint Resolve rltNotRefl : stalmarck.

Theorem rnextRlt : forall m : rNat, rlt m (rnext m).
Proof.
intros m; unfold rlt, rnext in |- *.
apply nat_of_P_lt_Lt_compare_complement_morphism.
rewrite Pplus_one_succ_r; rewrite nat_of_P_plus_morphism;
 unfold nat_of_P in |- *; simpl in |- *; rewrite Nat.add_comm;
 simpl in |- *; auto with arith stalmarck.
Qed.

#[export] Hint Resolve rnextRlt : stalmarck.

Theorem rnextNotZero : forall m : rNat, rlt zero (rnext m).
Proof.
intros m; unfold nat_of_P, rnext, rlt in |- *; elim m; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rnextNotZero : stalmarck.

(** Maximun of two rNat *)
Definition rmax : rNat -> rNat -> rNat.
intros n m; case (rltDec n m); intros Rlt0.
exact m.
exact n.
Defined.

Lemma rmaxRlt : forall n m p : rNat, rlt m n -> rlt p n -> rlt (rmax m p) n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck.
Qed.

Lemma rmaxRltLeft : forall n m p : rNat, rlt (rmax m p) n -> rlt m n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck; intros Rlt0.
intros Rlt1; apply rltTrans with (y := p); auto with stalmarck.
Qed.

Lemma rmaxRltRight : forall n m p : rNat, rlt (rmax m p) n -> rlt p n.
Proof.
intros n m p; unfold rmax in |- *; case (rltDec m p); auto with stalmarck; intros Rlt0.
Casec Rlt0; intros Rlt0; auto with stalmarck.
intros Rlt1; apply rltTrans with (y := m); auto with stalmarck.
rewrite <- Rlt0; auto with stalmarck.
Qed.

(** Properties of rnext *)
Lemma rNextS : forall n : rNat, nat_of_P (rnext n) = S (nat_of_P n).
Proof.
intros n; unfold rnext, nat_of_P in |- *; simpl in |- *.
rewrite Pmult_nat_succ_morphism; auto with stalmarck.
Qed.

Theorem rNextInv : forall n m : rNat, rlt n (rnext m) -> n = m \/ rlt n m.
Proof.
intros n m H'.
generalize (nat_of_P_lt_Lt_compare_morphism _ _ H').
rewrite rNextS.
intros H'0; case (proj1 (Nat.lt_eq_cases _ _) (proj1 (Nat.lt_succ_r _ _) H'0)).
intros H'1; right; red in |- *;
 apply nat_of_P_lt_Lt_compare_complement_morphism;
 auto with stalmarck.
intros H'1; left; apply nat_of_P_inj; auto with stalmarck.
Qed.

Lemma rltTransRnext1 :
 forall n m p : rNat, rlt n (rnext m) -> rlt m p -> rlt n p.
Proof.
intros n m p H' H'0; case (rNextInv n m); auto with stalmarck.
intros H'1; rewrite H'1; auto with stalmarck.
intros H'1; apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltTransRnext2 :
 forall n m p : rNat, rlt n m -> rlt m (rnext p) -> rlt n p.
Proof.
intros n m p H' H'0; case (rNextInv m p); auto with stalmarck.
intros H'1; rewrite <- H'1; auto with stalmarck.
intros H'1; apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltRnext2Inv : forall n m : rNat, rlt (rnext n) (rnext m) -> rlt n m.
Proof.
intros n m H'; case (rNextInv (rnext n) m); auto with stalmarck.
intros H'0; rewrite <- H'0; auto with stalmarck.
intros H'1; apply rltTrans with (y := rnext n); auto with stalmarck.
Qed.

Lemma rnextMono : forall m n : rNat, rlt m n -> rlt (rnext m) (rnext n).
Proof.
intros m n H'.
case (rltDec (rnext m) n); intros Rlt0; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
case Rlt0; intros Rlt1.
elim (rNextInv n m); auto with stalmarck; intros Rlt2; absurd (rlt m m); auto with stalmarck.
rewrite Rlt2 in H'; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
rewrite <- Rlt1; auto with stalmarck.
Qed.

#[export] Hint Resolve rnextMono : stalmarck.

Lemma rltRmaxLeft : forall n m : rNat, rlt n (rnext (rmax n m)).
Proof.
intros n m; unfold rmax in |- *; case (rltDec n m); auto with stalmarck; intros Rlt0.
apply rltTrans with (y := m); auto with stalmarck.
Qed.

Lemma rltRmaxRight : forall n m : rNat, rlt m (rnext (rmax n m)).
Proof.
intros n m; unfold rmax in |- *; case (rltDec n m); auto with stalmarck; intros Rlt0.
Casec Rlt0; intros Rlt0; auto with stalmarck.
apply rltTrans with (y := n); auto with stalmarck.
rewrite <- Rlt0; auto with stalmarck.
Qed.

#[export] Hint Resolve rltRmaxLeft rltRmaxRight : stalmarck.

Theorem rltAntiSym : forall a b : rNat, rlt a b -> ~ rlt b a.
Proof.
intros a b H'; red in |- *; intros H'0; absurd (rlt a a); auto with stalmarck.
apply rltTrans with (y := b); auto with stalmarck.
Qed.

(** The equality on rZ is decidable *)
Definition rZDec : forall a b : rZ, {a = b} + {a <> b}.
intros a b; case a; case b;
 try (intros; right; red in |- *; intros; discriminate);
 intros a' b'; case (rNatDec a' b'); intros Eq1;
 try (left; rewrite Eq1; auto with stalmarck; fail); auto with stalmarck; intros;
 right; red in |- *; intros Eq2; apply Eq1; inversion Eq2;
 auto with stalmarck.
Defined.

(** Absolute value *)
Definition valRz (a : rZ) :=
  match a with
  | rZPlus b => b
  | rZMinus b => b
  end.

(** Order on rZ *)
Definition rZlt (a b : rZ) := rlt (valRz a) (valRz b).

(** Equality on rZ, two elements sont eqRz if they have same rNat *)
Definition eqRz (a b : rZ) := valRz a = valRz b.

#[export] Hint Unfold eqRz rZlt : stalmarck.

(** Basic properties of eqRz and rZlt *)
Theorem eqrZRefl : reflexive rZ eqRz.
Proof.
red in |- *; intros a; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZRefl : stalmarck.

Theorem eqrZSym : symmetric rZ eqRz.
Proof.
red in |- *; intros a b; case a; case b; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZSym : stalmarck.

Theorem eqrZTrans : transitive rZ eqRz.
Proof.
red in |- *; auto with stalmarck.
unfold eqRz in |- *; intros x y z H'; rewrite H'; auto with stalmarck.
Qed.

#[export] Hint Resolve eqrZTrans : stalmarck.

Definition rZltDec : forall a b : rZ, {rZlt a b} + {rZlt b a \/ eqRz a b}.
intros a b; exact (rltDec (valRz a) (valRz b)).
Defined.

Definition rZltEDec : forall a b : rZ, {rZlt a b} + {rZlt b a} + {eqRz a b}.
intros a b; exact (rltEDec (valRz a) (valRz b)); auto with stalmarck.
Defined.

Theorem rZltEqComp :
 forall a b c d : rZ, rZlt a b -> eqRz a c -> eqRz b d -> rZlt c d.
Proof.
intros a b c d; unfold rZlt, eqRz in |- *; case a; case b; case c; case d;
 simpl in |- *; intros a' b' c' d' H'0 H'1 H'2; try rewrite <- H'1;
 try rewrite <- H'2; auto with stalmarck.
Qed.

Theorem rZltDef2 : forall a b : rZ, rZlt a b -> ~ eqRz a b.
Proof.
intros a b H; unfold eqRz in |- *; apply rltDef2; auto with stalmarck.
Qed.
#[export] Hint Resolve rZltDef2 : stalmarck.

Theorem rZltTrans : transitive rZ rZlt.
Proof.
red in |- *.
intros x y z H' H'0; red in |- *; apply rltTrans with (y := valRz y); auto with stalmarck.
Qed.

#[export] Hint Resolve rZltTrans : stalmarck.

Theorem rZltNotRefl : forall a : rZ, ~ rZlt a a.
Proof.
intros a; unfold rZlt in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rZltNotRefl : stalmarck.

Theorem rZltAntiSym : forall a b : rZ, rZlt a b -> ~ rZlt b a.
Proof.
intros a b H'; red in |- *; intros H'0; absurd (rZlt a a); auto with stalmarck.
apply rZltTrans with (y := b); auto with stalmarck.
Qed.

#[export] Hint Resolve rZltAntiSym : stalmarck.

Theorem NotEqComp : forall a : rZ, a <> rZComp a.
Proof.
intros a; case a; red in |- *; intros H'; discriminate.
Qed.

#[export] Hint Resolve NotEqComp : stalmarck.

Theorem eqRzComp : forall a : rZ, eqRz a (rZComp a).
Proof.
intros a; case a; auto with stalmarck.
Qed.

#[export] Hint Resolve eqRzComp : stalmarck.

Theorem valRzComp : forall a : rZ, valRz (rZComp a) = valRz a.
Proof.
intros a; case a; auto with stalmarck.
Qed.

Theorem rZCompInvol : forall a : rZ, a = rZComp (rZComp a).
Proof.
intros a; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rZCompInvol : stalmarck.

Theorem rZCompEq : forall a b : rZ, rZComp a = rZComp b -> a = b.
Proof.
intros a b; case a; case b; simpl in |- *; auto with stalmarck; intros a' b' H; inversion H;
 auto with stalmarck.
Qed.

(** Minimum of two rZ, if they are equal we choose arbitrary the second one *)
Definition min (a b : rZ) : rZ :=
  match rZltDec a b with
  | left _ => a
  | right _ => b
  end.

(** Maximum of two rZ, if they are equal we choose arbitrary the first one *)
Definition max (a b : rZ) : rZ :=
  match rZltDec a b with
  | left _ => b
  | right _ => a
  end.

(** Same basic properties of min and max *)
Theorem minProp1 : forall a b : rZ, rZlt a b -> min a b = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem minProp2 : forall a b : rZ, rZlt b a -> min a b = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem minProp3 : forall a b : rZ, rZlt a b -> min b a = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem minProp4 : forall a b : rZ, rZlt b a -> min b a = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem minProp5 : forall a b : rZ, eqRz a b -> min a b = b.
Proof.
intros a b; unfold min in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem minProp6 : forall a b : rZ, eqRz a b -> min b a = a.
Proof.
intros a b; unfold min in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem maxProp1 : forall a b : rZ, rZlt a b -> max a b = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem maxProp2 : forall a b : rZ, rZlt b a -> max a b = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem maxProp3 : forall a b : rZ, rZlt a b -> max b a = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'0 H'1; absurd (rZlt b a); auto with stalmarck.
Qed.

Theorem maxProp4 : forall a b : rZ, rZlt b a -> max b a = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H'; case H'; intros H'0 H'1.
absurd (rZlt b a); auto with stalmarck.
absurd (eqRz b a); auto with stalmarck.
Qed.

Theorem maxProp5 : forall a b : rZ, eqRz a b -> max a b = a.
Proof.
intros a b; unfold max in |- *; case (rZltDec a b); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz a b); auto with stalmarck.
Qed.

Theorem maxProp6 : forall a b : rZ, eqRz a b -> max b a = b.
Proof.
intros a b; unfold max in |- *; case (rZltDec b a); simpl in |- *; auto with stalmarck.
intros H' H'0; absurd (eqRz b a); auto with stalmarck.
Qed.

(** Check if two rZ are equal *)
Definition rZSignDec :
  forall a b : rZ, {a = b} + {a = rZComp b} + {~ eqRz a b}.
intros a b; case a; case b; intros a' b'; case (rNatDec a' b'); simpl in |- *;
 auto with stalmarck; intros Eqa'b'.
left; left; rewrite Eqa'b'; auto with stalmarck.
left; right; rewrite Eqa'b'; auto with stalmarck.
left; right; rewrite Eqa'b'; auto with stalmarck.
left; left; rewrite Eqa'b'; auto with stalmarck.
Defined.

(** Lift every function of rNat-> rZ to a function rZ -> rZ
   that is compatible with the complement *)
Definition liftRz (f : rNat -> rZ) (a : rZ) :=
  match a with
  | rZPlus a' => f a'
  | rZMinus a' => rZComp (f a')
  end.

(** Given a:rZ and b:rNat produces an rZ that has the same sign than
   a but the same rNat than b *)
Definition samePol (a : rZ) (b : rNat) := liftRz (fun a : rNat => rZPlus b) a.

(** Comparison between an rZ and an rNat *)
Definition rVlt (a : rZ) (b : rNat) := rlt (valRz a) b.

(** Comparison is compatible with the complement *)
Theorem rVltrZComp :
 forall (a : rZ) (b : rNat), rVlt a b -> rVlt (rZComp a) b.
Proof.
intros a b; case a; simpl in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve rVltrZComp : stalmarck.

(** Given a:rZ and b:rZ produces an rZ that has the same sign than
   sign(a)*sign(b) but the same rNat than b *)
Definition samePolRz (a b : rZ) := liftRz (fun c : rNat => b) a.

(** Some properties of samePolRz *)
Theorem samePolRzValRz :
 forall (p : rZ) (q : rNat), valRz (samePolRz p (rZPlus q)) = q.
Proof.
intros p; case p; simpl in |- *; auto with stalmarck.
Qed.

Theorem samePolRzEqRz : forall p q : rZ, eqRz (samePolRz p q) q.
Proof.
intros p; case p; auto with stalmarck.
Qed.

Theorem samePolRzRvlt :
 forall (p q : rZ) (r : rNat), rVlt p r -> rVlt (samePolRz q p) r.
Proof.
intros p q r; case q; auto with stalmarck.
Qed.

Theorem samePolRzInvRvlt :
 forall (p q : rZ) (r : rNat), rVlt (samePolRz q p) r -> rVlt p r.
Proof.
intros p q r; case q; simpl in |- *; auto with stalmarck.
intros H' H'0; replace p with (rZComp (rZComp p)); auto with stalmarck.
Qed.

Theorem samePolRzsamePolRz : forall p q : rZ, samePolRz p (samePolRz p q) = q.
Proof.
intros p; case p; auto with stalmarck.
Qed.

Theorem samePolSamePolRz :
 forall (p q : rZ) (r : rNat),
 samePol (samePolRz p q) r = samePolRz p (samePol q r).
Proof.
intros p q; case p; case q; auto with stalmarck.
Qed.

Theorem samePolRzComp :
 forall p q : rZ, rZComp (samePolRz p q) = samePolRz p (rZComp q).
Proof.
intros p q; case p; case q; simpl in |- *; auto with stalmarck.
Qed.

(**
 Definition of function arrays on an arbitrary type A, using
 positive numbers as indexes
*)
Section rA.
Variable A : Type.
(* Usual binary tree *)

Inductive rTree : Type :=
  | rEmpty : rTree
  | rSplit : option A -> rTree -> rTree -> rTree.
(* We use the positive number as a path in the tree to retrieve
   a value *)

Fixpoint rTreeGet (t : rTree) (r : rNat) {struct r} :
 option A :=
  match r, t with
  | _, rEmpty => None
  | xH, rSplit a _ _ => a
  | xO p, rSplit _ t' _ => rTreeGet t' p
  | xI p, rSplit _ _ t' => rTreeGet t' p
  end.
(* To update a Tree we modify the branch designated by the number *)

Fixpoint rTreeSet (t : rTree) (r : rNat) {struct r} :
 A -> rTree :=
  fun a : A =>
  match r, t with
  | xH, rEmpty => rSplit (Some a) rEmpty rEmpty
  | xO p, rEmpty => rSplit (None) (rTreeSet rEmpty p a) rEmpty
  | xI p, rEmpty => rSplit (None) rEmpty (rTreeSet rEmpty p a)
  | xH, rSplit _ t'1 t'2 => rSplit (Some a) t'1 t'2
  | xO p, rSplit b t'1 t'2 => rSplit b (rTreeSet t'1 p a) t'2
  | xI p, rSplit b t'1 t'2 => rSplit b t'1 (rTreeSet t'2 p a)
  end.
(* Standard properties for the Set and Get function *)

Theorem rTreeDef1 :
 forall (t : rTree) (m : rNat) (v : A),
 rTreeGet (rTreeSet t m v) m = Some v.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t v; case t; auto with stalmarck.
intros p H' t v; case t; auto with stalmarck.
intros t v; case t; auto with stalmarck.
Qed.

Theorem rTreeDef2 :
 forall (t : rTree) (m1 m2 : rNat) (v : A),
 m1 <> m2 -> rTreeGet (rTreeSet t m1 v) m2 = rTreeGet t m2.
Proof.
intros t m; generalize t; Elimc m; simpl in |- *; clear t.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p H' t m2 v; case m2; simpl in |- *; case t; auto with stalmarck.
intros p0 H'0; elim p0; simpl in |- *; auto with stalmarck.
intros p0 H'0; rewrite H'; auto with stalmarck.
elim p0; simpl in |- *; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros a r1 r2 p0 H'0; rewrite H'; auto with stalmarck.
Contradict H'0; rewrite H'0; auto with stalmarck.
intros t m2 v; case m2; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
case t; intros p H'; elim p; simpl in |- *; auto with stalmarck.
intros H'; Contradict H'; auto with stalmarck.
Qed.

(** We turn our rTree into a function array using a default function *)
Inductive rArray : Type :=
    rArrayMake : rTree -> (rNat -> A) -> rArray.

Definition rArrayGet (ar : rArray) (r : rNat) :=
  match ar with
  | rArrayMake t f => match rTreeGet t r with
                      | Some a => a
                      | _ => f r
                      end
  end.

Definition rArraySet (ar : rArray) (r : rNat) (v : A) :=
  match ar with
  | rArrayMake t f => rArrayMake (rTreeSet t r v) f
  end.
(* We get the standard properties *)

Theorem rArrayDef1 :
 forall (Ar : rArray) (m : rNat) (v : A), rArrayGet (rArraySet Ar m v) m = v.
Proof.
intros Ar m v; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef1 r m v); auto with stalmarck.
Qed.

Theorem rArrayDef2 :
 forall (Ar : rArray) (m1 m2 : rNat) (v : A),
 m1 <> m2 -> rArrayGet (rArraySet Ar m1 v) m2 = rArrayGet Ar m2.
Proof.
intros Ar m1 m2 v H'; case Ar; simpl in |- *.
intros r a; rewrite (rTreeDef2 r m1 m2 v); auto with stalmarck.
Qed.

(** Empty array with default value *)
Definition rArrayInit (f : rNat -> A) := rArrayMake rEmpty f.

Theorem rArrayDef :
 forall (m : rNat) (f : rNat -> A), rArrayGet (rArrayInit f) m = f m.
Proof.
intros m f; simpl in |- *; auto with stalmarck.
elim m; simpl in |- *; auto with stalmarck.
Qed.

End rA.


Require Export Coq.ZArith.ZArith.
Require Export Coq.Lists.List. Import ListNotations.
Require Import coqutil.Tactics.rdelta.
Require Import coqutil.Tactics.destr.
Require Import coqutil.Z.prove_Zeq_bitwise.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.fwd.
Require Export riscv.Spec.Decode.
Require Export riscv.Utility.Encode.
Require Export riscv.Utility.Utility.
Require Import riscv.Proofs.DecodeByExtension.

Local Open Scope Z_scope.

Ltac isConst x :=
  lazymatch x with
  | ?a ^ ?b => isConst a; isConst b
  | ?a - ?b => isConst a; isConst b
  | - ?a => isConst a
  | Z.max ?a ?b => isConst a; isConst b
  | _ => let x' := rdelta x in
         lazymatch isZcst x' with
         | true => idtac
         end
  end.

Lemma verify_decode: forall iset inst,
    supportsF iset = false ->
    verify (decode iset inst) iset \/ decode iset inst = InvalidInstruction inst.
Proof.
  intros. rewrite <- decode_seq_correct.
  assert (bitwidth iset = 2 ^ 5 \/ bitwidth iset = 2 ^ 6) as bw_cases. {
    destruct iset; cbn; auto.
  }
  assert (bitSlice inst 25 26 = 0 -> bitSlice inst 20 26 < bitwidth iset). {
    intros.
    rewrite bitSlice_alt in *. 2-3: cbv; intuition congruence.
    unfold bitSlice' in *.
    Z.div_mod_to_equations.
    Lia.lia.
  }
  assert (signExtend 32 (BinInt.Z.shiftl (bitSlice inst 12 32) 12) mod 2 ^ 12 = 0). {
    unfold signExtend.
    rewrite Z.shiftl_mul_pow2 by (cbv; discriminate 1).
    Z.div_mod_to_equations.
    Lia.lia.
  }
  assert (signExtend 13
   (Z.shiftl (bitSlice inst 31 32) 12 <|> BinInt.Z.shiftl (bitSlice inst 25 31) 5 <|>
    Z.shiftl (bitSlice inst 8 12) 1 <|> BinInt.Z.shiftl (bitSlice inst 7 8) 11) mod 2 = 0). {
    eapply mod20_bitSlice.
    prove_Zeq_bitwise.
  }
  assert (signExtend 21
   (BinInt.Z.shiftl (bitSlice inst 31 32) 20 <|> BinInt.Z.shiftl (bitSlice inst 21 31) 1 <|>
    BinInt.Z.shiftl (bitSlice inst 20 21) 11 <|> BinInt.Z.shiftl (bitSlice inst 12 20) 12)
   mod 2 = 0). {
    eapply mod20_bitSlice.
    prove_Zeq_bitwise.
  }
  unfold decode_seq.
  repeat destruct_one_match; fwd.
  all: (right; reflexivity) || left.
  all: try match goal with
           | H': supportsF _ = true |- _ => exfalso; congruence
           end.
  all: unfold verify, verify_iset.
  all: split;
    [|repeat match goal with
             | H: bitwidth _ = _ |- _ => unfold bitwidth in H
             end;
      unfold supportsM, supportsA, supportsF in *;
      destruct iset; try intuition congruence].
  all: match goal with
       | |- respects_bounds _ (_ ?d) => remember d as r in *; revert dependent r; intro r
       end.
  all: cbv beta zeta delta [decodeI decodeM decodeA decodeF
                            decodeI64 decodeM64 decodeA64 decodeF64
                            decodeCSR
                            isValidI isValidM isValidA isValidF
                            isValidI64 isValidM64 isValidA64 isValidF64
                            isValidCSR].
  all: loop INil.
  all: intros; subst.
  all: match goal with
       | H: ?x = ?x |- _ => clear H
       | H: false = true |- _ => discriminate H
       end.
  all: cbv beta iota zeta delta [respects_bounds apply_InstructionMapper Verifier
         map_Invalid map_R map_R_atomic map_I map_I_shift_57 map_I_shift_66
         map_I_system map_S map_SB map_U map_UJ map_Fence map_FenceI
         verify_Invalid verify_R verify_R_atomic verify_I verify_I_shift_57 verify_I_shift_66
         verify_I_system verify_S verify_SB verify_U verify_UJ verify_Fence verify_FenceI
         machineIntToShamt id
       ].
  all: repeat match goal with
              | |- 0 <= bitSlice _ _ _ < _ => eapply bitSlice_bounds
              | |- _ <= signExtend _ _ < _ => eapply signExtend_bounds; cbv; discriminate 1
              | |- _ /\ _ => split
              | |- ?x <= ?y => isConst x; isConst y; cbv; discriminate 1
              | |- ?x < ?y => isConst x; isConst y; reflexivity
              | |- 0 <= bitSlice _ _ _ => eapply bitSlice_nonneg
              | |- bitSlice _ _ _ < 2 ^ _ => eapply bitSlice_upper_bound
              | |- _ < bitwidth ?iset => replace (bitwidth iset) with 64;
                                         [ change 64 with (2 ^ 6) ]
              | |- _ => auto 3
              end.
Qed.


From mathcomp Require Import all_ssreflect.
Set Bullet Behavior "Strict Subproofs".
Require Import Types.

 (** Instructions for a machine to determine recursive inhabitation targets **)
Section RecursiveTargetsMachineInstuctions.
  Variable Constructor: ctor.

  Inductive Instruction: Type :=
  | AddSplitsWithSrcsToCtxt of (@IT Constructor * seq (@IT Constructor) * seq (seq (seq (@IT Constructor) * @IT Constructor)))
  | SplitType of (@IT Constructor).

  Inductive Result: Type :=
  | LengthGroupedSourceTargetPairs of seq (seq (seq (@IT Constructor) * @IT Constructor)).

  (** Enable mathcomp functionalities on instructions **)
  Section InstructionMathcompInstances.
    Fixpoint Instruction2tree (i: Instruction):
      GenTree.tree (@IT Constructor + (seq (@IT Constructor) + seq (seq (seq (@IT Constructor) * @IT Constructor)))) :=
      match i with
      | AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt) =>
        GenTree.Node 0 [:: GenTree.Leaf (inl A);
                          GenTree.Leaf (inr (inl Srcs));
                          GenTree.Leaf (inr (inr Ctxt))]
      | SplitType A => GenTree.Node 1 [:: GenTree.Leaf (inl A) ]
      end.

    Fixpoint Result2tree (r: Result): GenTree.tree (seq (seq (seq (@IT Constructor) * @IT Constructor))) :=
      match r with
      | LengthGroupedSourceTargetPairs Ctxt => GenTree.Node 0 [:: (GenTree.Leaf Ctxt) ]
      end.

    Fixpoint tree2Instruction (t: GenTree.tree (@IT Constructor + (seq (@IT Constructor) + seq (seq (seq (@IT Constructor) * @IT Constructor))))): option Instruction :=
      match t with
      | GenTree.Node n args =>
        match n, args with
        | 0, [:: GenTree.Leaf (inl A); GenTree.Leaf (inr (inl Srcs)); GenTree.Leaf (inr (inr Ctxt))] =>
          Some (AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt))
        | 1, [:: GenTree.Leaf (inl A)] => Some (SplitType A)
        | _, _ => None
        end
      | _ => None
      end.

    Fixpoint tree2Result (t: GenTree.tree (seq (seq (seq (@IT Constructor) * @IT Constructor)))): option Result :=
      match t with
      | GenTree.Node n args =>
        match n, args with
        | 0, [:: GenTree.Leaf Ctxt] => Some (LengthGroupedSourceTargetPairs Ctxt)
        | _, _ => None
        end
      | _ => None
      end.

    Lemma pcan_Instructiontree: pcancel Instruction2tree tree2Instruction.
    Proof. by case => //= [] [] [] //=. Qed.

    Lemma pcan_Resulttree: pcancel Result2tree tree2Result.
    Proof. by case => //= []. Qed.

    Definition Instruction_eqMixin := PcanEqMixin pcan_Instructiontree.
    Canonical Instruction_eqType := EqType Instruction Instruction_eqMixin.
    Definition Instruction_choiceMixin := PcanChoiceMixin pcan_Instructiontree.
    Canonical Instruction_choiceType := ChoiceType Instruction Instruction_choiceMixin.
    Definition Instruction_countMixin := PcanCountMixin pcan_Instructiontree.
    Canonical Instruction_countType := CountType Instruction Instruction_countMixin.
    Definition Result_eqMixin := PcanEqMixin pcan_Resulttree.
    Canonical Result_eqType := EqType Result Result_eqMixin.
    Definition Result_choiceMixin := PcanChoiceMixin pcan_Resulttree.
    Canonical Result_choiceType := ChoiceType Result Result_choiceMixin.
    Definition Result_countMixin := PcanCountMixin pcan_Resulttree.
    Canonical Result_countType := CountType Result Result_countMixin.
  End InstructionMathcompInstances.
End RecursiveTargetsMachineInstuctions.

Arguments Instruction [Constructor].
Arguments AddSplitsWithSrcsToCtxt [Constructor].
Arguments SplitType [Constructor].
Hint Constructors Instruction.

Arguments Result [Constructor].
Arguments LengthGroupedSourceTargetPairs [Constructor].
Hint Constructors Result.

Notation "[ 'split' A ]" := (SplitType A) (at level 0): it_scope.
Notation "[ 'add_splits_with_srcs' Srcs => A  'to' Ctxt ]" :=
  (AddSplitsWithSrcsToCtxt (A, Srcs, Ctxt)) (at level 0): it_scope.
Notation "[ 'splits' Delta ]" := (LengthGroupedSourceTargetPairs Delta) (at level 0): it_scope.

(** A machine to determine recursive inhabitation targets **)
Reserved Notation "A '~~>' B" (at level 70, no associativity).
Section RecursiveTargetsMachine.
  Variable Constructor: ctor.

  Definition addToHead {T: Type} (x: T) (xss: seq (seq T)): seq (seq T) :=
    match xss with
    | [::] => [:: [:: x]]
    | [:: xs & xss] => [:: [:: x & xs] & xss]
    end.

  (** Semantics of the recursive target machine **)
  Inductive Semantics : @Instruction Constructor -> @Result Constructor -> Prop :=
  | step__split : forall A Delta,
      [add_splits_with_srcs [::] => A to [:: [::]] ] ~~> [splits Delta ] ->
      [split A ] ~~> [splits Delta ]
  | step__splitCtor : forall c A Gamma Delta,
      [add_splits_with_srcs Gamma => Ctor c A to Delta ] ~~> [splits (addToHead (Gamma, Ctor c A) Delta) ]
  | step__splitProd : forall A B Gamma Delta,
      [add_splits_with_srcs Gamma => A \times B to Delta ] ~~> [splits (addToHead (Gamma, A \times B) Delta) ]
  | step__splitArr : forall A B Gamma Delta Delta',
      [add_splits_with_srcs [:: A & Gamma] => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => A -> B to Delta ]
        ~~> [splits if isOmega B then Delta else [:: [:: (Gamma, A -> B)] & Delta'] ]
  | step__splitOmega: forall Gamma Delta,
      [add_splits_with_srcs Gamma => Omega to Delta ] ~~> [splits Delta ]
  | step__splitInterCtor: forall c A B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (Ctor c A) \cap B to Delta ]
        ~~> [splits (addToHead (Gamma, Ctor c A) Delta') ]
  | step__splitInterProd: forall A1 A2 B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (A1 \times A2) \cap B to Delta ]
        ~~> [splits (addToHead (Gamma, A1 \times A2) Delta') ]
  | step__splitInterArr: forall A1 A2 B Gamma Gamma' Delta1 Delta2 Delta3,
      [add_splits_with_srcs Gamma => B to Delta1 ] ~~> [splits [:: Gamma' & Delta2] ] ->
      [add_splits_with_srcs [:: A1 & Gamma] => A2 to Delta2 ] ~~> [splits Delta3 ] ->
      [add_splits_with_srcs Gamma => (A1 -> A2) \cap B to Delta1 ]
        ~~> [splits if isOmega A2 then [:: Gamma' & Delta2] else [:: [:: (Gamma, A1 -> A2) & Gamma'] & Delta3] ]
  | step__splitInterAssoc: forall A1 A2 B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => A1 \cap (A2 \cap B) to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => (A1 \cap A2) \cap B to Delta ] ~~> [splits Delta' ]
  | step__splitInterOmega: forall B Gamma Delta Delta',
      [add_splits_with_srcs Gamma => B to Delta ] ~~> [splits Delta' ] ->
      [add_splits_with_srcs Gamma => Omega \cap B to Delta ] ~~> [splits Delta' ]
  where "p1 ~~> p2" := (Semantics p1 p2).

  Definition premisses_Semantics {i} {p} (s: i ~~> p) :=
    let diag i p :=
        match i, p with
        | [split A], [splits Delta]  =>
          forall (X: Result -> Prop),
            (forall Delta', [add_splits_with_srcs [::] => A to [:: [::]] ] ~~> [splits Delta' ] ->
                          X [splits Delta']) ->
            X [splits Delta]
        | [add_splits_with_srcs Gamma => Ctor c A to Delta ], [splits Delta'] =>
          forall (X: Result -> Prop),
            X [splits (addToHead (Gamma, Ctor c A) Delta) ] ->
            X [splits Delta']
        | [add_splits_with_srcs Gamma => A \times B to Delta ], [splits Delta] =>
          forall (X: Result -> Prop),
            X [splits (addToHead (Gamma, A \times B) Delta) ] ->
            X [splits Delta]
        | [add_splits_with_srcs Gamma => A -> B to Delta ], [splits Delta] =>

            ~~> [splits if isOmega B then Delta else [:: [:: (Gamma, A -> B)] & Delta'] ]
        | [add_splits_with_srcs Gamma => Omega to Delta ] ~~> [splits Delta ]
        | [add_splits_with_srcs Gamma => (Ctor c A) \cap B to Delta ]
            ~~> [splits (addToHead (Gamma, Ctor c A) Delta') ]
        | [add_splits_with_srcs Gamma => (A1 \times A2) \cap B to Delta ]
            ~~> [splits (addToHead (Gamma, A1 \times A2) Delta') ]
        | [add_splits_with_srcs Gamma => (A1 -> A2) \cap B to Delta1 ]
            ~~> [splits if isOmega A2 then [:: Gamma' & Delta2] else [:: [:: (Gamma, A1 -> A2) & Gamma'] & Delta3] ]
        |  [add_splits_with_srcs Gamma => (A1 \cap A2) \cap B to Delta ] ~~> [splits Delta' ]
        | [add_splits_with_srcs Gamma => Omega \cap B to Delta ] ~~> [splits Delta' ]
        | _, _  => True
        end in
    match s in i ~~> p return diag i p with
    | step__split A Delta prf => fun X k => k Delta prf
    | step__splitCtor c A Gamma Delta => fun X k => k
    | _ => I
    end.

End RecursiveTargetsMachine.

Arguments Semantics [Constructor].
Arguments step__split [Constructor A Delta].
Arguments step__splitCtor [Constructor c A Gamma Delta].
Arguments step__splitProd [Constructor A B Gamma Delta].
Arguments step__splitArr [Constructor A B Gamma Delta Delta'].
Arguments step__splitOmega [Constructor Gamma Delta].
Arguments step__splitInterCtor [Constructor c A B Gamma Delta Delta'].
Arguments step__splitInterProd [Constructor A1 A2 B Gamma Delta Delta'].
Arguments step__splitInterArr [Constructor A1 A2 B Gamma Gamma' Delta1 Delta2 Delta3].
Arguments step__splitInterAssoc [Constructor A1 A2 B Gamma Delta Delta'].
Arguments step__splitInterOmega [Constructor B Gamma Delta Delta'].
Hint Constructors Semantics.
Notation "p1 ~~> p2" := (Semantics p1 p2).

Arguments premisses_Semantics [Constructor] [i p].

Ltac foo :=
  match goal with
  |[ x : Result |- _ ~~> ?x -> _] =>
   let stp := fresh "step" in
   let r := fresh "result" in
   move: x => [] r stp; apply: (premisses_Semantics stp); eauto; move: r
  | [|- _ ~~> _ -> _] =>
    let stp := fresh "step" in
    move => stp; apply: (premisses_Semantics stp); eauto; move: stp
  | [|- forall _, _] =>
    let x := fresh "x" in
    move => x; foo; move: x
  | [|- _] => idtac
  end.

Section RecursiveTargetsMachineSpec.
  Variable Constructor: ctor.
  Implicit Type p: @Instruction Constructor.
  Implicit Type r: @Result Constructor.

  Lemma Semantics_functional: forall p r1 r2, p ~~> r1 -> p ~~> r2 -> r1 = r2.
  Proof.
    move => p r1 r2 pr1.
    move: r2.
    elim: p r1 / pr1 => //.
    - foo.
    - foo.
    - foo.
      move => ?.
      move => ?.
      move => ?.move => ?.
      move => [] r stp.
      apply: (premisses_Semantics stp).

      move => ? ? ? ? [] ? pr2.
        by apply: (premisses_Semantics pr2); eauto.
    - move => ? ? ? ? [] ? pr2.
        by apply: (premisses_Semantics pr2).
    -
    -


Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Common.

Set Implicit Arguments.

Section helpers.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.

  Local Ltac induction_str_len str :=
    let len := fresh "len" in
    set (len := length str);
      generalize (eq_refl : length str = len);
      clearbody len; revert str;
      induction len; intros str ?.

  Local Ltac t :=
    repeat match goal with
             | [ |- ?x = ?x ] => reflexivity
             | [ H : is_true false |- _ ] => solve [ inversion H ]
             | [ H : false = true |- _ ] => solve [ inversion H ]
             | _ => progress rewrite ?take_length, ?drop_length
             | [ H : _ |- _ ] => progress rewrite ?take_length, ?drop_length, ?drop_take, ?drop_0, ?NPeano.Nat.sub_0_r, ?NPeano.Nat.sub_1_r in H
             | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H'
             | [ H : length ?str = 0, H' : is_true (take _ (drop _ ?str) ~= [ _ ])%string_like |- _ ]
               => apply length_singleton in H'
             | [ H : get 0 _ = None |- _ ] => apply no_first_char_empty in H
             | _ => progress simpl in *
             | _ => progress subst
             | _ => setoid_rewrite Bool.andb_true_iff
             | [ H : (_ && _ = true)%bool |- _ ] => apply Bool.andb_true_iff in H
             | _ => progress specialize_by omega
             | _ => progress specialize_by assumption
             | _ => progress split_and
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
             | [ H : context[if ?e then _ else _] |- _ ] => destruct e eqn:?
             | _ => solve [ eauto with nocore ]
             | [ H : context[drop _ (drop _ _)] |- _ ] => setoid_rewrite drop_drop in H
             | [ |- appcontext[match get 0 (take _ _) with _ => _ end] ] => rewrite !get_take_lt by omega
             | [ H : context[(_ + 1)%nat] |- _ ] => setoid_rewrite NPeano.Nat.add_1_r in H
             | [ |- context[get 0 ?str] ] => erewrite (proj1 (get_0 str _)) by eassumption
             | [ |- context[get 0 (take 0 ?str)] ] => rewrite (has_first_char_nonempty (take 0 str))
                                                     by (rewrite take_length; reflexivity)
             | [ H : context[Compare_dec.zerop ?x] |- _ ] => destruct (Compare_dec.zerop x)
             | _ => progress intros
             | _ => omega
             | [ H : context[match get 0 ?str with _ => _ end] |- _ ] => destruct (get 0 str) eqn:?
             | _ => progress unfold is_true in *
           end.

  Lemma paren_balanced_hiding'_prefix (str : String) (n n' level : nat)
        (H_hiding : paren_balanced_hiding' (take n str) level)
        (H_hiding_prefix : paren_balanced' (take n' str) level)
        {ch}
        (Hlt : n' < n)
        (H_ch : (take 1 (drop n' str) ~= [ ch ])%string_like)
        (H_bin_op : is_bin_op ch)
  : False.
  Proof.
    generalize dependent level.
    generalize dependent n'.
    generalize dependent n.
    induction_str_len str.
    { t. }
    { specialize (IHlen (drop 1 str)).
      specialize_by ltac:(rewrite drop_length; omega).
      intros ?????.
      rewrite paren_balanced_hiding'_recr, paren_balanced'_recr.
      unfold paren_balanced_hiding'_step, paren_balanced'_step.
      destruct n' as [|n'].
      { t. }
      { specialize (IHlen (pred n) n').
        t. } }
  Qed.
End helpers.