Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.TypeInversion.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.Z.Syntax.Equality.
Require Import Crypto.Reflection.Z.Syntax.Util.
Require Import Crypto.Reflection.Z.Bounds.Interpretation.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Bool.

Local Lemma helper logsz v
  : (v < 2 ^ 2 ^ Z.of_nat logsz)%Z <-> (Z.to_nat (Z.log2_up (Z.log2_up (1 + v))) <= logsz)%nat.
Proof.
  rewrite Nat2Z.inj_le, Z2Nat.id by auto with zarith.
  transitivity (1 + v <= 2^2^Z.of_nat logsz)%Z; [ omega | ].
  rewrite !Z.log2_up_le_pow2_full by auto with zarith.
  reflexivity.
Qed.

Local Arguments Z.pow : simpl never.
Local Arguments Z.sub !_ !_.
Local Arguments Z.add !_ !_.
Local Arguments Z.mul !_ !_.
Lemma relax_output_bounds'
      t (tight_output_bounds relaxed_output_bounds : interp_flat_type Bounds.interp_base_type t)
      (Hv : SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds
            = SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) tight_output_bounds)
      v k
      (v' := eq_rect _ (interp_flat_type _) v _ Hv)
      (Htighter : @Bounds.is_bounded_by
                    t tight_output_bounds
                    (@cast_back_flat_const
                       (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds
                       v')
                  /\ @cast_back_flat_const
                       (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds
                       v'
                     = k)
      (Hrelax : Bounds.is_tighter_thanb tight_output_bounds relaxed_output_bounds = true)
  : @Bounds.is_bounded_by
      t relaxed_output_bounds
      (@cast_back_flat_const
         (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds
         v)
    /\ @cast_back_flat_const
         (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds
         v
       = k.
Proof.
  destruct Htighter as [H0 H1]; subst v' k.
  cbv [Bounds.is_bounded_by cast_back_flat_const Bounds.is_tighter_thanb] in *.
  apply interp_flat_type_rel_pointwise_iff_relb in Hrelax.
  induction t; unfold SmartFlatTypeMap in *; simpl @smart_interp_flat_map in *; inversion_flat_type.
  { cbv [Bounds.is_tighter_thanb' ZRange.is_tighter_than_bool is_true SmartFlatTypeMap Bounds.bounds_to_base_type ZRange.is_bounded_by' ZRange.is_bounded_by Bounds.is_bounded_by' Bounds.bit_width_of_base_type] in *; simpl in *.
    repeat first [ progress inversion_flat_type
                 | progress inversion_base_type
                 | progress destruct_head bounds
                 | progress split_andb
                 | progress Z.ltb_to_lt
                 | progress break_match_hyps
                 | progress destruct_head'_and
                 | progress simpl in *
                 | rewrite helper in *
                 | omega
                 | tauto
                 | congruence
                 | progress destruct_head @eq; (reflexivity || omega)
                 | progress break_innermost_match_step
                 | apply conj ]. }
  { compute in *; tauto. }
  { simpl in *.
    specialize (fun Hv => IHt1 (fst tight_output_bounds) (fst relaxed_output_bounds) Hv (fst v)).
    specialize (fun Hv => IHt2 (snd tight_output_bounds) (snd relaxed_output_bounds) Hv (snd v)).
    do 2 match goal with
         | [ H : _ = _, H' : forall x, _ |- _ ] => specialize (H' H)
         end.
    simpl in *.
    split_and.
    repeat apply conj;
      [ match goal with H : _ |- _ => apply H end..
      | apply (f_equal2 (@pair _ _)); (etransitivity; [ match goal with H : _ |- _ => apply H end | ]) ];
      repeat first [ progress destruct_head prod
                   | progress simpl in *
                   | reflexivity
                   | assumption
                   | match goal with
                     | [ |- ?P (eq_rect _ _ _ _ _) = ?P _ ]
                       => apply f_equal; clear
                     | [ H : interp_flat_type_rel_pointwise (@Bounds.is_bounded_by') ?x ?y |- interp_flat_type_rel_pointwise (@Bounds.is_bounded_by') ?x ?y' ]
                       => clear -H;
                          match goal with |- ?R _ _ => generalize dependent R; intros end
                     | [ H : ?x = ?y |- _ ]
                       => first [ generalize dependent x | generalize dependent y ];
                          let k := fresh in intro k; intros; subst k
                     end ]. }
Qed.

Lemma relax_output_bounds
      t (tight_output_bounds relaxed_output_bounds : interp_flat_type Bounds.interp_base_type t)
      (Hv : SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds
            = SmartFlatTypeMap (fun _ => Bounds.bounds_to_base_type) tight_output_bounds)
      v k
      (v' := eq_rect _ (interp_flat_type _) v _ Hv)
      (Htighter : @Bounds.is_bounded_by t tight_output_bounds k
                  /\ @cast_back_flat_const
                       (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) tight_output_bounds
                       v'
                     = k)
      (Hrelax : Bounds.is_tighter_thanb tight_output_bounds relaxed_output_bounds = true)
  : @Bounds.is_bounded_by t relaxed_output_bounds k
    /\ @cast_back_flat_const
         (@Bounds.interp_base_type) t (fun _ => Bounds.bounds_to_base_type) relaxed_output_bounds
         v
       = k.
Proof.
  pose proof (fun pf => @relax_output_bounds' t tight_output_bounds relaxed_output_bounds Hv v k (conj pf (proj2 Htighter)) Hrelax) as H.
  destruct H as [H1 H2]; [ | rewrite <- H2; tauto ].
  subst v'.
  destruct Htighter; subst k; assumption.
Qed.


Require Import Vector.
Require Import Arith.
Require Import Bool.Bvector.
(* Try to represent bool function as list of result,
for example conj will represent like {0, 0, 0, 1} *)

Definition BoolFunN (n: nat) : Type := t bool (2^n).

Definition BoolFun : Set := forall (n: nat), t bool (2^n).

Definition TwoBoolFun := BoolFunN 2.
(*Definition conj := BoolFun ([false ; false ; false ; true ]).*)

Inductive Close: closClass -> Prop :=
| ClPreserveFalse : forall x, Close ( PreservesFalse x)
| ClPreserveTrue : forall x, Close ( PreservesTrue x)
| ClSelfDual : forall x, Close ( SelfDual x)
| ClMonotonous : forall x, Close ( Monotonous x)
| ClLinear : forall x, Close ( Linear x).

Definition сompose {BoolFun} (f : BoolFun -> BoolFun) (g: BoolFun -> BoolFun) :=
  fun x: BoolFun => g (f x).

(*Systems of bool func*)
(*Definition SystemBoolFun := forall (m: nat), t BoolFun m.*)

Definition IsPreservesFalseFunc (f : BoolFun): Prop :=
  match f with
    |
    | false => False
end.

(*Inductive BoolFun : Type :=
| One (x : t bool 1)
| Two (x : t bool 2)
| Three (x : t bool 3)
| Four (x : t bool 4) .*)

(*Inductive BoolFun :=
| ConstTrue  (x : Prop)
| ConstFalse (x : Prop)
| Id (x : Prop)
| Not (x : Prop)impl
| And (x y: BoolFun)
| Or (x y: BoolFun).

Definition ConstTrueFun (x: Prop) := ConstTrue x.
Definition ConstFalseFun (x: Prop) := ConstFalse x.
Definition IdFun (x : Prop) := Id x.
Definition NotFun (x: Prop) := Not x.
Definition AndFun (x y: BoolFun) := And x y.
Definition OrFun (x y: BoolFun) := Or x y.

Fixpoint interpr (f : BoolFun) : Prop :=
  match f with

  | ConstTrue x => True
  | ConstFalse x => False
  | Id x => x
  | Not x => not x
  | And x y => and (interpr (x : BoolFun)) (interpr (y : BoolFun))
  | Or x y => or (interpr (x : BoolFun)) (interpr (y : BoolFun))
end.*)


Require Import Coq.Arith.Compare_dec.

Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types.

Require Import Metrics.Mappings Metrics.Cauchy Metrics.Mappings Metrics.Banach.
Require Import Metrics.Complete_UltraMetric.

Require Import
        Categories.Category.Main
        Categories.Functor.Main
        Categories.Ext_Cons.Prod_Cat.Prod_Cat
        Categories.Basic_Cons.Terminal
.
Require Import MCat.MCat.

Require Import MCat.MCat MCat.Opposite MCat.Product MCat.MFunc.

Require Import MCat.FixedPoint.BiAlgebra.

Section FixedPoint_Initial_BiAlg.
  Context {L : MLattice}
          {M : MCat L}
          (F : LocallyContractive (MCat_Prod (MCat_Op M) M) M)
          (MTerm : Terminal M)
          (starting_point :
             (
               (terminal MTerm)
                 –≻
                 (F _o (terminal MTerm, terminal MTerm))%object
             )%morphism
          )
  .

  (** The inhabited subcategory of M. *)
  Definition inhM := Full_SubCategory M (fun c => ((terminal MTerm) –≻ c)%morphism).

  Section inhM_Hom_inh.
    Context (a b : inhM).

    (** There always is an arrow from any a to any b in inhM. *)
    Definition inhM_Hom_inh : (a –≻ b)%morphism :=
      exist _ (MC_compose _ (t_morph MTerm (projT1 a), projT2 b)) I.

  End inhM_Hom_inh.

  (** F restricts to inhM. *)
  Program Definition inhF : (((inhM ^op) × inhM) –≻ inhM)%functor :=
    {|
      FO :=
        fun a =>
          existT
            _
            (F _o (projT1 (fst a), projT1 (snd a)))%object
            (MC_compose
               _
               (starting_point,
                ((F @_a (_, _) (_, _) (t_morph MTerm (projT1 (fst a)) , projT2 (snd a))))%morphism)
            );
      FA :=
        fun a b f =>
          exist _ (F @_a (_, _) (_, _) (proj1_sig (fst f), proj1_sig (snd f)))%morphism I;

      F_id :=
        fun a =>
          sig_proof_irrelevance
            _
            (exist _ _ _)
            (exist _ _ _)
            (F_id F (projT1 (fst a), projT1 (snd a)));
      F_compose :=
        fun a b c f g =>
          sig_proof_irrelevance
            _
            (exist _ _ _)
            (exist _ _ _)
            (@F_compose
               _
               _
               F
               (_, _)
               (_, _)
               (_, _)
               (proj1_sig (fst f), proj1_sig (snd f))
               (proj1_sig (fst g), proj1_sig (snd g))
            )
    |}.

  Context {A : inhM} (i : (inhF _o (A, A) ≃≃ A ::> inhM)%isomorphism).

  (** The BiAlgebra induced by A and i. *)
  Definition Ai_BiAlg : BiAlgebra inhF :=
    {|
      BiAlg_obj := A;
      BiAlg_from_obj := (inverse_morphism i);
      BiAlg_to_obj := (iso_morphism i)
    |}.

  Section Construct_BiAlg_Morph.
    Context (B : BiAlgebra inhF).

    (** The following is an operator D that maps a pair of arrows h : B –≻ A and
k : A –≻ B as follows: D(h, k) = (i ∘ F(h, k) ∘ g, f ∘ F(k, h) ∘ i⁻¹) where
f : F(B, B) –≻ B and g : B –≻ F(B, B) are the arrows forming bi-algebra B.

Here D is named Construct_BiAlg_Morph as it is used to create bi-algebra
morphisms.
     *)
    Program Definition Construct_BiAlg_Morph :
      Contractive
        (
          MC_Hom
            (MCat_Prod M (MCat_Op M))
            (projT1 (BiAlg_obj B), projT1 (BiAlg_obj B))
            (projT1 A, projT1 A)
        )
        (
          MC_Hom
            (MCat_Prod M (MCat_Op M))
            (projT1 (BiAlg_obj B), projT1 (BiAlg_obj B))
            (projT1 A, projT1 A)
        )
      :=
        {|
          CN_fun :=
            fun kh =>
              (
                (
                  MC_compose
                    _
                    (
                      MC_compose
                        _
                        (
                          (proj1_sig (BiAlg_from_obj B)),
                          (F @_a (_, _) (_, _) (snd kh, fst kh))%morphism
                        )
                      ,
                      proj1_sig (iso_morphism i)
                    )
                )
                ,
                (
                  MC_compose
                    _
                    (
                      MC_compose
                        _
                        (
                          (proj1_sig (inverse_morphism i)),
                          (F @_a (_, _) (_, _) (fst kh, snd kh))%morphism
                        )
                      ,
                      (proj1_sig (BiAlg_to_obj B))
                    )
                )
              );
          CN_ContrRate := LCN_ContrRate _ _ F
        |}.

    Next Obligation.
    Proof.
      repeat (apply lub_lst; intros [];
              try (eapply PO_Trans; [apply NE_non_expansive |]));
      cbn; try rewrite UM_eq_zero_dist; trivial;
      (eapply PO_Trans;
       [apply (@CCN_contractive _ _ _ _ (@LCN_FA _ _ _ F _ _))|]); trivial;
      rewrite lub_sym; trivial.
    Qed.

    (** A fixed point of D gives a bi-algebra morphism from Ai_BiAlg to B. *)
    Section fixedpoint_of_Construct_BiAlg_Morph_forms_BiAlg_Morph.
      Context
        (h : ((projT1 (BiAlg_obj B)) –≻ (projT1 A))%morphism)
        (k : ((projT1 A) –≻ (projT1 (BiAlg_obj B)))%morphism)
        (fx : Construct_BiAlg_Morph (h, k) = (h, k))
      .

      Local Obligation Tactic := idtac.

      Program Definition fixedpoint_of_Construct_BiAlg_Morph_forms_BiAlg_Morph :
        BiAlg_Morph Ai_BiAlg B :=
        {|
          BAM_forward := exist _ k I;
          BAM_backward := exist _ h I
        |}.

      Next Obligation.
      Proof.
        basic_simpl.
        apply sig_proof_irrelevance; cbn.
        set (W := f_equal snd fx); cbn in W; rewrite <- W at 2; clear W.
        rewrite MC_assoc_sym.
        rewrite MC_assoc.
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (left_inverse i)).
        rewrite MC_id_unit_right; trivial.
      Qed.

      Next Obligation.
      Proof.
        basic_simpl.
        apply sig_proof_irrelevance; cbn.
        set (W := f_equal fst fx); cbn in W; rewrite <- W at 2; clear W.
        rewrite MC_assoc_sym.
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (left_inverse i)).
        rewrite MC_id_unit_left; trivial.
      Qed.

    End fixedpoint_of_Construct_BiAlg_Morph_forms_BiAlg_Morph.

    (** A bi-algebra morphism from Ai_BiAlg to B gives a fixed point of D. *)
    Section BiAlg_Morph_forms_fixedpoint_of_Construct_BiAlg_Morph.
      Context
        (m : BiAlg_Morph Ai_BiAlg B)
      .

      Local Obligation Tactic := idtac.

      Theorem BiAlg_Morph_forms_fixedpoint_of_Construct_BiAlg_Morph :
        Construct_BiAlg_Morph
          (proj1_sig (BAM_backward m), proj1_sig (BAM_forward m)) =
        (proj1_sig (BAM_backward m), proj1_sig (BAM_forward m))
      .
      Proof.
        basic_simpl.
        repeat rewrite MC_assoc_sym.
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (BAM_forward_com m)).
        repeat rewrite MC_assoc.
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (BAM_backward_com m)).
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (right_inverse i)).
        repeat rewrite MC_assoc_sym.
        cbn_rewrite (f_equal (fun x : sig _ => proj1_sig x) (right_inverse i)).
        rewrite MC_id_unit_right, MC_id_unit_left; trivial.
      Qed.

    End BiAlg_Morph_forms_fixedpoint_of_Construct_BiAlg_Morph.

  End Construct_BiAlg_Morph.

  Program Definition FixedPoint_Initial_BiAlg : Initial (BiAlg_Cat inhF) :=
    {|
      terminal := Ai_BiAlg;
      t_morph :=
        fun d =>
          fixedpoint_of_Construct_BiAlg_Morph_forms_BiAlg_Morph
            d
            _
            _
            (
              Banach_is_FixedPoint
                (
                  Product.product_CUM
                    (MC_Hom M (projT1 (BiAlg_obj d)) (projT1 A))
                    (MC_Hom M (projT1 A) (projT1 (BiAlg_obj d)))
                )
                (proj1_sig (inhM_Hom_inh d A), proj1_sig (inhM_Hom_inh A d))
                (Construct_BiAlg_Morph d)
            )
    |}.

  Next Obligation.
    set (W :=
           Banach_unique
             _
             (Construct_BiAlg_Morph d)
             _
             _
             (BiAlg_Morph_forms_fixedpoint_of_Construct_BiAlg_Morph d f)
             (BiAlg_Morph_forms_fixedpoint_of_Construct_BiAlg_Morph d g)
        ).
    clearbody W.
    apply BiAlg_Morph_eq_simplify;
    destruct (BAM_forward f);
    destruct (BAM_backward f);
    destruct (BAM_forward g);
    destruct (BAM_backward g);
    apply sig_proof_irrelevance.
    apply (f_equal snd W).
    apply (f_equal fst W).
  Qed.

End FixedPoint_Initial_BiAlg.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ----                      binary_strat.v                           ----- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*
  This file proves that (euclidean) division by 2 is a correct
 strategy (in the sens of or chain generation algorithm); this
 is the worst strategy (wrt. the number of multiplications used
 to compute x^n.

*)

Require Import strategies.
Require Import Arith.
Require Import euclid.
Require Import shift.
Require Import Euclid.
Require Import Le_lt_compl.
Require Import Mult_compl.
Require Import Constants.

Lemma binary : strategy.
(********************)
Proof.
 refine
  (mkstrat
     (fun n h => match quotient two _ n with
                 | exist n0 e => exist _ n0 _
                 end)).
(*
 Realizer [n:nat](quotient two n) .
 Program_all.
*)
 auto with arith.
 elim e; simple induction 1; intros H1 H2.
  (* H1: n=(plus (mult n0 two) x)
     H2: (gt two x)
  *)
 case (enum1 x H2); intro H3.

 (* case of a null rest (x) *)

 cut (n = n0 * two); [ intro eg | idtac ].
 cut (two <= n0); [ intro H'1 | idtac ].
 split; auto.
 rewrite eg; apply mult_p_lt_pq.
 apply lt_le_trans with 2; auto with arith.
 auto with arith.
   (* goal: le two n0 *)
 apply not_lt_le; unfold not in |- *; intro.
 absurd (n < four); [ apply lt_asym; auto with arith | idtac ].
 rewrite eg; replace four with (two * two).
 apply mult_lt_r.
 auto with arith.
 auto with arith.
 simpl in |- *; auto with arith.
 rewrite (plus_n_O (n0 * two)); elim H3; auto with arith.

(* case of a rest = 1 *)
 cut (two <= n0); [ intro H'1 | idtac ].
 split; [ idtac | auto with arith ].
 rewrite H1; rewrite mult_comm; apply lt_b_qbr.
 rewrite H3; auto with arith.
 auto with arith.
 apply lt_le_trans with two; [ idtac | auto with arith ].
 rewrite H3; auto with arith.
 apply not_lt_le; unfold not in |- *; intro.
 cut (n <= three).
 intro; absurd (four < three);
  [ unfold four, three in |- *; auto with arith | idtac ].
 apply lt_le_trans with n; auto with arith.
 replace three with (one * two + x).
 rewrite H1; auto with arith.
 rewrite H3; simpl in |- *; auto with arith.
Qed.


From UT Require Import Prelims Setoid.
Require Import Coq.Classes.CRelationClasses.
Require Import FunctionalExtensionality.

Definition flip {A B C : Type} (f : A -> B -> C) := fun x y => f y x.

Class Typoid (A: Type): Type :=
   mkTypoid
   {
      st         :  Setoid A;
      ett        :  ∏ {x y: A}, crelation (@et A st x y) where "a == b" := (ett a b);
      ett_refl   :  ∏ {x y: A} (e: x ~> y), e == e;
      ett_sym    :  ∏ {x y: A} (e d: x ~> y), e == d -> d == e;
      ett_trans  :  ∏ {x y: A} (e d f: x ~> y), e == d -> d == f -> e == f;
      Typ1_i     :  ∏ {x y: A} (e: x ~> y), (eqv x) o e == e;
      Typ1_ii    :  ∏ {x y: A} (e: x ~> y), e o (eqv y) == e;
      Typ2_i     :  ∏ {x y: A} (e: x ~> y), e o (inv e) == eqv x;
      Typ2_ii    :  ∏ {x y: A} (e: x ~> y), (inv e) o e == eqv y;
      Typ3       :  ∏ {x y z t: A} (e1: x ~> y) (e2: y ~> z) (e3: z ~> t), ((e1 o e2) o e3) == (e1 o (e2 o e3));
      Typ4       :  ∏ {x y z: A} (e1 d1: x ~> y) (e2 d2: y ~> z), e1 == d1 -> e2 == d2 -> (e1 o e2) == (d1 o d2);
      SP         :> ∏ {x y z: A}, CMorphisms.Proper ((@ett x y) ===> (@ett y z) ===> (@ett x z)) (star);
      EP         :> ∏ {x: A}, CMorphisms.Proper (@ett x x) (eqv x);
      IP         :> ∏ {x y: A}, CMorphisms.Proper (@ett x y ===> @ett y x) (inv);
(*       IdP        :> ∏ {x y: A}, CMorphisms.Proper (@ett x y ===> @ett x y) (Id)  *)
   }.

(* Instance all_iff_morphism (A : Type) (x y: A) (T: Typoid A) :
         CMorphisms.Proper (@ett A T x y ===> @ett A T x y ===> @ett A T x y) (Id).

Add Parametric Morphism A (x y: A) (T: Typoid A): (Id)
  with signature (@ett A T x y) ===> (@ett A T x y) as www. *)

Notation "x '==' y" := (ett x y) : type_scope.

(* Instance EqRRel_ett: ∏ {A T} x y, RewriteRelation (@ett A T x y). *)

Instance EqRel_ett: ∏ {A T} x y, Equivalence (@ett A T x y).
   constructor; intro.
        apply ett_refl.
        apply ett_sym.
        apply ett_trans.
Defined.

Arguments et {_} _ _ _ .

Lemma Typ5: forall {A: Type} {x y z: A} {T: Typoid A} (f: x ~> y) (g: y ~> z),
  inv (f o g) == inv g o inv f.
Proof. intros.
        assert (inv (f o g) o (f o g) == eqv z).
        { now rewrite Typ2_ii. }
        assert (inv (f o g) o (f o g) o inv g o inv f == inv g o inv f).
        { now rewrite X, Typ1_i. }
        setoid_rewrite <- Typ3 at 1 in X0.
        setoid_rewrite Typ3 at 2 in X0.
        rewrite Typ2_i in X0.
        setoid_rewrite Typ3 at 1 in X0.
        rewrite Typ1_i in X0.
        setoid_rewrite Typ3 at 1 in X0.
        rewrite Typ2_i, Typ1_ii in X0. easy.
Qed.

Lemma Typ6: forall {A: Type} {x y: A} {T: Typoid A} (f: x ~> y),
  inv (inv f) == f.
Proof. intros.
        assert (inv (inv f) o (inv f) == eqv x).
        { now rewrite Typ2_ii. }
        assert (inv (inv f) o inv f o f == f).
        { now rewrite X, Typ1_i. }
        now rewrite Typ3, Typ2_ii, Typ1_ii in X0.
Qed.

Lemma Typ9: forall {A: Type} {x y: A} {T: Typoid A} (f: x ~> y),
  inv (eqv x) o f == f.
Proof. intros. specialize (@Typ2_i _ T x y f); intro H.
       now rewrite <- H, Typ5, Typ3, Typ6, Typ2_ii, Typ1_ii.
Defined.

Reserved Notation "x '~~>' y" (at level 70, y at next level).

Definition e3 A: Typoid A.
Proof. unshelve econstructor.
        - unshelve econstructor.
          + exact (fun x y: A => Id x y).
          + exact (fun x => refl x).
          + exact (fun (x y z: A) (p: Id x y) (q: Id y z) => concat p q).
          + exact (fun (x y: A) (p: Id x y) => inverse p).
        - exact (fun (x y: A) (e d: Id x y) => Id e d).
        - intros. now cbn.
        - cbn. intros. exact (inverse X).
        - cbn. intros. now induction X, X0.
        - cbn. intros. now induction e.
        - intros. now destruct e.
        - intros. cbn. now destruct e.
        - intros. cbn. now destruct e.
        - intros. cbn. now destruct e1, e2, e3.
        - intros. cbn in *. now induction X, X0.
        - repeat intros x y z p1 p2 r q1 q2 s. cbn in *.
           now induction r, s.
        - repeat intro.
          simpl.
          unfold CMorphisms.Proper.
          apply refl.
        - repeat intro.
          induction X.
          apply refl.
(*         - repeat intro. now cbn.
        - repeat intro. cbn. now induction X. *)
Defined.

Definition e4 (A B: Type): Typoid (A -> B).
Proof. unshelve econstructor.
       - unshelve econstructor.
         + exact (fun (f g: A -> B) => ∏x: A, Id (f x) (g x)).
         + exact (fun (f: A -> B) (x: A) => refl (f x)).
         + cbn. exact (fun (f g h: A -> B) (e1: ∏ x : A, Id (f x) (g x)) (d: ∏ x : A, Id (g x) (h x)) (x: A) => concat (e1 x) (d x)).
         + exact (fun (f g: A -> B) (e1: ∏ x : A, Id (f x) (g x)) (x: A) => inverse (e1 x)).
       - exact (fun (f g: A -> B) (e1 e2: ∏ x : A, Id (f x) (g x)) => ∏x: A, Id (e1 x) (e2 x)).
       - cbn. intros. easy.
       - cbn. intros.
         exact (inverse (X x0)).
       - cbn. intros.
         exact (concat (X x0) (X0 x0)).
       - cbn. intros.
         now destruct (e x0).
       - cbn. intros.
         now destruct (e x0).
       - cbn. intros.
         now destruct (e x0).
       - cbn. intros.
         now destruct (e x0).
       - cbn. intros.
         apply inverse, concat_assoc.
       - cbn. intros.
         now induction (X x0), (X0 x0).
       - repeat intro. cbn in *. now induction (X x2), (X0 x2).
        - repeat intro.
          simpl.
          unfold CMorphisms.Proper.
          apply refl.
        - repeat intro.
          unfold inv.
          induction (X x1).
          apply refl.
(*        - repeat intro. now cbn.
       - repeat intro. cbn. now induction (X x1). *)
Defined.

Definition OppositeT {A: Type} (T: Typoid A): Typoid A.
Proof. unshelve econstructor.
        - exact (OppositeS (@st A T)).
        - intros x y.
          exact (@ett A T y x).
        - intros.
          exact (ett_refl e).
        - intros x y e d p.
          exact (ett_sym e d p).
        - intros x y e d f p q.
          exact (ett_trans e d f p q).
        - intros x y e.
          exact (Typ1_ii e).
        - intros x y e.
          exact (Typ1_i e).
        - intros x y e.
          exact (Typ2_ii e).
        - intros x y e.
          exact (Typ2_i e).
        - intros x y z t e1 e2 e3.
          exact (ett_sym _ _ (Typ3 e3 e2 e1)).
        - intros x y z e1 d1 e2 d2 p q.
          exact (Typ4 _ _ _ _ q p).
        - repeat intro.
          exact (SP x1 y1 X0 x0 y0 X).
        - repeat intro. exact (EP).
        - repeat intro. exact (IP x0 y0 X).
Defined.

(*
Definition OppositeTypoid {A: Type} (T: Typoid A): Typoid A.
Proof. destruct T, st0.
        unshelve econstructor.
        - exact (OppositeSetoid (mkSetoid A et eqv star inv)).
        - unfold crelation in *.
          intros x y.
(*        exact (flip (ett0 y x)). *)
          exact (ett0 y x).
        - unfold flip.
          intros x y e.
          exact (ett_refl0 y x e).
        - unfold flip.
          intros x y e d eq.
          exact (ett_sym0 y x e d eq).
        - intros x y d e f eq1 eq2.
          unfold flip in *.
          exact (ett_trans0 y x d e f eq1 eq2).
        - cbn in *. unfold flip.
          intros x y e.
(*        exact (ett_sym0 _ _ _ _ (Typ1_ii0 y x e)). *)
          exact (Typ1_ii0 y x e).
        - intros x y e.
          exact (Typ1_i0 y x e).
        - intros x y e.
          exact (Typ2_ii0 y x e).
        - intros x y e.
          exact (Typ2_i0 y x e).
        - intros x y z t e1 e2 e3.
          exact (ett_sym0 _ _ _ _ (Typ7 t z y x e3 e2 e1)).
        - intros x y z e1 d1 e2 d2 eq1 eq2.
          exact (Typ8 z y x e2 d2 e1 d1 eq2 eq1).
        - repeat intro.
          exact (SP0 z y x x1 y1 X0 x0 y0 X).
        - repeat intro. exact (EP0 x).
        - repeat intro. exact (IP0 y x x0 y0 X).
Defined. *)

Definition ProductTypoid: ∏ {A B: Type} (TA: Typoid A) (TB: Typoid B), Typoid (A * B).
Proof. intros.
        unshelve econstructor.
        - exact (ProductSetoid (@st A TA) (@st B TB)).
        - intros x y (e1, e2) (e1', e2').
          exact (((e1 == e1') * (e2 == e2'))%type).
        - intros x y (e1, e2).
          easy.
        - intros x y (e1, e2) (d1, d2) (p, q).
          split; easy.
        - intros x y (e1, e2) (d1, d2) (f1, f2) (p, q) (r, s).
          split.
          + now rewrite p, r.
          + now rewrite q, s.
        - intros x y (e1, d1).
          split; now rewrite Typ1_i.
        - intros x y (e1, d1).
          split; now rewrite Typ1_ii.
        - intros x y (e1, d1).
          split; now rewrite Typ2_i.
        - intros x y (e1, d1).
          split; now rewrite Typ2_ii.
        - intros x y z t (e1, e2) (d1, d2) (f1, f2).
          split; now rewrite Typ3.
        - intros x y z (e1, e2) (d1, d2) (f1, f2) (h1, h2) (p, q) (r, s).
          split.
          + now rewrite p, r.
          + now rewrite q, s.
        - repeat intro.
          destruct x0 as (e1, e2).
          destruct y0 as (d1, d2).
          destruct x1 as (f1, f2).
          destruct y1 as (h1, h2).
          destruct X as (p, q).
          destruct X0 as (r, s).
          split.
          + now rewrite p, r.
          + now rewrite q, s.
        - repeat intro. easy.
        - repeat intro.
          destruct x0 as (e1, e2).
          destruct y0 as (d1, d2).
          destruct X as (p, q).
          split.
          + now rewrite p.
          + now rewrite q.
Defined.

Example UniT: Typoid Type.
Proof. unshelve econstructor.
       - unshelve econstructor.
         + exact (fun A B: Type => Id A B).
         + intros. cbn. apply refl.
         + simpl. intros. apply @concat with (b := y); easy.
         + simpl. intros. induction X. apply refl.
       - intros A B. simpl.
         intros p q.
         exact (Id p q).
       - simpl. intros X Y p. apply refl.
       - simpl. intros X Y p q H. induction H. apply refl.
       - simpl. intros X Y p q r Ha Hb.
         induction Ha; induction Hb. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y Z T p q r. induction p; induction q; induction r. simpl. apply refl.
       - simpl. intros X Y Z p q r t Ha Hb. induction Ha; induction Hb. apply refl.
       - repeat intro. induction X; induction X0. apply refl.
       - repeat intro. simpl. unfold CMorphisms.Proper. apply refl.
       - repeat intro. simpl. induction X. simpl. apply refl.
Defined.

Example UniS: Typoid Set.
Proof. unshelve econstructor.
       - unshelve econstructor.
         + exact (fun A B: Set => Id A B).
         + intros. cbn. apply refl.
         + simpl. intros. apply @concat with (b := y); easy.
         + simpl. intros. induction X. apply refl.
       - intros A B. simpl.
         intros p q.
         exact (Id p q).
       - simpl. intros X Y p. apply refl.
       - simpl. intros X Y p q H. induction H. apply refl.
       - simpl. intros X Y p q r Ha Hb.
         induction Ha; induction Hb. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y p. induction p. simpl. apply refl.
       - simpl. intros X Y Z T p q r. induction p; induction q; induction r. simpl. apply refl.
       - simpl. intros X Y Z p q r t Ha Hb. induction Ha; induction Hb. apply refl.
       - repeat intro. induction X; induction X0. apply refl.
       - repeat intro. simpl. unfold CMorphisms.Proper. apply refl.
       - repeat intro. simpl. induction X. simpl. apply refl.
Defined.

Example Uni: Typoid Type.
Proof. unshelve econstructor.
       - unshelve econstructor.
         + exact (fun A B: Type => ∑ f: A -> B, ishae f).
         + intros. cbn.
           exists id. apply isequiv_ishae.
           unshelve econstructor.
           * exists id. easy.
           * exists id. easy.
         + cbn. intros.
           destruct X as (f, cc1).
           destruct X0 as (g, cc2).
           apply ishae_isequiv, h249_ii in cc1.
           apply ishae_isequiv, h249_ii in cc2.
           destruct cc1 as (invf, (cc1a, cc1b)).
           destruct cc2 as (invg, (cc2a, cc2b)).
           unfold compose, homotopy, id in *. cbn.
           exists (compose f g).
           apply isequiv_ishae, h249_i.
           unshelve econstructor.
           exact (compose invg invf).
           split.
           ++ unfold compose, homotopy, id in *. cbn.
              intro c.
              specialize (cc1a (invg c)).
              apply Id_eql in cc1a. rewrite cc1a.
              easy.
           ++ unfold compose, homotopy, id in *. cbn.
              intro a.
              specialize (cc2b (f a)).
              apply Id_eql in cc2b. rewrite cc2b.
              easy.
         + cbn. intros.
           destruct X as (f, cc1).
           apply ishae_isequiv, h249_ii in cc1.
           destruct cc1 as (invf, (cc1, cc2)).
           exists invf.
           apply isequiv_ishae, h249_i.
           unshelve econstructor.
           ++ exact f.
           ++ split; easy.
       - cbn. intros A B (f, u) (f', v).
(*  (f, u) (f', u'). *)
         exact (homotopy f f').
(*          exact (fun (e1 e2: ∑ f: A -> B, ishae f) => ∏x: A, Id ((pr1 e1) x) ((pr1 e2) x)). *)
       - cbn. intros. now destruct e.
       - cbn. intros. destruct d, e.
         intro a.
         specialize (X a).
         now apply inverse in X.
       - cbn. intros.
         destruct e, f, d.
         intro a.
         exact (concat (X a) (X0 a)).
      - cbn. intros.
         destruct e, (h249_ii (ishae_isequiv pr1 pr2)), pr3.
         easy.
       - cbn. intros.
         destruct e, (h249_ii (ishae_isequiv pr1 pr2)), pr3.
         easy.
       - cbn. intros. destruct e.
         cbn. destruct ( h249_ii (ishae_isequiv pr1 pr2)), pr3.
         cbn.
         unfold homotopy, compose, id in *.
         intro x0.
         now specialize (pr4 x0).
       - cbn. intros. destruct e.
         cbn. destruct ( h249_ii (ishae_isequiv pr1 pr2)), pr3.
         cbn.
         unfold homotopy, compose, id in *.
         intro x0.
         now specialize (pr3 x0).
       - cbn. intros x y z t e1 e2 e3.
         destruct e1, e2, e3, (h249_ii (ishae_isequiv pr1 pr2)), pr7,
         (h249_ii (ishae_isequiv pr0 pr3)).
         destruct pr10. cbn.
         destruct (h249_ii (ishae_isequiv pr4 pr5)).
         destruct pr13. now cbn.
       - cbn. intros.
         destruct e1, e2, d1, d2, (h249_ii (ishae_isequiv pr1 pr2)).
         destruct pr9.
         destruct (h249_ii (ishae_isequiv pr0 pr3)).
         destruct pr12.
         destruct (h249_ii (ishae_isequiv pr4 pr5)).
         destruct pr15.
         destruct (h249_ii (ishae_isequiv pr6 pr7)).
         destruct pr18.
         unfold homotopy in *.
         intro x0.
         specialize (X0 (pr1 x0)).
         specialize (X x0).
         apply Id_eql in X.
         rewrite X in X0 at 2.
         unfold compose.
         exact X0.
       - repeat intro. cbn.
         destruct x0, x1, y0, y1, (h249_ii (ishae_isequiv pr1 pr2)).
         destruct pr9.
         destruct (h249_ii (ishae_isequiv pr0 pr3)).
         destruct pr12.
         destruct (h249_ii (ishae_isequiv pr4 pr5)).
         destruct pr15.
         destruct( h249_ii (ishae_isequiv pr6 pr7)).
         destruct pr18.
         unfold homotopy, compose in *.
         intro x0.
         specialize (X0 (pr1 x0)).
         specialize (X x0).
         now induction X, X0.
       - repeat intro. now cbn.
       - repeat intro.
         destruct x0, y0 as (pr3, pr4).
         rename pr4 into pr6.
         rename pr3 into pr5.
         rename pr1 into pr3.
         rename pr2 into pr4.
         destruct (h249_ii (ishae_isequiv pr3 pr4)) as (pr7, pr8).
         destruct pr8 as (pr8, pr9).
         destruct (h249_ii (ishae_isequiv pr5 pr6)) as (pr10, pr11).
         destruct pr11 as (pr11, pr12).
         cbn.
         destruct (h249_ii (ishae_isequiv pr3 pr4)) as (pr13, pr14).
         destruct pr14 as (pr14, pr15).
         destruct (h249_ii (ishae_isequiv pr5 pr6)) as (pr16, pr17).
         destruct pr17 as (pr17, pr18).
         unfold homotopy, compose, id in *.
         intro b.
         pose proof X as HH.
         specialize (pr15 (pr10 (pr5 (pr16 b)))).
         specialize (pr12 (pr16 b)).
         apply Id_eql in pr12.
         rewrite pr12 in pr15.
         specialize (X (pr16 b)).
         apply Id_eql in X.
         rewrite X in pr15.
         specialize (pr17 b).
         apply Id_eql in pr17.
         now rewrite pr17 in pr15.
Defined.

(** Universe of Typoids [correspondingly Category of Sets] *)
Definition TypoidUni: Typoid Type.
Proof. unshelve econstructor.
        - unshelve econstructor.
          + exact (et (@st _ Uni)).
          + cbn. intros. exists id.
            apply qinv_ishae.
            unshelve econstructor.
            ++ exact id.
            ++ easy.
          + cbn. intros.
            destruct X as (f, Hf).
            destruct X0 as (g, Hg).
            exists (compose f g).
            unfold compose. apply qinv_ishae.
            unshelve econstructor.
            destruct Hf as (finv, Hf).
            destruct Hg as (ginv, Hg).
            exact (compose ginv finv).
            destruct Hf as (finv, (f_eta, (f_eps, Hf))).
            destruct Hg as (ginv, (g_eta, (g_eps, Hg))).
            split.
            ++ unfold compose, homotopy, id in *.
               intro a. clear Hf.
               specialize (f_eps (ginv a)).
               specialize (ap g f_eps); intro H.
               clear Hg.
               specialize (g_eps a).
               now induction g_eps.
            ++ unfold compose, homotopy, id in *.
               intro a. clear Hg.
               specialize (g_eta (f a)).
               specialize (ap finv g_eta); intro H.
               clear Hf.
               specialize (f_eta a).
               now induction f_eta.
          + cbn. intros. destruct X as (f, Hf).
            destruct Hf as (finv, (eta, (eps, Hfinv))). exists finv.
            apply qinv_ishae.
            unshelve econstructor.
            exact f.
            split; [exact eta | exact eps].
        - unfold crelation. cbn. intros X Y (f, x) (f', x').
          exact (homotopy f f').
        - cbn. intros. destruct e. easy.
        - cbn. intros. destruct e, d. easy.
        - cbn. intros. destruct e, d, f.
          unfold homotopy in *.
          intro a.
          specialize (X a).
          specialize (X0 a).
          now induction X.
        - intros. destruct e. easy.
        - intros. destruct e. easy.
        - intros. destruct e, pr2, pr2, pr3. easy.
        - intros. destruct e, pr2, pr2, pr3. easy.
        - intros x y z t e1 e2 e3.
          destruct e1. destruct e2. destruct e3.
          easy.
        - intros.
          destruct e1 as (pr3, pr4).
          destruct e2 as (pr5, pr6).
          destruct d1 as (pr7, pr8).
          destruct d2 as (pr9, pr10).
          unfold compose, homotopy, id in *.
          intro a.
          specialize (X a).
          specialize (ap pr5 X); intro H.
          specialize (X0 (pr7 a)).
          now induction H.
        - repeat intro.
          destruct x0 as (pr3, pr4).
          destruct y0 as (pr5, pr6).
          destruct x1 as (pr7, pr8).
          destruct y1 as (pr9, pr10).
          unfold homotopy, compose, id in *.
          intro a.
          specialize (X a).
          specialize (ap pr7 X); intro H.
          specialize (X0 (pr5 a)).
          now induction H.
        - repeat intro. easy.
        - repeat intro.
          destruct x0 as (pr3, pr4).
          destruct y0 as (pr5, pr6).
          destruct pr4 as (pr4, pr7).
          destruct pr7 as (pr7, pr8).
          destruct pr8 as (pr8, pr9).
          destruct pr6 as (pr6, pr10).
          destruct pr10 as (pr10, pr11).
          destruct pr11 as (pr11, pr12).
          unfold homotopy, compose, id in *.
          intro a.
          pose proof X as HX.
          pose proof HX as HXX.
          specialize (X (pr4 a)).
          specialize (HX (pr6 a)).
          clear pr12.
          specialize (pr11 a). induction pr11.
          clear pr9.
          specialize (pr8 a). induction pr8.
          specialize (pr7 (pr6 a)).
          now induction HX.
Defined.

(*
(** the setoid of Coq types *)
Definition CoqSetoidT: Setoid Type.
Proof. unshelve econstructor.
        - exact iffT.
        - intro x. easy.
        - intros x y z (f, invf) (g, invg).
          split.
          + exact (compose f g).
          + exact (compose invg invf).
        - intros x y (f, invf).
          split.
          + exact invf.
          + exact f.
Defined.
*)


Require Export D.

(** 2 stars, advanced (double_neg_inf)  *)
Theorem double_neg_inf: forall (P: Prop),
  P -> ~~P.
Proof.
  intros P H. unfold not. intros HPF. apply HPF in H. inversion H.
Qed.


Require Import Coq.micromega.Lia.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Ltac inv H  := inversion H; subst; simpl; clear H.
Ltac contra := intros top; contradiction top; clear top.
Ltac invert := intros top; inversion top; clear top.

Tactic Notation "invert" "as" simple_intropattern(pat) :=
  intros top; inversion top as pat; clear top.

Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p.
Proof. intros. lia. Qed.

Definition comp {a b c} (f : b -> c) (g : a -> b) (x : a) : c := f (g x).
Arguments comp {a b c} f g x /.

Infix "\o" := comp (at level 50).

Theorem comp_id_left : forall {A B} (f : A -> B), id \o f = f.
Proof. reflexivity. Qed.

#[export] Hint Resolve comp_id_left : core.

Theorem comp_id_right : forall {A B} (f : A -> B), f \o id = f.
Proof. reflexivity. Qed.

#[export] Hint Resolve comp_id_right : core.

Theorem comp_assoc : forall {A B C D} (f : C -> D) (g : B -> C) (h : A -> B),
  f \o (g \o h) = (f \o g) \o h.
Proof. reflexivity. Qed.

#[export] Hint Resolve comp_assoc : core.

Theorem uncompose : forall {A B C} (f : B -> C) (g : A -> B) (x : A) (y : C),
  (f \o g) x = f (g x).
Proof. reflexivity. Qed.

Ltac uncompose k :=
  rewrite <- (uncompose k);
  repeat (rewrite <- comp_assoc).

Definition const {A B : Type} (x : A) : B -> A := fun _ => x.

(*
Ltac breakup :=
  repeat match goal with
    | [ H: is_true (_ && _) |- _ ] => move/andP: H => [? ?]
    | [ |- is_true (_ && _) ] => apply/andP; split
    | [ H: is_true (_ || _) |- _ ] => move/orP: H => [?|?]
    | [ |- is_true (_ || _) ] => apply/orP; split
    | [ H: is_true (?X <  ?Y <  ?Z) |- _ ] => move/andP: H => [? ?]
    | [ H: is_true (?X <= ?Y <= ?Z) |- _ ] => move/andP: H => [? ?]
    | [ H: is_true (?X <  ?Y <= ?Z) |- _ ] => move/andP: H => [? ?]
    | [ H: is_true (?X <= ?Y <  ?Z) |- _ ] => move/andP: H => [? ?]
    | [ |- is_true (?X <  ?Y <  ?Z) ] => apply/andP; split
    | [ |- is_true (?X <= ?Y <= ?Z) ] => apply/andP; split
    | [ |- is_true (?X <  ?Y <= ?Z) ] => apply/andP; split
    | [ |- is_true (?X <= ?Y <  ?Z) ] => apply/andP; split
    | [ H: is_true (~~ (?X <  ?Y <  ?Z)) |- _ ] => move/nandP in H
    | [ H: is_true (~~ (?X <= ?Y <  ?Z)) |- _ ] => move/nandP in H
    | [ H: is_true (~~ (?X <  ?Y <= ?Z)) |- _ ] => move/nandP in H
    | [ H: is_true (~~ (?X <= ?Y <= ?Z)) |- _ ] => move/nandP in H
    | [ |- is_true (~~ (?X <  ?Y <  ?Z)) ] => apply/nandP
    | [ |- is_true (~~ (?X <= ?Y <  ?Z)) ] => apply/nandP
    | [ |- is_true (~~ (?X <  ?Y <= ?Z)) ] => apply/nandP
    | [ |- is_true (~~ (?X <= ?Y <= ?Z)) ] => apply/nandP
    end;
  repeat match goal with
    | [ H1: is_true (?X <  ?Y), H2: is_true (?Y <  ?Z) |- _ ] =>
        match goal with
        | [ H: is_true (X < Z) |- _ ] => idtac
        | _ => move: (ltn_trans H1 H2) => ?
        end
    | [ H1: is_true (?X <  ?Y), H2: is_true (?Y <= ?Z) |- _ ] =>
        match goal with
        | [ H: is_true (X < Z) |- _ ] => idtac
        | _ => move: (ltn_leq_trans H1 H2) => ?
        end
    | [ H1: is_true (?X <= ?Y), H2: is_true (?Y <  ?Z) |- _ ] =>
        match goal with
        | [ H: is_true (X < Z) |- _ ] => idtac
        | _ => move: (leq_ltn_trans H1 H2) => ?
        end
    | [ H1: is_true (?X <= ?Y), H2: is_true (?Y <= ?Z) |- _ ] =>
        match goal with
        | [ H: is_true (X <= Z) |- _ ] => idtac
        | _ => move: (leq_trans H1 H2) => ?
        end
    end;
  intuition.

Lemma negneg : forall (a : eqType) (x y : a), ~~ (x != y) -> x = y.
Proof.
  move=> a x y H.
  move/negbTE in H.
  case E: (x == y).
    by move/eqP in E.
  move/eqP in E.
  by move/eqP in H.
Qed.

Lemma negb_eq : forall (T : eqType) (a b : T), ~~ (a != b) = (a == b).
Proof. by move=> T a b; case: (a == b). Qed.

Ltac ordered := abstract (
  intuition;
  breakup;
  repeat match goal with
  | [ H: (_ <= _) = false |- _ ] => move/negbT in H
  | [ H: (_ <  _) = false |- _ ] => move/negbT in H
  end;
  repeat match goal with
  | [ H: is_true (~~ (?X <  ?Y)) |- _ ] => rewrite -leqNgt in H
  | [ H: is_true (~~ (?X <= ?Y)) |- _ ] => rewrite -ltnNge in H
  | [ H: is_true (~~ (?X == ?Y)) |- _ ] => idtac
  | [ H: is_true (~~ (?X != ?Y)) |- _ ] => rewrite negb_eq in H
  | [ |- is_true (~~ (?X <  ?Y)) ] => rewrite -leqNgt
  | [ |- is_true (~~ (?X <= ?Y)) ] => rewrite -ltnNge
  | [ |- is_true (~~ (?X == ?Y)) ] => idtac
  | [ |- is_true (~~ (?X != ?Y)) ] => rewrite negb_eq
  end;
  repeat match goal with
  | [ H: is_true (?X <  ?Y) |- _ ] => move/ltP in H
  | [ H: is_true (?X <= ?Y) |- _ ] => move/leP in H
  | [ H: is_true (?X == ?Y) |- _ ] => move/eqP in H
  | [ H: is_true (?X != ?Y) |- _ ] => move/eqP in H
  | [ |- is_true (?X <  ?Y) ] => apply/ltP
  | [ |- is_true (?X <= ?Y) ] => apply/leP
  | [ |- is_true (?X == ?Y) ] => apply/eqP
  | [ |- is_true (?X != ?Y) ] => apply/eqP
  end;
  omega).

Lemma ltn_addn1 : forall n m, n < m -> n.+1 < m.+1.
Proof. by []. Qed.

Lemma leq_addn1 : forall n m, n <= m -> n.+1 <= m.+1.
Proof. by []. Qed.

Ltac undoubled :=
  breakup;
  do [ apply/ltn_addn1; rewrite ltn_double
     | apply/leq_addn1; rewrite leq_double
     | rewrite doubleS ];
  do [ ordered
     | do [ exact/ltnW/ltnW
          | exact/ltnW
          | exact/leqW/leqW
          | exact/leqW ];
       ordered ].

Lemma Forall_all : forall (T : Type) (a : pred T) (s : seq T),
  reflect (List.Forall a s) (all a s).
Proof.
  move=> T a.
  elim=> [|x xs IHxs] //=.
    by constructor; constructor.
  case E: (a x) => /=.
    case A: (all a xs).
      constructor.
      constructor.
        by rewrite E.
      exact/IHxs.
    constructor.
    move=> Hcontra.
    inversion Hcontra; subst.
    rewrite A in IHxs.
    by move/IHxs in H2.
  constructor.
  move=> Hcontra.
  inversion Hcontra; subst.
  by rewrite E in H1.
Qed.

Ltac match_all :=
  repeat match goal with
  | [ H: List.Forall _ ?Z |- _ ] => move/Forall_all in H
  | [ |- List.Forall _ ?Z ]      => apply/Forall_all
  end;
  abstract match goal with
  | [  H: is_true (all _ ?Z) |- is_true (all _ ?Z) ] =>
      move/allP in H;
      apply/allP;
      intros x_1 H_1;
      specialize (H x_1 H_1);
      clear H_1;
      ordered
  end.
*)

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.


Require Import Ssreflect.ssreflect Ssreflect.ssrbool Ssreflect.ssrnat Ssreflect.ssrfun Ssreflect.eqtype Ssreflect.seq.
Require Import x86proved.spred.
Require Import x86proved.common_tactics x86proved.charge_lemmas.
Require Import Coq.Classes.RelationClasses.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module Existentials.
  Inductive term :=
  | t_atom (P: SPred)
  | t_star (t1 t2: term)
  | t_ex A (f: A -> SPred)
  | t_propand (P: Prop) (Q: SPred).

  Fixpoint eval (t: term) : SPred :=
    match t with
    | t_atom P => P
    | t_star t1 t2 => eval t1 ** eval t2
    | t_ex _ f => lexists f
    | t_propand P Q => P /\\ Q
    end.

  Record find_res := mkf {
    find_type: Type;
    find_closure: find_type -> SPred
  }.

  (**
     Given a term t, when this function succeeds, it will return an SPred with
     one existential quantifier removed and the quantified variable free.
     Notice:
     - Recall that [P /\\ Q] is defined at [Exists _: P, Q], so that works too.
     - We do eval as part of this process rather than afterwards. This is
       because as soon as we represent "terms with a free variable" as
       functions, there isn't any structure left to do elimination on anyway.
     - There is no attempt to find multiple existentials. This keeps the code
       simple, and the tactic needs to be iterated in any case as long as we
       don't look under binders to find nested existentials.
     - The [term] type is a bit wasteful since it reflects the whole formula
       despite only needing the path down to the first existential. Optimising
       that may require more Ltac programming, so it is not guaranteed to be
       faster.
  *)
  Fixpoint find (t: term) : option find_res :=
    match t with
    | t_atom _ => None
    | t_star t1 t2 =>
        match find t1 with
        | Some (mkf _ f1) => Some (mkf (fun P' => (f1 P') ** eval t2))
        | None =>
            match find t2 with
            | Some (mkf _ f2) => Some (mkf (fun P' => eval t1 ** (f2 P')))
            | None => None
            end
        end
    | t_ex _ f => Some (mkf f)
    | t_propand P Q => Some (mkf (fun _: P => Q))
    end.

  Lemma find_correct_pull t:
    match find t with
    | Some (mkf _ f) => eval t |-- Exists a, f a
    | None => True
    end.
  Proof.
    elim: t; red => //.

      rewrite -/find /eval -/eval.
      move=> t1 Ht1 t2 Ht2.
      destruct (find t1) as [[A f]|].
      - rewrite ->Ht1. apply: sepSPAdj. apply: lexistsL => a. apply: wandSPAdj.
        by apply lexistsR with a.
      destruct (find t2) as [[A f]|].
      - rewrite ->Ht2. rewrite sepSPC. apply: sepSPAdj. apply: lexistsL => a.
        apply: wandSPAdj. rewrite sepSPC. by apply lexistsR with a.
      done.

      reflexivity.

      reflexivity.
  Qed.

  Lemma find_correct_push t:
    match find t with
    | Some (mkf _ f) => Exists a, f a |-- eval t
    | None => True
    end.
  Proof.
    elim: t; red => //.
    - rewrite -/find /eval -/eval.
      move=> t1 Ht1 t2 Ht2.
      destruct (find t1) as [[A f]|].
      - apply: lexistsL => a. cancel2. rewrite <-Ht1. by apply lexistsR with a.
      destruct (find t2) as [[A f]|].
      - apply: lexistsL => a. cancel2. rewrite <-Ht2. by apply lexistsR with a.
      done.
    - reflexivity.
    - reflexivity.
  Qed.

  Lemma find_correct t:
    match find t with
    | Some (mkf _ f) => eval t -|- Exists a, f a
    | None => True
    end.
  Proof.
    move: (@find_correct_push t) (@find_correct_pull t).
    case: (find t); last done. move=> []; by split.
  Qed.

  Lemma find_lhs t Q:
    match find t with
    | Some (mkf _ f) => (forall a, f a |-- Q) -> eval t |-- Q
    | None => True
    end.
  Proof.
    move: (@find_correct_pull t). destruct (find t) as [[A f]|]; last done.
    move=> Heval HQ. rewrite ->Heval. exact: lexistsL.
  Qed.

  Lemma find_rhs t P:
    match find t with
    | Some (mkf _ f) => forall a, P |-- f a -> P |-- eval t
    | None => True
    end.
  Proof.
    move: (@find_correct_push t). destruct (find t) as [[A f]|]; last done.
    move=> Hft a HPf. rewrite <-Hft. by apply lexistsR with a.
  Qed.

  Lemma sdestruct_hyp t s (G: Prop):
    match find t with
    | Some (mkf _ f) => (forall a, (f a) s -> G) -> (eval t) s -> G
    | None => True
    end.
  Proof.
    move: (@find_correct_pull t). destruct (find t) as [[A f]|]; last done.
    move=> Htf HG Ht. specialize (Htf _ Ht). destruct Htf as [a Htf]. eauto.
  Qed.

  Ltac quote_term P :=
    match P with
    | ?P1 ** ?P2 =>
        let t1 := quote_term P1 in
        let t2 := quote_term P2 in
        constr:(t_star t1 t2)
    | lexists ?f => constr:(t_ex f)
    | ?P /\\ ?Q => constr:(t_propand P Q)
    | _ => constr:(t_atom P)
    end.

  Ltac sdestruct :=
    match goal with
    | |- ?P |-- ?Q =>
        let t := quote_term P in
        apply: (@find_lhs t Q) || fail 1 "Nothing to destruct";
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
    end.

  Ltac sdestruct_hyp H :=
    move: H;
    match goal with
    | |- (ILFunFrm_pred ?P) ?s -> ?G =>
        let t := quote_term P in
        apply: (@sdestruct_hyp t s G) || fail 1 "Nothing to destruct";
        cbv [eval]
    | |- _ => fail 1 "Hypothesis not of the expected form"
    end.

  Ltac ssplit :=
    match goal with
    | |- ?P |-- ?Q =>
        let t := quote_term Q in
        (* If you change "eapply" to "apply:", you will get the side side
           condition you just proved in the t_propand case as an extra
           assumption in the main goal. I'm thinking that's not usually what
           you want. *)
        eapply (@find_rhs t P) || fail 1 "Nothing to split";
        cbv [eval]
    | |- _ => fail 1 "Goal is not an entailment"
    end.

  Section Example.
    Variable P: SPred.
    Variable f: nat -> SPred.

    Example ex1: P ** (Exists x1, 0 = 1 /\\ f x1) ** (Exists x2, f (1 + x2)) |-- ltrue.
    Proof.
      sdestruct => a. sdestruct => H. sdestruct => b.
      Fail sdestruct. apply: ltrueR.
    Qed.

    Example ex2: lfalse |-- P ** (Exists x1, 0 = 0 /\\ f x1) ** (Exists x2, f (1 + x2)).
    Proof.
      ssplit. ssplit; first done. ssplit. Fail ssplit.
      instantiate (1:=0). instantiate (1:=0). done.
    Qed.
  End Example.
End Existentials.

(* This tactic pulls one existential quantifier or pure proposition out of an
   SPred entailment. It should be syntactically visible, possibly nested under
   stars. *)
Ltac sdestruct := Existentials.sdestruct.

(* This tactic removes one existential quantifier or pure proposition from the
   right-hand side of an entailment goal. Existentials get instantiated by
   metavariables (like eexists), and pure propositions are created as subgoals.
 *)
Ltac ssplit := Existentials.ssplit.

(* Iterated version of sdestruct. *)
Ltac sdestructs :=
  sdestruct; let x := fresh "x" in move=> x; try sdestructs; move: x.

(* Iterated version of ssplit. *)
Ltac ssplits := ssplit; [..|try ssplits].

Tactic Notation "sdestruct" ":" hyp(H) := (Existentials.sdestruct_hyp H).

Module Solving.
  (* We index atoms in the environment with type idx, which is just a wrapper
     for nat. We cannot use any nat-specific functions on it, though, since
     cbv'ing these might cbv parts of the atom if that same function happens
     to be used there. The solution is to redefine such functions under a new
     name. *)
  Section Indexes.
    Definition idx := nat.

    Definition eqn' (i j: idx) := Eval red in eqn i j.

    Lemma eqn'P i j : reflect (i = j) (eqn' i j).
    Proof. apply eqnP. Qed.

    Definition LOOKUP_FAILURE {T} {x : T} := x.
  End Indexes.

  Inductive term :=
  | t_atom (i: idx)
  | t_star (t1 t2: term)
  | t_propand (i: idx) (t: term)
  | t_emp
  | t_false.

  (* Idea: reflect lhs first and choose index for each rhs term with a hole to
     be the first lhs atom that unifies. *)

  Definition spred_alist := seq (idx * SPred).
  Definition prop_alist := seq (idx * Prop).
  Definition env := (idx * spred_alist * prop_alist)%type.

  Fixpoint spred_lookup (a: spred_alist) (i: idx) : SPred :=
    match a with
    | (j,P) :: a' => if eqn' i j then P else spred_lookup a' i
    | [::] => @LOOKUP_FAILURE _ empSP (* default value; shouldn't happen *)
    end.

  Fixpoint prop_lookup (a: prop_alist) (i: idx) : Prop :=
    match a with
    | (j,P) :: a' => if eqn' i j then P else prop_lookup a' i
    | [::] => @LOOKUP_FAILURE _ False (* default value; shouldn't happen *)
    end.

  Fixpoint eval (e: env) (t: term) : SPred :=
    match t with
    | t_atom i => let: (_, a, _) := e in spred_lookup a i
    | t_star t1 t2 => eval e t1 ** eval e t2
    | t_propand i t => (let: (_, _, a) := e in prop_lookup a i) /\\ eval e t
    | t_emp => empSP
    | t_false => lfalse
    end.

  (* Inserts an SPred into an environment. Calls its continuation with the
     updated environment and the index where the predicate was inserted. *)
  Definition spred_insert (e: env) (P: SPred) : env * idx :=
    match e with
      | (i, a, a') => ((i.+1, (i,P)::a, a'), i)
    end.
  Ltac spred_insert_tac e(*:env*) P(*:SPred*) cont(*: env -> idx -> tactic *) :=
    let e'i := constr:(spred_insert e P) in
    let e' := (eval hnf in e'i.1) in
    let i := (eval hnf in e'i.2) in
    cont e' i.

  Definition prop_insert (e: env) (P: Prop) : env * idx :=
    match e with
      | (i, a, a') => ((i.+1, a, (i,P)::a'), i)
    end.
  Ltac prop_insert_tac e(*:env*) P(*:Prop*) cont(*: env -> idx -> tactic *) :=
    let e'i := constr:(prop_insert e P) in
    let e' := (eval hnf in e'i.1) in
    let i := (eval hnf in e'i.2) in
    cont e' i.

  (* Quote left-hand side of entailment. Duplicated terms don't get to share
     indices since this should not typically happen. *)
  (* This tactic is in CPS style to be consistent with rquote and because it
     "returns" both an updated environment and a quoted term. Ltac doesn't make
     it easy to return tuples, but CPS is easy. *)
  Ltac lquote e(*:env*) P(*:SPred*) cont(*: env -> term -> tactic *) :=
    idtac;
    lazymatch P with
    | ?P1 ** ?P2 =>
        lquote e P1 ltac:(fun e t1 =>
        lquote e P2 ltac:(fun e t2 =>
        cont e (t_star t1 t2)))
    | ?P /\\ ?T
      => prop_insert_tac e P ltac:(fun e p =>
         lquote e T ltac:(fun e t =>
         cont e (t_propand p t)))
    | lfalse => cont e t_false
    | empSP => cont e t_emp
    | _ => spred_insert_tac e P ltac:(fun e i => cont e (t_atom i))
    end.

  (*
  Goal forall P: SPred, True.
    move=> P.
    lquote ((0, [::], [::]) : env) (P ** empSP ** P ** lpropand (0 + 0 = 0) empSP) ltac:(fun e t =>
      idtac e; idtac t;
      let P := eval cbv [eval spred_lookup prop_lookup eqn'] in (eval e t) in idtac P
    ).
    apply I. Qed.
  *)

  (* Succeed iff t fails or completely solves the goal *)
  Tactic Notation "not" tactic1(t) := try (t; fail 1).

  (* This tactic succeeds if its two arguments are equal modulo alpha conversion
     and evars. As a side effect, those evars get instantiated. The power and
     complexity of this tactic falls somewhere between the built-in [constr_eq]
     and [unify] tactics. *)
  (* The programming pattern here with match/first/fail is an attempt to
     emulate if/then/else in Ltac. The first/fail pattern serves to prevent
     automatic back-tracking, analogous to "cut" in Prolog. *)
  Ltac cheap_unify p :=
    match p with
    | (?a,?b) => is_evar a; first [unify a b | fail 1]
    | (?a,?b) => is_evar b; first [unify a b | fail 1]
    | (?a,?b) => not (has_evar a); not (has_evar b); first [constr_eq a b | fail 1]
    | (?fa ?xa,?fb ?xb) => cheap_unify (fa, fb); cheap_unify (xa, xb)
    end.

  (* This looks up P in the range of the association list a and calls the
     appropriate continuation. It will look for P modulo instantiation of evars
     inside P and a. *)
  Ltac lookup_tac doUnify a(*:alist*) P(*:SPred*)
      found(*: idx -> tactic*) notfound(*: unit -> tactic*) :=
    match eval hnf in a with
    | (?i, ?P') :: _ =>
      (* We don't unify with something that's entirely an evar. This would lead
         to very random behaviour. *)
      not (is_evar P'); doUnify (P, P'); found i
    | _ :: ?a' => lookup_tac doUnify a' P found notfound
    | _ => notfound tt
    end.

  (* Quote right-hand side of entailment. Any atoms that are already in the env
     will be re-used. Existential metavariables will be instantiated greedily
     to match atoms in env. *)
  (* This tactic has to be in CPS because it refers to lookup_tac, which calls
     the [unify] tactic (https://github.com/coq/coq/commit/18e6108339aaf18499).
   *)
  Ltac rquote doUnify e(*:env*) P(*:SPred*) cont(*: env -> term -> tactic *) :=
    idtac;
    lazymatch P with
    | ?P1 ** ?P2 =>
        rquote doUnify e P1 ltac:(fun e t1 =>
        rquote doUnify e P2 ltac:(fun e t2 =>
        cont e (t_star t1 t2)))
    | ?P /\\ ?T =>
        rquote doUnify e T ltac:(fun e t =>
          let a' := match e with (_, ?a, ?a') => constr:(a') end in
          lookup_tac doUnify a' P
            ltac:(fun j => cont e (t_propand j t))
            ltac:(fun _ => prop_insert_tac e P ltac:(fun e i => cont e (t_propand i t))))
    | empSP => cont e t_emp
    | lfalse => cont e t_false
    | ltrue =>
          (* We don't match up ltrue. We leave it untouched on the right-hand
             side and let the user decide what to do with it. *)
           spred_insert_tac e P ltac:(fun e i => cont e (t_atom i))
    | _ => first [ is_evar P;
                   (* If an atom is entirely an evar, we don't touch it. Otherwise, it
                      would unify with the first thing it saw on the left, which is
                      probably not what the user expects. *)
                   spred_insert_tac e P ltac:(fun e i => cont e (t_atom i))
                 | idtac;
                   match e with
                     | (_, ?a, ?a') =>
                       lookup_tac doUnify a P
                         ltac:(fun j => cont e (t_atom j))
                         ltac:(fun _ => spred_insert_tac e P ltac:(fun e i => cont e (t_atom i)))
                   end ]
    end.

  (** Remove one instance of the atom with index [i] *)
  Fixpoint remove_atom t i : option term :=
    match t with
    | t_atom i' => if eqn' i' i then Some t_emp else None
    | t_star t1 t2 =>
        match remove_atom t1 i with
        | Some t1' => Some (t_star t1' t2)
        | None =>
            match remove_atom t2 i with
            | Some t2' => Some (t_star t1 t2')
            | None => None
            end
        end
    | t_propand P t' =>
      match remove_atom t' i with
        | Some t'' => Some (t_propand P t'')
        | None => None
      end
    | t_emp => None
    | t_false => None
    end.

  (** Remove all instances of the prop with index [i] *)
  Fixpoint remove_prop t i : option term :=
    match t with
    | t_atom i' => None
    | t_star t1 t2 =>
        match remove_prop t1 i, remove_prop t2 i with
        | Some t1', Some t2' => Some (t_star t1' t2')
        | Some t1', None => Some (t_star t1' t2)
        | None, Some t2' => Some (t_star t1 t2')
        | None, None => None
        end
    | t_propand p t' => if eqn' p i
                        then match remove_prop t' i with
                               | Some t'' => Some t''
                               | None => Some t'
                             end
                        else None
    | t_emp => None
    | t_false => None
    end.

  (** Remove all terms showing up in [tQ] from [tP]. *)
  Fixpoint remove (tP tQ: term) : option term :=
    match tQ with
    | t_atom i => remove_atom tP i
    | t_star t1 t2 =>
        match remove tP t1 with
        | Some tP' => remove tP' t2
        | None => None
        end
    | t_propand P t =>
        match remove tP t with
        | Some tP' => remove_prop tP' P
        | None => None
        end
    | t_emp => Some tP
    | t_false => None
    end.

  Local Ltac cancel_sepSP :=
    idtac;
    match goal with
      | [ |- ?a ** ?b |-- ?a ** ?b' ] => (f_cancel; [])
      | [ |- ?a ** ?b |-- ?a' ** ?b ] => (f_cancel; [])
      | [ |- ?a ** ?b -|- ?a ** ?b' ] => (f_cancel; [])
      | [ |- ?a ** ?b -|- ?a' ** ?b ] => (f_cancel; [])
    end.

  Local Ltac t_septac' :=
    idtac;
    match goal with
      | _ => reflexivity
      | _ => eassumption
      | _ => progress simpl_paths
      | _ => progress subst
      | _ => progress simpl
      | _ => progress rewrite ?eq_refl ?empSPL ?empSPR ?sepSPA
      | _ => progress setoid_rewrite <- bilpropandL
      | _ => progress setoid_rewrite <- bilpropandR
      | _ => rewrite ?sepSPA; progress cancel_sepSP
      | _ => rewrite -?sepSPA; progress cancel_sepSP
      | _ => progress destruct_head ex
      | _ => progress destruct_head and
      | [ H : eval _ _ -|- _ |- _ ] => setoid_rewrite -> H; clear H
      | [ H : context[?a == ?a] |- _ ] => rewrite eq_refl in H
      | [ H : context[eqn' ?a ?b] |- _ ] => change (eqn' a b) with (a == b) in *; case_eq (a == b) => *
      | [ H : (?a == ?b) = _, H' : context[?a == ?b] |- _ ] => rewrite H in H'
      | [ H : (?a == ?b) = true |- _ ] => move/eqP in H
      | [ |- _ /\\ _ |-- _ ] => apply lpropandL => *
      | [ |- _ |-- _ /\\ _ ] => (apply lpropandR; try assumption)
      | [ H : forall _, Some _ = Some _ -> _ |- _ ] => specialize (H _ (reflexivity _))
      | [ H : forall _, None = Some _ -> _ |- _ ] => clear H
      | [ H : forall _ _, (_, _) = (_, _) -> _ |- _ ] => specialize (H _ _ (reflexivity _))
      | [ |- ?a ** ?b -|- ?b ** ?a ] => by rewrite sepSPC
      | [ |- _ /\\ _ |-- _ ] => apply lpropandL => *
      | [ |- _ |-- _ /\\ _ ] => (apply lpropandR; first by eassumption)
    end.

  Local Ltac t_remove' :=
    idtac;
    match goal with
      | _ => t_septac'
      | [ H : context[match remove_prop ?a ?b with _ => _ end] |- _ ]
        => (destruct (remove_prop a b); try done)
      | [ H : context[remove_atom ?a ?b] |- _ ]
        => (destruct (remove_atom a b); try done)
    end.

  Local Ltac t_remove := do ?[ t_remove' | split; by t_remove ].

  Lemma remove_atom_correct e t i tR:
    remove_atom t i = Some tR ->
    eval e t -|- eval e (t_atom i) ** eval e tR.
  Proof.
    move: tR.
    (elim: t => /= *; try done);
      t_remove.
  Qed.

  Lemma remove_prop_correct e t i tR:
    remove_prop t i = Some tR ->
    eval e t -|- eval e (t_propand i tR).
  Proof.
    move: tR.
    (elim: t => /= *; try done);
      t_remove.
  Qed.

  Lemma remove_correct e tP tQ tR:
    remove tP tQ = Some tR ->
    eval e tP -|- eval e tQ ** eval e tR.
  Proof.
    move: tP tR. elim: tQ.
    { move=> i tP tR /= HtR. exact: remove_atom_correct. }
    { move=> t1 IHt1 t2 IHt2 tP tR /=.
      specialize (IHt1 tP).
      destruct (remove tP t1) as [tP'|]; last done.
      move=> HtR. move/(_ _ _ HtR): IHt2 => Ht2.
      rewrite sepSPA. rewrite <-Ht2. exact: IHt1. }
    { move => /= i t IH tP *.
      specialize (IH tP).
      destruct (remove tP t); last by exfalso.
      rewrite -> IH; clear IH; last by reflexivity.
      let H := match goal with | [ H : remove_prop ?a ?b = Some _ |- _ ] => constr:(H) end in
      rewrite -> (@remove_prop_correct _ _ _ _ H).
      by do ![ progress simpl
             | progress setoid_rewrite <- bilpropandL
             | progress setoid_rewrite <- bilpropandR ]. }

    { move=> tP tR /= [<-]. by rewrite empSPL. }

    { move=> tP tR /=. done. }
  Qed.

  (** We have the option to remove matched [Prop] bits from the
      hypotheses; we choose not to do so.  We treat [tH] as the
      hypotheses and [tC] as the conclusions. *)
  Fixpoint simplify (tC tH: term) : (term * term) :=
    match tH with
    | t_atom i =>
        match remove_atom tC i with
        | Some tC' => (tC', t_emp)
        | None => (tC, tH)
        end
    | t_star t1 t2 =>
        let (tC', t1')  := simplify tC t1 in
        let (tC'', t2') := simplify tC' t2 in
        (tC'', t_star t1' t2')
    | t_propand P t =>
        let (tC', t') := eta_expand (simplify tC t) in
        match remove_prop tC' P with
          | Some tC'' => (tC'', t_propand P t')
          | None => (tC', t_propand P t')
        end
    | t_emp => (tC, tH)
    | t_false => (tC, tH)
    end.

  Local Ltac t_simplify_correct' :=
    idtac;
    match goal with
      | [ e : env, H : context[match remove_atom ?a ?b with _ => _ end] |- _ ]
        => pose proof (@remove_atom_correct e a b); destruct (remove_atom a b)
      | [ e : env, H : context[match remove_prop ?a ?b with _ => _ end] |- _ ]
        => pose proof (@remove_prop_correct e a b); destruct (remove_prop a b)
      | _ => t_septac'
    end.

  Local Ltac t_simplify_correct :=
    do ![ t_simplify_correct'
        | eexists (t_propand _ _); by t_simplify_correct
        | eexists (t_star _ _); by t_simplify_correct
        | eexists (t_atom _); by t_simplify_correct
        | exists t_emp; by t_simplify_correct
        | eexists; by t_simplify_correct
        | split; by t_simplify_correct ].

  (* Correctness theorem strong enough for induction. *)
  Lemma simplify_correct e tH tC tH' tC' :
    simplify tC tH = (tC', tH') -> exists tR,
    (eval e tH -|- eval e tH' ** eval e tR)  /\
    (eval e tC -|- eval e tC' ** eval e tR).
  Proof.
    move: tC tC' tH'.
    elim: tH.
    { move => /= *; t_simplify_correct. }
    { move=> t1 IHt1 t2 IHt2 tC tC'' tH' /=.
      specialize (IHt1 tC). destruct (simplify tC t1) as [tC' t1'].
      specialize (IHt2 tC'). destruct (simplify tC' t2) as [ttmp t2'].
      move=> [Htmp <-] /=. subst ttmp.
      edestruct IHt1 as [tR1 [Hpre1 Hpost1]]; first reflexivity.
      edestruct IHt2 as [tR2 [Hpre2 Hpost2]]; first reflexivity.
      clear IHt1 IHt2. exists (t_star tR1 tR2) => /=.
      t_simplify_correct. }
    { move => /= P t IH tC *.
      have Hprop := @remove_prop_correct e (simplify tC t).1 P.
      specialize (IH tC _ _ (prod_eta _ _ _)).
      edestruct remove_prop; simpl_paths; subst;
      (specialize (Hprop _ (reflexivity _)) || clear Hprop);
      t_simplify_correct. }
    { move=> tP tP' tQ' /= [<- <-]. exists t_emp.
      rewrite !empSPR. split; reflexivity. }
    { move=> tP tP' tQ' /= [<- <-]. exists t_emp.
      rewrite !empSPR. split; reflexivity. }
  Qed.

  (* Weaker version of correctness theorem. *)
  Corollary simplify_sufficient e tH tC tH' tC' :
    simplify tC tH = (tC', tH') ->
    eval e tH' |-- eval e tC'  ->  eval e tH |-- eval e tC.
  Proof.
    move=> Heq H. have [tR [H1 H2]] := simplify_correct e Heq.
    rewrite ->H1, ->H2. by f_cancel.
  Qed.

  (* remove emp, pull false *)
  Fixpoint clean t :=
    match t with
    | t_star t1 t2 =>
        let t1' := clean t1 in
        let t2' := clean t2 in
        match t1', t2' with
        | t_false, t' => t_false
        | t', t_false => t_false
        | t_emp, t' => t'
        | t', t_emp => t'
        | _, _ => t_star t1' t2'
        end
    | t_propand P t' =>
        let t'' := clean t' in
        match t'' with
          | t_false => t_false
          | _ => t_propand P t''
        end
    | _ => t
    end.

  Lemma clean_correct e t : eval e (clean t) -|- eval e t.
  Proof.
    induction t; try reflexivity.
    { rewrite /=.
      destruct (clean t1); destruct (clean t2); rewrite -IHt1 -IHt2;
      try rewrite empSPL; try rewrite empSPR;
      try rewrite sepSP_falseL; try rewrite sepSP_falseR; reflexivity. }
    { simpl; destruct (clean t); simpl in *; rewrite <- IHt; try reflexivity.
      split; do ?[ reflexivity
                 | apply lfalseL
                 | apply lpropandL ]. }
  Qed.

  (** bring lpropand to the top *)
  (** I'm lazy, so I'll just count how many t_propands there are, and give the procedure that much fuel *)
  Definition addn' := Eval lazy in addn.
  Fixpoint count_t_propand t :=
    match t with
      | t_star t1 t2 => addn' (count_t_propand t1) (count_t_propand t2)
      | t_propand _ t' => (count_t_propand t').+1
      | _ => 0
    end.

  Fixpoint pull1_t_propand t :=
    match t with
      | t_star t1 t2
        => let t1' := pull1_t_propand t1 in
           let t2' := pull1_t_propand t2 in
           match t1', t2' with
             | t_propand P1 t1'', t_propand P2 t2'' => t_propand P1 (t_propand P2 (t_star t1'' t2''))
             | t_propand P t1'', t2'' => t_propand P (t_star t1'' t2'')
             | t1'', t_propand P t2'' => t_propand P (t_star t1'' t2'')
             | t1'', t2'' => t_star t1'' t2''
           end
      | t_propand P t' => t_propand P (pull1_t_propand t')
      | _ => t
    end.

  Fixpoint rep {T} (f : T -> T) x n :=
    if n is n.+1 then f (rep f x n) else x.

  Definition pull_t_propand t := rep pull1_t_propand t (count_t_propand t).

  Lemma pull1_t_propand_correct e t : eval e (pull1_t_propand t) -|- eval e t.
  Proof.
    induction t; try reflexivity;
    simpl; do !hyp_rewrite <- *; clear; try reflexivity.
    do 2 edestruct pull1_t_propand;
      do ![ reflexivity
          | progress setoid_rewrite <- bilpropandL
          | progress setoid_rewrite <- bilpropandR ].
  Qed.

  Lemma pull_t_propand_correct e t : eval e (pull_t_propand t) -|- eval e t.
  Proof.
    unfold pull_t_propand.
    generalize (count_t_propand t) => n.
    move: t.
    induction n => * //=.
    by rewrite -> pull1_t_propand_correct.
  Qed.

  Lemma do_simplify e tH tC tH' tC':
    simplify tC tH = (tC', tH') ->
    eval e (clean (pull_t_propand tH')) |-- eval e (clean (pull_t_propand tC'))  ->  eval e tH |-- eval e tC.
  Proof. rewrite !clean_correct !pull_t_propand_correct. apply simplify_sufficient. Qed.

  (* If speed is an issue at some point, we could make rquote take two
     environments: one to insert into and one to lookup in. Our decision
     procedures never care about duplicated atoms on either side -- only atoms
     in common between left and right.

     We first try to do unification up to syntax, and try again after we've simpled *)
  Ltac pre_ssimpl_with doUnify :=
    first [ syntax_unify_reflexivity
          | match goal with
              | [ |- ?P |-- ?Q ] =>
                lquote ((0, [::], [::]) : env) P ltac:(fun e tP =>
                  rquote doUnify e Q ltac:(fun e tQ =>
                    eapply (@do_simplify e tP tQ);
                    [ cbv; reflexivity
                    | cbv [eval spred_lookup prop_lookup eqn' clean pull_t_propand pull1_t_propand rep count_t_propand addn']
                    ]
                  )
                )
            end;
            try syntax_unify_reflexivity ].

  (** After we're done, we want to move the things involving
      [lpropand] in the hypothesis list into the Coq context.  They're
      all at the top, so we can just apply [lpropandL] repeatedly. *)
  Ltac post_ssimpl :=
    repeat match goal with
             | [ |- _ /\\ _ |-- _ ] => apply lpropandL => *
             | [ H : ?T |- _ |-- ?T /\\ _ ] => apply lpropandR; first by exact H
           end.

  Ltac ssimpl_with doUnify := pre_ssimpl_with doUnify; post_ssimpl.

  Ltac ssimpl := ssimpl_with cheap_unify.

  Example ex0: forall P Q: SPred, exists n,
        ltrue ** (1 = 1 /\\ empSP) ** P ** Q |-- (Q ** (n = 1 /\\ empSP)) ** ltrue.
  Proof. move=> P Q. eexists. ssimpl. done. Qed.

  (* TODO: probably subsumed by do_simplify, but this should be faster *)
  Lemma solve_uc e tH tC:
    if remove tH tC is Some _
    then eval e tH |-- eval e tC ** ltrue
    else True.
  Proof.
    move Hresult: (remove tH tC) => result.
    destruct result; last done.
    have Hcorrect := remove_correct e Hresult.
    rewrite -> Hcorrect. by f_cancel.
  Qed.

  Ltac solve_uc :=
    match goal with
    |- ?P |-- ?Q ** ltrue =>
        lquote ((0, [::], [::]) : env) P ltac:(fun e tP =>
          rquote cheap_unify e Q ltac:(fun e tQ =>
            apply (@solve_uc e tP tQ)
          )
        )
    end.

  Example ex1: forall P Q: SPred, exists n,
        (1 = 1 /\\ empSP) ** P ** Q |-- (Q ** (n = 1 /\\ empSP)) ** ltrue.
  Proof. move=> P Q. eexists. solve_uc. Qed.
End Solving.

Ltac ssimpl := Solving.ssimpl.
Ltac ssimpl_with := Solving.ssimpl_with.

Ltac sbazookaone_with PT :=
  (try sdestructs => * //; (* leaves 0 or 1 subgoal *)
  try ssplits; (* last subgoal is the entailment *)
  [..| done || (try (ssimpl_with PT))] => //).

Ltac sbazookaonealt_with PT :=
  (* First try and prove from lfalseL *)
  try (ssimpl_with PT);
  match goal with
  | |- lfalse |-- ?Q => apply lfalseL
  | |- ?P /\\ lfalse |-- ?Q => (apply lpropandL => _; apply lfalseL)
  | _ => sbazookaone_with PT
  end.

(** Overpowered super-tactic *)
(** Include [idtac;] so that if we pass [sbazooka] as an argument to a
    tactical, it doesn't immediately evaluate the [match] and complain
    that there are no matching goals. *)
Ltac sbazooka_with PT :=
    idtac;
    match goal with
    | |- ?P -|- ?Q => (split; sbazookaonealt_with PT)
    | |- _ => sbazookaonealt_with PT
    end.

Ltac sbazooka := sbazooka_with Solving.cheap_unify.


Require Import POCS.
Require Import ThreeVariablesAPI.

(** To start with, we define a module called [Exercises] that
    takes as an argument an implementation of our variables
    layer, called [vars].
  *)

Module Exercises (vars : VarsAPI).

  (** Now that we are inside the module, we have access to the
      variables API that we defined in [ThreeVariablesAPI].
      You can examine the functions provided by the [vars]
      module using the [Check] command, as follows: *)

  (* Check vars.read. *)

  (** The above [Check] command should have printed:

      <<
        vars.read
             : var -> proc nat
      >>

      meaning that [vars.read] is something that takes a variable
      name (of type [var]) and gives us a procedure that returns
      a [nat] value.
    *)

  (* Check vars.write. *)

  (** [vars.write] similarly takes a variable name and a new value
      and gives us a procedure with no return value.
    *)

  (** * Part A: incrementing and swapping. *)

  (** To start with, we will define a simple procedure [incX]
      that increments the value of the x variable: *)

  Definition incX : proc unit :=
    x <- vars.read VarX;
    _ <- vars.write VarX (1+x);
    Ret tt.

  (** To check if we got the implementation right, let's try first
      testing it on a specific input.  We can do this by writing a
      very particular specification: if the starting state was
      (1, 2, 3), corresponding to the values of variables x, y, and
      z respectively, then the final state should be (2, 2, 3).

      The [vars.recover] at the end of the specification says that
      we should run the [vars.recover] procedure after a crash; this
      does not matter so far, because we are ignoring crashes.

      The [vars.abstr] indicates how we are describing states in
      this specification.  Here, states are described in terms of
      the variables layer (i.e., consisting of the three values for
      x, y, and z).  We will see in the next lab how and why your
      specification may want to describe the state at a different
      abstraction layer.
    *)

  Theorem incX_test :
    proc_spec (fun (_:unit) state => {|
                    pre :=
                      state = mkState 1 2 3;
                    post := fun r state' =>
                      state' = mkState 2 2 3;
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    (*  Pretty much every proof in our lab infrastructure
        starts by expanding out the procedure you're proving.
      *)
    unfold incX.

    (*  We will now consider each step of this code in turn,
        using the [step_proc] Ltac tactic.  [step_proc] will
        take the first thing our code is doing (here, calling
        [vars.read VarX]) and find a corresponding proven spec
        for that code (here, it comes from [vars.read_ok],
        which states that [vars.read] satisfies [read_spec]).
      *)
    step_proc.

    (* We will potentially have to prove several subgoals after
      calling [step_proc]: that our precondition is sufficient to
      invoke the proven spec that [step_proc] found, that the
      recovery condition matches up, and that the rest of the
      procedure will be correct. Here, most of these were trivial
      and were proven automatically, so we are left with just one
      goal.

      This remaining goal requires us to prove something about
      executing the rest of the [incX] code. To help orient yourself
      in this proof ("what is this that I'm having to prove?"), look
      at [Lexec] in your proof context. It's a marker telling you
      that the current proof goal is what's left "after" running
      [(vars.read VarX)].

      This time, to illustrate what step_proc is doing, we break
      it apart into several steps.  This first invocation does
      everything step_proc does except solve trivial goals. *)

    step_proc_basic; simplify; split_all; simplify.

    (* We are now left with several sub-goals that we have
      to prove.  To orient yourself among these subgoals,
      look for [Marker] hypotheses in the context.  In this
      first subgoal, you should see [L] as a marker indicating
      that we are looking at a subgoal related to the precondition
      of [vars.write VarX 2].  The precondition happens to be
      just [True], so it would have been automatically solved
      if you had invoked the full [step_proc] tactic.
      *)

    {
      (* To solve this subgoal, we must use curly braces
        (or dashes), in order to keep the proof script
        clean and readable.

        Since the goal is [True], we can solve it using the
        [trivial] tactic.  [eauto] would have also worked.
        *)

      trivial.
    }

    {
      (* The next subgoal left for us by [step_proc_basic]
        relates to the recovery condition of [vars.write VarX 2],
        which you can determine by looking at the bottom-most
        [Marker] in the current context.

        Since we aren't reasoning about crashes in this lab,
        every recovered condition is [False].  You can prove
        this using the recovered condition of the [vars.read
        VarX] operation, which is [H: False].

        [assumption] does this, as would [eauto].
        *)
      assumption.
    }

    (*  Now we are left with the remaining part of the [incX] code:
        the call to [Ret tt].

        You can see there are two markers in your proof context now,
        since these markers simply accumulate. The bottom marker
        will always be the most recent one, so here [Lexec0] tells
        you that you're looking at the proof state just after
        calling [vars.write VarX (StateX {| ... |} + 1)].

        What's left for us to prove? The goal is saying something
        pretty simple: if the starting state is (2, 2, 3), as
        specified by the precondition, then running [Ret tt] gives
        us a state of (2, 2, 3).

        Invoking [step_proc] proves this simple fact. *)
    step_proc.
  Qed.

  (** Now your job is to state a more general specification for [incX]. It
      should take a precondition of [True], as stated in the theorem below. Your
      task is to fill in the postcondition below so that it applies to any
      starting state, unlike the previous theorem that only worked for [mkState
      1 2 3]. Then, prove your general specification correct.

      Replace [Admitted.] with [Qed.] when the proof is complete. When we grade,
      we basically check that your code compiles and that you didn't use
      [Admitted].

      Take a look at the specifications in ThreeVariablesAPI.v if you're not
      sure where to start.
  *)

  Theorem incX_ok :
    proc_spec (fun (_:unit) state => {|
                    pre := True;
                    post := fun r state' =>
                             state' = mkState (S (StateX state)) (StateY state) (StateZ state);
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    unfold incX.
    step_proc.
    step_proc.
    step_proc.
  Qed.

  (** You have proven that the code of [incX] satisfies your specification
      in [incX_ok], but how do you know if your specification is good enough?
      Did your specification omit any important details?

      One general approach is to try to use your specification to prove something.
      Let's do that now: prove that your specification above is sufficient
      to prove that running [incX] from state (5, 5, 5) gives us state (6, 5, 5).

      To use your [incX_ok] theorem from above, we tell the [step_proc] tactic
      about it by including it in the [core] hints database.  To make sure that
      we don't accidentally look inside the code of [incX], and thus force ourselves
      to prove statements about [incX] by relying on [incX_ok], we mark it opaque
      using [Opaque incX].
    *)

  Hint Resolve incX_ok : core.
  Opaque incX.

  Theorem incX_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                    pre :=
                      state = mkState 5 5 5;
                    post := fun r state' =>
                      state' = mkState 6 5 5;
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    step_proc.
  Qed.

  (** * Swapping. *)

  (** Here is another exercise, this time with you writing the code,
      the spec, and the proof.  Implement a procedure [swapXY] that
      swaps the values of x and y; write a specification for it; and
      prove that your code meets the spec. *)

  Definition swapXY : proc unit :=
    x <- vars.read VarX;
    y <- vars.read VarY;
    _ <- vars.write VarX y;
    _ <- vars.write VarY x;
    Ret tt.

  Theorem swapXY_ok :
    proc_spec (fun (_:unit) state => {|
                    pre := True;
                    post := fun r state' =>
                             state' = mkState (StateY state) (StateX state) (StateZ state);
                    recovered := fun _ _ => False;
                  |})
              swapXY
              vars.recover vars.abstr.
  Proof.
    step_proc.
    step_proc.
    step_proc.
    step_proc.
    step_proc.
  Qed.

  (** As a sanity check, prove that [swapXY] from state (2, 3, 4)
      gives you state (3, 2, 4). *)

  Hint Resolve swapXY_ok : core.
  Opaque swapXY.

  Theorem swapXY_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                   pre := state = mkState 2 3 4;
                   post := fun r state' => state' = mkState 3 2 4;
                   recovered := fun _ state' => False;
                 |})
              swapXY
              vars.recover
              vars.abstr.
  Proof.
    step_proc.
  Qed.

  (** * Part B: recursive procedures. *)

  (** In this last part of the lab assignment, you will reason about
      recursive procedures.  To start with, we will give an example.
      We define a helper called [addX] that adds [delta] to the x variable. *)

  Definition addX (delta : nat) : proc unit :=
    x <- vars.read VarX;
    _ <- vars.write VarX (x + delta);
    Ret tt.

  Theorem addX_ok : forall delta,
    proc_spec (fun (_:unit) state => {|
                   pre := True;
                   post := fun r state' => state' = mkState (delta + StateX state) (StateY state) (StateZ state);
                   recovered := fun _ _ => False;
                   |})
              (addX delta)
              vars.recover
              vars.abstr.
  Proof.
    intros.
    unfold addX.
    step_proc.
    step_proc.
    step_proc.
    replace (StateX state + delta) with (delta + StateX state).
    - reflexivity.
    - lia.
  Qed.

  Hint Resolve addX_ok : core.
  Opaque addX.

  (** Now, we define a procedure [addX_list] that takes a list of [nat]s,
      and calls [addX] on each of them in turn. *)

  Fixpoint addX_list (l : list nat) : proc unit :=
    match l with
    | nil =>
      Ret tt
    | v :: l' =>
      _ <- addX v;
      _ <- addX_list l';
      Ret tt
    end.

  (** To specify what we expect [addX_list] to do, we need to talk about
      the sum of values in a list.  To do that, we define a Gallina function
      (purely in Coq) that computes the sum of values in a list. *)

  Fixpoint list_sum (l : list nat) : nat :=
    match l with
    | nil => 0
    | v :: l' => v + (list_sum l')
    end.

  (** Now we can state a specification about [addX_list] and prove it using
      induction.

      Note: You get an error "Expected a single focused goal but 2 goals are
      focused". For the labs, we turned on an option in Coq that enforces proofs
      use bullets ([+], [-], [*]) or curly braces [{ }] to "focus" each line of
      the proof on a single goal. This makes proof scripts more manageable,
      which will help in later labs.

     If you get this error, make sure to use bullets or braces, the way you saw
     throughout Software Foundations.
   *)

  Theorem addX_list_ok : forall l,
    proc_spec (fun (_:unit) state => {|
                   pre := True;
                   post := fun r state' =>
                             state' = mkState (StateX state + list_sum l) (StateY state) (StateZ state);
                   recovered := fun _ _ => False;
                   |})
              (addX_list l)
              vars.recover
              vars.abstr.
  Proof.
    induction l.
    - (* The base case: adding an empty list. *)
      simpl.
      step_proc.
      simpl.
      replace (StateX state + 0) with (StateX state).
      + destruct state. reflexivity.
      + lia.
    - (* The inductive case: adding one more element. *)
      simpl.

      (* We first consider the [addX v] call in the second case of [addX_list]'s match. *)
      step_proc.

      (*  You can see that this is indeed where we are in the proof,
          by observing the [Lexec] marker: it says we're just after
          executing [addX a]. *)
      simpl.

      (*  Now we need to run the rest of [addX_list l].  This works
          out surprisingly easily, because the [induction l] tactic
          gave us an inductive hypothesis, [IHl], that gives us a
          specification for [addX_list l].  [step_proc] will use this
          hypothesis if it matches the invocation. *)
      step_proc.

      (*  Finally, we have to prove the state matches the postcondition
          after running both [addX] and [addX_list l]. *)
      step_proc.

      replace (a + StateX state + list_sum l) with (StateX state + (a + list_sum l)).
      + reflexivity.
      + lia.
  Qed.

  (** * Recursive procedures on your own. *)

  (** For the final part, you will work out an example of recursive procedures
      on your own.

      Your job is to implement a procedure [add_odds_evens] that takes a list
      of [nat]s, adds all of the even nats to variable x, and all of the odd
      nats to variable y.

      Implement [add_odds_events] in the recursive [Fixpoint] style
      that we used above in part C, write a spec for it, and prove it.

      Use [Nat.even] and [Nat.odd] to determine if a [nat] value is even
      or odd.  You can use [Search] to locate helpful theorems about
      these, as follows:
    *)

  Fixpoint add_odds_evens (l : list nat) : proc unit :=
    match l with
      | nil =>
        Ret tt
      | v :: l' =>
        match (Nat.even v) with
          | true =>
            x <- vars.read VarX;
            _ <- vars.write VarX (x + v);
            _ <- add_odds_evens l';
            Ret tt
          | false =>
            y <- vars.read VarY;
            _ <- vars.write VarY (y + v);
            _ <- add_odds_evens l';
            Ret tt
        end
    end.

  Fixpoint even_sum (l : list nat) : nat :=
    match l with
    | nil => 0
    | v :: l' => match (Nat.even v) with
               | true => (v + even_sum l')
               | false => even_sum l'
               end
    end.

  Fixpoint odd_sum (l : list nat) : nat :=
    match l with
    | nil => 0
    | v :: l' => match (Nat.even v) with
               | true => odd_sum l'
               | false => (v + odd_sum l')
               end
    end.

  Theorem add_odds_evens_ok : forall l,
    proc_spec (fun (_:unit) state => {|
                   pre := True;
                   post := fun r state' =>
                             state' = mkState (even_sum l + StateX state) (odd_sum l + StateY state) (StateZ state);
                   recovered := fun _ _ => False;
                   |})
              (add_odds_evens l)
              vars.recover
              vars.abstr.
  Proof.
    induction l.
    - simpl. step_proc. destruct state. reflexivity.
    - simpl. destruct (Nat.even a) as [|].
      + step_proc. step_proc. step_proc. step_proc.
        replace (even_sum l + (StateX state + a)) with (a + even_sum l + StateX state).
        { reflexivity. }
        { lia. }
      + step_proc. step_proc. step_proc. step_proc.
        replace (odd_sum l + (StateY state + a)) with (a + odd_sum l + StateY state).
        { reflexivity. }
        { lia. }
  Qed.

  (** To check your solution, prove this simple theorem about
      a particular execution of [add_odds_evens] using your spec.
      Add a [Hint Resolve] statement to let [step_proc] see your
      proven specification about [add_odds_evens]. *)

  Opaque add_odds_evens.
  Hint Resolve add_odds_evens_ok : core.

  Theorem add_odds_evens_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                   pre := state = mkState 0 0 0;
                   post := fun r state' => state' = mkState 6 7 0;
                   recovered := fun _ _ => False;
                   |})
              (add_odds_evens (2 :: 3 :: 3 :: 4 :: 1 :: nil))
              vars.recover
              vars.abstr.
  Proof.
    step_proc.
  Qed.

End Exercises.