Require Import Coq.Classes.RelationClasses.
Require Import Setoid.
Require Import ExtLib.Core.Type.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.MonadLaws.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Data.Monads.IdentityMonad.

Set Implicit Arguments.
Set Strict Implicit.

(*
Section with_T.
  Context {T : Type} (e : type T).

  Definition equal_ident (a b : ident T) : Prop :=
    equal (unIdent a) (unIdent b).

  Global Instance type_ident : type (ident T) :=
  { equal := equal_ident
  ; proper := fun x => proper (unIdent x)
  }.

  Global Instance typeOk_ident (tT : typeOk e) : typeOk type_ident.
  Proof.
    constructor.
    { unfold equal, proper, type_ident, equal_ident; simpl; intros.
      apply only_proper; auto. }
    { red. destruct x. intros.
      red; simpl. red; simpl.
      eapply preflexive with (wf := proper); eauto with typeclass_instances. }
    { red. simpl. unfold equal_ident. intros.
      symmetry. assumption. }
    { red; simpl. unfold equal_ident. intros.
      etransitivity; eassumption. }
  Qed.

  Global Instance proper_unIdent : proper unIdent.
  Proof. red; simpl; red; simpl. destruct x; compute; auto. Qed.

  Global Instance proper_mkIdent : proper mkIdent.
  Proof. do 7 red. compute; auto. Qed.

End with_T.

(*
Global Instance FunctorOrder_fmleq : FunctorOrder _ (@Identity_leq) _.
Proof.
  constructor; eauto with typeclass_instances.
Qed.
*)

Require Import ExtLib.Tactics.TypeTac.

Global Instance MonadLaws_GFix : MonadLaws Monad_ident (@type_ident).
Proof.
  constructor; eauto with typeclass_instances; try solve [ compute; intuition ].
  { unfold equal; simpl. intros. red in H2. red; simpl.
    eapply H2. eapply preflexive with (wf := proper); auto.
    eapply equiv_prefl; auto. }
  { unfold proper, equal; simpl. eauto with typeclass_instances. }
  { simpl; intros. red. solve_equal. }
  { unfold bind, Monad_ident. do 6 red; intros. solve_equal. }
Qed.
*)


(* -*- coding:utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Utf8_core.

(* Arithmetic *)
(*Notation "x ≤ y" := (le x y) (at level 70, no associativity).
Notation "x ≥ y" := (ge x y) (at level 70, no associativity).*)

(* test *)
(*
Check ∀ x z, True -> (∃ y v, x + v ≥ y + z) ∨ x ≤ 0.
*)

(* Integer Arithmetic *)
(* TODO: this should come after ZArith
Notation "x ≤ y" := (Z.le x y) (at level 70, no associativity).
*)


(** * The structure delta on carriers of lB-systems and its properties

Properties deltaT, deltaS, deltaSid and SdeltaT and StdeltaTt.

By Vladimir Voevodsky, started Jan. 14, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.T_Tt.
Require Export TypeTheory.Bsystems.S_St.

(** *** The structure dlt *)

Definition dlt_ops_type ( BB : lBsystem_carrier ) :=
  forall ( X : BB ) ( gt0 : ll X > 0 ) , Tilde BB .

(** Notice that the indices in [Tilde BB] are not specified here, see [dlt_ax0_type] below. *)

Identity Coercion dlt_to_Fun: dlt_ops_type >-> Funclass .

(** *** The zeroth property (later an axiom ) of operations [dlt] *)

Definition dlt_ax0_type { BB : lBsystem_carrier } ( dlt : dlt_ops_type BB ) :=
  forall ( X : BB ) ( gt0 : ll X > 0 ) , ll ( dd ( dlt X gt0 ) ) = 1 + ll X .

(** This definition gives the missing element of Definition 2.2 in arXiv:1410.5389v1 *)

Identity Coercion dlt_ax0_to_Fun: dlt_ax0_type >-> Funclass .

(** *** The first property (later an axiom) of operations [dlt] *)

Definition dlt_ax1_type { BB : lBsystem_carrier }
           ( T : T_ops_type BB )
           ( dlt : dlt_ops_type BB ) :=
  forall ( X : BB ) ( gt0 : ll X > 0 ) , dd ( dlt X gt0 ) = T X X ( T_dom_refl X gt0 ) .

(** This definition corresponds to Definition 2.6 in arXiv:1410.5389v1 *)

Identity Coercion dlt_ax1_to_Fun: dlt_ax1_type >-> Funclass .

(** The zeroth property follows from the first property: *)

Lemma ll_dd_dlt { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T )
           { dlt : dlt_ops_type BB } ( ax1 : dlt_ax1_type T dlt )
           { X : BB } ( gt0 : ll X > 0 ) : ll ( dd ( dlt X gt0 ) ) = 1 + ll X .
Proof .
  rewrite ax1 .
  rewrite ax0 .
  exact ( idpath _ ) .
Defined.

(** *** Lemmas that are required to formulate the property [dltT] *)

Lemma Tt_dom_12_to_1_dlt2 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( tax1b : T_ax1b_type T )
      { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
      { X1 X2 : BB } ( inn12 : T_dom X1 X2 ) : Tt_dom  X1 ( dlt X2 ( T_dom_gt0_2 inn12 ) ) .
Proof .
  unfold Tt_dom .
  use T_dom_constr.
  + exact ( T_dom_gt0 inn12 ) .
  + rewrite dltax1 .
    exact ( isabove_trans ( tax1b _ _ _ ) ( T_dom_isabove inn12 ) ) .
Defined.

(** *** The property [dltT] *)

Definition dltT_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax0 : T_ax0_type T ) ( tax1b : T_ax1b_type T )
           ( Tt : Tt_ops_type BB )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt ) :=
  forall ( X1 X2 : BB ) ( inn12 : T_dom X1 X2 ) ,
    Tt X1 ( dlt X2 ( T_dom_gt0_2 inn12 ) ) ( Tt_dom_12_to_1_dlt2 tax1b dltax1 inn12 ) =
    dlt ( T X1 X2 inn12 ) ( ll_T_gt0 tax0 inn12 ) .

(** This definition corresponds to Definition 3.2.1 in arXiv:1410.5389v1 *)

Identity Coercion dltT_to_Fun: dltT_type >-> Funclass .

(** *** Lemmas that are required to formulate the property [dltS] *)

Lemma St_dom_r1_to_r_dlt1 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( tax1b : T_ax1b_type T )
      { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
      { r : Tilde BB } { X : BB } ( innr1 : S_dom r X ) :
  St_dom  r ( dlt X ( S_dom_gt0 innr1 ) ) .
Proof .
  unfold St_dom .
  unfold S_dom .
  rewrite dltax1 .
  exact ( isabove_trans ( tax1b _ _ _ ) innr1 ) .
Defined.

(** *** The property [dltS] *)

Definition dltS_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax1b : T_ax1b_type T )
           { S : S_ops_type BB } ( sax0 : S_ax0_type S )
           ( St : St_ops_type BB )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt ) :=
  forall ( r : Tilde BB ) ( X : BB ) ( innr1 : S_dom r X ) ,
    St r ( dlt X ( S_dom_gt0 innr1 ) ) ( St_dom_r1_to_r_dlt1 tax1b dltax1 innr1 ) =
    dlt ( S r X innr1 ) ( ll_S_gt0 sax0 innr1 ) .

(** This definition corresponds to Definition 3.2.2 in arXiv:1410.5389v1 *)

Identity Coercion dltS_to_Fun: dltS_type >-> Funclass .

(** *** Lemmas needed to formulate the property [dltSid] *)

