(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require set.Set.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive datatype  :=
  | Tint : datatype
  | Tbool : datatype .
Axiom datatype_WhyType : WhyType datatype.
Existing Instance datatype_WhyType.

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

(* Why3 assumption *)
Definition ident  := Z.

(* Why3 assumption *)
Inductive term  :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : Z -> term -> fmla -> fmla
  | Fforall : Z -> datatype -> fmla -> fmla .
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Inductive value  :=
  | Vint : Z -> value
  | Vbool : bool -> value .
Axiom value_WhyType : WhyType value.
Existing Instance value_WhyType.

(* Why3 assumption *)
Definition env  := (map.Map.map Z value).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

(* Why3 assumption *)
Fixpoint eval_term(sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value))
  (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (map.Map.get pi id)
  | (Tderef id) => (map.Map.get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.

(* Why3 assumption *)
Fixpoint eval_fmla(sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (map.Map.set pi x (eval_term sigma pi
      t)) f1)
  | (Fforall x Tint f1) => forall (n:Z), (eval_fmla sigma (map.Map.set pi x
      (Vint n)) f1)
  | (Fforall x Tbool f1) => forall (b:bool), (eval_fmla sigma (map.Map.set pi
      x (Vbool b)) f1)
  end.

Parameter subst_term: term -> Z -> Z -> term.

Axiom subst_term_def : forall (e:term) (r:Z) (v:Z),
  match e with
  | (Tconst _) => ((subst_term e r v) = e)
  | (Tvar _) => ((subst_term e r v) = e)
  | (Tderef x) => ((r = x) -> ((subst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term e r v) = e))
  | (Tbin e1 op e2) => ((subst_term e r v) = (Tbin (subst_term e1 r v) op
      (subst_term e2 r v)))
  end.

(* Why3 assumption *)
Fixpoint fresh_in_term(id:Z) (t:term) {struct t}: Prop :=
  match t with
  | (Tconst _) => True
  | (Tvar v) => ~ (id = v)
  | (Tderef _) => True
  | (Tbin t1 _ t2) => (fresh_in_term id t1) /\ (fresh_in_term id t2)
  end.

Axiom eval_subst_term : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
  Z value)) (e:term) (x:Z) (v:Z), (fresh_in_term v e) -> ((eval_term sigma pi
  (subst_term e x v)) = (eval_term (map.Map.set sigma x (map.Map.get pi v))
  pi e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id:Z) (v:value), (fresh_in_term id t) ->
  ((eval_term sigma (map.Map.set pi id v) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Fixpoint fresh_in_fmla(id:Z) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst(f:fmla) (x:Z) (v:Z) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

Axiom eval_subst : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (x:Z) (v:Z), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (subst f x v)) <-> (eval_fmla (map.Map.set sigma x
  (map.Map.get pi v)) pi f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id1:Z) (id2:Z) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_fmla sigma (map.Map.set (map.Map.set pi id1 v1)
  id2 v2) f) <-> (eval_fmla sigma (map.Map.set (map.Map.set pi id2 v2) id1
  v1) f)).

Axiom eval_change_free : forall (f:fmla) (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)) (id:Z) (v:value), (fresh_in_fmla id f) ->
  ((eval_fmla sigma (map.Map.set pi id v) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Inductive stmt  :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Sassert : fmla -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .
Axiom stmt_WhyType : WhyType stmt.
Existing Instance stmt_WhyType.

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

(* Why3 assumption *)
Inductive one_step : (map.Map.map Z value) -> (map.Map.map Z value) -> stmt
  -> (map.Map.map Z value) -> (map.Map.map Z value) -> stmt -> Prop :=
  | one_step_assign : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (x:Z) (e:term), (one_step sigma pi (Sassign x e)
      (map.Map.set sigma x (eval_term sigma pi e)) pi Sskip)
  | one_step_seq : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (sigma':(map.Map.map Z value)) (pi':(map.Map.map Z value))
      (i1:stmt) (i1':stmt) (i2:stmt), (one_step sigma pi i1 sigma' pi'
      i1') -> (one_step sigma pi (Sseq i1 i2) sigma' pi' (Sseq i1' i2))
  | one_step_seq_skip : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (i:stmt), (one_step sigma pi (Sseq Sskip i) sigma pi i)
  | one_step_if_true : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool true)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i1)
  | one_step_if_false : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map
      Z value)) (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool false)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i2)
  | one_step_assert : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi
      (Sassert f) sigma pi Sskip)
  | one_step_while_true : forall (sigma:(map.Map.map Z value))
      (pi:(map.Map.map Z value)) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla sigma pi inv) -> (((eval_term sigma pi e) = (Vbool true)) ->
      (one_step sigma pi (Swhile e inv i) sigma pi (Sseq i (Swhile e inv
      i))))
  | one_step_while_false : forall (sigma:(map.Map.map Z value))
      (pi:(map.Map.map Z value)) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla sigma pi inv) -> (((eval_term sigma pi
      e) = (Vbool false)) -> (one_step sigma pi (Swhile e inv i) sigma pi
      Sskip)).

