From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable tP_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable sQ_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_inequalitysymmetric_1 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_2 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_NCorder_3 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_betweennotequal_11 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_NChelper_12 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable proposition_11B_13 : (forall A B C P : Universe, (exists X : Universe, ((betS_ A C B /\ ~(col_ A B P)) -> (per_ A C X /\ tS_ X A B P)))).
Variable defoppositeside_14 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_15 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_collinearorder_16 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_NCdistinct_17 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_layoff_18 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_ray5_19 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_collinear4_20 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_9_5_21 : (forall A B C P Q R : Universe, ((tS_ P A B C /\ (out_ R Q P /\ col_ A B R)) -> tS_ Q A B C)).
Variable lemma_rayimpliescollinear_22 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_ray2_23 : (forall A B C : Universe, (out_ A B C -> A <> B)).
Variable axiom_betweennesssymmetry_24 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable proposition_31short_25 : (forall A B C D : Universe, (exists X Y Z : Universe, ((betS_ B D C /\ ~(col_ B C A)) -> (betS_ X A Y /\ (congA_ X A D A D C /\ (par_ X Y B C /\ (betS_ X Z C /\ betS_ A Z D))))))).
Variable lemma_collinearparallel_26 : (forall A B C Xc Xd : Universe, ((par_ A B Xc Xd /\ (col_ Xc Xd C /\ C <> Xd)) -> par_ A B C Xd)).
Variable lemma_parallelsymmetric_27 : (forall A B C D : Universe, (par_ A B C D -> par_ C D A B)).
Variable lemma_triangletoparallelogram_28 : (forall A C D E F : Universe, (exists X : Universe, ((par_ D C E F /\ col_ E F A) -> (pG_ A X C D /\ col_ E F X)))).
Variable lemma_8_2_29 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Variable lemma_collinearright_30 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_equaltorightisright_31 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ congA_ Xa Xb Xc A B C) -> per_ Xa Xb Xc)).
Variable defrightangle_32 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_33 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable lemma_congruencesymmetric_34 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable defparallelogram_35 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_36 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_paralleldef2B_37 : (forall A B C D : Universe, (par_ A B C D -> tP_ A B C D)).
Variable deftarski_parallel_38 : (forall A B C D : Universe, (tP_ A B C D -> (A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))))).
Variable deftarski_parallel2_39 : (forall A B C D : Universe, ((A <> B /\ (C <> D /\ (~(meet_ A B C D) /\ oS_ C D A B))) -> tP_ A B C D)).
Variable lemma_planeseparation_40 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_oppositesidesymmetric_41 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Variable lemma_samenotopposite_42 : (forall A B C D : Universe, (oS_ A B C D -> ~(tS_ A C D B))).
Variable lemma_3_7a_43 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A C D)).
Variable defsameside_44 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_45 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable lemma_3_6a_46 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ A C D) -> betS_ B C D)).
Variable lemma_parallelNC_47 : (forall A B C D : Universe, (par_ A B C D -> (~(col_ A B C) /\ (~(col_ A C D) /\ (~(col_ B C D) /\ ~(col_ A B D)))))).
Variable proposition_34_48 : (forall A B C D : Universe, (pG_ A C D B -> (cong_ A B C D /\ (cong_ A C B D /\ (congA_ C A B B D C /\ (congA_ A B D D C A /\ cong_3_ C A B B D C)))))).
Variable lemma_congruenceflip_49 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_congruencetransitive_50 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_equalanglessymmetric_51 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable defsquare_52 : (forall A B C D : Universe, (sQ_ A B C D -> (cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))))).
Variable defsquare2_53 : (forall A B C D : Universe, ((cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))) -> sQ_ A B C D)).
Variable lemma_PGsymmetric_54 : (forall A B C D : Universe, (pG_ A B C D -> pG_ C D A B)).
Variable lemma_PGflip_55 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B A D C)).

Theorem proposition_46_56 : (forall A B R : Universe, (exists X Y : Universe, ((A <> B /\ ~(col_ A B R)) -> (sQ_ A B X Y /\ (tS_ Y A B R /\ pG_ A B X Y))))).
Proof.
  time tac.
Qed.

End FOFProblem.


From Complexity Require Import TM.PrettyBounds.PrettyBounds.
From Complexity Require Import TM.PrettyBounds.BaseCode.
From Undecidability Require Import LM_heap_def TM.PrettyBounds.MaxList.

From Undecidability.TM.L Require Import Alphabets CaseCom StepTM M_LHeapInterpreter.
From Complexity.L.AbstractMachines Require Import SizeAnalysisStep LMBounds.

From Undecidability Require Import UpToC UpToCNary.

Lemma sizeT_ge_1 t:
  1 <= sizeT t.
Proof.
  destruct t;cbn. all:nia.
Qed.

Lemma size_sizeT_le t:
  size t <= 2* sizeT t.
Proof.
  destruct t.
  1:rewrite size_Var.
  all:cbv - [plus mult]. all:nia.
Qed.

Lemma size_le_sizeP P:
  size P <= 3 * sizeP P.
Proof.
  induction P as [ | t P].
  {now cbv. }
  setoid_rewrite encodeList_size_cons. rewrite IHP.
  unfold sizeP;cbn. rewrite size_sizeT_le.
  specialize (sizeT_ge_1 t). nia.
Qed.

Lemma sizeT_le_size t:
  sizeT t <= size t.
Proof.
  destruct t.
  1:rewrite LMBounds.size_Var.
  all:cbv - [plus mult]. all:nia.
Qed.

Lemma sizeP_le_size P:
  sizeP P <= size P.
Proof.
  induction P as [ | t P].
  {now cbv. }
  setoid_rewrite BaseCode.encodeList_size_cons. rewrite <- IHP.
  unfold sizeP;cbn. rewrite sizeT_le_size. nia.
Qed.

(*
Lemma sizeH_le H:
  size H <=
Proof.
  induction P as [ | t P].
  {now cbv. }
  setoid_rewrite encodeList_size_cons. rewrite IHP.
  unfold sizeP;cbn. rewrite size_sizeT_le.
  specialize (sizeT_ge_1 t). nia.
Qed.
 *)

Lemma size_list (sig X : Type) (cX : codable sig X) (xs : list X):
  size xs = length xs + sumn (map size xs) + 1.
Proof.
  induction xs. now rewrite encodeList_size_nil.
  rewrite encodeList_size_cons. cbn [length map sumn]. nia.
Qed.

Lemma size_list_le_bound (sig X : Type) (cX : codable sig X) (xs : list X) c:
  (forall x, x el xs -> size x <= c)
  -> size xs <= length xs * (c+1) + 1.
Proof.
  intros H. rewrite size_list. rewrite sumn_le_bound.
  2:{ intros ?. rewrite in_map_iff. intros (?&<-&?). eauto. }
  rewrite map_length. nia.
Qed.

Lemma size_HClos_le (g : HClos):
  size g = fst g + size (snd g) + 1.
Proof.
  rewrite Encode_Clos_hasSize. destruct g as [a P];cbn.
  replace (Encode_list_size _ P) with (size P). nia. apply Encode_list_hasSize.
Qed.

Lemma heap_greatest_address2_bound H c:
  (forall P a, Some (P,a) el H -> a <= c) -> LM_Lookup_nice.heap_greatest_address2 H <= c.
Proof.
  induction H as [ | [ [] | ] ]. all:cbn.
  -easy.
  -intros H'. rewrite IHlist. rewrite H' with (a:=n). all:now auto.
  -eauto.
Qed.

Lemma Heap_size_nicer P0 (T V : list HClos) (H : Heap) i :
  pow step i ([(0,P0)],[],[]) (T,V,H)
  -> size H <= i * (6*i + 3*sizeP P0 + 4*i) + 1.
Proof.
  intros H0.
  specialize SizeAnalysisStep.size_clos with (1:=H0) as Hsize.
  unfold Encode_Heap, sigHeap. erewrite size_list_le_bound with (xs:=H).
  2:{
    intros [[[a' P'] beta] | ] H1. 2:cbv.
    -apply Hsize in H1. 2:easy. unfold sigHEntr,HEntr,Encode_HEntr,sigHEntr',Encode_HEntr'. rewrite Encode_option_hasSize.
    cbn. rewrite Encode_pair_hasSize;cbn. rewrite size_HClos_le. cbn.
    rewrite size_le_sizeP, Encode_nat_hasSize. destruct H1 as (->&->&->&_). reflexivity.
    -nia.
  }
  rewrite length_H. 2:eassumption. 2:easy. cbn [length]. nia.
Qed.

Lemma Heap_size_nicer2':
  {c : nat |
    forall P0 (T V : list HClos) (H : Heap) i,
      pow step i ([(0,P0)],[],[]) (T,V,H)
    -> size H <=(c) i * (i + sizeP P0) + 1}.
Proof.
  eexists ?[c]. intros P0 T V H i H0.
  specialize SizeAnalysisStep.size_clos with (1:=H0) as Hsize.
  unfold Encode_Heap, sigHeap. erewrite size_list_le_bound with (xs:=H).
  2:{
    intros [[[a' P'] beta] | ] H1. 2:cbv.
    -apply Hsize in H1. 2:easy. unfold sigHEntr,HEntr,Encode_HEntr,sigHEntr',Encode_HEntr'. rewrite Encode_option_hasSize.
    cbn. rewrite Encode_pair_hasSize;cbn. rewrite size_HClos_le. cbn.
    rewrite size_le_sizeP, Encode_nat_hasSize. destruct H1 as (->&->&->&_). reflexivity.
    -nia.
  }
  rewrite length_H. 2:eassumption. 2:easy.
  unfold sizeP.
  [c]:exact 8. cbn;hnf. ring_simplify. nia.
Qed.

(*
Lemma Heap_size_nicer2:
  {c : nat |
    forall P0 (T V : list HClos) (H : Heap) i,
      pow step i ([(0,P0)],[],[]) (T,V,H)
    -> size H <=(c) (i + 1 + sizeP P0) * (i + 1)}.
Proof.
  eexists ?[c]. intros P0 T V H i H0.
  specialize SizeAnalysisStep.size_clos with (1:=H0) as Hsize.
  unfold Encode_Heap, sigHeap. erewrite size_list_le_bound with (xs:=H).
  2:{
    intros [[[a' P'] beta] | ] H1. 2:cbv.
    -apply Hsize in H1. 2:easy. unfold sigHEntr,HEntr,Encode_HEntr,sigHEntr',Encode_HEntr'. rewrite Encode_option_hasSize.
    cbn. rewrite Encode_pair_hasSize;cbn. rewrite size_HClos_le. cbn.
    rewrite size_le_sizeP, Encode_nat_hasSize. destruct H1 as (->&->&->&_). reflexivity.
    -nia.
  }
  rewrite length_H. 2:eassumption. 2:easy.
  [c]:exact 4. cbn;hnf. ring_simplify. nia.
Qed. *)

Import ZArith.