Lemma St_dom_r_dltddr { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( tax1b : T_ax1b_type T )
      { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
      ( r : Tilde BB ) : St_dom r ( dlt ( dd r ) ( ll_dd r ) ) .
Proof.
  unfold St_dom.
  unfold S_dom .
  rewrite dltax1 .
  exact ( tax1b _ _ _ ) .
Defined.

(** *** The property [dltSid] *)

Definition dltSid_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax1b : T_ax1b_type T )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
           ( St : St_ops_type BB ) :=
  forall ( r : Tilde BB ) ,
    St r ( dlt ( dd r ) ( ll_dd r ) ) ( St_dom_r_dltddr tax1b dltax1 r ) = r .

(** This definition corresponds to Definition 3.2.3 in arXiv:1410.5389v1 *)

Identity Coercion dltSid_to_Fun: dltSid_type >-> Funclass .

(** *** Lemmas needed to formulate the property [SdltT] *)

Lemma T_dom_SdltT_l1 { BB : lBsystem_carrier }
      { X1 X2 : BB } ( gt0 : ll X1 > 0 ) ( isov : isover X2 X1 ) : T_dom X1 X2 .
Proof.
  use ( T_dom_constr gt0 ) .
  exact ( isabove_X_ftA' isov gt0 ) .
Defined.

Lemma S_dom_gt0_isab_to_dlt1_T12 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( tax0 :  T_ax0_type T ) ( tax1a : T_ax1a_type T )
      { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
      { X1 X2 : BB } ( gt0 : ll X1 > 0 ) ( isab : isabove X2 X1 ) :
  S_dom ( dlt X1 gt0 ) ( T X1 X2 ( T_dom_SdltT_l1 gt0 isab ) ) .
Proof.
  unfold S_dom .
  rewrite dltax1 .
  use ( isabove_T_T_2 tax0 tax1a _ _ isab ) .
Defined.

(** *** The property [SdltT] *)

Definition SdltT_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax0 : T_ax0_type T ) ( tax1a : T_ax1a_type T )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
           ( S : S_ops_type BB ) :=
  forall ( X1 X2 : BB ) ( gt0 : ll X1 > 0 ) ( isab : isabove X2 X1 ) ,
    S ( dlt X1 gt0 ) ( T X1 X2 ( T_dom_SdltT_l1 gt0 isab ) )
      ( S_dom_gt0_isab_to_dlt1_T12 tax0 tax1a dltax1 gt0 isab ) = X2 .

(** This definition corresponds to Definition 3.2.4(a) in arXiv:1410.5389v1 *)

Identity Coercion SdltT_to_Fun: SdltT_type >-> Funclass .

(** *** Lemmas needed to formulate the property [StdltTt] *)

Lemma Tt_dom_StdltTt_l1 { BB : lBsystem_carrier }
      { X : BB } { r : Tilde BB } ( gt0 : ll X > 0 ) ( isab : isabove ( dd r ) X ) :
  Tt_dom X r .
Proof.
  use T_dom_constr.
  + exact gt0 .
  + exact ( isabove_X_ftA isab ) .
Defined.

Lemma St_dom_gt0_isab_to_dlt1_Tt1r { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax0 : T_ax0_type T ) ( tax1a : T_ax1a_type T )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
           { Tt : Tt_ops_type BB } ( ttax1 : Tt_ax1_type T Tt )
           { X : BB } { r : Tilde BB } ( gt0 : ll X > 0 ) ( isab : isabove ( dd r ) X ) :
  St_dom ( dlt X gt0 ) ( Tt X r ( Tt_dom_StdltTt_l1 gt0 isab ) ) .
Proof .
  unfold St_dom. unfold S_dom.
  rewrite dltax1 .
  rewrite ttax1 .
  use ( isabove_T_T_2 tax0 tax1a _ _ isab ) .
Defined.

(** *** The property [StdltTt] *)

Definition StdltTt_type { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( tax0 : T_ax0_type T ) ( tax1a : T_ax1a_type T )
           { dlt : dlt_ops_type BB } ( dltax1 : dlt_ax1_type T dlt )
           { Tt : Tt_ops_type BB } ( ttax1 : Tt_ax1_type T Tt )
           ( St : St_ops_type BB ) :=
  forall ( X : BB ) ( r : Tilde BB ) ( gt0 : ll X > 0 ) ( isab : isabove ( dd r ) X ) ,
    St ( dlt X gt0 ) ( Tt X r ( Tt_dom_StdltTt_l1 gt0 isab ) )
      ( St_dom_gt0_isab_to_dlt1_Tt1r tax0 tax1a dltax1 ttax1 gt0 isab ) = r .

(** This definition corresponds to Definition 3.2.4(b) in arXiv:1410.5389v1 *)

Identity Coercion StdltTt_to_Fun: StdltTt_type >-> Funclass .

(* End of the file dlt.v - used to be units.v *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C I H1 H2 Aprime Cprime : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Cprime /\ (wd_ B Aprime /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B H1 A /\ (col_ B H2 C /\ (col_ I B H1 /\ (col_ C B Cprime /\ (col_ A B Aprime /\ (col_ B H2 Cprime /\ col_ B H1 Aprime)))))))))))))))))) -> col_ A B I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Mapping predicates over [StringLike] things *)

Require Import Coq.ZArith.ZArith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section for_first_char.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition for_first_char (str : String) (P : Char -> Prop)
    := forall ch,
         take 1 str ~= [ ch ]
         -> P ch.

  Global Instance for_first_char_Proper
  : Proper (beq ==> pointwise_relation _ impl ==> impl) for_first_char.
  Proof.
    unfold pointwise_relation, respectful, for_first_char, impl.
    intros ?? H' ?? H'' H''' ? H.
    rewrite <- H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance for_first_char_Proper_flip
  : Proper (beq ==> pointwise_relation _ (flip impl) ==> flip impl) for_first_char.
  Proof.
    unfold pointwise_relation, respectful, for_first_char, flip, impl.
    intros ?? H' ?? H'' H''' ? H.
    rewrite H' in H.
    eauto using is_char_Proper.
  Qed.

  Global Instance for_first_char_Proper_iff
  : Proper (beq ==> pointwise_relation _ iff ==> iff) for_first_char.
  Proof.
    unfold pointwise_relation, respectful.
    repeat intro; split;
    apply for_first_char_Proper; try assumption; repeat intro;
    match goal with
      | [ H : _ |- _ ] => apply H; assumption
    end.
  Qed.

  Lemma for_first_char_nil (str : String) P
  : length str = 0 -> for_first_char str P.
  Proof.
    intros H ch H'.
    apply length_singleton in H'.
    rewrite ?take_length, ?drop_length, H in H'.
    simpl in H'; omega.
  Qed.

  Lemma helper
        (P : nat -> nat -> Type)
        n
        (H0 : forall n0, P (min 1 (n - n0)) n0)
        (H1 : forall n0, P 1 (n0 + n))
        {n0}
  : P 1 n0.
  Proof.
    destruct (Compare_dec.le_dec n n0) as [H'|H'].
    { specialize (H1 (n0 - n)).
      rewrite Nat.sub_add in H1 by assumption; assumption. }
    { apply Compare_dec.not_le in H'.
      specialize (H0 n0).
      destruct (n - n0) as [|[|]] eqn:?; simpl in *; trivial; omega. }
  Defined.

  Lemma for_first_char__take n (str : String) P
  : for_first_char str P
    <-> for_first_char (take (S n) str) P.
  Proof.
    unfold for_first_char; repeat (split || intro);
    repeat match goal with
                         | [ H : _ |- _ ] => setoid_rewrite drop_length in H
                         | [ H : _ |- _ ] => setoid_rewrite take_length in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_take in H
                         | [ H : _ |- _ ] => setoid_rewrite take_take in H
                         | [ H : _ |- _ ] => setoid_rewrite drop_drop in H
                         | [ H : _ /\ _ |- _ ] => destruct H
                         | [ H : context[min 1 ?x] |- _ ] => destruct x eqn:?; simpl in H
                         | [ H : is_true (take 0 _ ~= [ _ ]) |- _ ] => exfalso; apply length_singleton in H
                         | _ => omega
                         | _ => progress simpl in *; omega
                         | _ => solve [ eauto ]
                         | _ => solve [ eapply (@helper (fun a b => take a (drop b str) ~= [ ch ] -> P ch)); eauto ]
                       end.
  Qed.

  Lemma for_first_char_singleton (str : String) P ch
  : str ~= [ ch ] -> (P ch <-> for_first_char str P).
  Proof.
    intro H.
    pose proof (length_singleton _ _ H).
    unfold for_first_char.
    split; intro H'; repeat intro.
    { repeat match goal with
               | _ => intro
               | _ => omega
               | [ H : _ |- _ ] => rewrite drop_0 in H
               | [ H : _, H' : _ |- _ ] => rewrite (singleton_take H') in H
               | [ H : _ |- False ] => apply length_singleton in H
               | [ H : _ |- _ ] => rewrite take_length in H
               | [ H : _ |- _ ] => rewrite drop_length in H
               | [ H : ?x = 1, H' : context[?x] |- _ ] => rewrite H in H'
               | _ => erewrite singleton_unique; eassumption
               | [ H : context[min] |- _ ] => revert H; apply Min.min_case_strong
             end. }
    { match goal with
        | [ H : _ |- _ ] => apply H
      end.
      rewrite take_long; trivial; omega. }
  Qed.

  Lemma for_first_char_singleton_length (str : String) P (H : length str = 1)
  : for_first_char str P <-> (forall ch, str ~= [ ch ] -> P ch).
  Proof.
    split.
    { intro H''.
      intros ch' H'''.
      apply (for_first_char_singleton _ _ _ H'''); assumption. }
    { destruct (singleton_exists _ H) as [ch H'].
      intro H''.
      apply (for_first_char_singleton _ P ch H'); eauto. }
  Qed.

  Global Opaque for_first_char.

  Lemma for_first_char_exists (str : String) P (H : length str >= 1)
  : for_first_char str P <-> (exists ch, take 1 str ~= [ ch ] /\ P ch).
  Proof.
    rewrite (for_first_char__take 0).
    assert (H' : length (take 1 str) = 1)
      by (rewrite take_length; apply Min.min_case_strong; omega).
    destruct (singleton_exists _ H') as [ch H''].
    rewrite for_first_char_singleton_length by exact H'.
    split; intros.
    { exists ch; split; eauto. }
    { destruct_head ex.
      destruct_head and.
      repeat match goal with
               | [ H : is_true (?str ~= [ ?ch ])%string_like, H' : is_true (?str ~= [ ?ch' ])%string_like |- _ ]
                 => assert (ch = ch') by (eapply singleton_unique; eassumption);
                   clear H'
             end.
      subst; assumption. }
  Qed.

  Lemma for_first_char_False (str : String) P
  : (forall ch, ~P ch) -> for_first_char str P -> length str = 0.
  Proof.
    intros H' H.
    case_eq (length str); trivial.
    pose proof (singleton_exists (take 1 str)) as H''.
    rewrite take_length in H''.
    intros n H'''.
    rewrite H''' in *.
    specialize (H'' eq_refl).
    destruct H'' as [ch H''].
    apply (for_first_char__take 0) in H.
    apply (for_first_char_singleton _ _ _ H'') in H.
    specialize (H' ch).
    exfalso; eauto.
  Qed.

  Lemma for_first_char_combine (str : String) (P P' : Char -> Prop) (T : Prop) (H : forall ch, P ch -> P' ch -> T)
        (H0 : for_first_char str P)
        (H1 : for_first_char str P')
  : length str = 0 \/ T.
  Proof.
    case_eq (length str).
    { left; reflexivity. }
    { intros n H'; right.
      pose proof (singleton_exists (take 1 str)) as H''.
      rewrite take_length, H' in H''.
      specialize (H'' eq_refl).
      destruct H'' as [ch H''].
      specialize (H ch).
      apply (for_first_char__take 0) in H0.
      apply (for_first_char__take 0) in H1.
      apply (for_first_char_singleton _ _ _ H'') in H0.
      apply (for_first_char_singleton _ _ _ H'') in H1.
      eauto. }
  Qed.

  Definition first_char_in (str : String) (ls : list Char)
    := for_first_char str (fun ch => List.In ch ls).

  Definition for_first_char__impl__first_char_in {str ls} {P : _ -> Prop}
             (H : forall ch, P ch -> List.In ch ls)
  : impl (for_first_char str P) (first_char_in str ls).
  Proof.
    unfold first_char_in.
    apply for_first_char_Proper; trivial; reflexivity.
  Qed.

  Definition first_char_in__impl__for_first_char {str ls} {P : _ -> Prop}
             (H : forall ch, List.In ch ls -> P ch)
  : impl (first_char_in str ls) (for_first_char str P).
  Proof.
    unfold first_char_in.
    apply for_first_char_Proper; trivial; reflexivity.
  Qed.

  Global Instance first_char_in__Proper
  : Proper (beq ==> eq ==> impl) first_char_in.
  Proof.
    unfold pointwise_relation, respectful, first_char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; assumption
    end.
  Qed.

  Global Instance first_char_in__Proper_iff
  : Proper (beq ==> eq ==> iff) first_char_in.
  Proof.
    unfold pointwise_relation, respectful, first_char_in, impl.
    repeat intro; subst.
    match goal with
      | [ H : _ |- _ ] => rewrite <- H; reflexivity
    end.
  Qed.

  Lemma first_char_in__take n (str : String) ls
  : first_char_in str ls
    <-> first_char_in (take (S n) str) ls.
  Proof.
    unfold first_char_in; apply for_first_char__take.
  Qed.

  Lemma first_char_in_nil (str : String)
  : first_char_in str nil <-> length str = 0.
  Proof.
    unfold first_char_in.
    split.
    { eapply for_first_char_False; simpl; eauto. }
    { apply for_first_char_nil. }
  Qed.

  Lemma first_char_in_empty (str : String) (H : length str = 0) ls
  : first_char_in str ls.
  Proof.
    unfold first_char_in.
    apply for_first_char_nil; assumption.
  Qed.

  Lemma first_char_in_singleton_str (str : String) ls ch (H : str ~= [ ch ])
  : first_char_in str ls <-> List.In ch ls.
  Proof.
    unfold first_char_in.
    rewrite <- for_first_char_singleton; try eassumption; reflexivity.
  Qed.

  Lemma first_char_in__app_or_iff (str : String) (ls1 ls2 : list Char)
  : first_char_in str (ls1 ++ ls2)
    <-> (first_char_in str ls1 \/ first_char_in str ls2).
  Proof.
    unfold first_char_in.
    setoid_rewrite List.in_app_iff.
    rewrite !(for_first_char__take 0 str).
    generalize (singleton_exists (take 1 str)).
    rewrite take_length.
    case_eq (length str).
    { intros H _.
      split; intro H0;
      [ left; apply first_char_in_empty
      | apply for_first_char_nil ];
      rewrite take_length, H; reflexivity. }
    { intros ? ? H.
      specialize (H eq_refl).
      destruct H as [ch H].
      rewrite <- !for_first_char_singleton by eassumption; tauto. }
  Qed.

  Lemma first_char_in__or_app (str : String) (ls1 ls2 : list Char)
  : first_char_in str ls1 \/ first_char_in str ls2 -> first_char_in str (ls1 ++ ls2).
  Proof.
    unfold first_char_in.
    intros [?|?]; repeat intro;
    (eapply for_first_char_Proper; [ .. | eassumption ]; [ reflexivity | ]; intros ??);
    apply List.in_or_app; eauto.
  Qed.

  Global Opaque first_char_in.

  Definition first_char_in__iff__for_first_char' {str ls} {P : _ -> Prop}
             (H : forall ch, P ch <-> List.In ch ls)
  : first_char_in str ls <-> for_first_char str P.
  Proof.
    split_iff.
    split; first [ apply for_first_char__impl__first_char_in | apply first_char_in__impl__for_first_char ];
    assumption.
  Qed.

  Definition first_char_in__iff__for_first_char {str ls}
  : first_char_in str ls <-> for_first_char str (fun ch => List.In ch ls).
  Proof.
    apply first_char_in__iff__for_first_char'; reflexivity.
  Qed.

  Lemma first_char_in_exists (str : String) ls (H : length str >= 1)
  : first_char_in str ls <-> (exists ch, take 1 str ~= [ ch ] /\ List.In ch ls).
  Proof.
    erewrite first_char_in__iff__for_first_char, for_first_char_exists by assumption.
    reflexivity.
  Qed.

  Lemma forall_chars__impl__for_first_char (str : String) P (H : forall_chars str P)
  : for_first_char str P.
  Proof.
    case_eq (length str).
    { apply for_first_char_nil. }
    { intros n H'.
      eapply forall_chars_take in H.
      apply (for_first_char__take 0).
      apply for_first_char_singleton_length.
      { rewrite take_length, H'; reflexivity. }
      { apply forall_chars_singleton_length.
        { rewrite take_length, H'; reflexivity. }
        { eassumption. } } }
  Qed.

  Lemma for_first_char__for_first_char__iff_short (str : String) P (H : length str <= 1)
  : forall_chars str P <-> for_first_char str P.
  Proof.
    case_eq (length str).
    { intro H'.
      split; intro.
      { apply for_first_char_nil; assumption. }
      { apply forall_chars_nil; assumption. } }
    { intros [|] H'; [ | exfalso; omega ].
      rewrite forall_chars_singleton_length by assumption.
      rewrite for_first_char_singleton_length by assumption.
      reflexivity. }
  Qed.

  Lemma for_first_char__split (str : String) P n
  : for_first_char str P
    <-> ((n = 0 /\ for_first_char (drop n str) P)
         \/ (n <> 0 /\ for_first_char (take n str) P)).
  Proof.
    destruct n; [ rewrite drop_0 | rewrite <- for_first_char__take ];
      intuition.
  Qed.

  Lemma for_first_char_True (str : String) (P : _ -> Prop) (p : forall ch, P ch)
  : for_first_char str P.
  Proof.
    destruct (length str) eqn:H.
    { apply for_first_char_nil; assumption. }
    { rewrite for_first_char_exists by omega.
      destruct (get 0 (take 1 str)) as [ch|] eqn:Heq.
      { exists ch; split; auto.
        rewrite is_char_parts.
        rewrite take_length; split; [ apply Min.min_case_strong; omega | assumption ]. }
      { apply no_first_char_empty in Heq.
        rewrite take_length, H in Heq.
        simpl in *; omega. } }
  Qed.
End for_first_char.


Require Export typing.
Require Export equiv.
Require Export continuations.
Require Export continuations_lemmas.
Require Export typing_lemmas.

Lemma Cut (g: env) (K : cont) (N: exp) (A B: exp):
(Types_cont g K (Cont N A B) ->
Types g N A ->
Types g (fill_hole N K) B)%ECCA.
Proof.
intros. inversion H ; subst ; cbv.
- assumption.
- cut (@bind N 0 (@wk 0 B) = B); simpl_term_eq.
  intros. rewrite <- H1. eapply aT_Let with (n:= N) (m:= M) (A:=A) (B:=(wk B)) (x:=y) (g:=g); assumption.
Qed.

Lemma type_requires_well_formed (g: env) (e A: exp):
(g ⊢ e : A) ->
(⊢ g).
Proof.
induction 1; auto.
+ inversion IHTypes. auto.
Qed.

(* Lemma weakening (g : env) (x : name) (N A A' : exp):
  Types g N A ->
  Types (ctx_cons g x (Assum A')) N A.
Proof.
Admitted.

Lemma def_weakening (g : env) (x : name) (N N' A A' : exp):
  Types g N A ->
  Types (ctx_cons g x (Def N' A')) N A.
Admitted.

Lemma append_env_weakening (g g': env) (N A : exp):
  Types g N A ->
  Types (append g g') N A.
Proof.
Admitted.

Lemma append_env_equiv_weakening (g g': env) (e e' : exp):
  Equiv g e e' ->
  Equiv (append g g') e e'.
Proof.
Admitted. *)

Require Import Coq.Program.Equality.

Lemma equivalence_in_derivation (g: env) (N N' M : exp) (A B : exp) (x : name):
Types g N A ->
Types g N' A ->
Equiv g N N' ->
Types (ctx_cons g x (Def N A)) M B ->
Types (ctx_cons g x (Def N' A)) M B.
Proof.
  intros. dependent induction H2.
(*   - apply aT_Ax_Prop. apply has_type_wf_g with (x:=x) in H2. auto.
    inversion H2. auto.
  - apply aT_Ax_Type. apply has_type_wf_g with (x:=x) in H0. auto.
    inversion H2. auto.
  - shelve.
  - apply aT_Bool. apply has_type_wf_g with (x:=x) in H0. auto.
    inversion H2. auto.
  - apply aT_True. apply has_type_wf_g with (x:=x) in H0. auto.
    inversion H2. auto.
  - apply aT_False. apply has_type_wf_g with (x:=x) in H0. auto.
    inversion H2. auto.
  - apply aT_Sig with (x:=x0). apply IHTypes1 with (N0:=N); auto.
    shelve.
  - apply aT_Pair. apply IHTypes1 with (N0:=N); auto.
    apply IHTypes2 with (N0:=N); auto.
  - apply aT_Prod_Prop with (x:=x0) (i:=i). apply IHTypes1 with (N0:=N); auto. shelve.
  - apply aT_Prod_Type with (x:=x0). apply IHTypes1 with (N0:=N); auto. shelve.
  - apply aT_Lam with (x:=x0). shelve.
  - apply aT_Let with (x:=x0) (A:=A0). apply IHTypes1 with (N0:=N); auto. shelve.
  - eapply aT_If. shelve. apply IHTypes2 with (N0:=N); auto. shelve.
    shelve.
  - shelve.
  - eapply aT_App. auto. apply IHTypes1 with (N0:=N); auto.
    apply IHTypes2 with (N0:=N); auto.
  - eapply aT_Fst. apply IHTypes with (N0:=N); auto.
  - eapply aT_Snd. apply IHTypes with (N0:=N); auto.   *)
Admitted.

Lemma Cut_modulo_equivalence (g: env) (K : cont) (N N': exp) (A B: exp):
(Types_cont g K (Cont N A B) ->
Types g N A ->
Types g N' A ->
Equiv g N N' ->
Types g (fill_hole N' K) B)%ECCA.
Proof.
intros. inversion H ; subst ; cbv.
- assumption.
- cut (@bind N' 0 (@wk 0 B) = B); simpl_term_eq.
  intros. rewrite <- H3. eapply aT_Let with (n:= N') (m:= M) (A:=A) (B:=(wk B)) (x:=y) (g:=g).
  * assumption.
  * apply equivalence_in_derivation with (N := N); assumption.
Qed.

Lemma append_rearrange {V:nat}(g g': env) (x: name) (a: ctxmem) :
  ((append g g')& x ~ a) = (append (g & x ~ a) g').
Proof.
  induction g; auto.
Qed.

Lemma cont_return_type_well_typed (g : env) (K : cont) (iK: cont_is_ANF K) (M : exp) (iM: isConf M) (A B: exp):
  Types_cont g K (Cont M A B) ->
  exists U , Types g B U.
Proof.
  intros. dependent induction H.
  + apply type_well_typed in H. auto. eapply type_requires_well_formed. apply H.
  + apply type_well_typed in H0. names in H0.
    (* need B : U but have (open y (wk B)) : U *)
    shelve.
Admitted.

Lemma shift_no_free (g : env) (B: exp) (x: name):
  (exists U, Types g B U) ->
  B = (open x (wk B)).
Admitted.

Lemma aT_Let_no_bind (g : env) (M : @exp 1) (N A B: exp) (x: name):
  Types g N A ->
  Types (g & x ~ Def N A) (open x M) B ->
  (exists U, Types g B U) ->
  Types g (eLet N M) B.
Proof.
  intros. cut ((bind N (wk B)) = B).
  - intros. rewrite <- H2. apply aT_Let with (A:=A) (x:=x).
    * apply H.
    * apply shift_no_free with (x:=x) in H1.
      rewrite <- H1. auto.
  - simpl_term_eq.
Qed.

Lemma aT_If_no_bind (g : env) (V B M1 M2: exp) (x y: name):
  Types g V eBool ->
  Types (g & y ~ (Eq V eTru)) M1 B ->
  Types (g & y ~ (Eq V eFls)) M2 B ->
  (exists U, Types (g & x ~ Assum eBool) B U) ->
  Types g (eIf V M1 M2) B.
Proof.
  intros. cut ((bind V (wk B)) = B).
  - intros. rewrite <- H3. assert (H4:=H2). destruct H2. apply aT_If with (x:=x) (y:=y) (U:=x0).
    * apply shift_no_free with (x:=x) in H4 as H5.
      rewrite H5 in H2. auto.
    * auto.
    * cut ((bind eTru (wk B)) = B). intros.
      rewrite H5. auto. simpl_term_eq.
    * cut ((bind eFls (wk B)) = B). intros.
      rewrite H5. auto. simpl_term_eq.
  - simpl_term_eq.
Qed.

Lemma open_wk_het_comp (K : cont_r) (M : conf) (x: name):
  open x (het_compose_r (wk_cont K) M) = (het_compose_r K (@open_conf 0 x M)).
Admitted.

Lemma defn_well_typed (g: env) (N M B: exp) :
  Types g (eLet N M) B ->
  exists A, Types g N A.
Proof.
  intros. dependent induction H.
  - exists A. auto.
  - apply IHTypes1 with (M0:=M). auto.
Qed.

Set Printing Implicit.

Lemma Hetereogeneous_Cut (g g': env) (K : cont_r) (M M': conf) (A B: exp):
Types_cont (append g g') (unrestrict_cont K) (Cont M' A B) ->
Types g M A ->
(@WellBound_conf 0 g M) ->
Equiv g M M' ->
Types (append g g') (het_compose_r K M) B.
  intros. induction H1.
  - erewrite het_compose_equal_fill_hole. apply Cut_modulo_equivalence with (A := A) (N:=M').
    assumption. inversion H. assumption. assumption. apply append_env_weakening with (g':=g') in H0.
    assumption. apply aE_Symm. apply append_env_equiv_weakening with (g':=g') in H2. assumption.
  - simpl. pose (defn_well_typed g n m A H0)as H3. destruct H3.
    eapply aT_Let_no_bind.
    * apply append_env_weakening with (g':=g') in H3. apply H3.
    * pose (append_rearrange g g' x (Def n A)) as H4.
      pose (open_wk_het_comp K m x) as H5. rewrite H5. shelve.
    * apply cont_return_type_well_typed in H. auto.
  - simpl. apply aT_If_no_bind with (x:=x) (y:=y).
    * shelve.
    * pose (append_rearrange g g' y (Eq (unrestrict_val v) eTru)) as H3.
      shelve. (*??? what the heLL*)
    * shelve.
    * apply cont_return_type_well_typed in H.
      destruct H. apply weakening with (x:=x) (A':=eBool) in H.
      exists x0. auto.

Admitted.

 *)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 lv1) (plus lv2 lv0)).
Admitted.
QuickChick conj3synthconj3.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e322m2e161m1_11limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* 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 Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Cava.Util.String.
Import ListNotations.
Local Open Scope N_scope.

Record sha256_test_vector :=
  { msg : string;
    msg_N := string_to_N msg;
    msg_bytes := string_to_bytes msg;
    l := N.of_nat (String.length msg * 8);
    expected_digest : N }.

Record sha256_step_by_step_test : Type :=
  { test :> sha256_test_vector;
    expected_padded_msg : N;
    (* first 16 blocks of W for each round *)
    expected_blocks : list (list N);
    (* H at the end of each round *)
    expected_intermediate_digests : list (list N) }.

(**** Test vectors from
      https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Standards-and-Guidelines/documents/examples/SHA256.pdf ****)

Definition test1 : sha256_step_by_step_test :=
  {| test :=
       {| msg := "abc";
          expected_digest := 0xBA7816BF8F01CFEA414140DE5DAE2223B00361A396177A9CB410FF61F20015AD |};
     expected_padded_msg := 0x61626380000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000018;
     expected_blocks :=
       [ (* first 16 blocks of W for i=0 *)
         [ 0x61626380
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000000
           ; 0x00000018 ] ];
     expected_intermediate_digests :=
       [ (* H[0] - H[7] after round 0 *)
         [ 0xBA7816BF
           ; 0x8F01CFEA
           ; 0x414140DE
           ; 0x5DAE2223
           ; 0xB00361A3
           ; 0x96177A9C
           ; 0xB410FF61
           ; 0xF20015AD ] ];
  |}.

Definition test2 : sha256_step_by_step_test :=
  {| test :=
       {| msg := "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq";
          expected_digest := 0x248D6A61D20638B8E5C026930C3E6039A33CE45964FF2167F6ECEDD419DB06C1 |};
     expected_padded_msg := 0x6162636462636465636465666465666765666768666768696768696A68696A6B696A6B6C6A6B6C6D6B6C6D6E6C6D6E6F6D6E6F706E6F70718000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001C0;
     expected_blocks :=
       [ (* first 16 blocks of W for i=0 *)
         [ 0x61626364
           ; 0x62636465
           ; 0x63646566
           ; 0x64656667
           ; 0x65666768
           ; 0x66676869
           ; 0x6768696A
           ; 0x68696A6B
           ; 0x696A6B6C
           ; 0x6A6B6C6D
           ; 0x6B6C6D6E
           ; 0x6C6D6E6F
           ; 0x6D6E6F70
           ; 0x6E6F7071
           ; 0x80000000
           ; 0x00000000];
       (* first 16 blocks of W for i=1 *)
       [ 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x00000000
         ; 0x000001C0 ] ];
     expected_intermediate_digests :=
       [ (* H[0] - H[7] after round 0 *)
         [ 0x85E655D6
           ; 0x417A1795
           ; 0x3363376A
           ; 0x624CDE5C
           ; 0x76E09589
           ; 0xCAC5F811
           ; 0xCC4B32C1
           ; 0xF20E533A ];
       (* H[0] - H[7] after round 1 *)
       [ 0x248D6A61
         ; 0xD20638B8
         ; 0xE5C02693
         ; 0x0C3E6039
         ; 0xA33CE459
         ; 0x64FF2167
         ; 0xF6ECEDD4
         ; 0x19DB06C1 ] ];
  |}.

(* Regression test : corresponds to the inner hash from HMAC test vector 1 from
      https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Standards-and-Guidelines/documents/examples/HMAC_SHA256.pdf  *)
Definition test3 : sha256_test_vector :=
  {| msg := N_to_string (64+34) 0x36373435323330313E3F3C3D3A3B383926272425222320212E2F2C2D2A2B282916171415121310111E1F1C1D1A1B181906070405020300010E0F0C0D0A0B080953616D706C65206D65737361676520666F72206B65796C656E3D626C6F636B6C656E;
     expected_digest := 0xC0918E14C43562B910DB4B8101CF8812C3DA2783C670BFF34D88B3B88E731716 |}.

(* Regression test : checks that padder correctly handles the case where there
   is exactly one word between message and length (52 characters)  *)
Definition test4 : sha256_test_vector :=
  {| msg := "abcdefghijklmnopqrstuvwzyzabcdefghijklmnopqrstuvwxyz";
     expected_digest := 0x8794B1A351873E838EE68D51098C279E9F50ABF5D8B8CBABE97EA3BEA57C6EC7 |}.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition carbongas_bmap_list := [Build_varinfo Tdouble 1%positive (1e-1) (5e-1)].

Definition carbongas_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list carbongas_bmap_list) in exact z).

Definition carbongas (v : ftype Tdouble) :=
  cast Tdouble (let p := (35e6)%F64 in
  let a := (401e-3)%F64 in
  let b := (427e-7)%F64 in
  let t := (300)%F64 in
  let n := (1000)%F64 in
  let k := (13806503e-30)%F64 in
  (((p + ((a * (n / v)%F64)%F64 * (n / v)%F64)%F64)%F64 * (v - (n * b)%F64)%F64)%F64 - ((k * n)%F64 * t)%F64)%F64).

Definition carbongas_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive]) carbongas in exact e').

Derive carbongas_b
SuchThat (forall vmap, prove_roundoff_bound carbongas_bmap vmap carbongas_expr carbongas_b)
As carbongas_bound.
Proof.
idtac "Starting carbongas".
time "carbongas" (
try (subst carbongas_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; error_rewrites);
try (
(prune_terms (cutoff 60);
try match goal with |- (Rabs ?e <= ?a - 0)%R =>
  rewrite Rminus_0_r (* case prune terms will fail to produce reasonable bound on goal*)
end));
(try match goal with |- (Rabs ?e <= ?a - ?b)%R =>
                      try (interval_intro (Rabs e) as G;
                      eapply Rle_trans;
                      [apply G | apply Rminus_plus_le_minus; apply Rle_refl]) end);
try (
try field_simplify_Rabs ;
try match goal with |-Rabs ?a <= _ =>
  try (interval_intro (Rabs a) upper with
  (i_taylor vxH, i_bisect vxH, i_depth 15) as H' ; apply H');
  try (interval_intro (Rabs a) upper as H' ; apply H') end;
  apply Rle_refl)).
Qed.

Lemma check_carbongas_bound: ltac:(CheckBound carbongas_b 2.5e-08%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import ListAux.
Require Import TreeAux.
Lemma customstk3bound_tail0 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_0 u_0 u_0)/\(list_member  il_1 u_0)/\(u_1 = u_0)) -> (list_member  il_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail1 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_head  il_0 u_0))/\(list_order  il_0 u_0 u_0)/\(list_member  il_1 u_0)/\(u_1 = u_0)) -> (list_order  il_1 u_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail2 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_0 u_0 u_0))/\(list_member  il_1 u_0)/\(u_1 = u_0)) -> (list_member  il_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail3 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_1 u_0 u_0)/\(list_head  il_0 u_0)/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (list_member  il_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail4 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_1 u_0 u_0)/\(list_head  il_0 u_0)/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail5 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_1 u_0 u_0))/\(list_head  il_0 u_0)/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (list_member  il_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail6 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_1 u_0 u_0))/\(list_head  il_0 u_0)/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail7 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_1 u_0 u_0))/\(list_head  il_0 u_0)/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_order  il_0 u_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail8 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_head  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail9 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_1 u_0 u_0)/\(not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_member  il_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail10 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_1 u_0 u_0)/\(not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_order  il_0 u_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail11 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_1 u_0 u_0))/\(not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_order  il_0 u_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail12 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_order  il_1 u_0 u_0))/\(not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(u_1 = u_0)) -> (not (list_member  il_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail13 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_1)/\(not (list_head  il_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_1 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_0 u_0)/\(list_head  il_0 u_0)/\(list_order  il_1 u_0 u_1)/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_member  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail14 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_1)/\(not (list_head  il_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_1 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_0 u_0)/\(not (list_head  il_1 u_1))/\(list_head  il_0 u_0)/\(list_order  il_1 u_0 u_1)/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail15 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_1)/\(not (list_head  il_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_1 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_0)/\(list_member  il_0 u_0)/\(not (list_head  il_0 u_0))/\(list_order  il_1 u_0 u_1)/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_head  il_1 u_1))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail16 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_1)/\(not (list_head  il_0 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_1 u_1)/\(not (list_order  il_1 u_1 u_0))/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_0))/\(not (list_head  il_0 u_0))/\(list_order  il_1 u_0 u_1)/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail17 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_0)/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_0 u_1)/\(list_member  il_1 u_0)/\(list_order  il_0 u_1 u_0)/\(list_head  il_0 u_0)/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_member  il_1 u_1))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail18 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_0)/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_head  il_1 u_1))/\(not (list_head  il_1 u_0))/\(list_member  il_0 u_1)/\(not (list_member  il_1 u_0))/\(list_order  il_0 u_1 u_0)/\(list_head  il_0 u_0)/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_member  il_1 u_1))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail19 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_0)/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_head  il_1 u_1))/\(not (list_head  il_1 u_0))/\(not (list_member  il_0 u_1))/\(not (list_member  il_1 u_0))/\(list_order  il_0 u_1 u_0)/\(list_head  il_0 u_0)/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_member  il_1 u_1)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail20 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_0 u_0)/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_member  il_0 u_1))/\(not (list_member  il_1 u_1))/\(list_member  il_1 u_0)/\(not (list_order  il_0 u_1 u_0))/\(list_head  il_0 u_0)/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_1)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail21 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_head  il_0 u_1))/\(list_member  il_1 u_1)/\(list_head  il_1 u_1)/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail22 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_head  il_0 u_1))/\(list_member  il_1 u_1)/\(list_head  il_1 u_1)/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_order  il_1 u_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail23 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_member  il_1 u_1))/\(list_head  il_0 u_1)/\(not (list_head  il_1 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_head  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail24 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(list_member  il_1 u_1)/\(not (list_head  il_0 u_1))/\(not (list_head  il_1 u_1))/\(list_order  il_0 u_1 u_0)/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail25 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_member  il_1 u_1))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail26 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_member  il_1 u_0)/\(list_head  il_0 u_1)/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_0)/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (list_head  il_1 u_1)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail27 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_member  il_1 u_0))/\(not (list_head  il_1 u_0))/\(list_member  il_1 u_1)/\(not (list_member  il_0 u_0))/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail28 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_member  il_1 u_0))/\(not (list_head  il_1 u_0))/\(list_member  il_1 u_1)/\(not (list_member  il_0 u_0))/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail29 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_member  il_1 u_0))/\(not (list_head  il_1 u_0))/\(list_head  il_0 u_1)/\(not (list_head  il_1 u_1))/\(not (list_member  il_1 u_1))/\(not (list_member  il_0 u_0))/\(list_member  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail30 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_order  il_0 u_1 u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_0 u_1))/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_member  il_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail31 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_member  il_1 u_0))/\(not (list_head  il_1 u_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_0 u_1))/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail32 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((not (list_head  il_0 u_1))/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_member  il_1 u_0))/\(not (list_head  il_1 u_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_0 u_1))/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_0 u_0 u_1)/\(not (u_1 = u_0))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail33 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_0 u_1 u_0)/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_order  il_1 u_0 u_1))/\(not (list_member  il_0 u_0))/\(list_head  il_0 u_1)/\(not (list_head  il_0 u_0))/\(not (list_member  il_1 u_0))/\(list_member  il_0 u_1)/\(not (list_order  il_0 u_0 u_1))/\(not (u_1 = u_0))) -> (list_head  il_1 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail34 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_0 u_1 u_0)/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_order  il_1 u_0 u_1))/\(not (list_head  il_0 u_1))/\(list_member  il_1 u_0)/\(not (list_member  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(not (u_1 = u_0))) -> (not (list_member  il_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail35 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_0 u_1 u_0)/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_order  il_1 u_0 u_1))/\(not (list_head  il_0 u_1))/\(not (list_head  il_1 u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(not (u_1 = u_0))) -> (not (list_head  il_0 u_0))).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3bound_tail36 (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (tail_spec  il_0 il_1) -> (((list_order  il_0 u_1 u_0)/\(not (list_member  il_1 u_1))/\(not (list_head  il_1 u_1))/\(not (list_order  il_1 u_1 u_0))/\(not (list_order  il_1 u_0 u_1))/\(not (list_head  il_0 u_1))/\(not (list_head  il_1 u_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_0))/\(not (list_member  il_0 u_1))/\(not (list_order  il_0 u_0 u_1))/\(not (u_1 = u_0))) -> (list_head  il_0 u_0)).
Proof. solve_tail; try (assert (u_0 = u_1); subst; eauto). Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq natural (plus (Zero) (Zero)) (mult (Zero) (Zero))).
Admitted.
QuickChick lfind_hyp_test.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import ast.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                            logic                             *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

(*

a bunch of stuff that was wrong used to live right here

*)

Inductive ExprHoare: forall (t: type), Prop -> expr -> (value -> Prop) :=
| ExprTriple: forall t p s q, ExprHoare t p s q.

Inductive StmtHoare: Prop -> stmt -> Prop -> Prop :=
| StmtTriple: forall p s q, StmtHoare p s q.

Inductive ProcHoare: forall (pt rt: type),
      (value -> Prop) -> proc -> (value -> value -> Prop) ->
	Prop :=
| ProcTriple: forall pt rt p s q, ProcHoare pt rt p s q.


From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Stc.StcSyntax.
From Velus Require Import Clocks.

From Velus Require Import VelusMemory.

From Velus Require Import Stc.StcIsLast.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

Module Type STCMEMORYCORRES
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX      Op)
       (Import Syn   : STCSYNTAX Ids Op CESyn)
       (Import Last  : STCISLAST Ids Op CESyn Syn).

  Definition state := memory val.
  Definition menv := memory val.

  Definition value_corres (x: ident) (S: state) (me: menv) : Prop :=
    find_val x S = find_val x me.

  Definition state_corres (s: ident) (S: state) (me: menv) : Prop :=
    find_inst s S ⌈≋⌉ find_inst s me.

  Definition Memory_Corres
             (tcs: list trconstr)
             (S I S': state)
             (me: menv) : Prop :=
    (forall x,
        (Is_last_in x tcs -> value_corres x S' me)
        /\
        (~ Is_last_in x tcs -> value_corres x S me))
    /\
    (forall s,
        (~ Step_in s tcs /\ ~ Reset_in s tcs ->
         state_corres s S me)
        /\
        (~ Step_in s tcs /\ Reset_in s tcs ->
         state_corres s I me)
        /\
        (Step_in s tcs ->
         state_corres s S' me)).

  Section Preservation.

    Variables (tcs: list trconstr) (S I S': state) (me: menv).
    Hypothesis MemCorres:  Memory_Corres tcs S I S' me.

    Lemma Memory_Corres_Def:
      forall x ck ce,
        Memory_Corres (TcDef x ck ce :: tcs) S I S' me.
    Proof.
      destruct MemCorres as (Lasts & Insts); intros; split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|]; eauto.
        + inv Last.
        + apply Lasts; auto.
      - intro NLast; apply Lasts.
        intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + intro; apply Nrst; right; auto.
      - intros (Nstep & Rst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + inversion_clear Rst as [?? IsSt|]; auto.
          inv IsSt.
      - intros Step.
        apply Insts; inversion_clear Step as [?? IsSt|]; auto.
        inv IsSt.
    Qed.

    Lemma Memory_Corres_Next_present:
      forall x ck e c,
        find_val x S' = Some c ->
        Memory_Corres (TcNext x ck e :: tcs) S I S' (add_val x c me).
    Proof.
      destruct MemCorres as (Lasts & Insts); intros; split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|?? Last]; eauto; unfold value_corres.
        + inv Last; rewrite find_val_gss; auto.
        + intros.
          destruct (ident_eq_dec x0 x).
          * subst; rewrite find_val_gss; auto.
          * rewrite find_val_gso; auto;
              apply Lasts with (1 := Last); auto.
      - intros NLast **; unfold value_corres.
        assert (x0 <> x)
          by (intro; subst; apply NLast; left; constructor).
        assert ( ~ Is_last_in x0 tcs)
          by (intro; apply NLast; right; auto).
        rewrite find_val_gso; auto;
          apply Lasts; auto.
      - intros (Nstep & Nrst).
        assert (~ Step_in s tcs) by (intro; apply Nstep; right; auto).
        assert (~ Reset_in s tcs) by (intro; apply Nrst; right; auto).
        unfold state_corres; setoid_rewrite find_inst_add_val;
          apply Insts; auto.
      - intros (Nstep & Rst).
        assert (~ Step_in s tcs) by (intro; apply Nstep; right; auto).
        assert (Reset_in s tcs)
          by (inversion_clear Rst as [?? IsSt|]; auto; inv IsSt).
        apply Insts; auto.
      - intros Step.
        assert (Step_in s tcs)
          by (inversion_clear Step as [?? IsSt|]; auto; inv IsSt).
        unfold state_corres; setoid_rewrite find_inst_add_val;
          apply Insts; auto.
    Qed.

    Lemma Memory_Corres_Next_absent:
      forall x ck e,
        find_val x S' = find_val x S ->
        Memory_Corres (TcNext x ck e :: tcs) S I S' me.
    Proof.
      destruct MemCorres as (Lasts & Insts); intros * Eq; split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|?? Last]; eauto; unfold value_corres.
        + inv Last.
          destruct (Is_last_in_dec x tcs).
          * apply Lasts; auto.
          * setoid_rewrite Eq; apply Lasts; auto.
        + apply Lasts; auto.
      - intros NLast.
        apply Lasts; intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + intro; apply Nrst; right; auto.
      - intros (Nstep & Rst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + inversion_clear Rst as [?? IsSt|]; auto.
          inv IsSt.
      - intros Step.
        apply Insts; inversion_clear Step as [?? IsSt|]; auto.
        inv IsSt.
    Qed.

    Lemma Memory_Corres_Reset_present:
      forall s ck b Is me',
        find_inst s I = Some Is ->
        me' ≋ Is ->
        ~ Step_in s tcs ->
        Memory_Corres (TcReset s ck b :: tcs) S I S' (add_inst s me' me).
    Proof.
      destruct MemCorres as (Lasts & Insts); intros ?????? E; split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|]; eauto.
        + inv Last.
        + apply Lasts; auto.
      - intro NLast; apply Lasts.
        intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        assert (s0 <> s)
          by (intro; subst; apply Nrst; left; constructor).
        assert (~ Step_in s0 tcs) by (intro; apply Nstep; right; auto).
        assert (~ Reset_in s0 tcs) by (intro; apply Nrst; right; auto).
        unfold state_corres; rewrite find_inst_gso; auto;
          apply Insts; auto.
      - intros (Nstep & Rst).
        unfold state_corres.
        inversion_clear Rst as [?? Rst'|].
        + inv Rst'.
          setoid_rewrite find_inst_gss.
          rewrite E; apply orel_eq_weaken; auto.
        + destruct (ident_eq_dec s0 s).
          * subst; rewrite find_inst_gss.
            rewrite E; apply orel_eq_weaken; auto.
          * assert (~ Step_in s0 tcs) by (intro; apply Nstep; right; auto).
            rewrite find_inst_gso; auto;
              apply (proj1 (proj2 (Insts s0))); auto.
      - intros Step.
        inversion_clear Step as [?? Step'|].
        + inv Step'.
        + unfold state_corres.
          destruct (ident_eq_dec s0 s).
          * subst; intuition.
          * rewrite find_inst_gso; auto; apply Insts; auto.
    Qed.

    Lemma Memory_Corres_Reset_absent:
      forall s ck b Is Ss,
        find_inst s I = Some Is ->
        find_inst s S = Some Ss ->
        Is ≋ Ss ->
        ~ Reset_in s tcs ->
        Memory_Corres (TcReset s ck b :: tcs) S I S' me.
    Proof.
      destruct MemCorres as (Lasts & Insts); intros ????? Find_I Find_S E; split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|]; eauto.
        + inv Last.
        + apply Lasts; auto.
      - intro NLast; apply Lasts.
        intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + intro; apply Nrst; right; auto.
      - intros (Nstep & Rst).
        inversion_clear Rst as [?? Rst'|].
        + inv Rst'.
          assert (~ Step_in s tcs) by (intro; apply Nstep; right; auto).
          unfold state_corres.
          rewrite Find_I, E, <-Find_S.
          apply (proj1 (Insts s)); auto.
        + apply Insts; split; auto.
          intro; apply Nstep; right; auto.
      - intros Step.
        inversion_clear Step as [?? Step'|].
        + inv Step'.
        + apply Insts; eauto.
    Qed.

    Lemma Memory_Corres_Call_present:
      forall s ys ck (rst: bool) b es Ss' me',
        find_inst s S' = Some Ss' ->
        me' ≋ Ss' ->
        Memory_Corres (TcCall s ys ck rst b es :: tcs) S I S' (add_inst s me' me).
    Proof.
      destruct MemCorres as (Lasts & Insts); intros ???????? Find_S' E;
        split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|]; eauto.
        + inv Last.
        + apply Lasts; auto.
      - intro NLast; apply Lasts.
        intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        assert (s0 <> s) as Neq
            by (intro; subst; apply Nstep; left; constructor).
        assert (~ Step_in s0 tcs) by (intro; apply Nstep; right; auto).
        assert (~ Reset_in s0 tcs) by (intro; apply Nrst; right; auto).
        unfold state_corres; rewrite find_inst_gso; auto;
          apply Insts; auto.
      - intros (Nstep & Rst).
        assert (s0 <> s) as Neq
            by (intro; subst; apply Nstep; left; constructor).
        assert (~ Step_in s0 tcs) by (intro; apply Nstep; right; auto).
        inversion_clear Rst as [?? Rst'|]; try inv Rst'.
        unfold state_corres; rewrite find_inst_gso; auto;
          apply Insts; auto.
      - intros Step.
        unfold state_corres.
        inversion_clear Step as [?? Step'|].
        + inv Step'.
          rewrite find_inst_gss.
          rewrite E; apply orel_eq_weaken; auto.
        + destruct (ident_eq_dec s0 s).
          * subst; rewrite find_inst_gss.
            rewrite E; apply orel_eq_weaken; auto.
          * rewrite find_inst_gso; auto; apply Insts; auto.
    Qed.

    Lemma Memory_Corres_Call_absent:
      forall s ys ck (rst: bool) b es Is Ss',
        find_inst s I = Some Is ->
        (rst = false -> find_inst s S ⌈≋⌉ Some Is) ->
        find_inst s S' = Some Ss' ->
        Ss' ≋ Is ->
        ~ Step_in s tcs /\ (if rst then Reset_in s tcs else ~ Reset_in s tcs) ->
        Memory_Corres (TcCall s ys ck rst b es :: tcs) S I S' me.
    Proof.
      destruct MemCorres as (Lasts & Insts); intros ???????? Find_I Find_S Find_S' E NstepRst;
        split; [split|split; [|split]].
      - inversion_clear 1 as [?? Last|]; eauto.
        + inv Last.
        + apply Lasts; auto.
      - intro NLast; apply Lasts.
        intro; apply NLast; right; auto.
      - intros (Nstep & Nrst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + intro; apply Nrst; right; auto.
      - intros (Nstep & Rst).
        apply Insts; split.
        + intro; apply Nstep; right; auto.
        + inversion_clear Rst as [?? Rst'|]; auto.
          inv Rst'.
      - intros Step.
        inversion_clear Step as [?? Step'|].
        + inv Step'.
          destruct rst; apply Insts in NstepRst; unfold state_corres in *.
          * rewrite <-NstepRst, Find_I, <-E.
            apply orel_eq_weaken; auto.
          * rewrite <-NstepRst, Find_S, <-E; auto.
            apply orel_eq_weaken; auto.
        + apply Insts; eauto.
    Qed.

  End Preservation.

End STCMEMORYCORRES.

Module StcMemoryCorresFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX      Op)
       (Syn   : STCSYNTAX Ids Op CESyn)
       (Last  : STCISLAST Ids Op CESyn Syn)
<: STCMEMORYCORRES Ids Op CESyn Syn Last.
  Include STCMEMORYCORRES Ids Op CESyn Syn Last.
End StcMemoryCorresFun.


From iris.base_logic.lib Require Import invariants.

Section tests.
  Context `{invG Σ}.

  Program Definition test : (iProp Σ -n> iProp Σ) -n> (iProp Σ -n> iProp Σ) :=
    λne P v, (▷ (P v))%I.
  Solve Obligations with solve_proper.

End tests.

(** Check that [@Reflexive Prop ?r] picks the instance setoid_rewrite needs.
    Really, we want to set [Hint Mode Reflexive] in a way that this fails, but
    we cannot [1].  So at least we try to make sure the first solution found
    is the right one, to not pay performance in the success case [2].

    [1] https://github.com/coq/coq/issues/7916
    [2] https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp/merge_requests/38
*)
Lemma test_setoid_rewrite :
  exists R, @Reflexive Prop R /\ R = iff.
Proof.
  eexists. split.
  - apply _.
  - reflexivity.
Qed.