(* Why3 assumption *)
Inductive many_steps : (map.Map.map Z value) -> (map.Map.map Z value) -> stmt
  -> (map.Map.map Z value) -> (map.Map.map Z value) -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (i:stmt), (many_steps sigma pi i sigma pi i 0%Z)
  | many_steps_trans : forall (sigma1:(map.Map.map Z value))
      (pi1:(map.Map.map Z value)) (sigma2:(map.Map.map Z value))
      (pi2:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
      (pi3:(map.Map.map Z value)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z),
      (one_step sigma1 pi1 i1 sigma2 pi2 i2) -> ((many_steps sigma2 pi2 i2
      sigma3 pi3 i3 n) -> (many_steps sigma1 pi1 i1 sigma3 pi3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map.Map.map Z value)) (pi1:(map.Map.map
  Z value)) (sigma2:(map.Map.map Z value)) (pi2:(map.Map.map Z value))
  (i1:stmt) (i2:stmt) (n:Z), (many_steps sigma1 pi1 i1 sigma2 pi2 i2 n) ->
  (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map.Map.map Z value))
  (pi1:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
  (pi3:(map.Map.map Z value)) (i1:stmt) (i2:stmt) (n:Z), (many_steps sigma1
  pi1 (Sseq i1 i2) sigma3 pi3 Sskip n) -> exists sigma2:(map.Map.map Z
  value), exists pi2:(map.Map.map Z value), exists n1:Z, exists n2:Z,
  (many_steps sigma1 pi1 i1 sigma2 pi2 Sskip n1) /\ ((many_steps sigma2 pi2
  i2 sigma3 pi3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

(* Why3 assumption *)
Definition valid_fmla(p:fmla): Prop := forall (sigma:(map.Map.map Z value))
  (pi:(map.Map.map Z value)), (eval_fmla sigma pi p).

(* Why3 assumption *)
Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop :=
  forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z value)),
  (eval_fmla sigma pi p) -> forall (sigma':(map.Map.map Z value))
  (pi':(map.Map.map Z value)) (n:Z), (many_steps sigma pi i sigma' pi' Sskip
  n) -> (eval_fmla sigma' pi' q).

(* Why3 assumption *)
Definition assigns(sigma:(map.Map.map Z value)) (a:(set.Set.set Z))
  (sigma':(map.Map.map Z value)): Prop := forall (i:Z), (~ (set.Set.mem i
  a)) -> ((map.Map.get sigma i) = (map.Map.get sigma' i)).

Axiom assigns_refl : forall (sigma:(map.Map.map Z value)) (a:(set.Set.set
  Z)), (assigns sigma a sigma).

Axiom assigns_trans : forall (sigma1:(map.Map.map Z value))
  (sigma2:(map.Map.map Z value)) (sigma3:(map.Map.map Z value))
  (a:(set.Set.set Z)), ((assigns sigma1 a sigma2) /\ (assigns sigma2 a
  sigma3)) -> (assigns sigma1 a sigma3).

Axiom assigns_union_left : forall (sigma:(map.Map.map Z value))
  (sigma':(map.Map.map Z value)) (s1:(set.Set.set Z)) (s2:(set.Set.set Z)),
  (assigns sigma s1 sigma') -> (assigns sigma (set.Set.union s1 s2) sigma').

Axiom assigns_union_right : forall (sigma:(map.Map.map Z value))
  (sigma':(map.Map.map Z value)) (s1:(set.Set.set Z)) (s2:(set.Set.set Z)),
  (assigns sigma s2 sigma') -> (assigns sigma (set.Set.union s1 s2) sigma').

(* Why3 assumption *)
Fixpoint stmt_writes(i:stmt) (w:(set.Set.set Z)) {struct i}: Prop :=
  match i with
  | (Sskip|(Sassert _)) => True
  | (Sassign id _) => (set.Set.mem id w)
  | ((Sseq s1 s2)|(Sif _ s1 s2)) => (stmt_writes s1 w) /\ (stmt_writes s2 w)
  | (Swhile _ _ s) => (stmt_writes s w)
  end.

(* Why3 goal *)
Theorem WP_parameter_compute_writes : forall (s:stmt),
  match s with
  | Sskip => True
  | (Sassign i _) => forall (sigma:(map.Map.map Z value)) (pi:(map.Map.map Z
      value)) (sigma':(map.Map.map Z value)) (pi':(map.Map.map Z value))
      (n:Z), (many_steps sigma pi s sigma' pi' Sskip n) -> (assigns sigma
      (set.Set.add i (set.Set.empty :(set.Set.set Z))) sigma')
  | (Sseq s1 s2) => True
  | (Sif _ s1 s2) => True
  | (Swhile _ _ s1) => True
  | (Sassert _) => True
  end.
destruct s; intuition.
red; intros.
inversion H; subst; clear H.
inversion H1; subst; clear H1.
inversion H2; subst; clear H2.
rewrite set.Set.add_def1 in H0.
rewrite Map.Select_neq; auto.
inversion H.
Qed.


Require Import
        Coq.Vectors.Vector
        Coq.Vectors.VectorDef
        Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.ilist
        Fiat.Common.StringBound
        Coq.Program.Program
        Fiat.QueryStructure.Specification.Representation.Notations.

(* Notations for attributes. *)

Record Attribute :=
  { attrName : string;
    attrType : Type }.

Infix "::" := Build_Attribute : Attribute_scope.

Bind Scope Attribute_scope with Attribute.

Definition attrName_eq (cs : Attribute) (idx : string) :=
  if (string_dec (attrName cs) idx) then true else false .

(* A heading describes a tuple as a set of Attributes
   and types. *)
Record RawHeading :=
  { NumAttr : nat;
    AttrList : Vector.t Type NumAttr }.

Definition Attributes (heading : RawHeading) : Set := Fin.t (NumAttr heading).

Definition Domain (heading : RawHeading) (idx : Attributes heading) : Type :=
  Vector.nth (AttrList heading) idx.
Arguments Domain : clear implicits.

(* Notations for schemas. *)

Record Heading :=
  { HeadingRaw :> RawHeading;
    HeadingNames : Vector.t string (NumAttr HeadingRaw) }.

Definition BuildHeading
           {n}
           (attrs : Vector.t Attribute n)
  : Heading :=
  {| HeadingRaw := {| NumAttr := n;
                      AttrList := Vector.map attrType attrs |};
     HeadingNames := Vector.map attrName attrs |}.

(* Notation for schemas built from [BuildHeading]. *)

Notation "< col1 , .. , coln >" :=
  (BuildHeading (@Vector.cons _ col1%Attribute _ .. (Vector.cons _ coln%Attribute _ (Vector.nil _)) ..))
  : Heading_scope.

(* Extending Headings *)
Definition AppendRawHeading (h1 h2 : RawHeading) : RawHeading :=
  {| NumAttr := NumAttr h1 + NumAttr h2;
     AttrList := Vector.append (AttrList h1) (AttrList h2) |}.

Definition AppendHeading (h1 h2 : Heading) : Heading :=
  {| HeadingRaw := AppendRawHeading (HeadingRaw h1) (HeadingRaw h2);
     HeadingNames := Vector.append (HeadingNames h1) (HeadingNames h2) |}.

Notation " h1 ++ h2 " := (AppendHeading h1%Heading h2%Heading) : Heading_scope.


Require Import Lia.
Require Export Qual.geq.
Require Export Qual.defeq.
Require Export Qual.par.

(* ------------------------------------------------------------------------ *)

Set Implicit Arguments.

Lemma Par_Abs_inv : forall {S D rho A1 a1 B}, Par S D (a_Abs rho A1 a1) B ->
      exists B1 b1,
          B = (a_Abs rho B1 b1)
        /\ forall x, x `notin` fv_tm_tm a1 \u fv_tm_tm b1 \u dom S ->
               Par ([(x,rho)]++S) D (open_tm_wrt_tm a1 (a_Var_f x)) (open_tm_wrt_tm b1 (a_Var_f x))
        /\ CPar S D q_Top A1 B1.
Proof.
  intros S D rho A1 a1 B h.
  dependent induction h.
  all: try invert_Grade; subst.
  all: eexists; eexists.
  all: split; try reflexivity; intros; split.
  all: pick fresh y.
  + eapply Par_Refl; eauto.
    eapply (@Grade_renaming y); eauto.
  + invert_CGrade A1; eauto.
  + repeat spec y.
    eapply (@Par_renaming y); eauto.
  + auto.
Qed.

Lemma Par_WPair_inv : forall {S D rho a0 a1 B}, Par S D (a_WPair a0 rho a1) B ->
      exists b0 b1,
          B = (a_WPair b0 rho b1)
        /\ (CPar S D rho a0 b0)
        /\ Par S D a1 b1.
Proof.
  intros S D rho a0 a1 B h. dependent induction h.
  all: try invert_Grade; subst;
        eexists; eexists; split; try reflexivity; split.
  all: repeat split.
  all: intros; try done.
  all: try eapply Par_Refl; eauto.
  invert_CGrade a0; auto.
Qed.

Lemma Par_SPair_inv : forall {S D rho a0 a1 B}, Par S D (a_SPair a0 rho a1) B ->
      exists b0 b1,
          B = (a_SPair b0 rho b1)
        /\ (CPar S D rho a0 b0)
        /\ Par S D a1 b1.
Proof.
  intros S D rho a0 a1 B h. dependent induction h.
  all: try invert_Grade; subst;
        eexists; eexists; split; try reflexivity; split.
  all: intros; try done.
  all: try eapply Par_Refl; eauto.
  invert_CGrade a0; auto.
Qed.

Lemma Par_Inj1_inv : forall {S D a0 B}, Par S D (a_Inj1 a0) B ->
      exists b0,
          B = (a_Inj1 b0)
        /\ Par S D a0 b0.
Proof.
  intros S D a0 B h. dependent induction h.
  all: try invert_Grade; subst;
        eexists; split; try reflexivity.
  all: intros; try done.
  all: try eapply Par_Refl; eauto.
Qed.

Lemma Par_Inj2_inv : forall {S D a0 B}, Par S D (a_Inj2 a0) B ->
      exists b0,
          B = (a_Inj2 b0)
        /\ Par S D a0 b0.
Proof.
  intros S D a0 B h. dependent induction h.
  all: try invert_Grade; subst;
        eexists; split; try reflexivity.
  all: intros; try done.
  all: try eapply Par_Refl; eauto.
Qed.

(* ----------------------------------------------------------------------------------- *)

Local Ltac use_size_induction a ac Par1 Par2 :=
  match goal with
  | [   IH : forall y: nat, ?T,
        H : Par ?G ?psi a ?b0,
        H4 : Par ?G ?psi a ?b1 |- _ ] =>
      move: (@IH (size_tm a) ltac:(lia) a ltac:(auto) _ _ _ H _ H4) => [ ac [Par1 Par2]]
  end.
Local Ltac use_size_induction_open a0 x ac Par1 Par2 :=
   let h0 := fresh in
   let h1 := fresh in
   let EQ1 := fresh in
   match goal with
        | [  H : forall x : atom,
              x `notin` ?L
              -> Par ?S ?psi (?open_tm_wrt_tm a0 (?a_Var_f x)) ?b
          ,  H4: forall x : atom,
              x `notin` ?L0
              -> Par ?S ?psi (?open_tm_wrt_tm a0 (?a_Var_f x)) ?c
          |- _ ] =>
    move: (@H x ltac:(auto)) => h0; clear H;
    move: (@H4 x ltac:(auto)) => h1; clear H4;
    move: (size_tm_open_tm_wrt_tm_var a0 x) => EQ1;
    use_size_induction (open_tm_wrt_tm a0 (a_Var_f x)) ac Par1 Par2;
    clear h0; clear h1; clear EQ1
  end.

Local Ltac invert_equality :=
  match goal with
  | [ H : _ = _ |- _ ] => inversion H ; clear H
  end.

Lemma confluence_size : forall n a, (size_tm a <= n)%nat -> forall S psi a1, Par S psi a a1 -> forall a2, Par S psi a a2 -> exists b, Par S psi a1 b /\ Par S psi a2 b.
Proof.
  pose confluence_size_def n :=
      forall a, (size_tm a <= n)%nat ->  forall S psi a1, Par S psi a a1 -> forall a2, Par S psi a a2 -> exists b, Par S psi a1 b /\ Par S psi a2 b.
  intro n. fold (confluence_size_def n).  eapply (well_founded_induction_type lt_wf).
  clear n. intros n IH. unfold confluence_size_def in *. clear confluence_size_def.
  intros a SZ S psi a1 P1 a2 P2.
  inversion P1; inversion P2; subst.
  (* 625 subgoals *)
  all: try solve [invert_equality].

  (* 101 subgoals *)
  (* refl left *)
  all: try solve [
  match goal with
      | [ P2 : Par _ _ ?b ?b |- exists cc:tm, Par ?S ?D ?b cc /\ Par ?S ?D ?a2 cc ] =>
        exists a2
      end; split; eauto using Par_Grade2].
  (*  76 subgoals *)
  all: try solve [
  match goal with
      | [ P2 : Par _ _ ?b ?b |- exists cc:tm, Par ?S ?D ?a2 cc /\ Par ?S ?D ?b cc ] =>
        exists a2
      end;  split; eauto using Par_Grade2].
  (* 52 subgoals *)
  all: try invert_equality; subst.
  all: simpl in SZ; destruct n; try solve [ inversion SZ ].
  all: try done.
  - (* pi cong / pi cong *)
    use_size_induction A1 ac Par1 Par2.
    pick fresh x;
    use_size_induction_open B1 x bc Par3 Par4;
    exists (a_Pi psi1 ac (close_tm_wrt_tm x bc));
    split; eauto;
    exists_apply_Par x; eauto.
  - (* two betas *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst;
    try done.
    (* both rel *)
    + use_size_induction b bc Par1 Par2.
      use_size_induction a0 a0c Par3 Par4.
      move: (Par_Abs_inv Par3) => [A'1 [a1' ?]].
      move: (Par_Abs_inv Par4) => [A'2 [a'2 ?]].
      split_hyp; subst; invert_equality; subst.
      exists (open_tm_wrt_tm a'2 bc).
      pick fresh x. repeat spec x. split_hyp.
      split.
      eapply open2; eauto.
      eapply open2; eauto.
    + (* both irrel *)
      use_size_induction a0 a0c Par3 Par4.
      move: (Par_Abs_inv Par3) => [A'1 [a1' ?]].
      move: (Par_Abs_inv Par4) => [A'2 [a'2 ?]].
      split_hyp; subst; invert_equality; subst.
      exists (open_tm_wrt_tm a'2 b').
      pick fresh x. repeat spec x. split_hyp.
      split.
      eapply open2; eauto using Par_uniq, Par_lc1, Par_lc2.
      eapply open2; eauto using Par_uniq, Par_lc1, Par_lc2.
  - (* beta / app cong *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst;
    try done.
     (* rel *)
     + use_size_induction a0 a0c Par1 Par2.
       use_size_induction b bc Par3 Par4.
       move: (Par_Abs_inv Par1) => [A'1 [a'1 ?]]; split_hyp; subst.
       pick fresh x. repeat spec x. split_hyp.
       exists (open_tm_wrt_tm a'1 bc).
       split.
       eapply open2; eauto.
       eapply Par_AppBeta; eauto.
     + (* beta / app cong irrel *)
       use_size_induction a0 a0c Par1 Par2.
       move: (Par_Abs_inv Par1) => [A'1 [a'1 ?]]; split_hyp; subst.
       pick fresh x. repeat spec x. split_hyp.
       exists (open_tm_wrt_tm a'1 b').
       split.
       eapply open2; eauto using Par_uniq.
       eapply Par_AppBeta; eauto.
  - (* app cong / beta *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst;
    try done.
    + (* rel *)
      use_size_induction a0 a0c Par1 Par2.
      use_size_induction b bc Par3 Par4.
      move: (Par_Abs_inv Par2) => [? [a'1 ?]]; split_hyp; subst.
      pick fresh x. repeat spec x. split_hyp.
      exists (open_tm_wrt_tm a'1 bc).
      split.
      eapply Par_AppBeta; eauto.
      eapply open2; eauto.
    + (* irrel *)
      use_size_induction a0 a0c Par1 Par2.
      move: (Par_Abs_inv Par2) => [? [a'1 ?]]; split_hyp; subst.
      pick fresh x. repeat spec x. split_hyp.
      exists (open_tm_wrt_tm a'1 b').
      split.
      eapply Par_AppBeta; eauto.
      eapply open2; eauto using Par_uniq.
  - (* app cong / app cong *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
      match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
      subst;
      try done.
    + (* rel *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b bc Par3 Par4.
    exists (a_App ac psi1 bc).
    split; eauto.
    +  (* irrel *)
      use_size_induction a0 ac Par1 Par2.
      exists (a_App ac psi1 b').
      split; eauto.
  - (* lam cong / lam cong *)
    pick fresh x.
    use_size_induction_open b1 x bc Par1 Par2.
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
      match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
      subst;
      try done.
    (* rel *)
    + use_size_induction A1 AC Par3 Par4.
      exists (a_Abs psi1 AC (close_tm_wrt_tm x bc)).
      split.
      exists_apply_Par x.
      exists_apply_Par x.
    + exists (a_Abs psi1 A1 (close_tm_wrt_tm x bc)).
      split.
      exists_apply_Par x.
      exists_apply_Par x.
  - (* Sigma cong / Sigma cong *)
    use_size_induction A1 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open B1 x bc Par3 Par4.
    exists (a_WSigma psi1 ac (close_tm_wrt_tm x bc)).
    split; exists_apply_Par x; eauto.
  - (* two wpair *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst; try done.
    + (* rel *)
      use_size_induction a0 ac Par1 Par2.
      use_size_induction b1 bc Par3 Par4.
      exists (a_WPair ac psi1 bc).
      split. eauto. eauto.
    + (* two wpair irrel *)
      use_size_induction b1 bc Par3 Par4.
      exists (a_WPair a3 psi1 bc).
      split. eauto. eauto.
  - (* letpair betas *)
    use_size_induction a0 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open b1 x bc Par3 Par4.
    move: (Par_WPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    move: (Par_WPair_inv Par2) => [a'2 [b2' ?]]; split_hyp; subst.
    invert_equality; subst.
    exists (a_App (open_tm_wrt_tm (close_tm_wrt_tm x bc) a'2) q_Bot b2').
    repeat rewrite <- subst_tm_tm_spec.
    rewrite (subst_tm_tm_intro x b2); auto.
    rewrite (subst_tm_tm_intro x b3); auto.
    split.
    + eapply Par_App; eauto using leq_Bot.
      eapply Par_subst3; try eassumption.
    + eapply Par_App; eauto using Par_lc1, leq_Bot.
      eapply Par_subst3; try eassumption.
  - (* letpair beta / cong *)
    use_size_induction a0 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open b1 x bc Par3 Par4.
    move: (Par_WPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    exists (a_App (open_tm_wrt_tm (close_tm_wrt_tm x bc) a'1) q_Bot b1').
    rewrite <- subst_tm_tm_spec.
    rewrite (subst_tm_tm_intro x b2); auto.
    split.
    + eapply Par_App; eauto using leq_Bot.
      eapply Par_subst3; try eassumption.
    + rewrite subst_tm_tm_spec.
      exists_apply_Par x.
  - (* letpair cong / beta *)
    use_size_induction a0 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open b1 x bc Par3 Par4.
    move: (Par_WPair_inv Par2) => [a'1 [b1' ?]]; split_hyp; subst.
    exists (a_App (open_tm_wrt_tm (close_tm_wrt_tm x bc) a'1) q_Bot b1').
    rewrite <- subst_tm_tm_spec.
    rewrite (subst_tm_tm_intro x b3); auto.
    split.
    + rewrite subst_tm_tm_spec.
      exists_apply_Par x.
    + eapply Par_App; eauto using leq_Bot.
      eapply Par_subst3; try eassumption.
  - (* letpair cong / cong *)
    use_size_induction a0 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open b1 x bc Par3 Par4.
    exists (a_LetPair psi1 ac (close_tm_wrt_tm x bc)).
    split.
    exists_apply_Par x.
    exists_apply_Par x.
  - (* SSigma *)
    use_size_induction A1 ac Par1 Par2.
    pick fresh x.
    use_size_induction_open B1 x bc Par3 Par4.
    exists (a_SSigma psi1 ac (close_tm_wrt_tm x bc)).
    split; exists_apply_Par x; eauto.
  - (* SPair cong / cong *)
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst; try done.
    +  use_size_induction a0 ac Par1 Par2.
       use_size_induction b1 bc Par3 Par4.
       exists (a_SPair ac psi1 bc).
       split. eauto. eauto.
    + (* SPair cong / cong irrel *)
    use_size_induction b1 bc Par3 Par4.
    exists (a_SPair a3 psi1 bc).
    split. eauto. eauto.
  - (* fst beta / fst beta *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    move: (Par_SPair_inv Par2) => [a'2 [b2' ?]]; split_hyp; subst.
     match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst; try done.
    invert_equality. subst.
    exists a'2. split. auto. auto.
  - (* fst beta / fst cong *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end;
    subst; try done.
    exists a'1. split; eauto.
  - (* fst cong / fst beta *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par2) => [a'1 [b1' ?]]; split_hyp; subst.
    match goal with [ H : CPar ?S ?psi ?phi _ _ |- _ ] => inversion H; clear H end; subst; try done.
    exists a'1. split; eauto.
  - (* fst cong / fst cong *)
    use_size_induction a0 ac Par1 Par2.
    exists (a_Proj1 psi1 ac).
    split.  auto. auto.
  - (* snd beta / snd beta *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    move: (Par_SPair_inv Par2) => [a'2 [b2' ?]]; split_hyp; subst.
    invert_equality. subst.
    exists b2'. split. auto. auto.
  - (* snd *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par1) => [a'1 [b1' ?]]; split_hyp; subst.
    exists b1'. split; eauto.
  - (* snd cong / snd beta *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_SPair_inv Par2) => [a'1 [b1' ?]]; split_hyp; subst.
    exists b1'. split; eauto.
  - (* snd cong / snd cong *)
    use_size_induction a0 ac Par1 Par2.
    exists (a_Proj2 psi1 ac).
    split.  auto. auto.
  - (* Sum cong *)
    use_size_induction A1 ac Par1 Par2.
    use_size_induction A2 bc Par3 Par4.
    exists (a_Sum ac bc).
    split. eauto. eauto.
  - (* Inj1 cong / cong *)
    use_size_induction a0 ac Par1 Par2.
    exists (a_Inj1 ac). split; eauto.
  - (* inj2 cong / cong *)
    use_size_induction a0 ac Par1 Par2.
    exists (a_Inj2 ac). split; eauto.
  - (* case beta1 / beta1 *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj1_inv Par1) => [a'1 ?]; split_hyp; subst.
    move: (Par_Inj1_inv Par2) => [a'2 ?]; split_hyp; subst.
    invert_equality; subst.
    exists (a_App b1c psi1 a'2).
    split; eapply Par_App; eauto.

  - (* case beta1 / beta2 (impossible) *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_Inj1_inv Par1) => [a'1 ?]; split_hyp; subst.
    move: (Par_Inj2_inv Par2) => [a'2 ?]; split_hyp; subst.
    invert_equality; subst.

  - (* case beta1 / cong *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj1_inv Par1) => [a'1 ?]; split_hyp; subst.

    exists (a_App b1c psi1 a'1).
    split. eapply Par_App; eauto.
    eapply Par_CaseBeta1; eauto.
  - (* case beta2 / beta1 *)
    use_size_induction a0 ac Par1 Par2.
    move: (Par_Inj2_inv Par1) => [a'1 ?]; split_hyp; subst.
    move: (Par_Inj1_inv Par2) => [a'2 ?]; split_hyp; subst.
    invert_equality; subst.
  - (* case beta2 / beta2 *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj2_inv Par1) => [a'1 ?]; split_hyp; subst.
    move: (Par_Inj2_inv Par2) => [a'2 ?]; split_hyp; subst.
    invert_equality; subst.
    exists (a_App b2c psi1 a'2).
    split; eapply Par_App; eauto.
  - (* case beta2 / cong *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj2_inv Par1) => [a'1 ?]; split_hyp; subst.
    exists (a_App b2c psi1 a'1).
    split. eapply Par_App; eauto.
    eapply Par_CaseBeta2; eauto.
  - (* case cong / beta1 *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj1_inv Par2) => [a'1 ?]; split_hyp; subst.
    exists (a_App b1c psi1 a'1).
    split. eapply Par_CaseBeta1; eauto.
    eapply Par_App; eauto.
  - (* case cong / beta2 *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    move: (Par_Inj2_inv Par2) => [a'1 ?]; split_hyp; subst.
    exists (a_App b2c psi1 a'1).
    split. eapply Par_CaseBeta2; eauto.
    eapply Par_App; eauto.
  - (* case cong / cong *)
    use_size_induction a0 ac Par1 Par2.
    use_size_induction b1 b1c Par3 Par4.
    use_size_induction b2 b2c Par5 Par6.
    exists (a_Case psi1 ac b1c b2c).
    split; eauto.
Qed.

Lemma confluence : forall {S a psi a1}, Par S psi a a1 -> forall {a2}, Par S psi a a2 -> exists b, Par S psi a1 b /\ Par S psi a2 b.
Proof.
  intros.
  eapply confluence_size; eauto.
Qed.


Add LoadPath "coq/playground".
Require Import List.
Require Import Ornamental.Ornaments.

Set DEVOID search prove equivalence.
Set DEVOID lift type.

(*
 * Attempts at figuring equivalences that correspond to constructor extension,
 * and the corresponding eliminator transformation, so we can make a good
 * interface for asking the user for exactly the new information that is needed,
 * and inferring it when possible.
 *
 * NOTE: Everything in this file is from February (you can check the history),
 * I just accidentally added something irrelevant here and then moved it recently.
 *)

(* --- No new information --- *)

Module NoNewInformation.

Inductive list_ext (A : Type) : Type :=
| nil_ext : list_ext A
| cons_ext : A -> list_ext A -> list_ext A
| nil_ext2 : list_ext A.

(*
 * This version gets you from proofs about list to proofs about list_ext, but
 * just ignores the nil_ext2 case:
 *)

Program Definition list_ext_inv (A : Type) (l : list_ext A) : Prop.
Proof.
  induction l.
  - apply True.
  - apply IHl.
  - apply False.
Defined.

Program Definition list_list_ext :
  forall (A : Type), list A -> sigT (fun (l : list_ext A) => list_ext_inv A l).
Proof.
  intros A l. induction l.
  - exists (nil_ext A). simpl. auto.
  - exists (cons_ext A a (projT1 IHl)). simpl.
    destruct IHl. simpl. auto.
Defined.

Program Definition list_ext_list :
  forall (A : Type), sigT (fun (l : list_ext A) => list_ext_inv A l) -> list A.
Proof.
  intros A lp. induction lp. induction x.
  - apply nil.
  - apply cons.
    + apply a.
    + apply IHx. simpl in p. apply p.
  - inversion p.
Defined.

Lemma list_list_ext_cons:
  forall (A : Type) (a : A) (l : list A),
    list_list_ext A (a :: l) =
    existT (fun (l : list_ext A) => list_ext_inv A l) (cons_ext A a (projT1 (list_list_ext A l))) (projT2 (list_list_ext A l)).
Proof.
  intros A a l. simpl. auto.
Defined.

Lemma list_ext_list_cons:
  forall (A : Type) (a : A) (l : sigT (fun (l : list_ext A) => list_ext_inv A l)),
    list_ext_list A (existT (fun l => list_ext_inv A l) (cons_ext A a (projT1 l)) (projT2 l)) =
    a :: list_ext_list A (existT (fun l => list_ext_inv A l) (projT1 l) (projT2 l)).
Proof.
  intros A a l. simpl. auto.
Defined.

Lemma list_ext_eta:
  forall (A : Type) (l : sigT (fun (l : list_ext A) => list_ext_inv A l)),
    existT (fun (l : list_ext A) => list_ext_inv A l) (projT1 l) (projT2 l) =
    l.
Proof.
  intros. induction l. auto.
Defined.

Program Definition list_list_ext_section :
  forall (A : Type) (l : list A), list_ext_list A (list_list_ext A l) = l.
Proof.
  intros A l. induction l.
  - reflexivity.
  - rewrite list_list_ext_cons. rewrite list_ext_list_cons. rewrite list_ext_eta.
    rewrite IHl. auto.
Defined.

Program Definition list_list_ext_retraction:
  forall (A : Type) (pl : sigT (fun (l : list_ext A) => list_ext_inv A l)), list_list_ext A (list_ext_list A pl) = pl.
Proof.
  intros A l. induction l. induction x.
  - simpl. simpl in p. destruct p. auto.
  - compute. compute in IHx. rewrite IHx. auto.
  - simpl. destruct p.
Defined.

(*
 * This version asks you for the extra information needed to get your list proofs
 * to proofs about list_ext (TODO what is this?)
 *)

Inductive list_missing (A : Type) : Type :=
| missing_nil2 : list_missing A.

Definition list_missing_inv (A : Type) (lo : option (list_missing A)) : Type :=
  match lo with
  | Some l => prod (list A) (list_missing A)
  | None => list A
  end.

Program Definition list_list_ext' :
  forall (A : Type), sigT (fun lo => list_missing_inv A lo) -> list_ext A.
Proof.
  intros A s. induction s. induction x.
  - induction p. induction a0.
    + apply nil_ext2.
    + apply cons_ext.
      * apply a0.
      * apply IHa0.
  - induction p.
    + apply nil_ext.
    + apply cons_ext.
      * apply a.
      * apply IHp.
Defined.

Program Definition list_ext_list' :
  forall (A : Type), list_ext A -> sigT (fun lo => list_missing_inv A lo).
Proof.
  intros A l. induction l.
  - exists None. apply nil.
  - induction IHl. induction x.
    + exists (Some a0). induction p.
      simpl. apply pair. apply (cons a a1). apply b.
    + exists None. apply (cons a p).
  - exists (Some (missing_nil2 A)). simpl.
    apply pair.
    + apply nil.
    + apply (missing_nil2 A).
Defined.

Program Definition list_list_ext_section' :
  forall (A : Type) lo, list_ext_list' A (list_list_ext' A lo) = lo.
Proof.
  intros A lo. induction lo. destruct x.
  - simpl. induction p. induction a.
    + simpl. induction b. induction l. reflexivity.
    + compute. compute in IHa. rewrite IHa. auto.
  - simpl. induction p.
    + simpl. auto.
    + compute. compute in IHp. rewrite IHp. auto.
Defined.

Program Definition list_list_ext_retraction':
  forall (A : Type) l, list_list_ext' A (list_ext_list' A l) = l.
Proof.
  intros A l. induction l.
  - simpl. auto.
  - simpl. remember (list_ext_list' A l) as l'. induction l'. simpl.
    induction x.
    + induction p. simpl. rewrite <- IHl. simpl. auto.
    + simpl. rewrite <- IHl. simpl. auto.
  - simpl. auto.
Defined.

End NoNewInformation.

(* --- No new inductive information --- *)

(* TODO *)

(* --- New inductive information --- *)

(* TODO *)


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * PreimageEq.v : Proof of equality of preimages under two homomorphisms *)

Require Export SigmaPhi.

Set Implicit Arguments.

(** Constraints on the special homomorphisms: values [u_1(x_1)] and
   [u_2(x_2)] must be some constant independent of [x_1] and [x_2],
   and the special exponent [v] must be the same for both
   homomorphisms.
*)
Module Type EP_CONSTRAINTS (G H1 H2:GROUP)
 (HM1:HOMOMORPHISM G H1) (HM2:HOMOMORPHISM G H2).

 Parameter special_u_same : forall k (x1:H1.t k) (x2:H2.t k),
  HM1.special_u x1 = HM2.special_u x2.

 Parameter special_v_same : HM1.special_v = HM2.special_v.

End EP_CONSTRAINTS.

(** The special homomorphism used to prove equality of the preimages
  of a pair of elements in [H1 * H2]
*)
Module EP_Homomorphism (G  H1 H2:GROUP)
 (HM1:HOMOMORPHISM G H1) (HM2:HOMOMORPHISM G H2)
 (EPC:EP_CONSTRAINTS G H1 H2 HM1 HM2).

 Import EPC.

 Module H := Group_Prod H1 H2.

 Module HP1 := Homomorphism_Properties G H1 HM1.
 Module HP2 := Homomorphism_Properties G H2 HM2.

 Definition phi k : G.t k -> H.t k := fun x => (HM1.phi x, HM2.phi x).

 Definition cost_phi k (x:G.t k) := 1 + (HM1.cost_phi x + HM2.cost_phi x).

 Definition cost_phi_poly := pplus 1 (pplus HM1.cost_phi_poly HM2.cost_phi_poly).

 Lemma cost_phi_poly_spec : forall k (x:G.t k),
  cost_phi x <= peval cost_phi_poly k.
 Proof.
  intros; unfold cost_phi, cost_phi_poly.
  rewrite pplus_spec, pplus_spec, pcst_spec.
  apply plus_le_compat; [ trivial | ].
  apply plus_le_compat;
   [ apply HM1.cost_phi_poly_spec | apply HM2.cost_phi_poly_spec ].
 Qed.

 Lemma phi_homo : forall k (x y:G.t k),
  phi (G.mul x y) = H.mul (phi x) (phi y).
 Proof.
  intros; unfold phi, H.mul; simpl.
  rewrite HM1.phi_homo, HM2.phi_homo; trivial.
 Qed.

 (* [phi] is a special homomorphism *)
 Definition special_v k := HM1.special_v k.

 Lemma special_v_spec : forall k, special_v k <> 0%Z.
 Proof.
  apply HM1.special_v_spec.
 Qed.

 Definition special_v_poly := HM1.special_v_poly.

 Lemma size_nat_special_v : forall k,
  size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
 Proof.
  apply HM1.size_nat_special_v.
 Qed.

 Definition cost_special_v k := HM1.cost_special_v k.

 Definition cost_special_v_poly := HM1.cost_special_v_poly.

 Lemma cost_special_v_poly_spec : forall k,
  cost_special_v k <= peval cost_special_v_poly k.
 Proof.
  apply HM1.cost_special_v_poly_spec.
 Qed.

 Definition special_u k : H.t k -> G.t k := fun x => HM1.special_u (fst x).

 Definition cost_special_u k (x:H.t k) := HM1.cost_special_u (fst x).

 Definition cost_special_u_poly := HM1.cost_special_u_poly.

 Lemma cost_special_u_poly_spec : forall k (x:H.t k),
  cost_special_u x <= peval cost_special_u_poly k.
 Proof.
  intros; apply HM1.cost_special_u_poly_spec.
 Qed.

 Lemma phi_special : forall k (x:H.t k),
  phi (special_u x) = H.powZ x (special_v k).
 Proof.
  intros k (x1, x2).
  unfold phi, special_u, special_v.
  rewrite H.powZ_equiv; simpl.
  rewrite HM1.phi_special.
  rewrite (special_u_same x1 x2), special_v_same.
  rewrite HM2.phi_special.
  trivial.
 Qed.

End EP_Homomorphism.


(*
Copyright © 2007-2008
 Russell O’Connor
 Bas Spitters

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.metric2.StepFunctionSetoid.
Require Import CoRN.metric2.StepFunctionMonad.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.structures.OpenUnit.
Require Import Coq.QArith.QArith.
Require Import CoRN.model.totalorder.QMinMax.
Require Import Coq.QArith.Qabs.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.metric2.Prelength.
Require Import CoRN.algebra.COrdFields2.
Require Import CoRN.tactics.CornTac.

Set Implicit Arguments.
Set Automatic Introduction.

Local Open Scope sfstscope.
Local Open Scope setoid_scope.

(**
** Linf metric for Step Functions
The Linf metric for [StepF X] is obtained by lifting the ball predicate on X *)

Section StepFSupBall.
Set Implicit Arguments.

Variable X:MetricSpace.

(** A setoid verion of the ball predicate *)
Definition ballS0 (m : MetricSpace): Q -> (msp_as_RSetoid m) -> (msp_as_RSetoid m) --> iffSetoid
  := fun (e : Q) (x : m) =>
       Build_Morphism
         (msp_as_RSetoid m) iffSetoid (ball e x)
         (fun (x1 x2 : m) (H : msp_eq x1 x2) =>
            ball_wd m (reflexivity e) x x (reflexivity x) x1 x2 H).

Definition ballS (m : MetricSpace): Q -> (msp_as_RSetoid m) --> (msp_as_RSetoid m) --> iffSetoid.
Proof.
 intros e.
 exists (ballS0  m e).
 intros. simpl. split; rewrite -> H; auto with *.
Defined.

(** The definition of the usp metric *)
Definition StepFSupBall (e:Q) (f:StepF (msp_as_RSetoid X)) (g:StepF (msp_as_RSetoid X))
  := StepFfoldProp (((@ballS X e)^@> f) <@> g).

Lemma StepFSupBallGlueGlue : forall e o fl fr gl gr,
StepFSupBall e (glue o fl fr) (glue o gl gr) <->
StepFSupBall e fl gl /\ StepFSupBall e fr gr.
Proof.
 intros e o fl fr gl gr.
 unfold StepFSupBall at 1.
 rewrite MapGlue.
 rewrite ApGlueGlue.
 reflexivity.
Qed.

End StepFSupBall.

Arguments StepFSupBall [X].

Add Parametric Morphism X : (@StepFSupBall X)
  with signature Qeq ==> (@StepF_eq _) ==> (@StepF_eq _) ==> iff
 as StepFSupBall_wd.
Proof.
 unfold StepFSupBall.
 intros a1 a2 Ha x1 x2 Hx y1 y2 Hy.
 apply StepFfoldProp_morphism.
 rewrite -> Hx.
 rewrite -> Hy.
 setoid_replace (ballS X a1) with (ballS X a2).
  reflexivity.
 intros x y.
 simpl.
 rewrite -> Ha.
 reflexivity.
Qed.

Lemma StepFSupBall_e_wd : forall X (e1 e2:Q) x y,
    Qeq e1 e2 -> (StepFSupBall e1 x y <-> @StepFSupBall X e2 x y).
Proof.
  intros. rewrite H. reflexivity.
Qed.

Section SupMetric.
(** The StepFSupBall satifies the requirements of a metric. *)
Variable X : MetricSpace.

Lemma StepFSupBall_refl : forall (e:Q) (x:StepF (msp_as_RSetoid X)),
    Qle (0#1) e -> StepFSupBall e x x.
Proof.
 intros e x epos.
 unfold StepFSupBall.
 set (b:=(@ballS X e)).
 set (f:=(@join _ _) ^@> (constStepF b)).
 cut (StepFfoldProp (f <@> x )).
  unfold f.
  evalStepF.
  auto.
 apply: StepFfoldPropForall_Map.
 simpl.
 auto with *.
Qed.

Lemma StepFSupBall_sym : forall e (x y:StepF (msp_as_RSetoid X)),
    (StepFSupBall e x y) -> (StepFSupBall e y x).
Proof.
 intros e x y.
 unfold StepFSupBall.
 set (b:=(@ballS X e)).
 apply StepF_imp_imp.
 unfold StepF_imp.
 set (f:=ap (compose (@ap _ _ _) (compose (compose imp) b)) (flip (b))).
 cut (StepFfoldProp (f ^@> x <@> y)).
  unfold f; evalStepF; tauto.
 apply StepFfoldPropForall_Map2.
 intros a b0.
 simpl. unfold compose0.
 auto with *.
Qed.

Lemma StepFSupBall_triangle : forall e d (x y z:StepF (msp_as_RSetoid X)),
 (StepFSupBall e x y) -> (StepFSupBall d y z) -> (StepFSupBall (e+d) x z).
Proof.
 intros e d x y z.
 unfold StepFSupBall.
 set (be:=(@ballS X e)).
 set (bd:=(@ballS X d)).
 set (bed:=(@ballS X (e+d) )).
 intro H. apply StepF_imp_imp. revert H.
 apply StepF_imp_imp.
 unfold StepF_imp.
 pose (f:= ap (compose (@ap _ _ _) (compose (compose (compose (@compose _ _ _) imp)) be))
   (compose (flip (compose (@ap _ _ _) (compose (compose imp) bd))) bed)).
 cut (StepFfoldProp (f ^@> x <@> y <@> z)).
  unfold f.
  evalStepF.
  tauto.
 apply StepFfoldPropForall_Map3.
 apply: (ball_triangle X e d).
Qed.

Lemma StepFSupBall_closed : forall e (x y:StepF (msp_as_RSetoid X)),
    (forall d, Qlt (0#1) d -> (StepFSupBall (e+d) x y)) -> (StepFSupBall e x y).
Proof.
 intros e.
 apply: (StepF_ind2).
 - intros. rewrite -> H, H0 in H1. apply H1.
   intro. rewrite -> H, H0. apply H2.
 - apply: ball_closed.
 - intros o s s0 t t0 IH0 IH1 H.
 unfold StepFSupBall in *.
 rewrite MapGlue. rewrite ApGlue. simpl.
 split.
  rewrite SplitLGlue. apply IH0. clear IH0.
  intros d dpos. pose (H2:=H d).
  rewrite -> MapGlue in H2. rewrite ApGlue in H2.
  rewrite SplitRGlue in H2. rewrite SplitLGlue in H2.
  destruct H2. exact dpos. auto.
  rewrite SplitRGlue. apply IH1. clear IH1.
 intros d dpos. pose (H2:=H d).
 rewrite -> MapGlue in H2. rewrite ApGlue in H2.
 rewrite SplitRGlue in H2. rewrite SplitLGlue in H2.
 destruct H2. exact dpos. auto.
Qed.

Lemma StepFSupBall_eq : forall (x y : StepF (msp_as_RSetoid X)),
(forall e : Qpos, StepFSupBall (proj1_sig e) x y) -> StepF_eq x y.
Proof.
 apply: (StepF_ind2).
 - intros s s0 t t0 H H0 H1 H2. rewrite -> H, H0 in H1. apply H1.
   intro. rewrite -> H, H0. apply H2.
 - intros. apply ball_eq. intros.
   specialize (H (exist _ _ H0)). exact H.
 - intros o s s0 t t0 H H0 H1.
 unfold StepFSupBall in *. apply glue_resp_StepF_eq.
 apply H. clear H.
  intro e. pose (H2:=H1 e).
  rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2.
  destruct H2; auto.
 apply H0. clear H0.
 intro e. pose (H2:=H1 e).
 rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2.
 destruct H2; auto.
Qed.

Lemma StepFSupBall_nonneg : forall (e : Q) (a b : StepFS (msp_as_RSetoid X)),
  StepFSupBall e a b -> Qle (0#1) e.
Proof.
  induction a.
  - (* a is the constant function x *)
    induction b. intro H0.
    unfold StepFSupBall, StepFfoldProp in H0. simpl in H0.
    exact (msp_nonneg (msp X) e x x0 H0).
    intros [H0 _]. exact (IHb1 H0).
  - intros b H.
    unfold StepFSupBall, StepFfoldProp in H. simpl in H.
    unfold Ap in H. simpl in H.
    destruct (@Split X b o). destruct H.
    apply (IHa1 _ H).
Qed.

Lemma StepFSupBall_stable : forall (e : Q) (a b : StepFS (msp_as_RSetoid X)),
  (~~StepFSupBall e a b) -> StepFSupBall e a b.
Proof.
  induction a.
  - induction b.
    unfold StepFSupBall, StepFfoldProp.
    simpl. intros. apply (msp_stable (msp X)), H.
    intros. split.
    apply IHb1.
    intro abs. contradict H; intros [H _].
    contradiction.
    apply IHb2.
    intro abs. contradict H; intros [_ H].
    contradiction.
  - unfold StepFSupBall, StepFfoldProp, Ap.
    simpl. intros b H.
    destruct (@Split X b o). split.
    apply IHa1.
    intro abs. contradict H; intros [H _].
    contradiction.
    apply IHa2.
    intro abs. contradict H; intros [_ H].
    contradiction.
Qed.

(**
*** Example of a Metric Space <Step, StepFSupBall>
*)
Lemma StepFSupBall_is_MetricSpace : is_MetricSpace (@StepFSupBall X).
Proof.
 split.
 - intros. intro x. apply StepFSupBall_refl, H.
 - apply: StepFSupBall_sym.
 - apply: StepFSupBall_triangle.
 - apply: StepFSupBall_closed.
 - exact StepFSupBall_nonneg.
 - exact StepFSupBall_stable.
Qed.

Definition StepFSup : MetricSpace :=
  Build_MetricSpace (@StepFSupBall_e_wd X) StepFSupBall_is_MetricSpace.

Lemma StepF_eq_equiv : forall (x y : StepFSup),
    StepF_eq x y <-> msp_eq x y.
Proof.
  split.
  - intro H. simpl. rewrite H. apply (ball_refl StepFSup).
    discriminate.
  - intro H. apply StepFSupBall_eq.
    simpl in H.
    intro e. exact (ball_weak_le StepFSup x y (Qpos_nonneg e) H).
Qed.

(** The StepFSup is is a prelength space. *)
Lemma StepFSupPrelengthSpace : PrelengthSpace X -> PrelengthSpace StepFSup.
Proof.
 intros pl.
 apply: StepF_ind2.
   intros s s0 t t0 Hs Ht H e d1 d2 He H0.
   rewrite <- Hs, <- Ht in H0.
   destruct (H _ _ _ He H0) as [c Hc0 Hc1].
   exists c.
    rewrite <- Hs; auto.
   rewrite <- Ht; auto.
  intros a b e d1 d2 He Hab.
  destruct (pl a b e d1 d2 He Hab) as [c Hc0 Hc1].
  exists (@constStepF (msp_as_RSetoid X) c); auto.
 intros o s s0 t t0 IHl IHr e d1 d2 He H.
 simpl in H.
 rewrite -> StepFSupBallGlueGlue in H.
 destruct H as [Hl Hr].
 destruct (IHl _ _ _ He Hl) as [c Hc0 Hc1].
 destruct (IHr _ _ _ He Hr) as [d Hd0 Hd1].
 exists (glue o c d); simpl; rewrite -> StepFSupBallGlueGlue; auto.
Qed.

End SupMetric.

(* begin hide *)
Canonical Structure StepFSup.
(* end hide *)

Lemma StepFSupBallBind(X:MetricSpace): ((forall (e : Qpos) (a b : StepF (StepFS (msp_as_RSetoid X))) ,
forall f:(StepFS (msp_as_RSetoid X)) -->(StepFS (msp_as_RSetoid X)),
(forall c d, (StepFSupBall (proj1_sig e) c d) -> (StepFSupBall (proj1_sig e) (f c) (f d)))->
StepFSupBall (X:=StepFSup X) (proj1_sig e) a b ->
StepFSupBall (X:=X) (proj1_sig e) (StFBind00 a f) (StFBind00 b f))).
Proof.
 intros e a. unfold ball_ex.
 induction a. simpl.
 induction b.
  intros. simpl. apply H. assumption.
  intros f Hf H. simpl in H. unfold StepFSupBall in H.
  pose proof (GlueAp (constStepF (ballS (StepFSup X) (proj1_sig e)) <@^ x) o b1 b2).
  rewrite H0 in H. clear H0.
  rewrite -> StepFfoldPropglue_rew in H. destruct H as [H H1].
  simpl.
  unfold StepFSupBall. rewrite -> GlueAp.
  rewrite -> StepFfoldPropglue_rew. split.
  pose (HH:=IHb1  (compose1 (SplitLS (msp_as_RSetoid X) o) f)). simpl in HH.
   simpl in HH. unfold StepFSupBall in HH. unfold compose0 in HH.
   assert (rew:(ballS X (proj1_sig e) ^@> SplitLS0 o (f x)) ==
               (SplitL (ballS X (proj1_sig e) ^@> f x) o)).
   unfold SplitLS0. rewrite SplitLMap;reflexivity.
    rewrite <-rew. clear rew. apply HH; auto with *.
   intros. unfold SplitLS0. rewrite <- SplitLMap. rewrite <- SplitLAp.
   apply StepFfoldPropSplitL. apply (Hf c d H0).
   (* right *)
   pose (HH:=IHb2  (compose1 (SplitRS (msp_as_RSetoid X) o) f)). simpl in HH.
  unfold StepFSupBall in HH. unfold compose0 in HH.
  assert (rew:(ballS X (proj1_sig e) ^@> SplitRS0 o (f x)) ==
              (SplitR (ballS X (proj1_sig e) ^@> f x) o)).
  unfold SplitRS0. rewrite SplitRMap;reflexivity.
   rewrite <-rew. clear rew. apply HH; auto with *.
  intros. unfold SplitRS0. rewrite <- SplitRMap. rewrite <- SplitRAp.
  apply StepFfoldPropSplitR. apply (Hf c d H0).
  intros b f Hf H.
 simpl.
 unfold StepFSupBall. simpl. rewrite MapGlue.
 rewrite ApGlue. rewrite -> StepFfoldPropglue_rew. split.
 clear IHa2. pose (HH:=IHa1 (SplitL b o) (compose1 (SplitLS (msp_as_RSetoid X) o) f)).
 simpl in HH.
  unfold compose0 in HH. unfold StepFSupBall in HH.
  rewrite -> SplitLBind. apply HH; clear HH.
  intros. unfold SplitLS0. rewrite <- SplitLMap. rewrite <- SplitLAp.
   apply StepFfoldPropSplitL. apply (Hf c d H0).
   pose (HH:=StepFfoldPropSplitL _ o H).
   rewrite -> SplitLAp in HH. rewrite SplitLMap in HH.
   assert (StepF_eq (ballS (StepFSup X) (proj1_sig e) ^@> a1 <@> SplitL b o)
                    (ballS (StepFSup X) (proj1_sig e) ^@> SplitL (glue o a1 a2) o <@> SplitL b o)).
   { rewrite SplitLGlue. reflexivity. }
   rewrite (StepFfoldProp_mor _ _ H0).
   exact HH.
  clear IHa1. pose (HH:=IHa2 (SplitR b o) (compose1 (SplitRS (msp_as_RSetoid X) o) f)). simpl in HH.
 unfold compose0 in HH. unfold StepFSupBall in HH.
 rewrite -> SplitRBind. apply HH; clear HH.
 intros. unfold SplitRS0. rewrite <- SplitRMap. rewrite <- SplitRAp.
  apply StepFfoldPropSplitR. apply (Hf c d H0).
  pose (HH:=StepFfoldPropSplitR _ o H). rewrite -> SplitRAp in HH.
  rewrite SplitRMap in HH.
   assert (StepF_eq (ballS (StepFSup X) (proj1_sig e) ^@> a2 <@> SplitR b o)
                    (ballS (StepFSup X) (proj1_sig e) ^@> SplitR (glue o a1 a2) o <@> SplitR b o)).
   { rewrite SplitRGlue. reflexivity. }
   rewrite H0. exact HH.
Qed.

Local Open Scope uc_scope.

Section UniformlyContinuousFunctions.

Variable X Y : MetricSpace.

(** Various functions with step functions are uniformly continuous with this metric. *)
Definition StFJoinSup :(StepFSup (StepFSup X)) --> (StepFSup X).
Proof.
  simpl.
  apply (@Build_UniformlyContinuousFunction
           (StepFSup (StepFSup X))
           _ (@StFJoin (msp_as_RSetoid X)) (fun e:Qpos=>e)).
 abstract (unfold is_UniformlyContinuousFunction; simpl; intros; apply
   StepFSupBallBind; [auto with * | assumption]).
Defined.

Definition StFReturn_uc : X --> (StepFSup X).
Proof.
 simpl. exists (StFReturn (msp_as_RSetoid X)) (fun x:Qpos=> x:QposInf).
 abstract (intros e a b H ; apply H).
Defined.

Lemma uc_stdFun(X0 Y0:MetricSpace):
  (UniformlyContinuousFunction X0 Y0) -> (extSetoid (msp_as_RSetoid X0) (msp_as_RSetoid Y0)).
Proof.
 intros f. exists (ucFun f). abstract (intros; apply uc_wd; assumption).
Defined.

(* Why doesn't this work?
Coercion uc_stdFun: (UniformlyContinuousFunction X Y)>-> (extSetoid X Y).
*)

Definition Map_uc (f:X-->Y):(StepFSup X)-->(StepFSup Y).
Proof.
 intros.
 exists (Map f) (mu f).
 intros e a b.
 simpl. unfold StepFSupBall.
 case_eq (mu f e).
  Focus 2. intros.
 set (bal:=(ballS Y (proj1_sig e))).
 unfold ball_ex in H.
 cut (StepFfoldProp ((flip (compose (flip (compose bal (uc_stdFun f))) (uc_stdFun f))) ^@> a <@> b)).
  evalStepF. auto with *.
  apply StepFfoldPropForall_Map2. intros. simpl.
 apply uc_prf.
 rewrite H. simpl. auto.
 intros q eq. apply: StepF_imp_imp.
 unfold StepF_imp.
 set (bal:=(ballS Y (proj1_sig e))).
 set (F:=(((flip (compose (flip (compose bal (uc_stdFun f))) (uc_stdFun f)))))).
 set (IMP:=(ap (compose (@ap _ _ _) (compose (compose imp) (ballS X (proj1_sig q)))) F)).
 cut (StepFfoldProp (IMP ^@> a <@> b)).
  unfold IMP, F; evalStepF. tauto.
  apply StepFfoldPropForall_Map2.
 intros a0 b0. simpl. unfold compose0.
 intro. apply uc_prf. rewrite eq. apply H.
Defined.

Definition glue_uc0 (o:OpenUnit):
 StepFSup X -> StepFSup X --> StepFSup X.
Proof.
 intros x.
 exists (fun y=>(glue o x y)) (fun x:Qpos=> x).
 abstract( intros e a b;  simpl; rewrite -> StepFSupBallGlueGlue; intuition; apply StepFSupBall_refl; apply Qpos_nonneg).
Defined.

Definition glue_uc (o:OpenUnit):
 StepFSup X --> StepFSup X --> StepFSup X.
Proof.
 exists (fun y=>(glue_uc0 o y)) (fun x:Qpos=> x).
 intros e a b H.
 split. apply Qpos_nonneg.
 intros. simpl. rewrite -> StepFSupBallGlueGlue. intuition.
 apply StepFSupBall_refl. apply Qpos_nonneg.
Defined.

(** There is an injection from X to StepFSup X. *)
Lemma constStepF_uc_prf
  : is_UniformlyContinuousFunction
      (@constStepF (msp_as_RSetoid X):X -> StepFSup X) Qpos2QposInf.
Proof.
 intros e x y H.
 simpl in *.
 assumption.
Qed.

Definition constStepF_uc : X --> StepFSup X
:= Build_UniformlyContinuousFunction (constStepF_uc_prf).

End UniformlyContinuousFunctions.

Arguments constStepF_uc {X}.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal30.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_2  := ( Cons Zero Nil).
Definition lfind_example_3  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_4  := ( Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_5  := ( Cons Zero Nil).
Definition lfind_example_6  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))).
Definition lfind_example_7  := ( Cons (Succ Zero) Nil).
Definition lfind_example_8  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_9  := ( Cons (Succ Zero) Nil).
Definition lfind_example_10  := ( Cons (Succ Zero) Nil).
Definition lfind_example_11  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_12  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero)            (Cons (Succ (Succ Zero))               (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil)))).
Definition lfind_example_13  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_14  := ( Cons (Succ Zero) Nil).
Definition lfind_example_15  := ( Cons Zero Nil).
Definition lfind_example_16  := ( Cons (Succ Zero) Nil).
Definition lfind_example_17  := ( Cons Zero Nil).
Definition lfind_example_18  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_19  := ( Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_20  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_21  := ( Cons Zero Nil).
Definition lfind_example_22  := ( Cons (Succ Zero) Nil).
Definition lfind_example_23  := ( Cons Zero Nil).
Definition lfind_example_24  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_25  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_26  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_27  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_28  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_29  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_31  := ( Cons Zero Nil).
Definition lfind_example_32  := ( Cons Zero Nil).
Definition lfind_example_33  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_34  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_35  := ( Cons (Succ Zero) Nil).
Definition lfind_example_36  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_37  := ( Cons Zero Nil).
Definition lfind_example_38  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_39  := ( Cons (Succ Zero)         (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) Nil)))).
Definition lfind_example_40  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal30_append_rev_cons_45_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 lfind_example_38 lfind_example_39 lfind_example_40 .


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism Terminal Dual.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Set Universe Polymorphism.

Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Coq.Strings.Byte.
Require Import Coq.Lists.List.

Local Open Scope list_scope.
Local Open Scope char_scope.

(** Initial Object *)

Class Initial (C: Category) (iobj: @obj C): Type :=
{
  imorph : forall X, @arrow C X iobj;
  imorphu: forall X (f g: @arrow C X iobj), f = g
}.

Class hasInitial (C: Category): Type :=
{
  iobj: @obj C;
  hasi: Initial C iobj
}.

Lemma ter_ini: forall (C: Category) (T: @obj C) (t: Terminal C T), Initial (DualCategory C) T.
Proof. intros C T (Tax1, Tax2).
       unshelve econstructor.
       - simpl. exact Tax1.
       - simpl. exact Tax2.
Qed.

Lemma ini_ter: forall (C: Category) (I: @obj C) (i: Initial C I), Terminal (DualCategory C) I.
Proof. intros C I (Iax1, Iax2).
       unshelve econstructor.
       - simpl. exact Iax1.
       - simpl. exact Iax2.
Qed.

Lemma initialIso0: forall (C: Category) (I I': @obj C) (i: Initial C I), @Isomorphic C I I' -> Initial C I'.
Proof. intros C I I' (Iax1, Iax2) (f, (finv, fax1, fax2)).
       simpl in *.
       unshelve econstructor.
       - simpl. intro a.
         exact (Iax1 a o finv).
       - simpl. intros a g h.
         specialize (Iax2 a (g o f) (h o f)).
         assert (g o f o finv = h o f o finv).
         { rewrite Iax2. easy.  }
         rewrite <- assoc, fax1, <- assoc, fax1, !f_identity in H.
         easy.
Qed.

Lemma InitialIso: forall (C: Category) (I I': @obj C) (i: Initial C I) (i': Initial C I'), @Isomorphic C I I'.
Proof. intros C I I' (iax1, iax2) (jax1, jax2).
       simpl in *.
       unshelve econstructor.
       - exact (iax1 I').
       - unshelve econstructor.
         + exact (jax1 I).
         + apply jax2.
         + apply iax2.
Qed.

Lemma InitialIsoUnique: forall (C: Category) (I I': @obj C) (i: Initial C I) (i': Initial C I'),
  { f: @arrow C I I' & Isomorphism C f ->
    forall g: @arrow C I I', Isomorphism C g -> f = g }.
Proof. intros C I I' (iax1, iax2) (jax1, jax2).
       simpl in *.
       exists (jax1 I).
       intros (finv, fax1, fax2) g (ginv, gax1, gax2).
       apply jax2.
Qed.

Definition iEmpty: Initial SetCat Empty_set.
Proof. unshelve econstructor.
       - simpl. intros X x. easy.
       - simpl. intros X f g.
         apply functional_extensionality.
         intro x. easy.
Defined.

Definition iunitMon: Initial Mon UMonoid.
Proof. unshelve econstructor.
       - simpl. intro M1.
         destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         unshelve econstructor.
         + simpl. intro a. exact e1.
         + simpl. reflexivity.
         + simpl. intros. rewrite M1ob2. reflexivity.
       - simpl. intros A f g.
         apply MonoidMapEq.
         destruct A as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         destruct f, g.
         simpl in *.
         apply functional_extensionality.
         intro x. destruct x.
         rewrite monrelmap1, monrelmap0.
         reflexivity.
Defined.

Class PreOrderBot : Type :=
{
   pob  : PreOrder;
   pbot : @pos pob;
   pobob: forall (x: @pos pob), (@pohrel pob pbot x) = true
}.

Lemma iPreOrderDetCat: forall (P: PreOrderBot), Initial (PreOrderDetCat (@pob P)) (@pbot P).
Proof. intros ((P, le, r, t), u, ax).
       unshelve econstructor.
       - simpl in *.
         intro y.
         unfold PreOrderICMap.
         rewrite ax. exact tt.
       - simpl in *.
         intros.
         unfold PreOrderICMap in *.
         simpl in *.
         destruct (le u X).
         destruct f, g. easy.
         destruct f, g.
Defined.

Definition FreeMonoid: Monoid.
Proof. unshelve econstructor.
       - exact (list ascii).
       - exact nil.
       - intros xs ys. exact (xs ++ ys).
       - intros. simpl. rewrite app_assoc. reflexivity.
       - simpl. intro xs. reflexivity.
       - simpl. intro xs. rewrite app_nil_r. reflexivity.
Defined.

Definition ListMonoid: Monoid.
Proof. unshelve econstructor.
       - exact (list unit).
       - exact nil.
       - intros xs ys. exact (xs ++ ys).
       - intros. simpl. rewrite app_assoc. reflexivity.
       - simpl. intro xs. reflexivity.
       - simpl. intro xs. rewrite app_nil_r. reflexivity.
Defined.

Definition eta {A: Set} (a: A): list A.
Proof. exact (a :: nil). Defined.

Fixpoint fP (A B: Set) (f: A -> A -> A) (g: B -> A) (l: list B) (a: A): A :=
  match l with
    | nil      => a
    | y :: ys  => f (g y) (fP A B f g ys a)
  end.

Definition fBar: forall (M: Monoid) (f: ascii -> (@mons M)), MonoidMap FreeMonoid M.
Proof. intros (M, e, ob, a, ax1, ax2) f.
       simpl in *.
       unshelve econstructor.
       - simpl. intro l. exact (fP _ _ ob f l e).
       - simpl. reflexivity.
       - simpl. intros x.
         induction x; intros.
         + simpl. rewrite ax1. reflexivity.
         + case_eq y; intros.
           ++ simpl. rewrite app_nil_r. rewrite ax2. reflexivity.
           ++ simpl. rewrite IHx. simpl. rewrite a. reflexivity.
Defined.

Theorem fBarUniEx: forall (M: Monoid) (f: ascii -> (@mons M)),
  { fM: MonoidMap FreeMonoid M & f = @comp SetCat _ _ _ (@monmap FreeMonoid M fM) (eta) /\
    forall gM: MonoidMap FreeMonoid M, f = @comp SetCat _ _ _ (@monmap FreeMonoid M gM) (eta) -> fM = gM }.
Proof. intros.
       exists (fBar M f).
       simpl.
       destruct M as (M, e, ob, a, ax1, ax2).
       split. simpl.
       apply functional_extensionality. intro b. rewrite ax2. reflexivity.
       intros Hg Hf.
       destruct Hg as (g, Hg1, Hg2).
       apply MonoidMapEq.
       simpl.
       apply functional_extensionality.
       intro l.
       induction l; intros.
       + simpl in *. rewrite Hg1. reflexivity.
       + simpl in *. rewrite IHl. rewrite Hf.
         rewrite <- Hg2. unfold eta. simpl. reflexivity.
Qed.

(** Slice Category *)

Definition SliceCat (C: Category) (s: @obj C): Category.
Proof. unshelve econstructor.
       - exact ({ a & @arrow C s a }).
       - intros (a, f) (b, g).
         exact ({ m: @arrow C b a & f = g o m }).
       - simpl. intros (a, f).
         exists (@identity C a).
         rewrite f_identity. reflexivity.
       - simpl. intros (a, f) (b, g) (c, h) (i, Hi) (k, Hk).
         exists (k o i). rewrite assoc, <- Hk, Hi. reflexivity.
       - repeat intro. now subst.
       - intros (a, f) (b, g) (c, h) (i, Hi) (k, Hk) (j, Hj) (n, Hn).
       Search subsetT_eq_compat.
         apply subsetT_eq_compat. rewrite assoc. reflexivity.
       - intros (a, f) (b, g) (c, h).
         apply subsetT_eq_compat. rewrite f_identity. reflexivity.
       - intros (a, f) (b, g) (c, h).
         apply subsetT_eq_compat. rewrite identity_f. reflexivity.
Defined.

Definition CoSliceCat (C: Category) (s: @obj C): Category.
Proof. unshelve econstructor.
       - exact ({ a & @arrow C a s }).
       - intros (a, f) (b, g).
         exact ({ m: @arrow C b a | g = m o f }).
       - simpl. intros (a, f).
         exists (@identity C a).
         rewrite identity_f. reflexivity.
       - simpl. intros (a, f) (b, g) (c, h) (i, Hi) (k, Hk).
         exists (k o i). rewrite <- assoc, <- Hi, Hk. reflexivity.
       - repeat intro. now subst.
       - intros (a, f) (b, g) (c, h) (i, Hi) (k, Hk) (j, Hj) (n, Hn).
         apply subset_eq_compat. rewrite assoc. reflexivity.
       - intros (a, f) (b, g) (c, h).
         apply subset_eq_compat. rewrite f_identity. reflexivity.
       - intros (a, f) (b, g) (c, h).
         apply subset_eq_compat. rewrite identity_f. reflexivity.
Defined.

Definition PCoSliceCat: Category.
Proof. unshelve econstructor.
       simpl in *.
       - (* exact (@obj Mon * (forall M, @arrow Mon M FreeMonoid))%type. *)
         exact ({ M: @obj Mon & @arrow SetCat (@mons M) ascii })%type.
       - intros (M1, f1) (M2, f2).
         simpl in *.
         exact { f: MonoidMap M2 M1 | (@comp SetCat _ _ _ (@monmap M2 M1 f) f2) = f1 }.
       - simpl. intros (M1, f).
         unshelve econstructor.
         + unshelve econstructor.
           ++ intro A. exact A.
           ++ simpl. reflexivity.
           ++ simpl. reflexivity.
         + simpl. easy.
       - simpl. intros (M1, f1) (M2, f2) (M3, f3) (f, fax) (g, gax).
         exists (@comp Mon _ _ _ f g). rewrite <- fax, <- gax.
         destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         destruct M2 as (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         destruct M3 as (M3, e3, M3f, M3ob1, M3ob2, M3ob3).
         destruct f as (f, fax1, fax2).
         destruct g as (g, gax1, gax2).
         apply functional_extensionality.
         intro x. simpl in *. reflexivity.
       - repeat intro. now subst.
       - simpl. intros (M1, f1) (M2, f2) (M3, f3) (M4, f4) (f, fax) (g, gax) (h, hax).
         destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         destruct M2 as (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         destruct M3 as (M3, e3, M3f, M3ob1, M3ob2, M3ob3).
         destruct M4 as (M4, e4, M4f, M4ob1, M4ob2, M4ob3).
         destruct f as (f, fax1, fax2).
         destruct g as (g, gax1, gax2).
         destruct h as (h, hax1, hax2).
         apply subset_eq_compat. apply MonoidMapEq. simpl. reflexivity.
       - simpl. intros (M1, f1) (M2, f2) (f, fax).
         destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         destruct M2 as (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         destruct f as (f, fax1, fax2).
         apply subset_eq_compat. apply MonoidMapEq. simpl. reflexivity.
       - simpl. intros (M1, f1) (M2, f2) (f, fax).
         destruct M1 as (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         destruct M2 as (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         destruct f as (f, fax1, fax2).
         apply subset_eq_compat. apply MonoidMapEq. simpl. reflexivity.
Defined.

Definition fm_eta: @obj PCoSliceCat.
Proof. simpl. exists FreeMonoid. exact eta. Defined.

Definition csiMon: Initial PCoSliceCat fm_eta.
Proof. unshelve econstructor.
       - simpl. intros (M, f).
         specialize (fBarUniEx M f); intro H; unfold unique in H.
         destruct H as (fM, H).
         exists fM. simpl in *. easy.
       - simpl. intros (M1, f) (M2, g) (M3, h).
         specialize (fBarUniEx M1 f); intro H; unfold unique in H.
         destruct H as (fM, (H1, H2)).
         apply subset_eq_compat.
         pose proof H2 as H22.
         simpl in *.
         specialize (H2 M2).
         specialize (H22 M3).
         rewrite <- H2, <- H22. reflexivity.
         easy. easy.
Defined.


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

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

Module Export S := PackageSynthesis P.


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

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

Module Export S := PackageSynthesis P.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section LeaderLogsPreserved.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaderLogs_preserved (net : network) : Prop :=
    forall h ll t' h' ll' e e',
      In (eTerm e, ll) (leaderLogs (fst (nwState net h))) ->
      In (t', ll') (leaderLogs (fst (nwState net h'))) ->
      In e ll' ->
      In e' ll ->
      In e' ll'.

  Class leaderLogs_preserved_interface : Prop :=
    {
      leaderLogs_preserved_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          leaderLogs_preserved net
    }.
End LeaderLogsPreserved.