Lemma dominatedWith_mult_into_r c c' x y:
  x <=(c) (c' * y) ->
  x <=(c'*c) y.
Proof.
  intros. unfold dominatedWith in *. rewrite H. lia.
Qed.

Lemma Step_steps_nicer :
  {c : nat |
    forall P0 (T V : list HClos) (H : Heap) i,
      pow step i ([(0,P0)],[],[]) (T,V,H)
      -> Step_steps T V H <=(c) (i + 1) * (i + sizeP P0 ) * sizeP P0}.
Proof.
  eexists. intros P0 T V H i H0. eapply dominatedWith_trans with (c':=?[c]). eapply (proj2_sig LM.Step_steps_nice).
  destruct T as [ | [a P] T].
  2:{
    specialize SizeAnalysisStep.size_clos with (1:=H0) as Hsize.
    repeat setoid_rewrite size_le_sizeP. rewrite !Encode_nat_hasSize.
    erewrite size_list_le_bound with (xs:=V).
    2:{ intros [a' P'] ?. rewrite size_HClos_le. cbn.
        rewrite size_le_sizeP.
        edestruct Hsize with (P:=P') (a:=a') as [(->&->&_) _]. easy. now eauto. reflexivity.
    }
    assert (Htmp:=proj2_sig Heap_size_nicer2' _ _ _ _ _ H0). hnf in Htmp. rewrite Htmp. clear Htmp.
    rewrite heap_greatest_address2_bound.
    2:{ intros [] ?. edestruct Hsize as [_ H']. easy. apply H'. }
    specialize Hsize with (P:=P) (a := a) as [(-> & -> &_) _]. 1,2:easy.
    rewrite Nat.max_id.
    specialize length_TV with (1:=H0) (2:=ltac:(easy) : forall c : _, False -> c = None) as H_TV. cbn in H_TV.
    assert (length V <= i) as -> by nia.
    specialize length_H  with (1:=H0) as ->. 2:easy.
    cbn [length]. rewrite Nat.add_0_l.
    unfold sizeP. set (sP:= sumn _).
    clear dependent T. clear dependent V. clear dependent H.  clear dependent P. clear dependent a.
    ring_simplify.
    eapply dominatedWith_mult_into_r with (c':=proj1_sig Heap_size_nicer2' + 1).
    set (c0:=proj1_sig _).
    repeat simple eapply dominatedWith_add. all:instantiate (1:=14);hnf. all:lia.
  }
  cbn. unfold sizeP. hnf. lia.
Qed.

Lemma dominatedWith_add_split (c x1 x2 y1 y2 : nat) :
  x1 <=(c) y1 -> x2 <=(c) y2 -> x1 + x2 <=(c) y1 + y2.
Proof.
  unfold dominatedWith. nia.
Qed.

Lemma Loop_steps_nice' :
  {c : nat |
    forall P0 (T V : list HClos) (H : Heap) k i,
    pow step i ([(0,P0)],[],[]) (T,V,H)
      -> Loop_steps T V H k <=(c) (k + 1) * ((k + i + 1) * (k + i + sizeP P0 ) * sizeP P0)}.
Proof.
  evar (c:nat).
  eexists c. intros P0 T V H k.
  induction k in T,V,H |-*.
  all:intros i Hi.
  all:cbn - [Step_steps Nat.pow step_fun plus].
  -eapply dominatedWith_mono_c. eapply dominatedWith_trans. now apply (proj2_sig Step_steps_nicer). apply dominatedWith_solve. now cbn.
  ring_simplify. shelve.
  -destruct (step_fun (T, V, H)) as [[[T' V'] H'] | ]  eqn:Hstep.
  2:{ eapply dominatedWith_mono_c. eapply dominatedWith_trans. now apply (proj2_sig Step_steps_nicer). apply dominatedWith_solve. now cbn.
      ring_simplify. shelve. }
  destruct is_halt_state.
  1:{ eapply dominatedWith_mono_c. all:repeat simple apply dominatedWith_add.
      1: apply dominatedWith_solve; now unfold sizeP;cbn.
      1,2: eapply dominatedWith_trans;[eapply (proj2_sig Step_steps_nicer) | ].
      easy. 2:{eapply pow_add. eexists;split. easy. rewrite <- rcomp_1. now apply step_fun_step. }
      1,2: apply dominatedWith_solve;now cbn. ring_simplify. shelve.
  }

  set (tmp:= (S k + i + 1) * (S k + i + sizeP P0) * sizeP P0).
  replace ( (S k + 1) * tmp) with (tmp + (k+1) * tmp) by nia.
  apply dominatedWith_add_split;subst tmp.
  { eapply dominatedWith_mono_c. eapply dominatedWith_add.
    -apply dominatedWith_solve. now unfold sizeP;cbn.
    -eapply dominatedWith_trans. now apply (proj2_sig Step_steps_nicer). apply dominatedWith_solve. now cbn.
    -ring_simplify. shelve.
  }
  replace (S k + i) with (k + (i+1)) by nia.
  eapply IHk.
  eapply pow_add. eexists;split. easy. rewrite <- rcomp_1. now apply step_fun_step.
  Unshelve.
  [c]:exact (2 * proj1_sig Step_steps_nicer + 1). all:subst c;nia.
Qed.

Lemma Loop_steps_nice :
  (fun '(P0,k) => Loop_steps [(0,P0)] [] [] k)
  <=c (fun '(P0,k) => (k + 1) * (k + 1) * (k + sizeP P0 ) * sizeP P0).
Proof.
  eexists. intros [? ?].
  assert (H':= proj2_sig Loop_steps_nice'). cbn beta in H'. unfold dominatedWith in H'.
  specialize H' with (i:=0). cbn [plus] in H'.
  rewrite H'. 2:reflexivity. rewrite !Nat.mul_assoc,Nat.add_0_r. reflexivity.
Qed.


(* 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                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Group_util.
Section Free_group_def.
Variable V : SET.

Inductive FG : Type :=
  | Var : V -> FG
  | Law : FG -> FG -> FG
  | Unit : FG
  | Inv : FG -> FG.

Inductive eqFG : FG -> FG -> Prop :=
  | eqFG_Var : forall x y : V, Equal x y -> (eqFG (Var x) (Var y):Prop)
  | eqFG_law :
      forall x x' y y' : FG,
      eqFG x x' -> eqFG y y' -> (eqFG (Law x y) (Law x' y'):Prop)
  | eqFG_law_assoc :
      forall x y z : FG, eqFG (Law (Law x y) z) (Law x (Law y z)):Prop
  | eqFG_law0r : forall x : FG, eqFG (Law x Unit) x:Prop
  | eqFG_inv : forall x y : FG, eqFG x y -> eqFG (Inv x) (Inv y)
  | eqFG_invr : forall x : FG, eqFG (Law x (Inv x)) Unit
  | eqFG_refl : forall x : FG, eqFG x x:Prop
  | eqFG_sym : forall x y : FG, eqFG x y -> (eqFG y x:Prop)
  | eqFG_trans : forall x y z : FG, eqFG x y -> eqFG y z -> (eqFG x z:Prop).
Hint Resolve eqFG_Var eqFG_law eqFG_law_assoc eqFG_law0r eqFG_invr eqFG_refl:
  algebra.
Hint Immediate eqFG_sym: algebra.

Lemma eqFG_Equiv : equivalence eqFG.
red in |- *.
split; [ try assumption | idtac ].
exact eqFG_refl.
red in |- *.
split; [ try assumption | idtac ].
exact eqFG_trans.
exact eqFG_sym.
Qed.

Definition FG_set := Build_Setoid eqFG_Equiv.

Definition FreeGroup : GROUP.
apply (BUILD_GROUP (E:=FG_set) (genlaw:=Law) (e:=Unit) (geninv:=Inv)).
exact eqFG_law.
exact eqFG_law_assoc.
exact eqFG_law0r.
exact eqFG_inv.
exact eqFG_invr.
Defined.
Section Universal_prop.
Variable G : GROUP.
Variable f : Hom V G.

Fixpoint FG_lift_fun (p : FreeGroup) : G :=
  match p with
  | Var v => f v
  | Law p1 p2 => sgroup_law _ (FG_lift_fun p1) (FG_lift_fun p2)
  | Unit => monoid_unit G
  | Inv p1 => group_inverse G (FG_lift_fun p1)
  end.

Definition FG_lift : Hom FreeGroup G.
apply (BUILD_HOM_GROUP (G:=FreeGroup) (G':=G) (ff:=FG_lift_fun)).
intros x y H'; try assumption.
elim H'; simpl in |- *; auto with algebra.
intros x0 y0 z H'0 H'1 H'2 H'3; try assumption.
apply Trans with (FG_lift_fun y0); auto with algebra.
simpl in |- *; auto with algebra.
simpl in |- *; auto with algebra.
Defined.

Definition FG_var : Hom V FreeGroup.
apply (Build_Map (A:=V) (B:=FreeGroup) (Ap:=Var)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Lemma FG_comp_prop :
 Equal f (comp_hom (FG_lift:Hom (FreeGroup:SET) G) FG_var).
simpl in |- *.
red in |- *.
simpl in |- *.
auto with algebra.
Qed.
End Universal_prop.
End Free_group_def.
Hint Resolve FG_comp_prop: algebra.


Require Import Core.Core Core.Tactics.
Require Import AbstractSpec.
Require Import VST.floyd.proofauto.
Require Import StructTact.StructTactics.

Notation value_until b j l := (value (Z_of_string_loop' (sublist 0 j l) 0 1 b)).

Definition ASN1_INTMAX_MAX := Int64.max_signed.
Definition upper_boundary := Z.div ASN1_INTMAX_MAX 10.
Definition last_digit_max := Zmod ASN1_INTMAX_MAX 10.
Definition last_digit_max_minus := last_digit_max + 1.

(* Lemmas about bounded *)
Ltac Zbool_to_Prop := try (rewrite Z.leb_le ||
                           rewrite Z.leb_gt ||
                           rewrite Z.eqb_eq ||
                           rewrite Z.eqb_neq).

Lemma is_digit_to_Z : forall c, is_digit c = true -> 0 <= Z_of_char c <= 9.
Proof.
  unfold is_digit, Z_of_char.
  intro.
  rewrite andb_true_iff in *.
  repeat Zbool_to_Prop.
  unfold zero_char, nine_char.
  nia.
Qed.

Lemma app_is_digit : forall ls j,
    0 <= j < Zlength ls ->
    (forall i : Z, 0 <= i < j -> is_digit (Znth i ls) = true) ->
    is_digit (Znth j ls) = true ->
    forall i0 : Z, 0 <= i0 < j + 1 -> is_digit (Znth i0 ls) = true.
Proof.
  intros.
  destruct (zle j i0).
  - replace i0 with j by nia.
    eassumption.
  - eapply H0. nia.
Qed.

Lemma sign_not_digit : forall  i, is_sign i = true -> is_digit i = false.
Proof.
  intros.
  unfold is_sign, is_digit in *.
  unfold zero_char, plus_char, minus_char, nine_char in *.
  rewrite andb_false_iff; do 2 rewrite Z.leb_gt.
  rewrite orb_true_iff in H; do 2 rewrite Z.eqb_eq in H.
  lia.
Qed.

Lemma digit_not_sign : forall i, is_digit i = true -> is_sign i = false.
Proof.
  intros.
  unfold is_sign, is_digit in *.
  unfold zero_char, plus_char, minus_char, nine_char in *.
  rewrite orb_false_iff; do 2 rewrite Z.eqb_neq.
  rewrite andb_true_iff in H; do 2 rewrite Z.leb_le in H.
  lia.
Qed.

Lemma bounded_bool_to_Prop :
  forall v, bounded v = true ->
       Int64.min_signed <= v <= Int64.max_signed.
Proof.
  unfold bounded.
  intro.
  rewrite andb_true_iff in *.
  repeat Zbool_to_Prop.
  auto.
Qed.

Lemma bounded'_bool_to_Prop :
  forall v, bounded' false v = true ->
       0<= v <= Int64.max_signed + 1.
Proof.
  unfold bounded'.
  intro.
  rewrite andb_true_iff in *.
  repeat Zbool_to_Prop.
  auto.
Qed.

Lemma lt_inv64:
 forall i j,
   Int64.lt i j = true -> (Int64.signed i < Int64.signed j)%Z.
Proof.
intros.
unfold Int64.lt in H. if_tac in H; inv H. auto.
Qed.

Lemma lt_false_inv64:
  forall i j,
    Int64.lt i j = false -> (Int64.signed i >= Int64.signed j)%Z.
Proof.
  intros.
  unfold Int64.lt in H. if_tac in H; inv H. auto.
Qed.

Lemma lt_ub_to_next_bounded'_bool : forall v d,
    0 <= d <= 9 ->
    0 <= v < upper_boundary ->
    bounded' false (v*10 + d) = true /\
    bounded' false (v*10) = true /\
    bounded' false v = true.
Proof.
  unfold upper_boundary.
  unfold bounded'.
  intros.
  repeat rewrite andb_true_iff in *.
  repeat Zbool_to_Prop.
  cbn in *.
  nia.
Qed.

Lemma lt_ub_to_bounded'_Prop : forall v d,
    0 <= d <= 9 -> (* is digit *)
    0 <= v < upper_boundary ->
    0 <= v <= Int64.max_signed + 1.
Proof.
  unfold upper_boundary.
  unfold bounded'.
  intros.
  cbn in *.
  nia.
Qed.

Lemma lt_ub_to_next_bounded'_Prop : forall v d,
    0 <= d <= 9 -> (* is digit *)
    0 <= v < upper_boundary ->
    0 <= v * 10 + d <= Int64.max_signed + 1 /\
    0 <= v * 10 <= Int64.max_signed + 1.
Proof.
  unfold upper_boundary.
  unfold bounded'.
  intros.
  cbn in *.
  nia.
Qed.

Definition upper_boundary_int := (
         (Int64.divs
            (Int64.shru (Int64.not (Int64.repr (Int.signed (Int.repr 0))))
                        (Int64.repr (Int.unsigned (Int.repr 1))))
            (Int64.repr (Int.signed (Int.repr 10))))).

Lemma lt_ub_to_Z1 : forall v,
    Int64.min_signed <= v <= Int64.max_signed ->
    Int64.lt (Int64.repr v) upper_boundary_int = true ->
    v < upper_boundary.
  Proof.
    intros v B Lt.
    eapply lt_inv64 in Lt.
  rewrite Int64.signed_repr in *.
  replace (Int64.signed upper_boundary_int) with upper_boundary
   in Lt by normalize.
  all: eassumption.
Qed.

Lemma upper_boundary_int_repr:
  upper_boundary_int =
  Int64.repr 922337203685477580.
Proof.
  reflexivity.
Qed.

Lemma lt_ub_to_Z2 :  forall v,
    Int64.min_signed <= v <= Int64.max_signed ->
    Int64.lt (Int64.repr v) upper_boundary_int = false ->
    v >= upper_boundary.
Proof.
  intros.
  cbn in *.
  unfold Int64.lt in H0.
  destruct zlt in H0; [discriminate|].
  rewrite upper_boundary_int_repr in g.
  do 2 rewrite Int64.signed_repr in g; cbn; lia.
Qed.

Lemma lt_ub_to_Z3 :  forall v,
    0 <= v <= Int64.max_signed ->
    Int64.eq (Int64.repr v) upper_boundary_int = true ->
    v = upper_boundary.
Proof.
  intros.
  unfold Int64.eq in H0.
  destruct zeq in H0; [|discriminate].
  rewrite upper_boundary_int_repr in e.
  replace (Int64.unsigned (Int64.repr 922337203685477580))
    with 922337203685477580 in e by reflexivity.
  rewrite Int64.unsigned_repr in e; cbn in *; lia.
Qed.

Definition last_digit_max_minus_int :=
   (Int64.add
      (Int64.mods (Int64.shru (Int64.not (Int64.repr 0))
                              (Int64.repr 1))
                  (Int64.repr 10))
      Int64.one).

Lemma last_digit_max_minus_int_repr :
  last_digit_max_minus_int =
  Int64.repr (8).
Proof.
  reflexivity.
Qed.

Lemma lt_ub_to_Z4 :  forall i,
    0 <= Byte.signed i <= Byte.max_unsigned ->
    Int64.lt last_digit_max_minus_int
             (Int64.repr (Int.signed (Int.sub (Int.repr (Byte.signed i))
                                              (Int.repr 48)))) = true ->
    last_digit_max_minus < (Byte.signed i - 48).
Proof.
  intros.
  rewrite last_digit_max_minus_int_repr in H0.
  unfold Int64.lt, Int.sub in H0; destruct zlt in H0; [|discriminate].
  replace (Int64.signed (Int64.repr 8)) with 8 in l by reflexivity;
    replace (Int.unsigned (Int.repr 48)) with 48 in l by reflexivity.
  pose proof Byte.signed_range i.
  rewrite Int.unsigned_repr in l by (cbn in *; lia).
  rewrite Int.signed_repr in l by (cbn in *; lia).
  rewrite Int64.signed_repr in l by (cbn in *; lia).
  assumption.
Qed.

Lemma lt_ub_to_Z5 :  forall v,
    0 <= v <= Int64.max_signed ->
    Int64.eq (Int64.repr v) upper_boundary_int = false ->
    v <> upper_boundary.
Proof.
  intros.
  rewrite upper_boundary_int_repr in H0.
  unfold Int64.eq in H0; destruct zeq in H0; [discriminate|].
  do 2 rewrite Int64.unsigned_repr in n; cbn in *; try lia.
Qed.

Lemma lt_ub_to_Z6 :  forall i,
    0 <= Byte.signed i <= Byte.max_signed ->
    Int64.lt last_digit_max_minus_int
             (Int64.repr (Int.signed (Int.sub (Int.repr (Byte.signed i))
                                              (Int.repr 48)))) = false ->
    (Byte.signed i - 48) <= last_digit_max_minus.
Proof.
  intros.
  rewrite last_digit_max_minus_int_repr in H0.
  unfold Int64.lt, Int.sub in H0; destruct zlt in H0; [discriminate|].
  pose proof Byte.signed_range i.
  do 2 rewrite Int.unsigned_repr in g by (cbn in *; lia).
  rewrite Int.signed_repr in g by (cbn in *; lia).
  replace (Int64.signed (Int64.repr 8)) with 8 in g by reflexivity.
  rewrite Int64.signed_repr in g by (cbn in *; lia).
  cbn in *; lia.
Qed.

Lemma eq_ub_not_bounded'_minus : forall v d,
    0 <= v ->
    0 <= d <= 9 ->
    v = upper_boundary ->
    d > last_digit_max_minus ->
    bounded' false (v*10 + d) = false.
Proof.
  intros.
  unfold bounded'; cbn in *.
  rewrite andb_false_iff; do 2 rewrite Z.leb_gt.
  lia.
Qed.

Ltac lt_ub_to_Z H := try (eapply lt_ub_to_Z1 in H ||
                            eapply lt_ub_to_Z2 in H ||
                               eapply lt_ub_to_Z3 in H ||
                                 eapply lt_ub_to_Z4 in H ||
                                  eapply lt_ub_to_Z5 in H ||
                                   eapply lt_ub_to_Z6 in H).

(* Lemma lt_ub_bounded'_Prop : forall v d,
    0 <= d <= 9 ->
    0 <= v ->
    Int64.min_signed <= v <= Int64.max_signed ->
    Int64.lt (Int64.repr v) upper_boundary_int = true ->
    Int64.min_signed <= v * 10 + d <= Int64.max_signed /\
    Int64.min_signed <= v * 10 <= Int64.max_signed.
Proof.
  intros v d D V V' Lt.
  eapply lt_ub_to_next_bounded'_Prop.
  eassumption.
  eapply lt_inv64 in Lt.
  rewrite Int64.signed_repr in *.
  replace (Int64.signed upper_boundary_int) with upper_boundary
   in Lt by normalize.
  all: nia.
Qed. *)

Lemma neg_bounded' : forall v,
    0 <= v ->
    bounded' false v = true -> bounded (-1 * v) = true.
  Proof.
    unfold bounded', bounded.
    cbn.
    intros v H.
     repeat rewrite andb_true_iff in *.
     repeat rewrite Z.leb_le in *;
    try nia.
Qed.

Lemma lt_ub_not_bounded' : forall v d,
      0 <= v ->
      0 <= d <= 9 ->
      v > upper_boundary ->
      bounded' false (v*10 + d) = false.
Proof.
  intros.
  unfold bounded'; cbn in *.
  rewrite andb_false_iff; do 2 rewrite Z.leb_gt.
  lia.
Qed.

Lemma eq_ub_bounded'_minus : forall v d,
    0 <= v ->
    0 <= d <= 9 ->
    v = upper_boundary ->
    d <= last_digit_max_minus ->
    bounded' false (v*10 - d) = true.
Proof.
  intros.
  unfold bounded'; cbn in *.
  rewrite andb_true_iff; do 2 rewrite Z.leb_le.
  nia.
Qed.

Lemma eq_ub_next : forall v d,
    0 <= v ->
    0 <= d  ->
    v = upper_boundary ->
    v*10 + d > upper_boundary.
Proof.
  intros.
  cbn in *.
  lia.
Qed.

Lemma eq_ub_bounded'_plus : forall v d,
      0 <= v ->
      0 <= d <= 9 ->
      v = upper_boundary ->
      d <= last_digit_max ->
      bounded' true (v*10 + d) = true.
Proof.
  intros.
  unfold bounded'; cbn in *.
  rewrite andb_true_iff; do 2 rewrite Z.leb_le.
  lia.
Qed.

Lemma eq_ub_not_bounded'_plus : forall v d,
    0 <= v ->
    0 <= d <= 9 ->
    v = upper_boundary ->
    d > last_digit_max ->
    bounded' true (v*10 + d) = false.
Proof.
  intros.
  unfold bounded'; cbn in *.
  rewrite andb_false_iff; do 2 rewrite Z.leb_gt.
  lia.
Qed.

Lemma bounded'_false : forall v w b,
    bounded' b v = false ->
    0 <= v <= w ->
    bounded' b w = false.
  Proof.
    destruct b;
  unfold bounded'; cbn in *;
  intros;
  rewrite andb_false_iff in *;
  repeat rewrite Z.leb_gt in *;
  nia.
Qed.

Lemma loop_non_neg : forall ls v i, 0 <= v -> 0 <= value (Z_of_string_loop' ls v i false).
Proof.
  induction ls.
  - intuition.
  - intros.
    simpl;
      repeat break_if;
    simpl; try congruence;
       eapply is_digit_to_Z in Heqb.
    eapply IHls.
    all: nia.
Qed.

(* Lemmas about Spec *)

(* ERROR RANGE *)

Lemma ERROR_RANGE_not_bounded'_loop : forall ls v i b,
  0 <= v ->
  res (Z_of_string_loop' ls v i b) = ERROR_RANGE ->
  bounded' b (value (Z_of_string_loop' ls v i b)) = false.
Proof.
  induction ls; intros v i b.
  - discriminate.
  - simpl.
 repeat break_if;
      simpl; try congruence;
        intros;
 try eapply IHls; intuition.
 eapply is_digit_to_Z in Heqb0.
 nia.
 eapply bounded'_false with (v := v).
 eassumption.
 eapply is_digit_to_Z in Heqb0.
 nia.
Qed.

Lemma ERROR_RANGE_not_bounded_loop_C : forall ls v i b,
  0 <= v ->
  res (Z_of_string_loop_C ls v i b) = ERROR_RANGE ->
  bounded (value (Z_of_string_loop_C ls v i b)) = false.
Proof.
  induction ls; intros v i b.
  - discriminate.
  - simpl.
 repeat break_if;
      simpl; try congruence;
        intros;
 try eapply IHls; intuition.
 eapply is_digit_to_Z in Heqb0.
 nia.
 break_match.
 simpl in *. congruence.
 break_if. simpl.
 (* add lemma *)
 admit.
 simpl in *; congruence.
 admit.
Admitted.

Lemma Zlength_aux_inc : forall ls i,
    1 + Zlength_aux i byte ls = Zlength_aux (i + 1) byte ls.
Proof.
  induction ls.
  intros; cbn; lia.
  cbn.
  intros.
  eapply IHls with (i := (Z.succ i)).
Qed.

Lemma sublist_ERROR_RANGE : forall ls v j i,
    0 < j ->
    res (Z_of_string_loop' (sublist 0 j ls) v i false) = ERROR_RANGE ->
    res (Z_of_string_loop' ls v i false) = ERROR_RANGE.
Proof.
  induction ls; intros v j i.
  -
    unfold sublist; rewrite skipn_nil; rewrite firstn_nil;
      cbn; discriminate.
  -
    intros J.
    assert (0 <= j - 1) by lia.
    replace (sublist 0 j (a :: ls)) with (a :: sublist 0 (j - 1) ls); cbn.
    repeat break_if;
      cbn; try congruence.
    apply Z_le_lt_eq_dec in H; destruct H.
    eapply IHls with (j := j - 1); assumption.
    rewrite <-e; cbn; discriminate.
    unfold sublist; cbn.
    replace (j - 1 - 0) with (j - 1) by lia; replace (j - 0) with (j) by lia.
    remember (j - 1) as n; assert (Z.succ n = j) by lia; rewrite <-H0.
    rewrite Z2Nat.inj_succ by assumption.
    rewrite firstn_cons; reflexivity.
Qed.

Lemma sublist_ERROR_RANGE_C : forall ls v j i,
    0 < j ->
    res (Z_of_string_loop_C (sublist 0 j ls) v i false) = ERROR_RANGE ->
    res (Z_of_string_loop_C ls v i false) = ERROR_RANGE.
Proof.
  intros.
  erewrite <- abstract_spec_C_spec_equiv_false_res in *.
  eapply sublist_ERROR_RANGE;
    try eassumption.
Qed.

Lemma bounded'_to_bounded : forall ls v i, bounded (value (Z_of_string_loop_C ls v i false)) = true
             ->  bounded' false (value (Z_of_string_loop' ls v i false)) = true.
  Proof.
    intros.
    erewrite abstract_spec_C_spec_equiv_false_value.
    unfold bounded', bounded in *.
Admitted.

Lemma ERROR_RANGE_index_C : forall ls v i j,
    0 <= j ->
    j + 1 <= Zlength ls ->
    res (Z_of_string_loop_C ls v i false) = ERROR_RANGE ->
    bounded (value (Z_of_string_loop_C (sublist 0 j ls) v i false)) = true ->
    bounded (value (Z_of_string_loop_C (sublist 0 (j + 1) ls) v i false)) = false ->
    index (Z_of_string_loop_C ls v i false) = j + i.
Proof.
Admitted.

(* OK *)

Lemma all_digits_OK_or_ERROR_RANGE_loop : forall ls v i b,
    (forall i, 0 <= i < Zlength ls -> is_digit (Znth i ls)  = true) ->
    res (Z_of_string_loop' ls v i b) = OK \/
    res (Z_of_string_loop' ls v i b) = ERROR_RANGE.
Proof.
  - induction ls; intros v0 i0 b DIG.
    -- autorewrite with sublist in *.
      auto.
    --
    cbn.
    replace (is_digit a) with true.
    break_if.
    eapply IHls.
    (*from V *)
    (* from DIG *)
    admit.
    auto.
    (* from DIG *)
    admit.
Admitted.

Lemma all_digits_OK_or_ERROR_RANGE_loop_C : forall ls v i b,
    (forall i, 0 <= i < Zlength ls -> is_digit (Znth i ls)  = true) ->
    res (Z_of_string_loop_C ls v i b) = OK \/
    res (Z_of_string_loop_C ls v i b) = ERROR_RANGE.
Proof.
Admitted. (* use the map *)

(* OK *)
Lemma OK_index_loop : forall ls b v i,
  res (Z_of_string_loop' ls v i b) = OK ->
  index (Z_of_string_loop' ls v i b) = i + Zlength ls.
Proof.
   induction ls; intros b v i.
  - intuition.
  - simpl.
    repeat break_match;
      autorewrite with sublist;
      simpl; try congruence.
    replace (i + Z.succ (Zlength ls)) with
        ((i+1) + Zlength ls) by nia.
    specialize (IHls b (v * 10 + Z_of_char a) (i + 1)).
    intuition.
Qed.

Lemma OK_index_loop_C : forall ls b v i,
  res (Z_of_string_loop_C ls v i b) = OK ->
  index (Z_of_string_loop_C ls v i b) = i + Zlength ls.
Proof.
Admitted.
(* use map *)

Lemma OK_index : forall ls,
    res (Z_of_string' ls) = OK ->
    index (Z_of_string' ls) = Zlength ls.
Proof.
  destruct ls.
  - intuition.
  - simpl.
    break_if.
    * repeat break_if;
      simpl;
      autorewrite with sublist;
      try congruence; try nia.
    * repeat break_if.
      all: replace (Zlength (i :: i0 :: l))
                   with (1 + Zlength (i0::l)).
      all: try eapply OK_index_loop.
      all: autorewrite with sublist;
      try nia; simpl; easy.
Qed.

Lemma OK_index_C : forall ls,
    res (Z_of_string_C ls) = OK ->
    index (Z_of_string_C ls) = Zlength ls.
Proof.
Admitted.

Lemma bounded'_to_OK_loop : forall ls v i b,
   0 <= v ->
  bounded' b (value (Z_of_string_loop' ls v i b)) = true ->
  (forall i, 0 <= i < Zlength ls -> is_digit (Znth i ls)  = true) ->
  res (Z_of_string_loop' ls v i b) = OK.
Proof.
  intros.
  edestruct all_digits_OK_or_ERROR_RANGE_loop with (ls := ls)
                                                   (v := v)
  as [Ok | ER];
    intuition;
    try eassumption.
  eapply ERROR_RANGE_not_bounded'_loop in ER.
  congruence.
  nia.
Qed.

Lemma bounded_to_OK_loop_C : forall ls v i b,
   0 <= v ->
  bounded (value (Z_of_string_loop_C ls v i b)) = true ->
  (forall i, 0 <= i < Zlength ls -> is_digit (Znth i ls)  = true) ->
  res (Z_of_string_loop_C ls v i b) = OK.
Proof.
  intros.
  edestruct all_digits_OK_or_ERROR_RANGE_loop_C with (ls := ls)
                                                   (v := v)
  as [Ok | ER];
    intuition;
    try eassumption.
  eapply ERROR_RANGE_not_bounded_loop_C in ER.
  congruence.
  nia.
Qed.

Lemma OK_bounded_loop : forall ls b v i,
    bounded v = true ->
    res (Z_of_string_loop_C ls v i b) = OK ->
    bounded (value (Z_of_string_loop_C ls v i b)) = true.
Proof.
  induction ls; intros b v i.
  - simpl; congruence.
  - intro.
    simpl.
    repeat break_if;
      simpl; try congruence.
     eapply IHls.
    all: intuition.
     try (rewrite Z.ltb_lt in *).
     admit.
     break_match.
     simpl.
     admit.
     break_if.
     simpl in *; congruence.
     simpl in *; congruence.
Admitted.

Lemma app_char_to_OK_loop : forall ls b i,
    0 < Zlength ls ->
    is_sign i = true ->
    res (Z_of_string_loop' ls 0 1 b) = OK ->
    res (Z_of_string' (i :: ls)) = OK.
Proof.
  intros until i. intros N S Ok.
  pose proof (sign_not_digit i S).
  unfold is_sign in S.
  destruct_orb_hyp.
  all:
  simpl;
    repeat break_if; autorewrite with sublist in *;
      try nia;
    try eapply sign_not_digit in S;
    intuition; try congruence; try eassumption.
  admit. (* refactor *)
Admitted.

Lemma is_digit_bounded' : forall b c,
    is_digit c = true ->
    bounded' b (Z_of_char c) = true.
Proof.
  destruct b.
  intros.
  unfold is_digit, bounded', zero_char, nine_char, Z_of_char in *; cbn in *.
  rewrite andb_true_iff in *.
  repeat rewrite ->Z.leb_le in *.
  lia.
  intros.
  unfold is_digit, bounded', zero_char, nine_char, Z_of_char in *; cbn in *.
  rewrite andb_true_iff in *.
  repeat rewrite ->Z.leb_le in *.
  lia.
Qed.

(* EXTRA DATA *)

Lemma value_next_loop : forall ls v i b r,
    (res (Z_of_string_loop' ls v i r)) = OK ->
    is_digit b = true ->
    value (Z_of_string_loop' (ls ++ [b]) v i r) =
    (value (Z_of_string_loop' ls v i r)) * 10 + (Z_of_char b).
Proof.
  induction ls; intros.
  * simpl in *.
    repeat bool_rewrite.
    break_if; easy.
  * simpl in *.
    break_if.
    break_if.
    erewrite IHls.
    reflexivity.
    eassumption.
    all: simpl in *;
    repeat break_if;
      try congruence; simpl in *;
    try congruence.
Qed.

Lemma EXTRA_DATA_next_loop : forall ls v i b r,
    (res (Z_of_string_loop' ls v i r)) = OK ->
    is_digit b = false ->
    res (Z_of_string_loop' (ls ++ [b]) v i r) = EXTRA_DATA.
Proof.
  induction ls; intros.
  * simpl in *.
    repeat bool_rewrite.
    easy.
  * simpl in *.
    break_if.
    break_if.
    erewrite IHls.
    reflexivity.
    eassumption.
    all: simpl in *;
    repeat break_if;
      try congruence; simpl in *;
    try congruence.
Qed.

Lemma EXTRA_DATA_index_loop : forall ls v i b r,
    (res (Z_of_string_loop' ls v i r)) = OK ->
    is_digit b = false ->
    index (Z_of_string_loop' (ls ++ [b]) v i r) = Zlength ls + i.
Proof.
  induction ls; intros.
  * simpl in *.
    repeat bool_rewrite.
    easy.
  * simpl in *.
    break_if.
    break_if.
    erewrite IHls.
    autorewrite with sublist.
    nia.
    eassumption.
    all: simpl in *;
    repeat break_if;
      try congruence; simpl in *;
    try congruence.
Qed.

Lemma next_value_lt_ub : forall ls j i b,
     (forall i : Z, 0 <= i < j  ->
               is_digit (Znth i ls) = true) ->
     0 < j + 1 <= Zlength ls ->
     bounded' b (value_until b j ls) = true ->
     Znth j ls = i ->
     is_digit i = true ->
     (value_until b (j + 1) ls) = (value_until b j ls * 10 + (Z_of_char i)).
Proof.
  intros.
  rewrite sublist_last_1.
  subst.
  eapply value_next_loop.
  eapply bounded'_to_OK_loop.
  nia.
  eassumption.
  admit.
  eassumption.
  all: nia.
Admitted.
(*
Lemma ub_last_digit_error_range : forall j i ls,
  0 <= j < Zlength ls ->
  Znth j ls = i ->
  is_digit i = true ->
  (forall i0 : Z, 0 <= i0 < j -> is_digit (Znth i0 ls) = true) ->
  bounded' false (value_until false j ls) = true ->
  (value_until false j ls > upper_boundary \/
  (value_until false j ls = upper_boundary /\
  last_digit_max_minus < (Byte.signed i - 48))) ->
  (res (Z_of_string_loop' ls 0 1 false)) = ERROR_RANGE.
Proof.
  intros.
  inversion H4.
  -
  inversion H3.
  eapply bounded'_bool_to_Prop in H3.
  assert (bounded' false (value_until false (j + 1) ls) = false) as Bound.
  { erewrite next_value_lt_ub.
    eapply lt_ub_not_bounded'.
    eapply loop_non_neg; nia.
    eapply is_digit_to_Z; eassumption.
    all: unfold value_until, Z_of_char in *;
      try eassumption; try nia. }

  assert (res (Z_of_string_loop' ls 0 1 false) = ERROR_RANGE) as Result_loop.
  { edestruct all_digits_OK_or_ERROR_RANGE_loop
      with (ls := sublist 0 (j + 1) ls) (v := 0) (i := 1) (b := false) as [Ok | Er].
    autorewrite with sublist.
    admit.
    inversion Ok.
    eapply OK_bounded'_loop in Ok.
    congruence.
    admit.
    eapply sublist_ERROR_RANGE in Er.
    rewrite Er.
    reflexivity.
    nia.
  }
  eassumption.
  -
    inversion H3.
  eapply bounded'_bool_to_Prop in H3.
  assert (bounded' false (value_until false (j + 1) ls) = false) as Bound.
  { erewrite next_value_lt_ub.
    eapply eq_ub_not_bounded'_minus.
    eapply loop_non_neg; nia.
    eapply is_digit_to_Z; eassumption.
    all: unfold value_until, Z_of_char in *;
      try eassumption; try nia. }

  assert (res (Z_of_string_loop' ls 0 1 false) = ERROR_RANGE) as Result_loop.

  { edestruct all_digits_OK_or_ERROR_RANGE_loop
      with (ls := sublist 0 (j + 1) ls) (v := 0) (i := 1) (b := false)  as [Ok | Er].
    autorewrite with sublist.
    admit.
    inversion Ok.
    eapply OK_bounded'_loop in Ok.
    congruence.
    admit.
    eapply sublist_ERROR_RANGE in Er.
    rewrite Er.
    reflexivity.
    nia.
  }
  eassumption.
Admitted.

(* EXTRA DATA *)

Lemma EXTRA_DATA_or_ERROR_RANGE_result :
  forall ls v k j i b,
    0 <= j < Zlength ls ->
    Znth j ls = i ->
    is_digit i = false ->
    res (Z_of_string_loop' ls v k b) = EXTRA_DATA
    \/ res (Z_of_string_loop' ls v k b) = ERROR_RANGE.
  induction ls; intros v k j i b N Dig Bound.
  - autorewrite with sublist in *.
    nia.
  - simpl.
    repeat break_if.
    assert (0 <= Zlength ls).
    eapply Zlength_nonneg.
    assert (0 < j) as ZZ.
    destruct (zle 0 (j -1)).
    nia.
    assert (j = 0) as Z by nia.
    rewrite Z in Dig.
    erewrite Znth_0_cons in Dig.
    subst.
    congruence.
    eapply IHls with (j := j - 1) (i := i).
    autorewrite with sublist in *.
    auto with zarith.
    rewrite <- Dig.
    erewrite Znth_pos_cons; auto.
    eassumption.
    all: intuition.
Qed.

Lemma EXTRA_DATA_value_loop : forall ls v i b r,
    (res (Z_of_string_loop' ls v i r)) = OK ->
    is_digit b = false ->
    value (Z_of_string_loop' (app ls [b]) v i r) =
    value (Z_of_string_loop' ls v i r).
Proof.
  induction ls; intros.
  * simpl in *.
    repeat bool_rewrite.
    easy.
  * simpl in *.
    break_if.
    break_if.
    erewrite IHls.
    autorewrite with sublist.
    nia.
    eassumption.
    all: simpl in *;
      repeat break_if;
      try congruence; simpl in *;
        try congruence.
Qed.

Lemma sublist_EXTRA_DATA : forall ls v j i m vl b,
    res (Z_of_string_loop' (sublist 0 j ls) v i b) = EXTRA_DATA ->
    value (Z_of_string_loop' (sublist 0 j ls) v i b) = vl ->
    index (Z_of_string_loop' (sublist 0 j ls) v i b) = m ->

    res (Z_of_string_loop' ls v i b) = EXTRA_DATA /\
    index (Z_of_string_loop' ls v i b) = m /\
    value (Z_of_string_loop' ls v i b) = vl.
Admitted.
*)


From Velus Require Import Common.
From Velus Require Import Environment.

From Coq Require Import Setoid Morphisms.
From Coq Require Import List.
Import List.ListNotations.

Set Implicit Arguments.

(** * VelusMemory *)

(**

  Both Obc and the Lustre rely on a rather structured notion of
  (static) memory, as found in object-oriented languages. Every node
  instance/class instance forms a node whose leafs are nodes/instances
  it is calling upon. This is captured by the [memory] tree-like
  datastructure.

 *)

(** ** Datatype *)

Definition env := Env.t.

Inductive memory (V: Type) :=
  Mem {
      values: env V;
      instances: env (memory V)
    }.

(** ** Operations *)

Section Operations.

  Variable V W: Type.

  Definition empty_memory : memory V := Mem (Env.empty V) (Env.empty (memory V)).

  Definition find_val (x: ident) (m: memory V) : option V :=
    Env.find x (values m).

  Definition find_inst (x: ident) (m: memory V) : option (memory V) :=
    Env.find x (instances m).

  Definition add_val (x: ident) (v: V) (m: memory V) : memory V :=
    Mem (Env.add x v (values m)) (instances m).

  Definition add_inst (x: ident) (m': memory V) (m: memory V) : memory V :=
    Mem (values m) (Env.add x m' (instances m)).

  Fixpoint mmap (f: V -> W) (m: memory V) : memory W :=
    Mem (Env.map f (values m)) (Env.map (mmap f) (instances m)).

  Definition remove_inst (x: ident) (m: memory V) : memory V :=
    Mem (values m) (Env.remove x (instances m)).

  Definition remove_val (x: ident) (m: memory V) : memory V :=
    Mem (Env.remove x (values m)) (instances m).

End Operations.

(** ** Induction Scheme *)

Section VelusMemoryInd.

  Variable V: Type.
  Variable P: memory V -> Prop.

  Hypothesis MemCase:
    forall m,
      (forall m' x, find_inst x m = Some m' -> P m') ->
      P m.

  Fixpoint memory_ind' (m : memory V): P m.
  Proof.
    unfold find_inst in MemCase.
    destruct m as [? xms].
    apply MemCase; simpl.
    induction xms; intros * Find.
    - rewrite Env.gleaf in Find; discriminate.
    - destruct x; simpl in Find.
      + eapply IHxms2; eauto.
      + eapply IHxms1; eauto.
      + destruct o.
        * symmetry in Find; inv Find. apply memory_ind'.
        * discriminate.
  Qed.

End VelusMemoryInd.

Inductive equal_memory {V: Type} : memory V -> memory V -> Prop :=
  equal_memory_intro:
    forall m m',
      Env.Equal (values m) (values m') ->
      Env.Equiv equal_memory (instances m) (instances m') ->
      equal_memory m m'.

Infix "≋" := equal_memory (at level 70, no associativity).
Infix "⌈≋⌉" := (orel equal_memory) (at level 70, no associativity).

Section EqualVelusMemory.

  Context {V: Type}.

  Lemma equal_memory_refl:
    forall (m: memory V),
      m ≋ m.
  Proof.
    induction m as [? IH] using memory_ind'.
    constructor.
    - reflexivity.
    - split.
      + reflexivity.
      + intros * Find ?.
        eapply Env.Props.P.F.MapsTo_fun in Find; eauto.
        rewrite <-Find; eauto.
  Qed.

  Lemma equal_memory_sym:
  forall (m m': memory V),
    m ≋ m' -> m' ≋ m.
  Proof.
    induction m as [? IH] using memory_ind'.
    inversion_clear 1 as [?? Vals Insts].
    constructor.
    - now symmetry.
    - destruct Insts as (Insts1 & Insts2); split.
      now symmetry; auto.
      intros k e1 e2 M1 M2.
      eapply Insts2 in M1; eauto.
  Qed.

  Lemma equal_memory_trans:
    forall (m1 m2 m3: memory V),
      m1 ≋ m2 -> m2 ≋ m3 -> m1 ≋ m3.
  Proof.
    induction m1 as [? IH] using memory_ind'.
    inversion_clear 1 as [?? Vals12 Insts12];
      inversion_clear 1 as [?? Vals23 Insts23].
    constructor.
    - now rewrite Vals12.
    - destruct Insts12 as (In12 & HMapsTo12).
      destruct Insts23 as (?& HMapsTo23).
      split.
      + now setoid_rewrite In12.
      + intros * Find1 Find3.
        assert (exists e'', Env.MapsTo k e'' (instances m2)) as (e'' &?).
        { setoid_rewrite Env.Props.P.F.find_mapsto_iff.
          rewrite <-Env.In_find, <-In12, Env.In_find.
          setoid_rewrite <-Env.Props.P.F.find_mapsto_iff; eauto.
        }
      pose proof Find1.
      apply (HMapsTo12 _ _ e'') in Find1; auto.
      apply (HMapsTo23 _ e'') in Find3; eauto.
  Qed.

  Add Relation (memory V) equal_memory
    reflexivity proved by equal_memory_refl
    symmetry proved by equal_memory_sym
    transitivity proved by equal_memory_trans
      as equal_memory_rel.

End EqualVelusMemory.

Existing Instance equal_memory_rel.
Hint Immediate equal_memory_rel_Reflexive.
Hint Immediate equal_memory_rel_Transitive.

Add Parametric Morphism V: (@values V)
    with signature equal_memory ==> Env.Equal
      as values_equal_memory.
Proof.
  intros * E x.
  inversion_clear E as [?? Vals]; now rewrite Vals.
Qed.

Add Parametric Morphism V: (@instances V)
    with signature equal_memory ==> Env.Equiv equal_memory
      as instances_equal_memory.
Proof.
  intros * E.
  inversion_clear E as [??? Insts]; auto.
Qed.

Add Parametric Morphism V x: (@add_inst V x)
    with signature equal_memory ==> equal_memory ==> equal_memory
      as add_inst_equal_memory.
Proof.
  intros ? ?  E1  ? ? E2.
  constructor; simpl; rewrite E2.
  + reflexivity.
  + now rewrite E1.
Qed.

Add Parametric Morphism V x: (@add_val V x)
    with signature eq ==> equal_memory ==> equal_memory
      as add_val_equal_memory.
Proof.
  intros * E.
  constructor; simpl; rewrite E; reflexivity.
Qed.

Add Parametric Morphism V x: (@find_val V x)
    with signature equal_memory ==> eq
      as find_val_equal_memory.
Proof.
  intros * E.
  inversion_clear E as [?? Vals].
  apply Vals.
Qed.

(** ** Properties *)

Section Properties.

  Variable V: Type.
  Variables (x y: ident)
            (v: V)
            (m m': memory V).

  Lemma find_val_gss:
    find_val x (add_val x v m) = Some v.
  Proof.
    unfold find_val, add_val.
    now apply Env.gss.
  Qed.

  Lemma find_val_gso:
    x <> y ->
    find_val x (add_val y v m) = find_val x m.
  Proof.
    unfold find_val, add_val.
    now apply Env.gso.
  Qed.

  Lemma find_inst_gss:
      find_inst x (add_inst x m' m) = Some m'.
  Proof.
    unfold find_inst, add_inst.
    now apply Env.gss.
  Qed.

  Lemma find_inst_gso:
    x <> y ->
    find_inst x (add_inst y m' m) = find_inst x m.
  Proof.
    unfold find_inst, add_inst.
    now apply Env.gso.
  Qed.

  Lemma find_val_add_inst:
    find_val x (add_inst y m' m) = find_val x m.
  Proof.
    unfold find_val, add_inst.
    reflexivity.
  Qed.

  Lemma find_inst_add_val:
    find_inst x (add_val y v m) = find_inst x m.
  Proof.
    unfold find_inst, add_val.
    reflexivity.
  Qed.

  Lemma find_val_mmap:
    forall W (f: V -> W),
      find_val x (mmap f m) = option_map f (find_val x m).
  Proof.
    unfold find_val.
    destruct m; simpl.
    intros; apply Env.Props.P.F.map_o.
  Qed.

  Lemma find_inst_mmap:
    forall W (f: V -> W),
      find_inst x (mmap f m) = option_map (mmap f) (find_inst x m).
  Proof.
    unfold find_inst.
    destruct m; simpl.
    intros; apply Env.Props.P.F.map_o.
  Qed.

  Lemma add_remove_inst_same:
    find_inst x m = Some m' ->
    m ≋ add_inst x m' (remove_inst x m).
  Proof.
    unfold add_inst, find_inst; intros * Find.
    constructor; simpl.
    - reflexivity.
    - split.
      + setoid_rewrite Env.Props.P.F.add_in_iff;
          setoid_rewrite Env.Props.P.F.remove_in_iff.
        split; intros * Hin.
        * destruct (ident_eq_dec x k); auto.
        * destruct Hin; try tauto.
          subst; apply Env.In_find; eauto.
      + intros * HMapsTo Hremove.
        rewrite Env.Props.P.F.add_mapsto_iff, Env.Props.P.F.remove_mapsto_iff in Hremove.
        destruct Hremove as [(?&?)|(?&?& HMapsTo')].
        * subst.
          apply Env.find_1 in HMapsTo; rewrite HMapsTo in Find; inv Find.
          reflexivity.
        * eapply Env.Props.P.F.MapsTo_fun in HMapsTo as <-; eauto.
          reflexivity.
  Qed.

  Lemma find_inst_grs:
    find_inst x (remove_inst x m) = None.
  Proof.
    intros; apply Env.grs.
  Qed.

  Lemma find_inst_gro:
    x <> y ->
    find_inst x (remove_inst y m) = find_inst x m.
  Proof.
    intros; apply Env.gro; auto.
  Qed.

  Lemma add_remove_val_same:
    find_val x m = Some v ->
    m ≋ add_val x v (remove_val x m).
  Proof.
    unfold add_val, find_val; intros * Find.
    constructor; simpl.
    - intro z.
      destruct (ident_eq_dec z x).
      + subst; now rewrite Env.gss.
      + rewrite Env.gso, Env.gro; auto.
    - reflexivity.
  Qed.

  Lemma find_val_grs:
    find_val x (remove_val x m) = None.
  Proof.
    intros; apply Env.grs.
  Qed.

  Lemma find_val_gro:
    x <> y ->
    find_val x (remove_val y m) = find_val x m.
  Proof.
    intros; apply Env.gro; auto.
  Qed.

  Lemma find_inst_gempty:
    find_inst x (empty_memory V) = None.
  Proof.
    apply Env.gempty.
  Qed.

  Lemma find_val_gempty:
    find_val x (empty_memory V) = None.
  Proof.
    apply Env.gempty.
  Qed.

  Lemma add_inst_val_comm:
    add_inst x m' (add_val y v m) = add_val y v (add_inst x m' m).
  Proof eq_refl.

  Lemma add_val_comm:
    forall w,
      x <> y ->
      add_val x v (add_val y w m) = add_val y w (add_val x v m).
  Proof.
    intros; unfold add_val; simpl.
    now rewrite Env.add_comm.
  Qed.

  Lemma In_find_inst:
    forall x (m : memory V),
      Env.In x (instances m) -> exists v, find_inst x m = Some v.
  Proof.
    unfold find_inst. setoid_rewrite Env.In_find; auto.
  Qed.

  Lemma find_inst_In:
    forall x (m : memory V) v,
      find_inst x m = Some v -> Env.In x (instances m).
  Proof.
    unfold find_inst. intros * HH.
    now apply Env.find_In in HH.
  Qed.

  Lemma MapsTo_find_inst:
    forall i (m mi : memory V),
      Env.MapsTo i mi (instances m) <-> find_inst i m = Some mi.
  Proof.
    unfold find_inst. split; intro HH; now apply Env.find_1.
  Qed.

  (** Combined with [orel] *)

  Global Instance find_inst_Proper {A : Type}:
    Proper (eq ==> equal_memory ==> orel equal_memory) (@find_inst A).
  Proof.
    intros s t Exy mm mn Emn; subst.
    apply instances_equal_memory in Emn.
    rewrite Env.Equiv_orel in Emn.
    apply Emn.
  Qed.

  Lemma memory_equiv_orel_inst:
    forall (S T : memory V),
      S ≋ T ->
      forall x, find_inst x S ⌈≋⌉ find_inst x T.
  Proof.
    intros * EM. now setoid_rewrite EM.
  Qed.

  Lemma memory_equiv_orel_val:
    forall (S T : memory V),
      S ≋ T ->
      forall x, orel eq (find_val x S) (find_val x T).
  Proof.
    intros * EM. now setoid_rewrite EM.
  Qed.

  Lemma equal_memory_find_inst:
    forall (M : memory V) N x Mx,
      N ≋ M ->
      find_inst x M = Some Mx ->
      exists Nx, find_inst x N = Some Nx /\ Nx ≋ Mx.
  Proof.
    intros * NM Fx.
    apply memory_equiv_orel_inst with (x:=x0) in NM.
    rewrite Fx in NM. inv NM; eauto.
  Qed.

  Lemma orel_find_inst_Some (R : relation (memory V)):
    forall insts x m,
      orel R (find_inst x insts) (Some m) ->
      exists m', R m' m /\ find_inst x insts = Some m'.
  Proof.
    unfold find_inst. eauto using Env.orel_find_Some.
  Qed.

  Lemma orel_find_val_Some (R : relation V):
    forall vals x m,
      orel R (find_val x vals) (Some m) ->
      exists m', R m' m /\ find_val x vals = Some m'.
  Proof.
    unfold find_val. eauto using Env.orel_find_Some.
  Qed.

End Properties.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e32m977_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(****************************************************************

   File: EqualUntypedR_ITP10.v
   Author: Amy Felty

   original: January 2010
   Apr 2021: Current Coq Version: V8.13.1

   Example from:
   Amy Felty and Brigitte Pientka, Reasoning with Higher-Order
   Abstract Syntax and Contexts: A Comparison, In International
   Conference on Interactive Theorem Proving (ITP), 2010.

   We formalized the proof of Theorem 1 in Section 2.1 using context
   relations.  The formal proof is described in Section 4.

   Contents:
   1. Admissibility of reflexivity for algorithmic equality
   2. Admissibility of transitivity for algorithmic equality
   3. Correctness of algorithmic equality with respect to declaritive
      equality.
   4. Adequacy

  ***************************************************************)

From HybridSys Require Export sl.

#[global] Hint Resolve level_CON level_VAR level_BND level_APP level_ABS : hybrid.
#[global] Hint Resolve proper_APP abstr_proper : hybrid.
#[global] Hint Unfold proper: hybrid.

Section encoding.

(****************************************************************
   Constants for Lambda Terms
  ****************************************************************)

Inductive Econ: Set := cAPP: Econ | cLAM: Econ.
Definition uexp : Set := expr Econ.

Definition Var : var -> uexp := (VAR Econ).
Definition Bnd : bnd -> uexp := (BND Econ).
Definition app : uexp -> uexp -> uexp :=
  fun M:uexp => fun N:uexp => (APP (APP (CON cAPP) M) N).
Definition lam : (uexp -> uexp) -> uexp :=
  fun M:uexp->uexp => (APP (CON cLAM) (lambda M)).

(****************************************************************
   Some Properties of Constructors
  ****************************************************************)

Lemma proper_Var: forall x:var, (proper (Var x)).
Proof.
unfold Var; auto with hybrid.
Qed.

Lemma proper_lam : forall (e:uexp->uexp), abstr e -> proper (lam e).
Proof.
unfold lam; auto with hybrid.
Qed.

Lemma proper_app : forall e1 e2:uexp,
  proper e1 -> proper e2 -> proper (app e1 e2).
Proof.
unfold app; auto with hybrid.
Qed.

(****************************************************************
   The atm type and instantiation of oo.
  ****************************************************************)

Inductive atm : Set :=
   is_tm : uexp -> atm
 | equal_d : uexp -> uexp -> atm
 | eq_a : uexp -> uexp -> atm.

Definition oo_ := oo atm Econ.
Definition atom_ : atm -> oo_ := atom Econ.
Definition T_ : oo_ := T atm Econ.

(****************************************************************
   Definition of prog
  ****************************************************************)

Inductive prog : atm -> oo_ -> Prop :=
  (* well-formedness of terms (app and lam) *)
  | tm_app : forall T1 T2:uexp,
      prog (is_tm (app T1 T2))
        (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)))
  | tm_lam : forall T:uexp->uexp, abstr T ->
      prog (is_tm (lam T))
        (All (fun x:uexp =>
          (Imp (is_tm x) (atom_ (is_tm (T x))))))
  (* declarative equality *)
  | e_l :forall T T':uexp->uexp, abstr T -> abstr T' ->
      prog (equal_d (lam T) (lam T'))
        (All (fun x:uexp =>
          (Imp (is_tm x)
            (Imp (equal_d x x) (atom_ (equal_d (T x) (T' x)))))))
  | e_a : forall T1 T2 E1 E2:uexp,
      prog (equal_d (app T1 T2) (app E1 E2))
        (Conj (atom_ (equal_d T1 E1)) (atom_ (equal_d T2 E2)))
  | e_r : forall T:uexp,
      prog (equal_d T T) (atom_ (is_tm T))
  | e_t : forall T T' S:uexp,
      prog (equal_d T S) (Conj (atom_ (equal_d T T')) (atom_ (equal_d T' S)))
  (* algorithmic equality *)
  | eq_lam :forall T T':uexp->uexp, abstr T -> abstr T' ->
      prog (eq_a (lam T) (lam T'))
        (All (fun x:uexp =>
          (Imp (eq_a x x) (atom_ (eq_a (T x) (T' x))))))
  | eq_app : forall T1 T2 E1 E2:uexp,
      prog (eq_a (app T1 T2) (app E1 E2))
        (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2))).

(****************************************************************
   Instantiation of seq
  ****************************************************************)

Definition seq_ : nat -> list atm -> oo_ -> Prop := seq prog.
Definition seq'_ := seq' prog.
Definition seq0 (B : oo_) : Prop := seq'_ nil B.

End encoding.

#[global] Hint Resolve proper_Var : hybrid.
#[global] Hint Resolve tm_app tm_lam e_l e_a e_r e_t eq_lam eq_app : hybrid.
#[global] Hint Unfold oo_ atom_ T_: hybrid.
#[global] Hint Unfold seq_ seq'_ seq0: hybrid.

(****************************************************************
 1. Admissibility of Reflexivity
  ****************************************************************)

Section ref.

(************)
(* Contexts *)
(************)

Definition ref_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
  (forall (T:uexp), In (is_tm T) Phi -> In (eq_a T T) Psi).

Lemma ref_extended_cInv1 : forall (Phi Psi:list atm) (x:uexp),
  ref_inv Phi Psi -> ref_inv (is_tm x::Phi) (eq_a x x::Psi).
Proof.
unfold ref_inv; intros Phi Psi x cInv T h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; clear h1; intros; subst; subst.
  simpl; tauto.
- specialize cInv with (1:=h1).
  simpl; tauto.
Qed.

Lemma ref_extended_cInv2 : forall (Phi Psi:list atm) (x:uexp),
  ref_inv Phi Psi ->
  ref_inv (equal_d x x::is_tm x::Phi) (eq_a x x::Psi).
Proof.
unfold ref_inv; intros Phi Psi x cInv T h1.
simpl in h1; elim h1; clear h1; intro h1.
- discriminate h1.
- elim h1; clear h1; intro h1.
  + injection h1; clear h1; intros; subst; subst.
    simpl; tauto.
  + specialize cInv with (1:=h1).
    simpl; tauto.
Qed.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Lemma eq_ref :
  forall (i:nat) (T:uexp) (Phi Psi:list atm), ref_inv Phi Psi ->
  seq_ i Phi (atom_ (is_tm T)) ->
  seq_ i Psi (atom_ (eq_a T T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (Phi Psi:list atm),
     ref_inv Phi Psi ->
     seq_ i Phi (atom_ (is_tm T)) ->
     seq_ i Psi (atom_ (eq_a T T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (eq_a T1 T1)) (atom_ (eq_a T2 T2)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    generalize (H4 x h1); intro h2.
    inversion h2; subst; clear h2.
    apply s_imp; auto.
    apply h with (is_tm x::Phi); auto; try lia.
    apply ref_extended_cInv1; auto.
(* context case *)
- unfold ref_inv in cInv.
  specialize cInv with (1:=H2); clear H2.
  generalize cInv; case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

Lemma eq_ref_cor :
  forall (T:uexp), seq0 (atom_ (is_tm T)) -> seq0 (atom_ (eq_a T T)).
Proof.
intros T [n h].
assert (cInv:ref_inv nil nil).
{ unfold ref_inv; simpl; tauto. }
specialize eq_ref with (1:=cInv) (2:=h); intro h2.
exists n; auto.
Qed.

End ref.

(****************************************************************
 2. Admissibility of Transivity
  ****************************************************************)

Section tr.

(************)
(* Contexts *)
(************)

Definition tr_inv : list atm -> Prop :=
  fun Psi:list atm =>
   (forall (T T':uexp), In (eq_a T T') Psi -> T=T').

Lemma tr_extended_cInv : forall (Psi:list atm) (x:uexp),
  tr_inv Psi -> tr_inv (eq_a x x::Psi).
Proof.
unfold tr_inv; intros Psi x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; clear h1; intros; subst; subst; auto.
- specialize cInv with (1:=h1); auto.
Qed.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Lemma eq_tr :
  forall (i:nat) (T R U:uexp) (Psi:list atm), tr_inv Psi ->
  seq_ i Psi (atom_ (eq_a T R)) ->
  seq_ i Psi (atom_ (eq_a R U)) ->
  seq_ i Psi (atom_ (eq_a T U)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T R U:uexp) (Psi:list atm), tr_inv Psi ->
     seq_ i Psi (atom_ (eq_a T R)) ->
     seq_ i Psi (atom_ (eq_a R U)) ->
     seq_ i Psi (atom_ (eq_a T U)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T R U Psi cInv h1 h2.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      specialize abstr_lbind_simp with (1:=H7) (2:=H5) (3:=H0); intro h1.
      rewrite H.
      unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h2.
      inversion H6; subst; clear H6.
      specialize H10 with (1:=h2).
      unfold ext_eq in h1; rewrite -> h1 in H10; auto; clear H0 H7 h1 T.
      assert (hi:i1=i); try lia; subst; clear H.
      specialize H4 with (1:=h2).
      inversion H10; subst; clear H10.
      inversion H4; subst; clear H4.
      apply s_imp; auto.
      assert (hi:i0=i); try lia; subst; clear H.
      apply h with (T' x); auto; try lia.
      apply tr_extended_cInv; auto.
    (* lam case: context subcase *)
    * unfold tr_inv in cInv.
      specialize cInv with (1:=H3); subst.
      unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T' x))))));
        auto with hybrid.
      apply s_all; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    inversion h2; subst; clear h2.
    * inversion H1; subst; clear H1.
      inversion H3; subst; clear H3.
      assert (hi:i1=i); try lia; subst; clear H.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (eq_a T1 E0)) (atom_ (eq_a T2 E3)));
        auto with hybrid.
      apply s_and; auto.
      -- apply h with E1; try lia; auto.
      -- apply h with E2; try lia; auto.
    (* app case: context subcase *)
    * unfold tr_inv in cInv.
      specialize cInv with (1:=H2); subst.
      unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- unfold tr_inv in cInv.
  specialize cInv with (1:=H2); clear H2; subst; auto.
Qed.

Lemma eq_tr_cor : forall (T R U:uexp),
 seq0 (atom_ (eq_a T R)) -> seq0 (atom_ (eq_a R U)) ->
 seq0 (atom_ (eq_a T U)).
Proof.
intros T R U [i h1] [j h2].
assert (cInv:tr_inv nil).
- unfold tr_inv; simpl; tauto.
- exists (i+j); apply eq_tr with R; auto.
  * apply seq_mono_cor with i; auto; try lia.
  * apply seq_mono_cor with j; auto; try lia.
Qed.

End tr.

(****************************************************************
 3. Correctness
  ****************************************************************)

Section ceq.

(************)
(* Contexts *)
(************)

Definition ceq_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
   ((forall (T T':uexp), In (equal_d T T') Phi -> In (eq_a T T') Psi) /\
    ref_inv Phi Psi /\
    tr_inv Psi).

Lemma ceq_extended_cInv : forall (Phi Psi:list atm) (x:uexp),
  ceq_inv Phi Psi ->
  ceq_inv (equal_d x x::is_tm x::Phi) (eq_a x x::Psi).
Proof.
unfold ceq_inv; intros Phi Psi x [cInv1 [cInv2 cInv3]].
repeat split.
- intros T T' h1.
  simpl in h1; elim h1; clear h1; intro h1.
  + injection h1; clear h1; intros; subst; subst; simpl; tauto.
  + elim h1; clear h1; intro h1.
    * discriminate h1.
    * specialize cInv1 with (1:=h1); simpl; tauto.
- apply ref_extended_cInv2; auto.
- apply tr_extended_cInv; auto.
Qed.

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Lemma equal_lam_inv :
forall (i:nat) (Phi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Phi (Imp (is_tm x) (Imp (equal_d x x)
                   (atom_ (equal_d (T x) (T' x)))))) ->
exists j:nat, (i=j+2 /\
 forall x : uexp,
       proper x ->
       seq_ j ((equal_d x x)::(is_tm x)::Phi) (atom_ (equal_d (T x) (T' x)))).
Proof.
induction i; auto.
- intros Phi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  replace (i+1) with (S i) in H0; try lia.
- generalize i; clear i IHi.
  induction i; auto.
  + intros Phi T T' H.
    generalize (H (Var 0) (proper_Var 0)); intro H1.
    inversion H1; clear H1; subst.
    inversion H4; clear H4; subst.
    replace (i0+1+1) with (S (S i0)) in H0; try lia.
  + intros Phi T T' H.
    exists i; split; try lia.
    intros x H0.
    generalize (H x H0); intro H1.
    inversion H1; clear H1; subst.
    inversion H5; clear H5; subst.
    assert (i1 = i); try lia.
    subst; auto.
Qed.

(****************************)
(* Main Lemmas and Theorems *)
(****************************)

Lemma eq_ceq :
  forall (i:nat) (T R:uexp) (Phi Psi:list atm), ceq_inv Phi Psi ->
  seq_ i Phi (atom_ (equal_d T R)) ->
  seq_ i Psi (atom_ (eq_a T R)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T R:uexp) (Phi Psi:list atm), ceq_inv Phi Psi ->
     seq_ i Phi (atom_ (equal_d T R)) ->
     seq_ i Psi (atom_ (eq_a T R)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T R Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (equal_lam_inv i Phi T0 T' H4); clear H4; intros [j [h1 h2]];
      subst.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (eq_a x x) (atom_ (eq_a (T0 x) (T' x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h1.
    apply seq_mono with (j+1); try lia.
    apply s_imp; auto.
    apply h with (equal_d x x::is_tm x::Phi); auto; try lia.
    apply ceq_extended_cInv; auto.
  (* app case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (eq_a T1 E1)) (atom_ (eq_a T2 E2)));
      auto with hybrid.
    apply s_and; auto.
    * apply h with Phi; try lia; auto.
    * apply h with Phi; try lia; auto.
  (* refl case *)
  + apply seq_mono with i0; auto; try lia.
    apply eq_ref with Phi; auto.
    unfold ceq_inv in cInv; tauto.
  (* trans case *)
  + inversion H3; subst; clear H3.
    apply eq_tr with T'; auto.
    * unfold ceq_inv in cInv; tauto.
    * apply seq_mono with i; auto; try lia.
      apply h with Phi; auto; try lia.
    * apply seq_mono with i; auto; try lia.
      apply h with Phi; auto; try lia.
(* context case *)
- elim cInv; clear cInv; intros cInv1 [cInv2 cInv3].
  specialize cInv1 with (1:=H2); clear H2.
  generalize cInv1; case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

Lemma eq_ceq_cor : forall (T R:uexp),
 seq0 (atom_ (equal_d T R)) -> seq0 (atom_ (eq_a T R)).
Proof.
intros T R [i h1].
assert (cInv:ceq_inv nil nil).
- unfold ceq_inv; unfold tr_inv,ref_inv; simpl; tauto.
- exists i; apply eq_ceq with nil; auto.
Qed.

End ceq.

(****************************************************************
 4. Adequacy
  ****************************************************************)

(*********************)
(* "proper" Adequacy *)
(*********************)

Section proper_adeq.

Lemma is_tm_proper : forall T:uexp,
  seq0 (atom_ (is_tm T)) -> (proper T).
Proof.
intros T [n h1].
generalize T h1; clear h1 T.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T : uexp, seq_ n nil (atom_ (is_tm T)) -> proper T)).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* app case *)
- inversion H3; clear H3; subst.
  apply proper_app; auto.
  + apply h1 with i0; auto; try lia.
  + apply h1 with i0; auto; try lia.
(* lam case *)
- inversion H3; clear H3; subst.
  apply proper_lam; auto.
Qed.

Lemma equal_proper : forall T T':uexp,
  seq0 (atom_ (equal_d T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (equal_d T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; apply proper_app; auto.
(* refl case *)
- split; apply is_tm_proper; unfold seq0,seq'_,seq'; auto.
  + exists i; auto.
  + exists i; auto.
(* trans case *)
- inversion H3; clear H3; subst.
  generalize h1; generalize h1; intros h2 h3.
  assert (h4:i0<i0+1+1); try lia.
  specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
  specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
  split; auto.
Qed.

Lemma eq_proper : forall T T':uexp,
  seq0 (atom_ (eq_a T T')) -> (proper T /\ proper T').
Proof.
intros T T' [n h1].
generalize T T' h1; clear h1 T T'.
generalize
 (lt_wf_ind n
    (fun n:nat =>
       forall T T' : uexp, seq_ n nil (atom_ (eq_a T T')) ->
        (proper T /\ proper T'))).
intro h'.
apply h'; clear h'; auto.
clear n.
intros n h1 T T' h2.
inversion h2; clear h2; subst.
inversion H0; clear H0; subst.
(* lam case *)
- split; apply proper_lam; auto.
(* app case *)
- inversion H3; clear H3; subst.
generalize h1; generalize h1; intros h2 h3.
assert (h4:i0<i0+1+1); try lia.
specialize h2 with (1:=h4) (2:=H4); elim h2; clear h2; intros h2 h5.
specialize h3 with (1:=h4) (2:=H5); elim h3; clear h3; intros h3 h6.
split; apply proper_app; auto.
Qed.

End proper_adeq.

Section equal_adeq.

(************************)
(* Inversion Properties *)
(************************)
(* Specialized inversion properties of prog (could be automated) *)

Lemma eq_lam_inv :
forall (i:nat) (Psi:list atm) (T T':uexp->uexp),
(forall x : uexp,
       proper x ->
       seq_ i Psi (Imp (eq_a x x) (atom_ (eq_a (T x) (T' x))))) ->
exists j:nat, (i=j+1 /\
 forall x : uexp,
       proper x ->
       seq_ j (eq_a x x::Psi) (atom_ (eq_a (T x) (T' x)))).
Proof.
induction i; auto.
- intros Psi T T' H.
  generalize (H (Var 0) (proper_Var 0)); intro H1.
  inversion H1; clear H1; subst.
  replace (i+1) with (S i) in H0; try lia.
- intros Psi T T' H.
  exists i; split; try lia.
  intros x H0.
  generalize (H x H0); intro H1.
  inversion H1; clear H1; subst.
  assert (i0 = i); try lia.
  subst; auto.
Qed.

(************)
(* Contexts *)
(************)

Definition equal_context_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
  ((forall (T T':uexp), (In (equal_d T T') Phi) ->
    (In (is_tm T) Psi /\ In (is_tm T') Psi)) /\
   (forall (T:uexp), In (is_tm T ) Phi ->  In (is_tm T) Psi)).

Lemma equal_extended_cInv :
  forall (Phi Psi:list atm) (x:uexp), equal_context_inv Phi Psi ->
   equal_context_inv (equal_d x x::is_tm x::Phi) (is_tm x::Psi).
Proof.
unfold equal_context_inv; intros Phi Psi x [cInv1 cInv2]; split.
- intros T T' h5; simpl in h5; elim h5; clear h5; [intro h5 | intros [h5 | h5]].
  + injection h5; clear h5; intros; subst; subst.
    simpl; tauto.
  + discriminate h5.
  + specialize cInv1 with (1:=h5).
    elim cInv1; simpl; tauto.
- simpl.
  intros T [h3 | [h3 | h3]].
  + discriminate h3.
  + injection h3; subst; tauto.
  + specialize cInv2 with (1:=h3); tauto.
Qed.

Lemma is_tm_related_contexts :
  forall (i:nat) (T:uexp) (Phi Psi:list atm),
  (forall (T:uexp), In (is_tm T) Phi ->  In (is_tm T) Psi) ->
  seq_ i Phi (atom_ (is_tm T)) ->
  seq_ i Psi (atom_ (is_tm T)).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T:uexp) (Phi Psi:list atm),
     (forall (T:uexp), In (is_tm T ) Phi ->  In (is_tm T) Psi) ->
     seq_ i Phi (atom_ (is_tm T)) ->
     seq_ i Psi (atom_ (is_tm T)))).
intro H'.
apply H'; clear H' i; auto.
intros i h T Phi Psi h1 h2.
inversion h2; subst; clear h2.
- inversion H0; subst; clear H0.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=h1) (3:=H4).
    specialize h' with (1:=hi) (2:=h1) (3:=H5).
    unfold seq_,atom_;
      apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
      auto with hybrid.
    apply s_and; auto.
  (* lam case *)
  + inversion H3; subst; clear H3.
    unfold seq_,atom_;
      apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
      auto with hybrid.
    apply s_all; auto.
    intros x h5.
    generalize (H4 x h5); intro h6.
    inversion h6; subst; clear h6 H4.
    apply s_imp; auto.
    apply h with (is_tm x::Phi); auto; try lia.
    (* proof of extended context inv *)
    intro T; generalize (h1 T); simpl; tauto.
(* context case *)
- generalize (h1 T H2); clear h1 H2.
case Psi.
  + simpl; tauto.
  + intros a Phi h1.
    apply s_init; auto with hybrid.
Qed.

(********************)
(* equal_d Adequacy *)
(********************)

Lemma equal_is_tm :
  forall (i:nat) (T T':uexp) (Phi Psi:list atm),
  equal_context_inv Phi Psi ->
  seq_ i Phi (atom_ (equal_d T T')) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi Psi:list atm),
     equal_context_inv Phi Psi ->
     seq_ i Phi (atom_ (equal_d T T')) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (equal_lam_inv i Phi T0 T'0 H4); clear H4; intros [j [h1 h2]];
      subst.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_tm x:: Psi) (atom_ (is_tm (T'0 x))))).
    { intros x h1.
      apply h with (equal_d x x::is_tm x::Phi); auto; try lia.
      apply equal_extended_cInv; auto. }
    replace (j+2) with (j+1+1); try lia.
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); intros [h6 h7].
      apply seq_mono with j; auto; try lia.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); intros [h6 h7].
      apply seq_mono with j; auto; try lia.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm E1)) (atom_ (is_tm E2)));
        auto with hybrid.
      apply s_and; auto.
  (* refl case *)
  + elim cInv; intros cInv1 cInv2.
    specialize is_tm_related_contexts with (1:=cInv2) (2:=H3); intro h1.
    split; apply seq_mono with i0; auto; try lia.
  (* trans case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split; apply seq_mono with i; auto; try lia.
(* context case *)
- elim cInv; intros cInv1 cInv2.
  specialize cInv1 with (1:=H2); clear H2.
  elim cInv1; clear cInv2; case Psi.
  simpl; tauto.
  intros a Phi h1 h2.
  split; apply s_init; auto with hybrid.
Qed.

Lemma equal_is_tm_cor : forall T T':uexp, seq0 (atom_ (equal_d T T')) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_tm T'))).
Proof.
intros T T' [n h].
assert (cInv:equal_context_inv nil nil).
{ unfold equal_context_inv; simpl; tauto. }
specialize equal_is_tm with (1:=cInv) (2:=h); intros [h2 h3].
split; exists n; auto.
Qed.

End equal_adeq.

Section eq_adeq.

(************)
(* Contexts *)
(************)

Definition eq_context_inv : list atm -> list atm -> Prop :=
  fun Phi:list atm => fun Psi:list atm =>
  (forall (T T':uexp), (In (eq_a T T') Phi) ->
    (In (is_tm T) Psi /\ In (is_tm T') Psi)).

Lemma eq_extended_cInv :
  forall (Phi Psi:list atm) (x:uexp), eq_context_inv Phi Psi ->
   eq_context_inv (eq_a x x::Phi) (is_tm x::Psi).
Proof.
unfold eq_context_inv; intros Phi Psi x cInv T T' h1.
simpl in h1; elim h1; clear h1; intro h1.
- injection h1; clear h1; intros; subst; subst.
  simpl; tauto.
- specialize cInv with (1:=h1).
  elim cInv; simpl; tauto.
Qed.

(*****************)
(* eq_a Adequacy *)
(*****************)

Lemma eq_is_tm :
  forall (i:nat) (T T':uexp) (Phi Psi:list atm),
  eq_context_inv Phi Psi ->
  seq_ i Phi (atom_ (eq_a T T')) ->
  seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')).
Proof.
intro i.
generalize
 (lt_wf_ind i
    (fun i:nat =>
     forall (T T':uexp) (Phi Psi:list atm),
     eq_context_inv Phi Psi ->
     seq_ i Phi (atom_ (eq_a T T')) ->
     seq_ i Psi (atom_ (is_tm T)) /\ seq_ i Psi (atom_ (is_tm T')))).
intro H'.
apply H'; clear H' i; auto.
intros i h T T' Phi Psi cInv h1.
inversion h1; subst; clear h1.
- inversion H0; subst; clear H0.
  (* lam case *)
  + inversion H3; subst; clear H3.
    generalize (eq_lam_inv i Phi T0 T'0 H4); clear H4; intros [j [h1 h2]];
      subst.
    assert (h':forall x:uexp, proper x ->
        (seq_ j (is_tm x:: Psi) (atom_ (is_tm (T0 x))) /\
         seq_ j (is_tm x:: Psi) (atom_ (is_tm (T'0 x))))).
    { intros x h1.
      apply h with (eq_a x x::Phi); auto; try lia.
      apply eq_extended_cInv; auto. }
    split.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); tauto.
    * unfold seq_,atom_;
        apply s_bc with (All (fun x:uexp => (Imp (is_tm x) (atom_ (is_tm (T'0 x))))));
        auto with hybrid.
      apply s_all; auto.
      intros x h5.
      apply s_imp; auto.
      generalize (h' x h5); tauto.
  (* app case *)
  + inversion H3; subst; clear H3.
    assert (hi:i<i+1+1); try lia.
    generalize h; intro h'.
    specialize h with (1:=hi) (2:=cInv) (3:=H4).
    specialize h' with (1:=hi) (2:=cInv) (3:=H5).
    elim h; intros h2 h3; elim h'; intros h4 h5; clear h h'.
    split.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm T1)) (atom_ (is_tm T2)));
        auto with hybrid.
      apply s_and; auto.
    * unfold seq_,atom_;
        apply s_bc with (Conj (atom_ (is_tm E1)) (atom_ (is_tm E2)));
        auto with hybrid.
      apply s_and; auto.
(* context case *)
- unfold eq_context_inv in cInv.
  specialize cInv with (1:=H2); clear H2.
  elim cInv; clear cInv; case Psi.
  + simpl; tauto.
  + intros a Phi h1 h2.
    split; apply s_init; auto with hybrid.
Qed.

Lemma eq_is_tm_cor : forall T T':uexp, seq0 (atom_ (eq_a T T')) ->
  (seq0 (atom_ (is_tm T)) /\ seq0 (atom_ (is_tm T'))).
Proof.
intros T T' [n h].
assert (cInv:eq_context_inv nil nil).
unfold eq_context_inv; simpl; tauto.
specialize eq_is_tm with (1:=cInv) (2:=h); intros [h2 h3].
split; exists n; auto.
Qed.

End eq_adeq.


From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.

Global Hint Resolve rtc_refl : steps.
Global Hint Resolve rtc_l : steps.
Global Hint Resolve rtc_r : steps.

Theorem nsteps_ind_strong_l :
  ∀ X R (P : nat → X → X → Prop),
    (∀ x, P 0 x x) →
    (∀ n x y z,
      (∀ a b (s : nsteps R n a b), P n a b) →
      R x y →
      nsteps R n y z →
      P (Datatypes.S n) x z) →
    ∀ n x y, nsteps R n x y → P n x y.
Proof.
  intros X R P Base Ind n.
  induction n as [|n IH]; intros x y Hsteps;
  inv Hsteps; [by eapply Base|by eapply Ind].
Qed.

Section PathVia.
Context {X} (R : relation X) (P : X → Prop).

Inductive path_via : relation X :=
  | path_via_refl p : P p → path_via p p
  | path_via_l p q r : P p → R p q → path_via q r → path_via p r.

Lemma path_source_satisfies p q : path_via p q → P p.
Proof. intros H. by inv H. Qed.
Lemma path_target_satisfies p q : path_via p q → P q.
Proof. by induction 1. Qed.

Lemma rtc_to_path_via {p q} (Hpos : ∀ p1 p2, R p1 p2 → P p2 → P p1) :
  rtc R p q → P q → path_via p q.
Proof.
  intros Hpq Hq. revert p Hpq. eapply rtc_ind_l;
  eauto using path_via_refl, path_via_l, path_source_satisfies.
Qed.

Lemma path_via_to_rtc {p q} : path_via p q → rtc R p q.
Proof. induction 1; eauto using rtc_refl, rtc_l. Qed.

End PathVia.

Global Hint Constructors path_via : steps.

Section SuccessorFunc.
Context {X} (R : relation X).

Definition sucessor_func (f : X → list X) := ∀ p q, q ∈ f p ↔ R p q.
End SuccessorFunc.

Section FilteredPathVia.
Context {X : Set} (R : relation X) (f : X → list X).
Context (P : X → Prop) (dec : ∀ x, Decision (P x)).

Definition filtered_successors : X → list X := list_filter P dec ∘ f.
End FilteredPathVia.

Section Defs.
Context `{System : system X}.

Section Persistently.
Context (P : X → Prop).

Definition persistently q1 : Prop :=
  ∀ q2, rtc (can_step silent) q1 q2 → P q2.

Instance persistently_closed_down :
  Proper (rtc (can_step silent) ==> impl) persistently.
Proof.
  intros q1 q2 Hq12 HQ q3 Hq23.
  eapply HQ. eauto using rtc_transitive with steps.
Qed.
End Persistently.

Lemma persistently_closed_implication {R1 R2 : X → Prop} {q1} :
  (∀ q2, rtc (can_step silent) q1 q2 → R1 q2 → R2 q2) →
  persistently R1 q1 → persistently R2 q1.
Proof. unfold persistently. eauto. Qed.

Lemma persistently_closed_implication_weak {R1 R2 : X → Prop} :
  (∀ q2, R1 q2 → R2 q2) → ∀ q1, persistently R1 q1 → persistently R2 q1.
Proof. unfold persistently. eauto. Qed.

Section Eventually.
Context (P : X → Prop).

Definition eventually q1 : Prop :=
  ∃ q2, rtc (can_step silent) q1 q2 ∧ P q2.

Instance eventually_closed_up :
  Proper (rtc (can_step silent) ==> flip impl) eventually.
Proof.
  intros q1 q2 Hq12 (q3 & Hq23 & HQ).
  exists q3. split; [eauto using rtc_transitive with steps|done].
Qed.
End Eventually.

Definition for_all_steps l (P : relation X) (q1 : X) : Prop :=
  ∀ q2, can_step l q1 q2 → P q1 q2.

Lemma for_all_steps_closed_implication {l} {R1 R2 : relation X} {q1} :
  (∀ q2, can_step l q1 q2 → R1 q1 q2 → R2 q1 q2) →
  for_all_steps l R1 q1 → for_all_steps l R2 q1.
Proof. unfold for_all_steps. eauto. Qed.

Definition persistently_for_all_steps l (P : relation X) : X → Prop := persistently (for_all_steps l P).

Lemma persistently_for_all_steps_closed_implication {l} {R1 R2 : relation X} {q1} :
  (∀ q2 q3, rtc (can_step silent) q1 q2 → can_step l q2 q3 → R1 q2 q3 → R2 q2 q3) →
  persistently_for_all_steps l R1 q1 → persistently_for_all_steps l R2 q1.
Proof. unfold persistently_for_all_steps, persistently, for_all_steps. eauto. Qed.

Lemma persistently_for_all_steps_closed_implication_weak {l} {R1 R2 : relation X} :
  (∀ q2 q3, R1 q2 q3 → R2 q2 q3) → ∀ q1, persistently_for_all_steps l R1 q1 → persistently_for_all_steps l R2 q1.
Proof. unfold persistently_for_all_steps, persistently, for_all_steps. eauto. Qed.

Lemma persistently_for_all_steps_manual {l q1} {R : relation X} :
  (∀ q2 q3, rtc (can_step silent) q1 q2 → can_step l q2 q3 → R q2 q3) → persistently_for_all_steps l R q1.
Proof. intros H. intros q2 Hq12 q3 Hq23. eauto. Qed.

End Defs.

Global Hint Resolve persistently_for_all_steps_manual : steps.

Section DownstreamProperty.
Context `{System : system X}.
Context (l : label) (T : relation X → relation X).
Definition Downstream_property (R : relation X) : X → Prop :=
  persistently_for_all_steps l (T R).

Lemma Downstream_property_closed_down (R : relation X) q1 q2 :
  rtc (can_step silent) q1 q2 → Downstream_property R q1 → Downstream_property R q2.
Proof. eapply persistently_closed_down. Qed.
Lemma Downstream_property_closed_implication `{MBRT : MonoBinRelTrans X T} (R1 R2 : relation X) :
  (∀ x1 x2, R1 x1 x2 → R2 x1 x2) → ∀ q1, Downstream_property R1 q1 → Downstream_property R2 q1.
Proof.
  intros H.
  by eapply persistently_for_all_steps_closed_implication_weak, binreltrans_is_mono.
Qed.
Lemma Downstream_property_manual {q1} {R : relation X} :
  (∀ q2 q3, rtc (can_step silent) q1 q2 → can_step l q2 q3 → T R q2 q3) → Downstream_property R q1.
Proof. intros H. intros q2 Hq12 q3 Hq23. eauto. Qed.

End DownstreamProperty.

Global Hint Resolve Downstream_property_manual : hints.
Global Hint Resolve Downstream_property_closed_down : hints.


Require Import Ics WaterTank.

Module Parameters.
  Definition tankMax := 100.
  Definition sensorAccuracy := 5.

  Theorem sensorAccuracy_positive : 0 <= sensorAccuracy.
  Proof.
    unfold sensorAccuracy; omega.
  Qed.

  Definition fillRate := 3.
  Definition emptyRate := 2.

  Definition minFill := 1.
  Definition maxFill := 3.
  Definition minEmpty := 1.
  Definition maxEmpty := 2.

  Theorem fillBounds : minFill <= maxFill.
  Proof.
    unfold minFill, maxFill; omega.
  Qed.

  Theorem emptyBounds : minEmpty <= maxEmpty.
  Proof.
    unfold minEmpty, maxEmpty; omega.
  Qed.
End Parameters.

Module D := Deterministic(Parameters).
Module N := Nondeterministic(Parameters).

(** Let's take the extra step to OCaml code via extraction. *)

Module Det.
  Import D.

  Definition new : Z -> cRep impl'.
    extractConstructor impl' "new".
  Defined.

  Definition update : cRep impl' -> Z -> cRep impl' * unit.
    extractMethod impl' "update".
  Defined.

  Definition timestep : cRep impl' -> Z -> cRep impl' * action.
    extractMethod impl' "timestep".
  Defined.
End Det.

Module Nondet.
  Import N.

  Definition new : Z -> cRep impl'.
    extractConstructor impl' "new".
  Defined.

  Definition update : cRep impl' -> Z -> cRep impl' * unit.
    extractMethod impl' "update".
  Defined.

  Definition timestep : cRep impl' -> request -> cRep impl' * action.
    extractMethod impl' "timestep".
  Defined.
End Nondet.

Recursive Extraction Det Nondet.


(* Check that inversion of names of mutual inductive fixpoints works *)
(* (cf bug #1031) *)

Inductive tree : Set :=
| node : nat -> forest -> tree
with forest    : Set :=
| leaf : forest
| cons : tree    -> forest   -> forest
    .
Definition copy_of_compute_size_forest :=
fix copy_of_compute_size_forest (f:forest) : nat :=
  match f with
  | leaf => 1
  | cons t f0 => copy_of_compute_size_forest f0 + copy_of_compute_size_tree t
  end
with copy_of_compute_size_tree (t:tree) : nat :=
  match t with
  | node _ f => 1 + copy_of_compute_size_forest f
  end for copy_of_compute_size_forest
.
Eval simpl in (copy_of_compute_size_forest leaf).

(* Another interesting case: Hrec has to occurrences: one cannot be folded
   back to f while the second can. *)
Parameter g : (nat->nat)->nat->nat->nat.

Definition f (n n':nat) :=
  nat_rec (fun _ => nat -> nat)
    (fun x => x)
    (fun k Hrec => g Hrec (Hrec k))
    n n'.

Goal forall a b, f (S a) b = b.
intros.
simpl.
admit.
Qed. (* Qed will fail if simpl performs eta-expansion *)

(* Yet another example. *)

Require Import List.

Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i.
simpl.
admit.
Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *)