(** * Finiteness *)

From Coq Require Import
  Lia Lists.List Logic.FinFun NArith.NArith
  Arith.Compare_dec Arith.EqNat Logic.Decidable Lists.ListDec.
From DEZ.Has Require Export
  EquivalenceRelations Decisions Enumerations Cardinalities.
From DEZ.Is Require Export
  Isomorphic Extensional Truncated Bijective.
From DEZ.Justifies Require Export
  OptionTheorems ProductTheorems LogicalTheorems NTheorems.
From DEZ.Provides Require Import
  TypeclassTactics.
From DEZ.Supports Require Import
  EquivalenceNotations.

#[export] Instance le_is_prop (x y : nat) : IsProp (x <= y).
Proof. intros a b. apply Peano_dec.le_unique. Qed.

#[export] Instance lt_is_prop (x y : nat) : IsProp (x < y).
Proof. intros a b. apply Peano_dec.le_unique. Qed.

Import ListNotations.

Notation "'_::_'" := cons : list_scope.
Notation "x '::' a" := (cons x a) : list_scope.

Lemma map_bimap_combine (A B C D : Type)
  (f : A -> C) (g : B -> D) (a : list A) (b : list B) :
  map (prod_bimap f g) (combine a b) = combine (map f a) (map g b).
Proof.
  revert b. induction a as [| x c s]; intros [| y d].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - simpl. f_equal. apply s.
Qed.

Lemma Forall2_dec (A B : Type) (P : A -> B -> Prop)
  (d : forall (x : A) (y : B), {P x y} + {~ P x y})
  (a : list A) (b : list B) :
  {Forall2 P a b} + {~ Forall2 P a b}.
Proof.
  destruct (dec (length a = length b)) as [s | s].
  -- revert b s. induction a as [| x c t]; intros [| y e] s.
  - left. apply Forall2_nil.
  - discriminate.
  - discriminate.
  - pose proof d x y as d'.
    inversion s as [s']. pose proof t _ s' as t'. clear s'.
    destruct d' as [d' | fd'], t' as [t' | ft'].
    + left. apply Forall2_cons.
      * apply d'.
      * apply t'.
    + right. intros cd. inversion_clear cd. contradiction.
    + right. intros cd. inversion_clear cd. contradiction.
    + right. intros cd. inversion_clear cd. contradiction.
  -- revert b s. induction a as [| x c t]; intros [| y e] s.
  - left. apply Forall2_nil.
  - right. intros cd. inversion cd.
  - right. intros cd. inversion cd.
  - simpl length in s.
    apply (PeanoNat.Nat.succ_inj_wd_neg (length c) (length e)) in s.
    pose proof d x y as d'.
    pose proof t _ s as t'. clear s.
    destruct d' as [d' | fd'], t' as [t' | ft'].
    + left. apply Forall2_cons.
      * apply d'.
      * apply t'.
    + right. intros cd. inversion_clear cd. contradiction.
    + right. intros cd. inversion_clear cd. contradiction.
    + right. intros cd. inversion_clear cd. contradiction.
Defined.

Section Context.

Context (A : Type).

#[export] Instance list_has_equiv_rel
  {X : HasEquivRel A} : HasEquivRel (list A) :=
  Forall2 X.

#[export] Instance list_has_equiv_dec
  {X : HasEquivRel A} {d : HasEquivDec A} : HasEquivDec (list A) :=
  Forall2_dec d.

#[export] Instance list_is_equiv
  {X : HasEquivRel A} {d : HasEquivDec A} `{!IsEquiv X} : IsEquiv (Forall2 X).
Proof.
  split.
  - intros x. induction x as [| y b s].
    + apply Forall2_nil.
    + apply Forall2_cons.
      * reflexivity.
      * apply s.
  - intros x. induction x as [| z b t]; intros [| w c] s.
    + apply Forall2_nil.
    + inversion s.
    + inversion s.
    + inversion_clear s as [| ? ? ? ? u v]. apply Forall2_cons.
      * symmetry. apply u.
      * apply t. apply v.
  - intros x. induction x as [| z b t]; intros [| w c] [| ww cc] s tt.
    + apply Forall2_nil.
    + inversion tt.
    + inversion s || inversion tt.
    + inversion s.
    + inversion s.
    + inversion s || inversion tt.
    + inversion tt.
    + inversion_clear s as [| ? ? ? ? u v].
      inversion_clear tt as [| ? ? ? ? uu vv]. apply Forall2_cons.
      * etransitivity.
        -- apply u.
        -- apply uu.
      * eapply t.
        -- apply v.
        -- apply vv.
Qed.

#[export] Instance cons_Proper {X : HasEquivRel A} :
  IsProper (X ==> Forall2 X ==> Forall2 X) _::_.
Proof.
  intros x y s a b t. apply Forall2_cons.
  - apply s.
  - apply t.
Qed.

End Context.

#[local] Open Scope relation_scope.
#[local] Open Scope core_scope.
#[local] Open Scope sig_scope.
#[local] Open Scope N_scope.

(** TODO This does not belong here! *)

Equations comparison_eq_dec (x y : comparison) : {x = y} + {x <> y} :=
  comparison_eq_dec Eq Eq := left _;
  comparison_eq_dec Lt Lt := left _;
  comparison_eq_dec Gt Gt := left _;
  comparison_eq_dec _ _ := right _.
Next Obligation. intros x y a. discriminate. Qed.
Next Obligation. intros x y a. discriminate. Qed.
Next Obligation. intros x y a. discriminate. Qed.
Next Obligation. intros x y a. discriminate. Qed.
Next Obligation. intros x y a. discriminate. Qed.
Next Obligation. intros x y a. discriminate. Qed.

#[export] Instance comparison_is_has_eq_dec : HasEqDec comparison :=
  comparison_eq_dec.

#[local] Instance comparison_is_set : IsSet comparison.
Proof. typeclasses eauto. Qed.

#[export] Instance N_lt_is_prop (n p : N) : IsProp (p < n).
Proof. intros a b. apply uip. Qed.

Section Context.

Context (A : Type).

Equations nindex_from (n : nat) (a : list A) : list (nat * A) by struct a :=
  nindex_from _ [] := [];
  nindex_from n (x :: b) := (n, x) :: nindex_from (S n) b.

Equations nindex (a : list A) : list (nat * A) :=
  nindex := nindex_from O.

Context {X : HasEquivRel A} {d : HasEquivDec A}.

Equations nfind_from_error (n : nat) (x : A) (a : list A) : option nat :=
  nfind_from_error _ _ [] := None;
  nfind_from_error n x (y :: b) with dec (x == y) := {
    | left _ := Some n
    | right _ := nfind_from_error (S n) x b
  }.

Equations nfind_error (x : A) (a : list A) : option nat :=
  nfind_error := nfind_from_error O.

Equations nfind_from (n : nat) (x : A) (a : list A) (p : nat) : nat :=
  nfind_from _ _ [] p := p;
  nfind_from n x (y :: b) p with dec (x == y) := {
    | left _ := n
    | right _ := nfind_from (S n) x b p
  }.

Equations nfind (x : A) (a : list A) (p : nat) : nat :=
  nfind := nfind_from O.

End Context.

Section Context.

Context (A : Type) {X : HasEquivRel A} {d : HasEquivDec A}.

Lemma nfind_error_nfind (x : A) (a : list A) (n p : nat)
  (s : nfind_error x a = Some n) : nfind x a p = n.
Proof. Admitted.

Lemma nfind_error_nfind' (x : A) (a : list A) (n p : nat)
  (s : (n < length a)%nat) : nfind_error x a = Some (nfind x a p).
Proof. Admitted.

Lemma nfind_error_None (x : A) (a : list A) (n : nat)
  (s : nfind_error x a = None) : (length a <= n)%nat.
Proof. Admitted.

Lemma nfind_error_Some (x : A) (a : list A) (n : nat)
  (s : nfind_error x a <> None) : (n < length a)%nat.
Proof. Admitted.

End Context.

(** This reference implementation is simpler to use in proofs;
    the other implementation is faster to use in computations. *)

Module Ref.

Section Context.

Context (A : Type).

Equations nindex_from (n : nat) (a : list A) : list (nat * A) :=
  nindex_from n a := combine (seq n (length a)) a.

Equations nindex (a : list A) : list (nat * A) :=
  nindex := nindex_from O.

End Context.

Section Context.

Equations N_seq (n p : N) : list N :=
  N_seq n p := map N.of_nat (seq (N.to_nat n) (N.to_nat p)).

Context (A : Type).

Equations N_length (a : list A) : N :=
  N_length a := N.of_nat (length a).

Equations Nth (n : N) (a : list A) (x : A) : A :=
  Nth n := nth (N.to_nat n).

Equations Nindex_from (n : N) (a : list A) : list (N * A) :=
  Nindex_from n a := map (prod_bimap N.of_nat id) (nindex_from (N.to_nat n) a).

Equations Nindex (a : list A) : list (N * A) :=
  Nindex a := map (prod_bimap N.of_nat id) (nindex a).

Context {X : HasEquivRel A} {d : HasEquivDec A}.

Equations Nfind_from_error (n : N) (x : A) (a : list A) : option N :=
  Nfind_from_error n x a := option_map N.of_nat (nfind_from_error (N.to_nat n) x a).

Equations Nfind_error (x : A) (a : list A) : option N :=
  Nfind_error x a := option_map N.of_nat (nfind_error x a).

Equations Nfind_from (n : N) (x : A) (a : list A) (p : N) : N :=
  Nfind_from n x a p := N.of_nat (nfind_from (N.to_nat n) x a (N.to_nat p)).

Equations Nfind (x : A) (a : list A) (p : N) : N :=
  Nfind x a p := N.of_nat (nfind x a (N.to_nat p)).

End Context.

End Ref.

Section Context.

Equations N_seq (n p : N) : list N by wf p N.lt :=
  N_seq n N0 := [];
  N_seq n p := n :: N_seq (N.succ n) (N.pred p).
Next Obligation. intros n p r q. lia. Qed.

Context (A : Type).

Equations N_length (a : list A) : N by struct a :=
  N_length [] := 0;
  N_length (x :: b) := N.succ (N_length b).

Equations Nth (n : N) (a : list A) (x : A) : A by struct a :=
  Nth _ [] x := x;
  Nth N0 (y :: _) _ := y;
  Nth n (y :: b) x := Nth (N.pred n) b x.

Equations Nindex_from (n : N) (a : list A) : list (N * A) by struct a :=
  Nindex_from _ [] := [];
  Nindex_from n (x :: b) := (n, x) :: Nindex_from (N.succ n) b.

Equations Nindex (a : list A) : list (N * A) :=
  Nindex := Nindex_from 0.

Context {X : HasEquivRel A} {d : HasEquivDec A}.

Equations Nfind_from_error (n : N) (x : A) (a : list A) : option N :=
  Nfind_from_error _ _ [] := None;
  Nfind_from_error n x (y :: b) with dec (x == y) := {
    | left _ := Some n
    | right _ := Nfind_from_error (N.succ n) x b
  }.

Equations Nfind_error (x : A) (a : list A) : option N :=
  Nfind_error := Nfind_from_error 0.

Equations Nfind_from (n : N) (x : A) (a : list A) (p : N) : N :=
  Nfind_from _ _ [] p := p;
  Nfind_from n x (y :: b) p with dec (x == y) := {
    | left _ := n
    | right _ := Nfind_from (N.succ n) x b p
  }.

Equations Nfind (x : A) (a : list A) (p : N) : N :=
  Nfind := Nfind_from 0.

End Context.

Lemma nindex_from_ref (A : Type) (n : nat) (a : list A) :
  nindex_from n a = Ref.nindex_from n a.
Proof.
  apply Ref.nindex_from_elim. clear n a. intros n a. apply nindex_from_elim.
  - clear n a. intros n. reflexivity.
  - clear n a. intros n x a s.
    simpl. f_equal. apply s.
Qed.

Lemma nindex_ref (A : Type) (a : list A) : nindex a = Ref.nindex a.
Proof. apply Ref.nindex_elim. apply nindex_elim. apply nindex_from_ref. Qed.

Lemma N_length_ref (A : Type) (a : list A) :
  N_length a = Ref.N_length a.
Proof.
  apply Ref.N_length_elim. clear a. intros a. apply N_length_elim.
  - clear a. reflexivity.
  - clear a. intros x b s.
    simpl length. rewrite Nat2N.inj_succ. f_equal. apply s.
Qed.

Lemma Nth_ref (A : Type) (n : N) (a : list A) (x : A) :
  Nth n a x = Ref.Nth n a x.
Proof.
  apply Ref.Nth_elim. clear n. intros n. apply Nth_elim.
  - clear x n. intros n x. destruct n as [| p _] using N.peano_ind.
    + reflexivity.
    + rewrite N2Nat.inj_succ. reflexivity.
  - clear x n. intros y n x. reflexivity.
  - clear x n. intros p y b x s.
    rewrite N2Nat.inj_pred in s. destruct (N.to_nat (N.pos p)) as [| q] eqn : t.
    + lia.
    + apply s.
Qed.

Lemma N_seq_ref (n p : N) :
  N_seq n p = Ref.N_seq n p.
Proof.
  apply Ref.N_seq_elim. clear n p. intros n p.
  revert n. induction p as [| q s] using N.peano_ind; intros n.
  - reflexivity.
  - rewrite N2Nat.inj_succ. simpl seq. simpl map.
    pose proof s (N.succ n) as s'. rewrite N2Nat.inj_succ in s'.
    rewrite N2Nat.id. rewrite <- N.succ_pos_spec. simp N_seq.
    rewrite N.succ_pos_spec. rewrite N.pred_succ. f_equal. apply s'.
Qed.

Lemma Nindex_from_ref (A : Type) (n : N) (a : list A) :
  Nindex_from n a = Ref.Nindex_from n a.
Proof.
  apply Ref.Nindex_from_elim. clear n a. intros n a. apply Nindex_from_elim.
  - clear n a. intros n. reflexivity.
  - clear n a. intros n x a s.
    simpl. rewrite N2Nat.id. f_equal.
    rewrite N2Nat.inj_succ in s. apply s.
Qed.

Lemma Nindex_ref (A : Type) (a : list A) : Nindex a = Ref.Nindex a.
Proof. apply Ref.Nindex_elim. apply Nindex_elim. apply Nindex_from_ref. Qed.

Lemma N_seq_succ (n p : N) :
  N_seq n (N.succ p) = n :: N_seq (N.succ n) p.
Proof.
  do 2 rewrite N_seq_ref. unfold Ref.N_seq. rewrite N2Nat.inj_succ.
  rewrite <- cons_seq. simpl map. rewrite N2Nat.id. rewrite <- N2Nat.inj_succ.
  reflexivity.
Qed.

Section Context.

Context (A : Type) {X : HasEquivRel A} {d : HasEquivDec A}.

Lemma Nfind_from_error_ref (n : N) (x : A) (a : list A) :
  Nfind_from_error n x a = Ref.Nfind_from_error n x a.
Proof.
  apply Ref.Nfind_from_error_elim. clear n x a. intros n x a.
  revert n x. induction a as [| y b s]; intros n x.
  - reflexivity.
  - destruct (dec (x == y)) as [ex | fx] eqn : ed.
    + simp Nfind_from_error nfind_from_error. rewrite ed. simpl.
      rewrite N2Nat.id. reflexivity.
    + simp Nfind_from_error nfind_from_error. rewrite ed. simpl.
      pose proof s (N.succ n) x as s'. rewrite N2Nat.inj_succ in s'.
      apply s'.
Qed.

Lemma Nfind_error_ref (x : A) (a : list A) :
  Nfind_error x a = Ref.Nfind_error x a.
Proof.
  apply Nfind_error_elim. apply Ref.Nfind_error_elim. clear x a. intros x a.
  apply nfind_error_elim. apply Nfind_from_error_ref.
Qed.

Lemma Nfind_from_ref (n : N) (x : A) (a : list A) (p : N) :
  Nfind_from n x a p = Ref.Nfind_from n x a p.
Proof.
  apply Ref.Nfind_from_elim. clear n x a p. intros n x a p.
  revert n x p. induction a as [| y b s]; intros n x p.
  - simpl. rewrite N2Nat.id. reflexivity.
  - destruct (dec (x == y)) as [ex | fx] eqn : ed.
    + simp Nfind_from nfind_from. rewrite ed. simpl.
      rewrite N2Nat.id. reflexivity.
    + simp Nfind_from nfind_from. rewrite ed. simpl.
      pose proof s (N.succ n) x as s'. rewrite N2Nat.inj_succ in s'.
      apply s'.
Qed.

Lemma Nfind_ref (x : A) (a : list A) (p : N) :
  Nfind x a p = Ref.Nfind x a p.
Proof.
  apply Nfind_elim. apply Ref.Nfind_elim. clear x a p. intros x a p.
  apply nfind_elim. apply Nfind_from_ref.
Qed.

End Context.

Section Context.

Context (A : Type) {X : HasEquivRel A} {d : HasEquivDec A}
  `{!IsEquiv X}.

Ltac notations f := progress (
  f X (equiv_rel (A := A));
  f d (equiv_dec (A := A))).

Equations is_in (x : A) (a : list A) : bool :=
  is_in _ [] := false;
  is_in x (y :: b) := is_left (dec (x == y)) || is_in x b.

(** ** List Membership *)

(** This is a generalization of [In]. *)

Equations IsIn (x : A) (a : list A) : Prop :=
  IsIn _ [] := False;
  IsIn x (y :: b) := x == y \/ IsIn x b.

Equations IsIn_dec (x : A) (a : list A) :
  {IsIn x a} + {~ IsIn x a} by struct a :=
  IsIn_dec x [] := right _;
  IsIn_dec x (y :: b) with dec (x == y) := {
    | left _ => left _
    | right _ => _ (IsIn_dec x b)
  }.
Next Obligation.
  intros _ x y fs b [t | ft].
  - left. right. apply t.
  - right. intros [u | u].
    + contradiction.
    + contradiction.
Defined.

#[export] Instance IsIn_has_dec (x : A) (a : list A) :
  HasDec (IsIn x a) := IsIn_dec x a.

Lemma Exists_IsIn (P : A -> Prop) (a : list A) (s : Exists P a) :
  exists x : A, IsIn x a /\ P x.
Proof.
  induction s as [x b s | x b _ [y [i s]]].
  - exists x. split.
    + left. reflexivity.
    + apply s.
  - exists y. split.
    + right. apply i.
    + apply s.
Qed.

Lemma IsIn_Exists (P : A -> Prop) `{!IsProper (X ==> _<->_) P}
  (a : list A) (s : exists x : A, IsIn x a /\ P x) :
  Exists P a.
Proof.
  destruct s as [x [i t]]. induction a as [| y b u].
  - contradiction.
  - induction i as [v | v].
    + apply Exists_cons. left. rewrite <- v. apply t.
    + apply Exists_cons. right. apply u. apply v.
Qed.

Lemma Proper_IsIn (x y : A) (a : list A)
  (s : x == y) (t : IsIn x a) : IsIn y a.
Proof.
  induction a as [| z b u].
  - contradiction.
  - destruct t as [v | v].
    + left. rewrite <- s, <- v. reflexivity.
    + right. apply u. apply v.
Qed.

#[export] Instance IsIn_is_proper (a : list A) :
  IsProper (X ==> _<->_) (fun x : A => IsIn x a).
Proof.
  intros x y s. split.
  - intros t. eapply Proper_IsIn. apply s. apply t.
  - intros t. eapply Proper_IsIn. symmetry. apply s. apply t.
Qed.

#[export] Instance IsIn_is_proper' (x : A) :
  IsProper (Forall2 X ==> _<->_) (IsIn x).
Proof.
  intros a b s. split.
  - intros t. induction s as [| y z a b s u v].
    + contradiction.
    + destruct t as [w | w].
      * left. etransitivity.
        -- apply w.
        -- apply s.
      * right. auto.
  - intros t. induction s as [| y z a b s u v].
    + contradiction.
    + destruct t as [w | w].
      * left. etransitivity.
        -- apply w.
        -- symmetry. apply s.
      * right. auto.
Qed.

Lemma nth_IsIn (n : nat) (a : list A) (y : A) :
  (n < length a)%nat -> IsIn (nth n a y) a.
Proof.
  revert a; induction n as [| p s]; intros a t.
  - destruct a as [| z b]. simpl in t; lia.
    simpl. left. reflexivity.
  - destruct a as [| z b]. simpl in t; lia.
    simpl. right. apply s. simpl in t; lia.
Qed.

Lemma Nth_succ (n : N) (y : A) (b : list A) (x : A) :
  Nth (N.succ n) (y :: b) x = Nth n b x.
Proof.
  destruct n as [| p].
  - simp Nth. simpl N.pred. reflexivity.
  - simp Nth. simpl N.pred. rewrite Pos.pred_N_succ. reflexivity.
Qed.

Lemma Nfind_from_error_succ (n p : N) (x : A) (a : list A)
  (e : Nfind_from_error n x a = Some p) : Nfind_from_error (N.succ n) x a = Some (N.succ p).
Proof.
  revert e. apply Nfind_from_error_elim.
  - clear n x a. intros n x e.
    discriminate.
  - clear n x a. intros n x y ex b ed e.
    simp Nfind_from_error. rewrite ed. simpl.
    inversion_clear e. reflexivity.
  - clear n x a. intros n x y ex b es ed e.
    simp Nfind_from_error. rewrite ed. simpl.
    apply es. apply e.
Qed.

Lemma Nfind_from_error_succ' (n p : N) (x : A) (a : list A)
  (e : Nfind_from_error (N.succ n) x a = Some (N.succ p)) : Nfind_from_error n x a = Some p.
Proof.
  revert e. apply (Nfind_from_error_elim
  (fun (n : N) (x : A) (a : list A) (s : option N) =>
  Nfind_from_error (N.succ n) x a = Some (N.succ p) -> s = Some p)).
  - clear n x a. intros n x e.
    discriminate.
  - clear n x a. intros n x y ex b ed e.
    simp Nfind_from_error in e. rewrite ed in e. simpl in e.
    f_equal. apply N.succ_inj. inversion_clear e. reflexivity.
  - clear n x a. intros n x y ex b es ed e.
    simp Nfind_from_error in e. rewrite ed in e. simpl in e.
    apply es. apply e.
Qed.

Lemma Nfind_from_error_succ_iff (n p : N) (x : A) (a : list A) :
  Nfind_from_error n x a = Some p <-> Nfind_from_error (N.succ n) x a = Some (N.succ p).
Proof.
  split.
  - apply Nfind_from_error_succ.
  - apply Nfind_from_error_succ'.
Qed.

Lemma Nfind_from_error_succ_zero (n : N) (x : A) (a : list A)
  (e : Nfind_from_error (N.succ n) x a = Some 0) : 0.
Proof.
  revert e. apply (Nfind_from_error_elim
  (fun (n : N) (x : A) (a : list A) (s : option N) =>
  Nfind_from_error (N.succ n) x a = Some 0 -> 0)).
  - clear n x a. intros n x e.
    discriminate.
  - clear n x a. intros n x y ex b ed e.
    simp Nfind_from_error in e. rewrite ed in e. simpl in e.
    injection e. lia.
  - clear n x a. intros n x y ex b f ed e.
    simp Nfind_from_error in e. rewrite ed in e. simpl in e.
    apply f. apply e.
Qed.

Lemma Nfind_from_error_lt (n p : N) (x : A) (a : list A)
  (i : p < n) (e : Nfind_from_error n x a = Some p) : 0.
Proof.
  revert p i e. induction n as [| q f] using N.peano_ind; intros p i e.
  - lia.
  - destruct p as [| r _] using N.peano_ind.
    + apply Nfind_from_error_succ_zero in e. contradiction.
    + apply Nfind_from_error_succ' in e. apply f in e.
      * contradiction.
      * lia.
Qed.

Lemma Nfind_from_error_some (n p : N) (x y : A) (a : list A)
  (e : Nfind_from_error n x a = Some (n + p)) :
  IsIn x a /\ p < N_length a /\ Nth p a y == x.
Proof.
  revert n p e. induction a as [| z b c]; intros n p e.
  - discriminate.
  - destruct p as [| q _] using N.peano_ind.
    + destruct (dec (x == z)) as [ex | fx] eqn : ed.
      * split.
        -- left. apply ex.
        -- split.
           ++ simpl N_length. lia.
           ++ symmetry. apply ex.
      * exfalso.
        simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        apply Nfind_from_error_lt in e.
        -- contradiction.
        -- lia.
    + destruct (dec (x == z)) as [ex | fx] eqn : ed.
      * exfalso. simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        injection e. lia.
      * simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        pose proof c (N.succ n) q as cq.
        rewrite <- N.add_succ_comm in e. apply cq in e. destruct e as [i [iq ex]].
        split.
        -- right. apply i.
        -- split.
           ++ simp N_length. lia.
           ++ rewrite Nth_succ. apply ex.
Qed.

Lemma Nfind_from_error_none (n : N) (x : A) (a : list A)
  (e : Nfind_from_error n x a = None) (s : IsIn x a) : 0.
Proof.
  revert n e s. induction a as [| z b c]; intros n e s.
  - contradiction.
  - simpl in s. destruct s as [t | t].
    + destruct (dec (x == z)) as [ex | fx] eqn : ed.
      * exfalso. simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        discriminate.
      * contradiction.
    + destruct (dec (x == z)) as [ex | fx] eqn : ed.
      * simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        discriminate.
      * simp Nfind_from_error in e. rewrite ed in e. simpl in e.
        revert t. eapply c. apply e.
Qed.

Lemma Nfind_error_some (x y : A) (a : list A) (n : N) (s : Nfind_error x a = Some n) :
  IsIn x a /\ n < N_length a /\ Nth n a y == x.
Proof. eapply Nfind_from_error_some. rewrite N.add_0_l. apply s. Qed.

Lemma Nfind_error_none (x : A) (a : list A)
  (s : Nfind_error x a = None) (i : IsIn x a) : 0.
Proof. eapply Nfind_from_error_none. apply s. apply i. Qed.

Lemma Nfind_from_error_some' (n : N) (x y : A) (a : list A) (s : IsIn x a) :
  exists p : N,
  Nfind_from_error n x a = Some (n + p) /\ p < N_length a /\ Nth p a y == x.
Proof.
  revert n s. induction a as [| z b c]; intros n s.
  - contradiction.
  - simpl in s.
    destruct (dec (x == z)) as [ex | fx] eqn : ed.
    + exists 0. repeat split.
      * simp Nfind_from_error. rewrite ed. simpl.
        rewrite N.add_0_r. reflexivity.
      * simp N_length. lia.
      * symmetry. apply ex.
    + destruct s as [t | t].
      * contradiction.
      * simp Nfind_from_error. rewrite ed. cbn -[Nth].
        pose proof c n t as c'. destruct c' as [p [c0 [c1 c2]]].
        exists (N.succ p). repeat split.
        -- rewrite N.add_succ_r. apply Nfind_from_error_succ. apply c0.
        -- lia.
        -- rewrite Nth_ref. unfold Ref.Nth. rewrite N2Nat.inj_succ.
           simpl. rewrite Nth_ref in c2. apply c2.
Qed.

Lemma Nfind_error_some' (x y : A) (a : list A) (s : IsIn x a) :
  exists n : N,
  Nfind_error x a = Some n /\ n < N_length a /\ Nth n a y == x.
Proof. eapply Nfind_from_error_some'. apply s. Qed.

Lemma Nfind_from_error_Proper (n : N) (x y : A) (a : list A) (s : x == y) :
  Nfind_from_error n x a = Nfind_from_error n y a.
Proof.
  revert n; induction a as [| z b t]; intros n.
  - reflexivity.
  - simp Nfind_from_error.
    destruct (dec (x == z)) as [ex | fx] eqn : dx,
    (dec (y == z)) as [ey | fy] eqn : dy.
    + reflexivity.
    + exfalso. apply fy. etransitivity.
      * symmetry. apply s.
      * apply ex.
    + exfalso. apply fx. etransitivity.
      * apply s.
      * apply ey.
    + apply t.
Qed.

Lemma Nfind_error_Proper (x y : A) (a : list A) (s : x == y) :
  Nfind_error x a = Nfind_error y a.
Proof. apply Nfind_from_error_Proper. apply s. Qed.

Lemma Nfind_error_Nth (n : N) (a : list A) (x : A) (s : n < N_length a) :
  exists p : N,
  Nfind_error (Nth n a x) a = Some p /\ p <= n /\ Nth p a x == Nth n a x.
Proof. Admitted.

Lemma Nfind_from_succ (x : A) (a : list A) (n p : N) (s : IsIn x a) :
  Nfind_from (N.succ n) x a p = N.succ (Nfind_from (N.succ n) x a p).
Proof. Admitted.

Lemma Nfind_from_le (x : A) (a : list A) (n p q : N) (s : IsIn x a)
  (t : Nfind_from n x a p = q) : n <= q /\ q < n + N_length a.
Proof. Admitted.

Lemma Nfind_from_nope (x : A) (a : list A) (n p q : N) (s : ~ IsIn x a)
  (t : Nfind_from n x a p = q) : q = p.
Proof. Admitted.

Lemma Nth_Nfind_from (x y : A) (a : list A) (n p : N) (s : IsIn x a) :
  Nth (Nfind_from n x a p - n) a y == x.
Proof.
  revert s. apply Nfind_from_elim.
  - clear x a n p. intros n x p s. contradiction.
  - clear x a n p. intros n x z t b p t' s. rewrite N.sub_diag. symmetry. apply t.
  - clear x a n p. intros n x z t b p f t' s.
    simpl in s. destruct s as [s' | s'].
    + contradiction.
    + assert (u : n < Nfind_from (N.succ n) x b p).
      { pose proof Nfind_from_le x b (N.succ n) p s' (refl _). lia. }
      pose proof N.lt_exists_pred n (Nfind_from (N.succ n) x b p) u as v.
      destruct v as [q [e i]].
      rewrite e. rewrite N.sub_succ_l by lia. rewrite Nth_succ.
      specialize (f s').
      rewrite Nfind_from_succ in f by assumption.
      rewrite N.sub_succ in f.
      rewrite e in f.
      rewrite <- f.
      (** Nonsense! *)
Admitted.

Lemma Nth_Nfind (x y : A) (a : list A) (p : N) (s : IsIn x a) :
  Nth (Nfind x a p) a y == x.
Proof.
  apply Nfind_elim. rewrite <- (N.sub_0_r (Nfind_from _ _ _ _)).
  apply Nth_Nfind_from. apply s.
Qed.

End Context.

Lemma map_compose (A B C : Type) (f : A -> B) (g : B -> C) (a : list A) :
  map g (map f a) = map (g o f) a.
Proof. apply map_map. Qed.

Section Context.

Context (A B : Type)
  {X : HasEquivRel A} {d : HasEquivDec A}
  {Y : HasEquivRel B} {e : HasEquivDec B}
  `{!IsEquiv X} `{!IsEquiv Y}.

Lemma IsIn_map (f : A -> B) `{!IsProper (X ==> Y) f} (a : list A) (x : A)
  (s : IsIn x a) : IsIn (f x) (map f a).
Proof.
  revert x s. induction a as [| y b t]; intros x s.
  - contradiction.
  - simpl in s. destruct s as [ex | fx].
    + left. rewrite ex. reflexivity.
    + right. apply t. apply fx.
Qed.

Lemma map_ext_equiv
  (f g : A -> B) (s : forall x : A, f x == g x) (a : list A) :
  map f a == map g a.
Proof.
  induction a as [| x b t].
  - reflexivity.
  - simpl map. rewrite s. rewrite t. reflexivity.
Qed.

Lemma map_ext_in_equiv
  (f g : A -> B) (a : list A)
  (s : forall (x : A) (t : IsIn x a), f x == g x) :
  map f a == map g a.
Proof.
  induction a as [| x b t].
  - reflexivity.
  - simpl map. rewrite s. rewrite t. reflexivity. Admitted.

Lemma map_in_ext_equiv
  (f g : A -> B) (a : list A) (s : map f a == map g a) (x : A) (t : In x a) :
  f x == g x.
Proof.
  induction a as [| y b u].
  - contradiction.
  - simpl map in s. destruct t as [v | v].
    + apply u. Admitted.

End Context.

(** ** Unsorted Enumeration of a Type *)

(** This is a generalization of [Full]. *)

Class IsFull (A : Type) (X : A -> A -> Prop) (a : list A) : Prop :=
  full (x : A) : Exists (X x) a.

(** ** Uniqueness of a Listing *)

(** This is a generalization of [NoDup]. *)

Section Context.

Context (A : Type) (X : A -> A -> Prop).

#[local] Instance has_equiv_rel : HasEquivRel A := X.

Inductive IsNoDup : list A -> Prop :=
  | IsNoDup_nil : IsNoDup []
  | IsNoDup_cons (x : A) (a : list A) (f : ~ IsIn x a)
    (s : IsNoDup a) : IsNoDup (x :: a).

Existing Class IsNoDup.

End Context.

Lemma IsNoDup_inversion (A : Type) (X : A -> A -> Prop) (x : A) (a : list A)
  `{!IsNoDup X (x :: a)} : IsNoDup X a.
Proof.
  match goal with
  | x : IsNoDup _ _ |- _ => revert x
  end.
  intros IND. inversion_clear IND as [| ? ? FII IND']. apply IND'.
Qed.

(** ** Unsorted Unique Enumeration of a Type *)

(** This is a generalization of [Listing]. *)

Class IsListing (A : Type) (X : A -> A -> Prop) (a : list A) : Prop := {
  listing_is_full :> IsFull X a;
  listing_is_no_dup :> IsNoDup X a;
}.

(** ** Finiteness in Terms of Enumeration *)

Class IsFinFull (A : Type) (X : A -> A -> Prop) : Prop :=
  fin_full : exists a : list A, IsFull X a.

#[export] Instance full_is_fin_full (A : Type) (X : A -> A -> Prop)
  (a : list A) `{!IsFull X a} : IsFinFull X.
Proof. exists a. auto. Qed.

(** ** Finiteness in Terms of Unique Enumeration *)

Class IsFinListing (A : Type) (X : A -> A -> Prop) : Prop :=
  fin_listing : exists a : list A, IsListing X a.

#[export] Instance listing_is_fin_listing (A : Type) (X : A -> A -> Prop)
  (a : list A) `{!IsListing X a} : IsFinListing X.
Proof. exists a. auto. Qed.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (d : forall x y : A, {X x y} + {~ X x y}).

#[local] Instance has_equiv_rel'1 : HasEquivRel A := X.
#[local] Instance has_equiv_dec'1 : HasEquivDec A := d.

Equations nodup (a : list A) : list A by struct a :=
  nodup [] := [];
  nodup (x :: b) with dec (IsIn x b) := {
    | left _ => nodup b
    | right _ => x :: nodup b
  }.

#[local] Instance nodup_spec (a : list A) : IsNoDup X (nodup a).
Proof. Admitted.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (d : forall x y : A, {X x y} + {~ X x y}) (a : list A)
  `{!IsEquiv X}.

Ltac notations f := progress (
  f X (equiv_rel (A := A));
  f d (equiv_dec (A := A));
  f a (enum A)).

#[local] Instance has_equiv_rel'0 : HasEquivRel A := X.
#[local] Instance has_equiv_dec'0 : HasEquivDec A := d.
#[local] Instance has_enum'0 : HasEnum A := a.

(** Finiteness does not require uniqueness. *)

#[local] Instance full_is_nodup_listing
  `{!IsFull X a} : IsListing X (nodup d a).
Proof with notations enabled.
  split...
  - revert IsFull0. apply nodup_elim.
    + auto.
    + clear a. intros x b s t ss v. apply t. intros y. pose proof v y as v'.
      apply Exists_cons in v'. destruct v' as [w | w]; auto.
      pose proof Proper_IsIn _ _ b (w ^-1) s. apply IsIn_Exists.
      exists y. split; easy.
    + clear a. intros x b fs t ss v. intros y. apply Exists_cons_tl.
      apply t. pose proof v y as v'.
      apply Exists_cons in v'. destruct v' as [w | w]; auto.
Admitted.

#[local] Instance nodup_listing_is_full
  `{!IsListing X (nodup d a)} : IsFull X a.
Proof with notations enabled.
  intros x... pose proof full x as E.
  match goal with
  | IL : IsListing _ _ |- _ => clear IL
  end.
  revert E. apply nodup_elim.
  - intros E. apply E.
  - intros y b II E eII E'.
    apply Exists_cons. destruct (dec (x == y)) as [ex | Fx] eqn : eex.
    + left. apply ex.
    + right. apply E. apply E'.
  - intros y b FII E eII E'.
    apply Exists_cons in E'; rename E' into eE. destruct eE as [e | E'].
    + apply Exists_cons_hd. apply e.
    + apply Exists_cons_tl. apply E. apply E'.
Qed.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (d : forall x y : A, {X x y} + {~ X x y}) `{!IsEquiv X}.

Ltac notations f := progress (
  f X (equiv_rel (A := A));
  f d (equiv_dec (A := A))).

#[local] Instance has_equiv_rel'2 : HasEquivRel A := X.
#[local] Instance has_equiv_dec'2 : HasEquivDec A := d.

(** Finiteness does not require uniqueness. *)

#[export] Instance fin_listing_is_fin_full
  `{!IsFinListing X} : IsFinFull X.
Proof with notations enabled.
  destruct fin_listing as [a s]... exists a. intros x. apply full.
Qed.

Lemma uniquify :
  forall l : list A, exists l' : list A, IsNoDup X l' /\ forall a, IsIn a l -> IsIn a l'.
Proof. Admitted.

#[local] Instance fin_full_is_fin_listing
  `{!IsFinFull X} : IsFinListing X.
Proof with notations enabled.
  destruct fin_full as [a s]... exists a. split.
  - intros x. apply full.
  - destruct (uniquify a) as [c [? ?]]... induction a as [| x b t].
    + apply IsNoDup_nil.
    + Admitted.

End Context.

(** ** Size of a Type *)

Class IsSize (A : Type) (X : A -> A -> Prop) (n : N) : Prop :=
  size_is_equiv_types :> IsEquivTypes {p : N | p < n} A _=_ X.

(** ** Finiteness in Terms of Counting *)

Class IsFinSize (A : Type) (X : A -> A -> Prop) : Prop :=
  fin_size : exists n : N, IsSize X n.

#[export] Instance size_is_fin_size (A : Type) (X : A -> A -> Prop)
  (n : N) `{!IsSize X n} : IsFinSize X.
Proof. exists n. auto. Qed.

(** Then in Bishop-style, which is missing from the diagram... *)

Module Ref'.

Equations Fin_of_nat (n : nat) (a : {p : nat | (p < n)%nat}) : Fin.t n :=
  Fin_of_nat a := Fin.of_nat_lt (proj2_sig a).

End Ref'.

Equations Fin_of_nat (n : nat) (a : {p : nat | (p < n)%nat}) :
  Fin.t n by struct n :=
  Fin_of_nat (n := O) (_; _) := _;
  Fin_of_nat (n := _) (O; _) := Fin.F1;
  Fin_of_nat (n := S q) (S p; i) := Fin.FS (Fin_of_nat (n := q) (p; _)).
Next Obligation. intros _ p i. lia. Defined.
Next Obligation. intros _ q p i. lia. Defined.

#[local] Open Scope nat_scope.

Lemma Fin_of_nat_ref (n : nat) (a : {p : nat | p < n}) :
  Fin_of_nat a = Ref'.Fin_of_nat a.
Proof.
  apply Ref'.Fin_of_nat_elim. clear n a. intros n [p i].
  apply (Fin_of_nat_elim (fun (n : nat) (a : {p : nat | p < n}) (q : Fin.t n) =>
  q = Fin.of_nat_lt (proj2_sig a))).
  - clear n p i. intros n i. exfalso. lia.
  - clear n p i. intros n i. reflexivity.
  - clear n p i. intros n p i e.
    rewrite e. erewrite Fin.of_nat_ext. reflexivity.
Qed.

#[local] Open Scope N_scope.

(** ** Size of a Type *)

Class IsBishopSize (A : Type) (X : A -> A -> Prop) (n : N) : Prop :=
  bishop_size_is_equiv_types :> IsEquivTypes (Fin.t (N.to_nat n)) A _=_ X.

(** ** Finiteness in Terms of Counting *)

Class IsBishopFinSize (A : Type) (X : A -> A -> Prop) : Prop :=
  bishop_fin_size : exists n : N, IsBishopSize X n.

#[export] Instance bishop_size_is_bishop_fin_size (A : Type) (X : A -> A -> Prop)
  (n : N) `{!IsBishopSize X n} : IsBishopFinSize X.
Proof. exists n. auto. Qed.

(** ** Lemmas *)

#[export] Instance nat_has_equiv_rel : HasEquivRel nat := eq.

#[export] Instance sig_has_equiv_rel (A : Type) (P : A -> Prop)
  {X : HasEquivRel A} : HasEquivRel {x : A | P x} :=
  fun x y : {x : A | P x} => proj1_sig x == proj1_sig y.

Lemma sig_N_of_nat (n : nat) (a : {p : nat | p < n}%nat) : {p : N | p < N.of_nat n}.
Proof. destruct a as [p i]. exists (N.of_nat p). abstract lia. Defined.

Lemma sig_N_to_nat (n : nat) (a : {p : N | p < N.of_nat n}) : {p : nat | p < n}%nat.
Proof. destruct a as [p i]. exists (N.to_nat p). abstract lia. Defined.

Lemma sig_N_of_nat' (n : N) (a : {p : nat | p < N.to_nat n}%nat) : {p : N | p < n}.
Proof. destruct a as [p i]. exists (N.of_nat p). abstract lia. Defined.

Lemma sig_N_to_nat' (n : N) (a : {p : N | p < n}) : {p : nat | p < N.to_nat n}%nat.
Proof. destruct a as [p i]. exists (N.to_nat p). abstract lia. Defined.

#[export] Instance sig_is_prop (A : Type) (P : A -> Prop)
  `{!IsProp A} `{!forall x : A, IsProp (P x)} : IsProp {x : A | P x}.
Proof.
  intros [x a] [y b]. apply eq_sig_hprop.
  - intros z c d. apply irrel.
  - apply irrel.
Qed.

Lemma eq_sig_hprop' (A : Type) (P : A -> Prop) `{!forall x : A, IsProp (P x)}
  (u v : {a : A | P a}) (s : proj1_sig u = proj1_sig v) : u = v.
Proof. apply eq_sig_hprop. intros x p q. apply irrel. apply s. Qed.

Lemma obvious (n : nat) (a : {p : nat | (p < n)%nat}) :
  Fin.to_nat (m := n) (Fin_of_nat a) = a.
Proof.
  rewrite Fin_of_nat_ref. unfold Ref'.Fin_of_nat.
  destruct a as [p i]. apply Fin.to_nat_of_nat.
Qed.

Lemma obvious' (n : nat) (p : Fin.t n) :
  Fin_of_nat (n := n) (Fin.to_nat p) = p.
Proof.
  rewrite Fin_of_nat_ref. unfold Ref'.Fin_of_nat.
  apply Fin.of_nat_to_nat_inv.
Qed.

Lemma evident (n : N) (a : {p : N | p < n}) :
  sig_N_of_nat' n (sig_N_to_nat' n a) = a.
Proof.
  destruct a as [p i]. unfold sig_N_to_nat', sig_N_of_nat'.
  apply eq_sig_hprop'. simpl proj1_sig. rewrite N2Nat.id. reflexivity.
Qed.

Lemma evident' (n : N) (a : {p : nat | (p < N.to_nat n)%nat}) :
  sig_N_to_nat' n (sig_N_of_nat' n a) = a.
Proof.
  destruct a as [p i]. unfold sig_N_to_nat', sig_N_of_nat'.
  apply eq_sig_hprop'. simpl proj1_sig. rewrite Nat2N.id. reflexivity.
Qed.

Lemma bishop_or_not (A : Type) (X : A -> A -> Prop) (n : N) :
  IsBishopSize X n <-> IsSize X n.
Proof.
  split.
  - intros [f [[g r] [h s]]]. hnf.
    exists (f o Fin_of_nat o sig_N_to_nat' _).
    split.
    + exists (sig_N_of_nat' _ o Fin.to_nat o g).
      split.
      * typeclasses eauto.
      * typeclasses eauto.
      * intros [p i]. unfold compose. rewrite retr.
        rewrite obvious. rewrite evident. reflexivity.
    + exists (sig_N_of_nat' _ o Fin.to_nat o h).
      split.
      * typeclasses eauto.
      * typeclasses eauto.
      * intros x. unfold compose.
        rewrite evident'. rewrite obvious'. apply sect.
  - intros [f [[g r] [h s]]]. hnf.
    exists (f o sig_N_of_nat' _ o Fin.to_nat).
    split.
    + exists (Fin_of_nat o sig_N_to_nat' _ o g).
      split.
      * typeclasses eauto.
      * typeclasses eauto.
      * intros x. unfold compose. rewrite retr.
        rewrite evident'. rewrite obvious'. reflexivity.
    + exists (Fin_of_nat o sig_N_to_nat' _ o h).
      split.
      * typeclasses eauto.
      * typeclasses eauto.
      * intros x. unfold compose.
        rewrite obvious. rewrite evident. apply sect.
Qed.

Lemma Nindex_In (A : Type)
  (n : N) (x : A) (a : list A) (s : In (n, x) (Nindex a)) :
  n < N.of_nat (length a).
Proof.
  rewrite Nindex_ref in s. unfold Ref.Nindex, Ref.nindex, Ref.nindex_from in s.
  rewrite map_bimap_combine in s.
  apply in_combine_l in s. apply (in_map N.to_nat) in s.
  rewrite map_map in s. rewrite (map_ext _ id) in s.
  - rewrite map_id in s. apply in_seq in s. lia.
  - intros p. rewrite Nat2N.id. reflexivity.
Qed.

Lemma Nindex_length (A : Type) (a : list A) : length (Nindex a) = length a.
Proof.
  rewrite Nindex_ref. unfold Ref.Nindex. unfold Ref.nindex, Ref.nindex_from.
  rewrite map_length. rewrite combine_length. rewrite seq_length.
  rewrite Min.min_idempotent. reflexivity.
Qed.

Lemma Nindex_nth (A : Type)
  (n : N) (x : A) (a : list A) (s : n < N.of_nat (length a)) :
  nth (N.to_nat n) (Nindex a) (N.of_nat 0, x) = (n, nth (N.to_nat n) a x).
Proof.
  rewrite Nindex_ref. unfold Ref.Nindex. unfold Ref.nindex, Ref.nindex_from.
  rewrite map_bimap_combine. rewrite combine_nth.
  - f_equal.
    + rewrite map_nth. rewrite seq_nth.
      * lia.
      * lia.
    + rewrite map_id. reflexivity.
  - rewrite map_length. rewrite seq_length. rewrite map_id. reflexivity.
Qed.

Section Context.

Context (A : Type) {X : HasEquivRel A} {d : HasEquivDec A} {a : HasEnum A}
  `{!IsEquiv X} `{!IsFull X a}.

Ltac notations f := progress (
  f X (equiv_rel (A := A));
  f d (equiv_dec (A := A));
  f a (enum A)).

Equations encode (s : {p : N | p < N.of_nat (length (enum A))}) : A :=
  encode (p; t) with inspect (enum A) := {
    | [] eqn : _ => _
    | x :: b eqn : _ => snd (nth (N.to_nat p) (Nindex (x :: b)) (0, x))
  }.
Next Obligation with notations enabled.
  cbv beta...
  intros p t u. rewrite u in t. unfold length, N.of_nat in t. lia.
Qed.

Equations decode (x : A) : {p : N | p < N.of_nat (length (enum A))} :=
  decode x with inspect (Nfind_error x (enum A)) := {
    | Some p eqn : _ => (p; _)
    | None eqn : _ => (0; _)
  }.
Next Obligation with notations enabled.
  cbv beta...
  intros x p s. apply (Nfind_error_some x x (enum A)) in s.
  destruct s as [i [ip ex]]. rewrite N_length_ref in ip. apply ip.
Qed.
Next Obligation with notations enabled.
  cbv beta...
  intros x t. exfalso.
  apply (Nfind_error_none x a).
  - apply t.
  - pose proof full x as u. apply Exists_exists in u. destruct u as [y [v w]].
    idtac...
    clear IsEquiv0 IsFull0 t.
    induction (enum A) as [| z b u].
    + contradiction.
    + destruct v as [v0 | v1].
      * left. rewrite v0. apply w.
      * right. apply u. apply v1.
Qed.

Lemma nth_inversion `{!IsNoDup X a} (n p : nat) (x : A)
  (inl : (n < length (enum A))%nat) (ipl : (p < length (enum A))%nat)
  (s : nth n (enum A) x == nth p (enum A) x) : n = p.
Proof with notations enabled.
  idtac...
  clear IsFull0.
  revert n p s inl ipl; induction IsNoDup0 as [| y b f t u]; intros n p s inl ipl.
  - simpl in inl; lia.
  - destruct n as [| q], p as [| r].
    + reflexivity.
    + simpl in s. exfalso. apply f. eapply Proper_IsIn.
      symmetry; apply s. apply nth_IsIn. simpl in ipl; lia.
    + simpl in s. exfalso. apply f. eapply Proper_IsIn.
      apply s. apply nth_IsIn. simpl in inl; lia.
    + f_equal. simpl in s. apply u. apply s.
      simpl in inl; lia. simpl in ipl; lia.
Qed.

End Context.

#[export] Instance prod_has_equiv_rel (A B : Type)
  {X : HasEquivRel A} {Y : HasEquivRel B} : HasEquivRel (A * B).
Proof.
  intros [x0 y0] [x1 y1].
  apply (x0 == x1 /\ y0 == y1).
Defined.

#[export] Instance prod_is_equiv (A B : Type)
  {X : HasEquivRel A} {Y : HasEquivRel B} `{!IsEquiv X} `{IsEquiv Y} :
  IsEquiv (prod_has_equiv_rel (A := A) (B := B)).
Proof.
  unfold prod_has_equiv_rel. split.
  - intros [x y]. split.
    + reflexivity.
    + reflexivity.
  - intros [x0 y0] [x1 y1] [a b]. split.
    + symmetry. apply a.
    + symmetry. apply b.
  - intros [x0 y0] [x1 y1] [x2 y2] [a0 b0] [a1 b1]. split.
    + transitivity x1.
      * apply a0.
      * apply a1.
    + transitivity y1.
      * apply b0.
      * apply b1.
Qed.

#[export] Instance option_has_equiv_rel (A : Type) {X : HasEquivRel A} :
  HasEquivRel (option A).
Proof.
  intros [x |] [y |].
  - apply (x == y).
  - apply False.
  - apply False.
  - apply True.
Defined.

#[export] Instance option_is_equiv (A : Type)
  {X : HasEquivRel A} `{!IsEquiv X} :
  IsEquiv option_has_equiv_rel.
Proof.
  unfold option_has_equiv_rel. split.
  - intros [x |].
    + reflexivity.
    + auto.
  - intros [x0 |] [x1 |].
    + intros a. symmetry. apply a.
    + intros [].
    + intros [].
    + intros a. apply a.
  - intros [x0 |] [x1 |] [x2 |].
    + intros a0 a1. transitivity x1.
      * apply a0.
      * apply a1.
    + intros a0 [].
    + intros [] [].
    + intros [] a1.
    + intros [] a1.
    + intros [] [].
    + intros a0 [].
    + intros a0 a1. auto.
Qed.

#[export] Instance N_has_equiv_rel : HasEquivRel N := eq.
#[export] Instance N_has_equiv_dec : HasEquivDec N := N.eq_dec.

Equations map_with_sig (A B : Type) (P : A -> Prop)
  (f : forall x : A, P x -> B) (a : list A) (s : Forall P a) :
  list B by struct a :=
  map_with_sig f (a := []) s := [];
  map_with_sig f (a := x :: b) s :=
  f x (Forall_inv s) :: map_with_sig f (a := b) (Forall_inv_tail s).

Arguments map_with_sig {_ _ _} _ _ _.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (d : forall x y : A, {X x y} + {~ X x y}) (a : list A) `{!IsEquiv X}.

#[local] Instance has_equiv_rel' : HasEquivRel A := X.
#[local] Instance has_equiv_dec : HasEquivDec A := d.
#[local] Instance has_enum : HasEnum A := a.

Ltac notations f := progress (
  f X (equiv_rel (A := A));
  f d (equiv_dec (A := A));
  f a (enum A)).

#[local] Instance is_proper_decode
  `{!IsListing X a} : IsProper (_==_ ==> _=_) (@decode A X d a _ _).
Proof.
  - intros x y. apply decode_elim.
    + clear x. intros x p s _ t.
      revert s t. apply decode_elim.
      * clear y. intros y q t _ u s.
        pose proof u as u'.
        rewrite (Nfind_error_Proper _ _ _ s) in u'.
        rewrite t in u'. inversion u' as [u''].
        apply (eq_exist_curried (u'' ^-1)). apply irrel.
      * clear y. intros y t _ u s.
        pose proof u as u'.
        rewrite (Nfind_error_Proper _ _ _ s) in u'.
        rewrite t in u'. inversion u'.
    + clear x. intros x s _ t.
      revert s t. apply decode_elim.
      * clear y. intros y q t _ u s.
        pose proof u as u'.
        rewrite (Nfind_error_Proper _ _ _ s) in u'.
        rewrite t in u'. inversion u'.
      * clear y. intros y t _ u s.
        apply (eq_exist_curried id%type). apply irrel.
Qed.

#[export] Instance listing_is_size_length
  `{!IsListing X a} : IsSize X (N_length a).
Proof with notations enabled.
  rewrite N_length_ref. unfold Ref.N_length.
  exists encode; split; exists decode; split...
  - typeclasses eauto.
  - typeclasses eauto.
  - intros [p t]. apply encode_elim.
    + clear p t. intros p t u _. exfalso.
      rewrite u in t. unfold length, N.of_nat in t. lia.
    + clear p t. intros p t x b u _. rewrite Nindex_nth.
      * unfold snd.
        remember (nth (N.to_nat p) (x :: b) x) as k eqn : ek.
        revert t u ek.
        apply decode_elim.
        -- clear k. intros y q vf _ t vt ve.
           pose proof vf as vf'.
           apply (Nfind_error_some y x (enum A)) in vf'.
           subst y. destruct vf' as [h0 [h1 v]].
           rewrite Nth_ref in v. simp Nth in v. rewrite <- vt in v.
           assert (m' : q = p).
           { apply nth_inversion in v. lia. rewrite N_length_ref in h1.
             unfold Ref.N_length in h1. lia. lia. }
           match goal with
           | |- (?p; ?a) = (?q; ?b) =>
             apply (eq_exist_curried
             (P := fun p => p < N.of_nat (length (enum A)))
             (u1 := p) (v1 := q) (u2 := a) (v2 := b) m')
           end. apply irrel.
        -- clear k. intros y vf _ t vt ve. exfalso.
           apply Nfind_error_none in vf.
           ++ contradiction.
           ++ pose proof full y as fz. apply Exists_IsIn in fz.
              destruct fz as [z [i e]].
              pose proof Proper_IsIn z y (enum A) as w. apply w.
              symmetry. apply e. apply i.
      * rewrite u in t. lia.
  - typeclasses eauto.
  - typeclasses eauto.
  - intros x. apply decode_elim.
    + clear x. intros x n s _.
      remember (n; decode_obligations_obligation_1 x s) as t eqn : et.
      revert et.
      apply encode_elim.
      * clear t. intros p t u _ _. exfalso. rewrite u in t. cbn in t. lia.
      * clear t. intros p t z c u _ et. inversion et; subst p.
        rewrite Nindex_nth.
        -- unfold snd. clear et.
           rewrite <- u.
           apply (Nfind_error_some x z) in s.
           destruct s as [ix [i e]].
           rewrite Nth_ref in e. apply e.
        -- rewrite <- u. lia.
    + clear x. intros x s _. exfalso.
      apply Nfind_error_none in s. contradiction.
      pose proof full x as fz. apply Exists_IsIn in fz.
      destruct fz as [z [i e]].
      pose proof Proper_IsIn z x (enum A) as w. apply w.
      symmetry. apply e. apply i.
Qed.

#[export] Instance listing_is_size_length'
  `{!IsListing X a} : IsBishopSize X (N_length a).
Proof. apply bishop_or_not. apply listing_is_size_length. Qed.

Equations tabulate (n : nat) (f : Fin.t n -> A) : list A by struct n :=
  tabulate (n := O) f := [];
  tabulate (n := S p) f := f Fin.F1 :: tabulate (n := p) (f o Fin.FS).

Lemma at_tabulate (k : nat) (x : A) (f : Fin.t k -> A)
  (ns : exists n : Fin.t k, f n == x) : IsIn x (tabulate f).
Proof.
  destruct ns as [n s].
  induction n as [| p q r].
  - Fail rewrite <- s. epose proof Proper_IsIn _ _ _ s as e. apply e. left. reflexivity.
  - right. apply r. rewrite <- s. reflexivity.
Qed.

Lemma in_index (k : nat) (x : A) (f : Fin.t k -> A)
  (s : IsIn x (tabulate f)) : exists n : Fin.t k, f n == x.
Proof.
  induction k as [| k' eh].
  - contradiction.
  - simpl in s. destruct s as [s | s].
    + exists Fin.F1. rewrite s. reflexivity.
    + pose proof eh (f o Fin.FS) s as w. destruct w as [n e].
      exists (Fin.FS n). rewrite <- e. reflexivity.
Qed.

#[local] Instance bishop_fin_size_is_fin_listing
  `{!IsBishopFinSize X} : IsFinListing X.
Proof with notations enabled.
  destruct bishop_fin_size as [p s].
  destruct s as [f [[g R] [i S]]].
  exists (tabulate f).
  split...
  - intros x. apply IsIn_Exists. exists x. split.
    + apply at_tabulate. exists (i x). rewrite sect. reflexivity.
    + reflexivity.
  - pose proof inj_un_fn (X := _=_) (Y := X) (f := f) as j.
    clear i g R S. induction p as [| q r] using N.peano_ind.
    + apply IsNoDup_nil.
    + remember (N.to_nat (N.succ q)) as n eqn : rm.
      rewrite N2Nat.inj_succ in rm. subst n.
      simp tabulate. apply IsNoDup_cons.
      * intros w. apply in_index in w. destruct w as [x e].
        unfold compose in e. apply j in e. inversion e.
      * apply (r (f o Fin.FS)). intros x y b. apply j in b.
        apply Fin.FS_inj in b. apply b.
Qed.

Equations N_seq_sig' (n p : N) : list {q : N | q < n + p} :=
  N_seq_sig' n p with inspect (N_seq n p) := {
    | a eqn : _ => _
  }.
Next Obligation.
  intros n p b s.
  revert n b s; induction p as [| q t] using N.peano_rect; intros n b s.
  - apply nil.
  - rewrite N_seq_ref in s. unfold Ref.N_seq in s.
    rewrite N2Nat.inj_succ in s. rewrite <- cons_seq in s.
    rewrite map_cons in s. destruct b as [| x b].
    + discriminate.
    + inversion s as [[sx sb]]. clear s. apply cons.
      * exists x. lia.
      * rewrite N.add_succ_r. rewrite <- N.add_succ_l.
        pose proof t (N.succ n) b as t'. apply t'.
        rewrite N_seq_ref. unfold Ref.N_seq.
        rewrite N2Nat.inj_succ. apply sb.
Defined.

Equations N_seq_sig (n p : N) : list {q : N | q < n + p} :=
  N_seq_sig n p := map_with_sig (P := fun q : N => q < n + p) _ (N_seq n p) _.
Next Obligation. cbv beta. intros n p q i. exists q. lia. Defined.
Next Obligation. cbv beta. intros n p.
  revert n; induction p as [| q s] using N.peano_rect; intros n.
  simp N_seq. apply Forall_nil.
  rewrite N_seq_ref. unfold Ref.N_seq. rewrite N2Nat.inj_succ. rewrite <- cons_seq.
  rewrite map_cons.
  rewrite <- N2Nat.inj_succ.
  change (map N.of_nat (seq (N.to_nat (N.succ n)) (N.to_nat q))) with (Ref.N_seq (N.succ n) q).
  rewrite <- N_seq_ref.
  apply Forall_cons. lia.
  replace (n + N.succ q) with (N.succ n + q) by lia.
  apply s.
Defined.

#[local] Instance fin_size_is_fin_listing
  `{!IsFinSize X} : IsFinListing X.
Proof.
  destruct fin_size as [p s].
  apply bishop_or_not in s.
  apply bishop_fin_size_is_fin_listing.
Qed.
  (* destruct s as [f [g i]].
  exists (map f (N_seq_sig 0 p)). *)

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (d : forall x y : A, {X x y} + {~ X x y}) `{!IsEquiv X}.

#[export] Instance fin_listing_is_fin_size
  `{!IsFinListing X} : IsFinSize X.
Proof.
  destruct fin_listing as [a ?]. exists (N_length a).
  apply listing_is_size_length; eauto || typeclasses eauto.
Qed.

End Context.

Lemma N_seq_sig_proj1_sig (n p : N) : map proj1_sig (N_seq_sig n p) = N_seq n p.
Proof. Admitted.

Section Context.

Context (A : Type) (P : A -> Prop).

Equations list_proj1_sig (a : list {x : A | P x}) : list A by struct a :=
  list_proj1_sig [] := [];
  list_proj1_sig ((x; _) :: b) := x :: list_proj1_sig b.

Lemma list_proj2_sig (a : list {x : A | P x}) : Forall P (list_proj1_sig a).
Proof.
  induction a as [| [x a] b s].
  - apply Forall_nil.
  - simp list_proj1_sig. apply Forall_cons.
    + apply a.
    + apply s.
Qed.

End Context.


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

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

(* Why3 assumption *)
Inductive option (a:Type) {a_WT:WhyType a} :=
  | None : option a
  | Some : a -> option a.
Axiom option_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (option a).
Existing Instance option_WhyType.
Implicit Arguments None [[a] [a_WT]].
Implicit Arguments Some [[a] [a_WT]].

(* Why3 assumption *)
Inductive list (a:Type) {a_WT:WhyType a} :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a] [a_WT]].
Implicit Arguments Cons [[a] [a_WT]].

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a}(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.

Axiom Length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), (0%Z <= (length l))%Z.

Axiom Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

(* Why3 assumption *)
Inductive char  :=
  | Zero : char
  | One : char .
Axiom char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Inductive regexp  :=
  | Empty : regexp
  | Epsilon : regexp
  | Char : char -> regexp
  | Alt : regexp -> regexp -> regexp
  | Concat : regexp -> regexp -> regexp
  | Star : regexp -> regexp .
Axiom regexp_WhyType : WhyType regexp.
Existing Instance regexp_WhyType.

(* Why3 assumption *)
Fixpoint infix_plpl {a:Type} {a_WT:WhyType a}(l1:(list a)) (l2:(list
  a)) {struct l1}: (list a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.

Axiom Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((infix_plpl l (Nil :(list a))) = l).

Axiom Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), ((length (infix_plpl l1
  l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Fixpoint mem {a:Type} {a_WT:WhyType a}(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.

Axiom mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x
  l2)).

Axiom mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (infix_plpl l1 (Cons x l2))).

(* Why3 assumption *)
Definition word  := (list char).

(* Why3 assumption *)
Inductive mem1 : (list char) -> regexp -> Prop :=
  | mem_eps : (mem1 (Nil :(list char)) Epsilon)
  | mem_char : forall (c:char), (mem1 (Cons c (Nil :(list char))) (Char c))
  | mem_altl : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem1 w r1) ->
      (mem1 w (Alt r1 r2))
  | mem_altr : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem1 w r2) ->
      (mem1 w (Alt r1 r2))
  | mem_concat : forall (w1:(list char)) (w2:(list char)) (r1:regexp)
      (r2:regexp), (mem1 w1 r1) -> ((mem1 w2 r2) -> (mem1 (infix_plpl w1 w2)
      (Concat r1 r2)))
  | mems1 : forall (r:regexp), (mem1 (Nil :(list char)) (Star r))
  | mems2 : forall (w1:(list char)) (w2:(list char)) (r:regexp), (mem1 w1
      r) -> ((mem1 w2 (Star r)) -> (mem1 (infix_plpl w1 w2) (Star r))).

(* Why3 assumption *)
Inductive stream  :=
  | mk_stream : (list char) -> stream .
Axiom stream_WhyType : WhyType stream.
Existing Instance stream_WhyType.

(* Why3 assumption *)
Definition state(v:stream): (list char) :=
  match v with
  | (mk_stream x) => x
  end.

(* Why3 goal *)
Theorem nil_notin_r1 : ~ (mem1 (Nil :(list char))
  (Concat (Star (Alt (Char Zero) (Char One))) (Char One))).
red; intro.
inversion H.
inversion H4.
rewrite <- H5 in H0.
destruct w1;
simpl in H0;
discriminate H0.
Qed.


From iris_c.program_logic Require Export weakestpre.
From iris.algebra Require Import gmap auth agree gset coPset.
From iris.base_logic Require Import big_op soundness.
From iris.base_logic.lib Require Import wsat.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

(* Global functor setup *)
Definition invΣ : gFunctors :=
  #[GFunctor (authRF (gmapURF positive (agreeRF (laterCF idCF))));
    GFunctor coPset_disjUR;
    GFunctor (gset_disjUR positive)].

Class invPreG (Σ : gFunctors) : Set := WsatPreG {
  inv_inPreG :> inG Σ (authR (gmapUR positive (agreeR (laterC (iPreProp Σ)))));
  enabled_inPreG :> inG Σ coPset_disjR;
  disabled_inPreG :> inG Σ (gset_disjR positive);
}.

Instance subG_invΣ {Σ} : subG invΣ Σ → invPreG Σ.
Proof. solve_inG. Qed.

(* Allocation *)
Lemma wsat_alloc `{invPreG Σ} : (|==> ∃ _ : invG Σ, wsat ∗ ownE ⊤)%I.
Proof.
  iIntros.
  iMod (own_alloc (● (∅ : gmap _ _))) as (γI) "HI"; first done.
  iMod (own_alloc (CoPset ⊤)) as (γE) "HE"; first done.
  iMod (own_alloc (GSet ∅)) as (γD) "HD"; first done.
  iModIntro; iExists (WsatG _ _ _ _ γI γE γD).
  rewrite /wsat /ownE; iFrame.
  iExists ∅. rewrite fmap_empty big_sepM_empty. by iFrame.
Qed.

(* Program logic adequacy *)
Record adequate {Λ} (e1 : expr Λ * local_state Λ) (σ1 : state Λ) (φ : val Λ → Prop) := {
  adequate_result l2 t2 σ2 v2 :
   rtc step ([e1], σ1) ((of_val v2, l2) :: t2, σ2) → φ v2;
  adequate_safe l2 t2 σ2 e2 :
   rtc step ([e1], σ1) (t2, σ2) →
   (e2, l2) ∈ t2 → (is_Some (to_val e2) ∨ reducible e2 l2 σ2)
}.

Theorem adequate_tp_safe {Λ} (e1 : expr Λ * local_state Λ) t2 σ1 σ2 φ :
  adequate e1 σ1 φ →
  rtc step ([e1], σ1) (t2, σ2) →
  Forall (λ e, is_Some (to_val (e.1))) t2 ∨ ∃ t3 σ3, step (t2, σ2) (t3, σ3).
Proof.
  intros Had ?.
  destruct (decide (Forall (λ e, is_Some (to_val (e.1))) t2)) as [|Ht2]; [by left|].
  apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
  destruct e2 as [e2 l2].
  destruct (adequate_safe e1 σ1 φ Had l2 t2 σ2 e2) as [?|(e3&l3&σ3&efs&?)];
    rewrite ?eq_None_not_Some; auto.
  { exfalso. eauto. }
  destruct (elem_of_list_split t2 (e2, l2)) as (t2'&t2''&->); auto.
  right; exists (t2' ++ (e3, l3) :: t2'' ++ map (,init_local Λ) efs), σ3; econstructor; eauto.
Qed.

Section adequacy.
Context `{irisG Λ Σ}.
Implicit Types e : expr Λ * local_state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types Φs : list (val Λ → iProp Σ).

Notation world σ := (wsat ∗ ownE ⊤ ∗ state_interp σ)%I.

Notation wptp t := ([∗ list] ef ∈ t, WP ef {{ _, True }})%I.

Lemma wp_step e1 σ1 e2 σ2 efs Φ :
  prim_step (e1.1) (e1.2) σ1 (e2.1) (e2.2) σ2 efs →
  world σ1 ∗ WP e1 {{ Φ }} ==∗ ▷ |==> ◇ (world σ2 ∗ WP e2 {{ Φ }} ∗ wptp (map (, init_local Λ) efs)).
Proof.
  rewrite {1}wp_unfold /wp_pre. iIntros (Hstep) "[(Hw & HE & Hσ) [H|[_ H]]]".
  { iDestruct "H" as (v) "[% _]". apply val_stuck in Hstep; simplify_eq. }
  rewrite fupd_eq /fupd_def.
  iMod ("H" $! σ1 with "Hσ [Hw HE]") as ">(Hw & HE & _ & H)"; first by iFrame.
  iModIntro; iNext.
  iMod ("H" $! e2 σ2 efs with "[%] [$Hw $HE]") as ">($ & $ & $ & $ & ?)"=>//.
  iDestruct (@big_sepL_fmap _ (expr Λ) (expr Λ * local_state Λ) (,init_local Λ)
                            (fun _ x => (WP x {{ _, True }})%I) efs with "~") as "?".
  auto.
Qed.

Lemma wptp_step e1 t1 t2 σ1 σ2 Φ :
  step (e1 :: t1,σ1) (t2, σ2) →
  world σ1 ∗ WP e1 {{ Φ }} ∗ wptp t1
  ==∗ ∃ e2 t2', ⌜t2 = e2 :: t2'⌝ ∗ ▷ |==> ◇ (world σ2 ∗ WP e2 {{ Φ }} ∗ wptp t2').
Proof.
  iIntros (Hstep) "(HW & He & Ht)".
  destruct Hstep as [e1' l1' σ1' e2' l2' σ2' efs [|? t1'] t2' ?? Hstep]; simplify_eq/=.
  - iExists (e2', l2'), (t2' ++ map (,init_local Λ) efs); iSplitR; first eauto.
    rewrite big_sepL_app. iFrame "Ht". iApply wp_step; try iFrame; eauto.
  - iExists p, (t1' ++ (e2', l2') :: t2' ++ map (,init_local Λ) efs); iSplitR; first eauto.
    rewrite !big_sepL_app !big_sepL_cons big_sepL_app.
    iDestruct "Ht" as "($ & He' & $)"; iFrame "He".
    iApply wp_step; try iFrame; eauto.
Qed.

Lemma wptp_steps n e1 t1 t2 σ1 σ2 Φ :
  nsteps step n (e1 :: t1, σ1) (t2, σ2) →
  world σ1 ∗ WP e1 {{ Φ }} ∗ wptp t1 ⊢
  Nat.iter (S n) (λ P, |==> ▷ P) (∃ e2 t2',
    ⌜t2 = e2 :: t2'⌝ ∗ world σ2 ∗ WP e2 {{ Φ }} ∗ wptp t2').
Proof.
  revert e1 t1 t2 σ1 σ2; simpl; induction n as [|n IH]=> e1 t1 t2 σ1 σ2 /=.
  { inversion_clear 1; iIntros "?"; eauto 10. }
  iIntros (Hsteps) "H". inversion_clear Hsteps as [|?? [t1' σ1']].
  iMod (wptp_step with "H") as (e1' t1'') "[% H]"; first eauto; simplify_eq.
  iModIntro; iNext; iMod "H" as ">?". by iApply IH.
Qed.

Instance bupd_iter_mono n : Proper ((⊢) ==> (⊢)) (Nat.iter n (λ P, |==> ▷ P)%I).
Proof. intros P Q HP. induction n; simpl; do 2?f_equiv; auto. Qed.

Lemma bupd_iter_frame_l n R Q :
  R ∗ Nat.iter n (λ P, |==> ▷ P) Q ⊢ Nat.iter n (λ P, |==> ▷ P) (R ∗ Q).
Proof.
  induction n as [|n IH]; simpl; [done|].
  by rewrite bupd_frame_l {1}(later_intro R) -later_sep IH.
Qed.

Lemma wptp_result n e1 t1 v2 t2 σ1 σ2 l2 φ :
  nsteps step n (e1 :: t1, σ1) ((of_val v2, l2) :: t2, σ2) →
  world σ1 ∗ WP e1 {{ v, ⌜φ v⌝ }} ∗ wptp t1 ⊢
  Nat.iter (S (S n)) (λ P, |==> ▷ P) ⌜φ v2⌝.
Proof.
  intros. rewrite wptp_steps //.
  rewrite (Nat_iter_S_r (S n)). apply bupd_iter_mono.
  iDestruct 1 as (e2 t2') "(% & (Hw & HE & _) & H & _)"; simplify_eq.
  iDestruct (wp_value_inv with "H") as "H". rewrite fupd_eq /fupd_def.
  iMod ("H" with "[Hw HE]") as ">(_ & _ & $)"; iFrame; auto.
Qed.

Lemma wp_safe e σ Φ :
  world σ ∗ WP e {{ Φ }} ==∗ ▷ ⌜is_Some (to_val (e.1)) ∨ reducible (e.1) (e.2) σ⌝.
Proof.
  rewrite wp_unfold /wp_pre. iIntros "[(Hw&HE&Hσ) [H|[_ H]]]".
  { iDestruct "H" as (v) "[% _]"; eauto 10. }
  rewrite fupd_eq. iMod ("H" with "* Hσ [-]") as ">(?&?&%&?)"; first by iFrame.
  eauto 10.
Qed.

Lemma wptp_safe n e1 e2 t1 t2 σ1 σ2 Φ :
  nsteps step n (e1 :: t1, σ1) (t2, σ2) → e2 ∈ t2 →
  world σ1 ∗ WP e1 {{ Φ }} ∗ wptp t1 ⊢
  Nat.iter (S (S n)) (λ P, |==> ▷ P) ⌜is_Some (to_val (e2.1)) ∨ reducible (e2.1) (e2.2) σ2⌝.
Proof.
  intros ? He2. rewrite wptp_steps //; rewrite (Nat_iter_S_r (S n)). apply bupd_iter_mono.
  iDestruct 1 as (e2' t2') "(% & Hw & H & Htp)"; simplify_eq.
  apply elem_of_cons in He2 as [<-|?]; first (iApply wp_safe; by iFrame "Hw H").
  iApply wp_safe. iFrame "Hw". by iApply (big_sepL_elem_of with "Htp").
Qed.

Lemma wptp_invariance n e1 e2 t1 t2 σ1 σ2 φ Φ :
  nsteps step n (e1 :: t1, σ1) (t2, σ2) →
  (state_interp σ2 ={⊤,∅}=∗ ⌜φ⌝) ∗ world σ1 ∗ WP e1 {{ Φ }} ∗ wptp t1
  ⊢ Nat.iter (S (S n)) (λ P, |==> ▷ P) ⌜φ⌝.
Proof.
  intros ?. rewrite wptp_steps //.
  rewrite (Nat_iter_S_r (S n)) !bupd_iter_frame_l. apply bupd_iter_mono.
  iIntros "[Hback H]".
  iDestruct "H" as (e2' t2') "(% & (Hw&HE&Hσ) & _)"; subst.
  rewrite fupd_eq.
  iMod ("Hback" with "Hσ [$Hw $HE]") as "> (_ & _ & $)"; auto.
Qed.
End adequacy.

Theorem wp_adequacy Σ Λ `{invPreG Σ} e σ φ :
  (∀ `{Hinv : invG Σ},
     True ={⊤}=∗ ∃ stateI : state Λ → iProp Σ,
       let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in
       stateI σ ∗ WP e {{ v, ⌜φ v⌝ }}) →
  adequate e σ φ.
Proof.
  intros Hwp; split.
  - intros l2 t2 σ2 v2 [n ?]%rtc_nsteps.
    eapply (soundness (M:=iResUR Σ) _ (S (S (S n)))); iIntros "".
    rewrite Nat_iter_S. iMod wsat_alloc as (Hinv) "[Hw HE]".
    rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)".
    iDestruct "Hwp" as (Istate) "[HI Hwp]".
    iModIntro. iNext. iApply (@wptp_result _ _ (IrisG _ _ Hinv Istate)); eauto.
    iFrame. by iApply big_sepL_nil.
  - intros l2 t2 σ2 e2 [n ?]%rtc_nsteps ?.
    eapply (soundness (M:=iResUR Σ) _ (S (S (S n)))); iIntros "".
    rewrite Nat_iter_S. iMod wsat_alloc as (Hinv) "[Hw HE]".
    rewrite fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)".
    iDestruct "Hwp" as (Istate) "[HI Hwp]".
    iModIntro. iNext. iApply (@wptp_safe _ _ (IrisG _ _ Hinv Istate) _ _ (e2, l2)); eauto.
    iFrame. by iApply big_sepL_nil.
Qed.

Theorem wp_invariance Σ Λ `{invPreG Σ} e σ1 t2 σ2 φ Φ :
  (∀ `{Hinv : invG Σ},
     True ={⊤}=∗ ∃ stateI : state Λ → iProp Σ,
       let _ : irisG Λ Σ := IrisG _ _ Hinv stateI in
       stateI σ1 ∗ WP e {{ Φ }} ∗ (stateI σ2 ={⊤,∅}=∗ ⌜φ⌝)) →
  rtc step ([e], σ1) (t2, σ2) →
  φ.
Proof.
  intros Hwp [n ?]%rtc_nsteps.
  eapply (soundness (M:=iResUR Σ) _ (S (S (S n)))); iIntros "".
  rewrite Nat_iter_S. iMod wsat_alloc as (Hinv) "[Hw HE]".
  rewrite {1}fupd_eq in Hwp; iMod (Hwp with "[$Hw $HE]") as ">(Hw & HE & Hwp)".
  iDestruct "Hwp" as (Istate) "(HIstate & Hwp & Hclose)".
  iModIntro. iNext. iApply (@wptp_invariance _ _ (IrisG _ _ Hinv Istate)); eauto.
  iFrame "Hw HE Hwp HIstate Hclose". by iApply big_sepL_nil.
Qed.


(* RtacDemo.v
 * Contains a demonstration of the quantifier-puller's funcionality,
 * As well as some supporting infrastructure/automation.
 *)

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.
Require Import MirrorCore.Lambda.RedAll.
Require Import MirrorCore.Lambda.RewriteStrat.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.Reify.Reify.
Require Import MirrorCore.RTac.IdtacK.
Require Import McExamples.PolyRewrite.MSimple.
Require Import McExamples.PolyRewrite.MSimpleReify.
Require Import McExamples.PolyRewrite.QuantifierPuller.PolyQuantPullRtac.

Set Implicit Arguments.
Set Strict Implicit.

(* Convenient abbreviation for modular type *)
Let tyBNat := CoreTypes.tyBase0 tyNat.

Definition fAnd a b : expr typ func := App (App (Inj MSimple.And) a) b.
Definition fOr a b : expr typ func := App (App (Inj MSimple.And) a) b.
Definition fAll t P : expr typ func := App (Inj (MSimple.All t)) (Abs t P).
Definition fEx t P : expr typ func := App (Inj (MSimple.Ex t)) (Abs t P).
Definition fEq t : expr typ func := (Inj (MSimple.Eq t)).
Definition fImpl : expr typ func := (Inj MSimple.Impl).
Definition fEq_nat a b : expr typ func := App (App (fEq tyBNat) a) b.
Definition fN n : expr typ func := Inj (MSimple.N n).

Fixpoint goal n : expr typ func :=
  match n with
  | 0 => fEq_nat (fN 0) (fN 0)
  | S n =>
    fAnd (fEx tyBNat (goal n)) (fEx tyBNat (goal n))
  end.

Fixpoint goal2 mx n (acc : nat) : expr typ func :=
  match n with
  | 0 =>
    if acc ?[ lt ] mx then
      fEx tyBNat (fEq_nat (fN 0) (fN 0))
    else
      fEq_nat (fN 0) (fN 0)
  | S n =>
    fAnd (goal2 mx n (acc * 2)) (goal2 mx n (acc * 2 + 1)) (*
    fAnd (fEx tyNat (goal n)) (fEx tyNat (goal n)) *)
  end.

Fixpoint goal2_D mx n (acc : nat) : Prop :=
  match n with
  | 0 =>
    if acc ?[ lt ] mx then
      exists x : nat, 0 = 0
    else
      0 = 0
  | S n =>
    goal2_D mx n (acc * 2) /\ goal2_D mx n (acc * 2 + 1)
  end.

Fixpoint goal2_D' mx mx2 n (acc : nat) : Prop :=
  match n with
  | 0 =>
    if acc ?[ lt ] mx then
      exists x : nat, 0 = 0
    else if acc ?[lt] mx2 then
           exists b : bool, 0 = 0 else
           0 = 0
  | S n =>
    goal2_D' mx mx2 n (acc * 2) /\ goal2_D' mx mx2 n (acc * 2 + 1)
  end.

Fixpoint count_quant (e : expr typ func) : nat :=
  match e with
  | App (Inj (Ex _)) (Abs _ e') => S (count_quant e')
  | _ => 0
  end.

Definition benchmark (n m : nat) : bool :=
  match quant_pull (goal2 m n 0) (Rinj fImpl) nil (TopSubst _ nil nil)
  with
  | Some _ => true
  | _ => false
  end.

Definition rewrite_it : rtac typ (expr typ func) :=
  @auto_setoid_rewrite_bu typ func (expr typ func)
                          (Rflip (Rinj fImpl))
                          (is_reflR is_refl) (is_transR is_trans) pull_all_quant get_respectful.

Theorem rewrite_it_sound : rtac_sound rewrite_it.
Proof.
  eapply auto_setoid_rewrite_bu_sound with (RbaseD:=RbaseD).
  - eapply RbaseD_single_type.
  - reflexivity.
  - eapply is_reflROk; eapply is_refl_ok.
  - eapply is_transROk; eapply is_trans_ok.
  - eapply pull_all_quant_sound.
  - eapply get_respectful_sound.
Qed.

Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Reify.Reify.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.CTypes.CoreTypes.

Instance Expr_expr : Expr typ (expr typ func) := Expr.Expr_expr.

Ltac reduce_propD g e := eval cbv beta iota zeta delta
    [ g goalD Ctx.propD exprD_typ0 exprD Expr_expr Expr.Expr_expr
      exprT_UseV exprT_UseU exprT_GetUAs exprT_GetVAs
      HList.nth_error_get_hlist_nth HList.hlist_hd HList.hlist_tl
      ExprDsimul.ExprDenote.lambda_exprD func_simul symAs typ0_cast Typ0_Prop
      typeof_sym RSym_func type_cast typeof_func RType_ctyp typ2_match
      Typ2_Fun ctyp_dec
      ctyp_dec
      typ2 Relim exprT_Inj eq_ind eq_rect eq_rec
      AbsAppI.exprT_App eq_sym
      typ2_cast sumbool_rec sumbool_rect eq_ind_r f_equal typ0 symD funcD
      RType_typ symbol_dec ctyp_cast TSym_typ' typ'_dec
      typD ctypD symbolD
    ] in e.

Arguments Typ0_Prop {_ _}.

(* Maybe we can use typeclasses to resolve the reification function *)
  Ltac run_tactic reify tac tac_sound :=
    match goal with
    | |- ?goal =>
      let k g :=
          let result := constr:(runRtac typ (expr typ func) nil nil g tac) in
          let resultV := eval vm_compute in result in
          lazymatch resultV with
          | Solved _ =>
            change (@propD _ _ _ Typ0_Prop Expr_expr nil nil g) ;
              cut(result = resultV) ;
              [
              | vm_cast_no_check (@eq_refl _ resultV) ]
          | More_ _ ?g' =>
            pose (g'V := g') ;
            let post := constr:(match @goalD _ _ _ Typ0_Prop Expr_expr nil nil g'V with
                                | Some G => G HList.Hnil HList.Hnil
                                | None => True
                                end) in
            let post := reduce_propD g'V post in
            lazymatch post with
            | ?G =>
              cut G ;
                [ change (@closedD _ _ _ Typ0_Prop Expr_expr nil nil g g'V) ;
                  cut (result = More_ (@TopSubst _ _ _ _) g'V) ;
                  [ exact (@rtac_More_closed_soundness _ _ _ _ _ _ tac_sound nil nil g g'V)
                  | vm_cast_no_check (@eq_refl _ resultV) ]
                | try clear g'V g ]
            end
          | Fail => idtac "failed"
          | ?G => fail "reduction failed with " G
          end
      in
      reify_expr_bind reify k [[ True ]] [[ goal ]]
    end.

  Definition goal2_D'' n : Prop :=
  let thirdn := Nat.div n 3 in
  goal2_D' thirdn (2 * thirdn) n 0.

(*Set Printing Depth 5.*) (* To avoid printing large terms *)

Ltac the_tac := run_tactic reify_simple rewrite_it rewrite_it_sound.

(* examples of things that don't work *)
(*
Goal ((exists (x : nat), 1 = 1)/\(exists (y : nat), 2 = 2)).
Variable k : nat.
Goal (1 = 1 /\ exists (y : nat), y = 1).
  Time the_tac.
 *)

Goal (exists x : nat, x = 1) /\ (1 = 1).
  Time the_tac.
  repeat exists 1. tauto.
Qed.

Goal goal2_D'' 2.
  vm_compute. Time the_tac.
  repeat exists 0.
repeat exists true. tauto.
Qed.

(* Data: keeping track of values for runs for different n
   we report time-out if any runs time out

   we report (total, reification) times as pairs

   TODO: we should also report QED times

   we need at least 3-14
   3: .034, .032, .032, .032, .032 (reif 0 for all)
   4: .042, .043, .043, .043, .043 (reif 0 for all)
   5: (.062, 0), (.069, .004), (.062, 0), (.062, 0), (.063, 0)
   6: (.111, .004), (.115, .004), (.113, 0), (.113, 0), (.115, 0)
   7: ?
   8: (.371, .004), (.372, .004), (.372, .004), (.372, .004), (.373, .008)
   9: ?
   10: (1.602, .016), (1.749, .012), (1.651, .016), (1.633, .016), (1.65, .016)
   12: (7.123, .06), (7.08, .052), (7.02, .056), (6.977, .056), (6.98, .056)
   13: ?
   14: (28.662, .276), (30.69, .264), (28.595, .272), (,), (,)
   16:
*)

(* original goal *)
Goal goal2_D' 2 4 (* n = *) 5 0.
  simpl.
(*
  Check ex.

  Ltac reify_term e :=
    lazymatch e with
    | fun ctx => fst ctx => uconstr:(Var 0)
    | fun ctx => snd (@?V ctx) => get_var V uconstr:(1)
    | fun ctx => @?X ctx /\ @?Y ctx =>
      let x := reify_term X in
      let y := reify_term Y in
      uconstr:(fAnd x y)
    | fun ctx => @eq ?ty (@?l ctx) (@?r ctx) =>
      let ty := reify_type ty in
      let l := reify_term l in
      let r := reify_term r in
      uconstr:(App (App (fEq ty) l) r)
    | fun ctx => @ex ?ty (@?P ctx) =>
      let ty := reify_type ty in
      let P := reify_term P in
      uconstr:(fEx ty P)
    | fun ctx => (fun x : ?ty => @?P ctx x) =>
      let ty := reify_type ty in
      let P := constr:(fun ctx => P (snd ctx) (fst ctx)) in
      let P := reify_term P in
      uconstr:(Abs ty P)
    | fun ctx => O =>
      uconstr:(fN 0)
    end
  with get_var v acc :=
    lazymatch v with
    | fun ctx => fst ctx => uconstr:(Var acc)
    | fun ctx => snd (@?X ctx) => let acc' := uconstr:(S acc) in
                                  get_var X acc'
    end
  with reify_type t :=
    lazymatch t with
    | nat => tyBNat
    end.

  Goal (fun x : nat => x) = fun x => x.
    match goal with
    | |- ?X => let x := reify_term (fun ctx : unit => (fun x : nat => x)) in
               pose x
    end.
*)

Time run_tactic reify_simple rewrite_it rewrite_it_sound.
repeat exists 0.
repeat exists true. tauto.
Qed.

Module Demo.
  Ltac prep := vm_compute.
  Ltac run := run_tactic reify_simple rewrite_it rewrite_it_sound.
  Ltac cleanup := repeat ( first [exists 0 | exists true]); tauto.
  Definition goal := goal2_D''.
End Demo.


Definition level0 := 1.

Extraction "extractDebug.ml" level0.

Module Type ADT.

  Parameter ADTValue : Type.

End ADT.

Module Type RepInv (E : ADT).

  Parameter rep_inv : E.ADTValue.

End RepInv.

Module NatADT <: ADT.

    Definition ADTValue := nat.

End NatADT.

Module NatRepInv <: RepInv NatADT.

    Definition rep_inv := 1.

End NatRepInv.

Module File1.

  Module Make (E : ADT) (M : RepInv E).

    Definition value := M.rep_inv.

  End Make.

End File1.

Module Level1 := File1.Make NatADT NatRepInv.
Definition level1 := Level1.value.

Extraction "extractDebug.ml" level1.

Module File2.

  Module Make (E : ADT) (M : RepInv E).

    Module Made := File1.Make E M.
    Definition value := Made.value.

  End Make.

End File2.

Module Level2 := File2.Make NatADT NatRepInv.
Definition level2 := Level2.value.

Extraction "extractDebug.ml" level2.

Module File3.

  Module Make (E : ADT) (M : RepInv E).

    Module Made := File2.Make E M.
    Definition value := Made.value.

  End Make.

End File3.

Module Level3 := File3.Make NatADT NatRepInv.
Definition level3 := Level3.value.

Extraction "extractDebug.ml" level3.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)
Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.

Class Age_alg (A:Type) {JOIN: Join A}{as_age : ageable A} :=
mkAge {
  age1_join : forall x {y z x'}, join x y z -> age x x' ->
    exists y':A, exists z':A, join x' y' z' /\ age y y' /\ age z z'
; age1_join2 : forall x {y z z'}, join x y z -> age z z' ->
    exists x':A, exists y':A, join x' y' z' /\ age x x' /\ age y y'
; unage_join : forall x {x' y' z'}, join x' y' z' -> age x x' ->
    exists y:A, exists z:A, join x y z /\ age y y' /\ age z z'
; unage_join2 : forall z {x' y' z'}, join x' y' z' -> age z z' ->
    exists x:A, exists y:A, join x y z /\ age x x' /\ age y y'
}.

Lemma age1_None_joins {A}{JA: Join A}{PA: Perm_alg A}{agA: ageable A}{XA: Age_alg A}: forall phi1 phi2, joins phi1 phi2 -> age1 phi1 = None -> age1 phi2 = None.
Proof.
  intros.
  destruct H.
  case_eq (age1 phi2); intros; auto.
  destruct (age1_join _ (join_comm H) H1)  as [phi1' [x' [? [? ?]]]].
  unfold age in *; rewrite H0 in H3; inv H3.
Qed.

Lemma age1_joins_eq {A} {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{XA: Age_alg A}: forall phi1 phi2,
        joins phi1 phi2 ->
        forall phi1', age1 phi1 = Some phi1' ->
        forall phi2', age1 phi2 = Some phi2' ->
        joins phi1' phi2'.
Proof.
  intros.
  destruct H.
  destruct (age1_join _ H H0) as [phi7 [x' [? [? ?]]]].
  unfold age in *; rewrite H1 in H3; inv H3.
  exists x'; auto.
Qed.

Section BIJECTION.
  Variables A B : Type.
  Variable JA: Join A.
  Variable PA: Perm_alg A.
  Variable ag: ageable A.
  Variable bijAB: bijection A B.
  Variable asa : Age_alg A.

  Existing Instance PA.

  Instance agB : ageable B := (ag_bij _ _ ag bijAB).

(*  Instance PA_B:  @Perm_alg B (Join_bij _ _ _ bijAB ) := @Perm_bij A JA PA B bijAB. *)

  Theorem asa_bijection : @Age_alg B (Join_bij _ _ _ bijAB) agB.
  Proof.
    constructor; unfold age, Join_bij; simpl;     destruct bijAB as [f g fg gf]; simpl  in *; intros.

    (* commute1 *)
    revert H0; case_eq (age1 (g x)); intros; try discriminate.
    inv H1.
    rename a into gx'.  red in H.
    destruct (age1_join _ H H0) as  [gy' [gz' [? [? ?]]]].
    exists (f gy'); exists (f gz').
    split. red.
    repeat rewrite gf. auto.
    rewrite H2; rewrite H3.
    auto.

    (* commute2 *)
    revert H0; case_eq (age1 (g z)); intros; try discriminate.
    inv H1.
    rename a into gz'. red in H.
    destruct (age1_join2 _ H H0) as  [gx' [gy' [? [? ?]]]].
    exists (f gx'); exists (f gy').
    split. red; repeat rewrite gf; auto.
    rewrite H2; rewrite H3.
    auto.

    (* commute3 *)
    revert H0; case_eq (age1 (g x)); intros; try discriminate.
    inv H1.
    rename a into gx'. red in H.
    rewrite gf in *.
    destruct (unage_join _ H H0) as  [gy' [gz' [? [? ?]]]].
    exists (f gy'); exists (f gz').
    split. red; repeat rewrite gf; auto.
    repeat rewrite gf. rewrite H2; rewrite H3.
    repeat rewrite fg; split; auto.

    (* commute4 *)
    revert H0; case_eq (age1 (g z)); intros; try discriminate.
    inv H1.
    rename a into gz'. red in H.
    rewrite gf in *.
    destruct (unage_join2 _ H H0) as  [gx' [gy' [? [? ?]]]].
    exists (f gx'); exists (f gy').
    split. red.    repeat rewrite gf; auto.
    repeat rewrite gf.
    rewrite H2; rewrite H3.
    repeat rewrite fg; split; auto.
  Qed.
End BIJECTION.

Section PROD.
  Variable A : Type.
  Variable J_A: Join A.
  Variable saA : Perm_alg A.
  Variable agA : ageable A.
  Variable B: Type.
  Variable J_B: Join B.
  Variable saB : Perm_alg B.
  Variable asa : Age_alg A.

  Theorem asa_prod : @Age_alg (prod A B) _ (ag_prod A B agA).
  Proof.
    constructor; unfold age; simpl; unfold Join_prod.

    (* commute1 *)
    intros [xa xb] [ya yb] [za zb] [xa' xb'] [? ?].
    simpl in *.
    case_eq (age1 xa); intros; inv H2.
    destruct (age1_join _ H H1) as [ya' [za' [? [? ?]]]].
    exists (ya',yb); exists (za',zb);
      rewrite H3; rewrite H4; repeat split; auto.

    (* commute2 *)
    intros [xa xb] [ya yb] [za zb] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 za); intros; inv H2.
    destruct (age1_join2 _ H H1) as [xa' [ya' [? [? ?]]]].
    exists (xa',xb); exists (ya',yb);
      rewrite H3; rewrite H4; repeat split; auto.

    (* commute3 *)
    intros [xa xb] [xa' xb'] [ya' yb'] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 xa); intros; inv H2.
    destruct (unage_join _ H H1) as [ya [za [? [? ?]]]].
    exists (ya,yb'); exists (za,zb'); simpl.
    rewrite H3; rewrite H4; repeat split; auto.

    (* commute4 *)
    intros [za zb] [xa' xb'] [ya' yb'] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 za); intros; inv H2.
    destruct (unage_join2 _ H H1) as [xa [ya [? [? ?]]]].
    exists (xa,xb'); exists (ya,yb'); simpl.
    rewrite H3; rewrite H4; repeat split; auto.
  Qed.
End PROD.

Section PROD'.
  Variable A : Type.
  Variable J_A: Join A.
  Variable saA : Perm_alg A.
  Variable B: Type.
  Variable J_B: Join B.
  Variable saB : Perm_alg B.
  Variable agB : ageable B.
  Variable asb : Age_alg B.

  Theorem asa_prod' : @Age_alg (prod A B) _ (ag_prod' A B agB).
  Proof.
    constructor; unfold age; simpl; unfold Join_prod.

    (* commute1 *)
    intros [xa xb] [ya yb] [za zb] [xa' xb'] [? ?].
    simpl in *.
    case_eq (age1 xb); intros; inv H2.
    destruct (age1_join _ H0 H1) as [yb' [zb' [? [? ?]]]].
    exists (ya,yb'); exists (za,zb');
      rewrite H3; rewrite H4; repeat split; auto.

    (* commute2 *)
    intros [xa xb] [ya yb] [za zb] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 zb); intros; inv H2.
    destruct (age1_join2 _ H0 H1) as [xb' [yb' [? [? ?]]]].
    exists (xa,xb'); exists (ya,yb');
      rewrite H3; rewrite H4; repeat split; auto.

    (* commute3 *)
    intros [xa xb] [xa' xb'] [ya' yb'] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 xb); intros; inv H2.
    destruct (unage_join _ H0 H1) as [yb [zb [? [? ?]]]].
    exists (ya',yb); exists (za',zb); simpl.
    rewrite H3; rewrite H4; repeat split; auto.

    (* commute4 *)
    intros [za zb] [xa' xb'] [ya' yb'] [za' zb'] [? ?].
    simpl in *.
    case_eq (age1 zb); intros; inv H2.
    destruct (unage_join2 _ H0 H1) as [xb [yb [? [? ?]]]].
    exists (xa',xb); exists (ya',yb); simpl.
    rewrite H3; rewrite H4; repeat split; auto.
  Qed.
End PROD'.

Lemma joins_fashionR {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{XA: Age_alg A} : forall x y,
  joins x y -> fashionR x y.
Proof.
  pose proof I.
  intros.
  unfold fashionR.
  destruct H0 as [z ?].
  revert y z H0; induction x using age_induction; intros.
  case_eq (age1 x); intros.
  destruct (age1_join _ H1 H2) as [p [q [? [? ?]]]].
  assert (level a = level p).
  apply H0 with q; auto.
  replace (level x) with (S (level a)).
  replace (level y) with (S (level p)).
  f_equal; auto.
  symmetry; apply age_level; auto.
  symmetry; apply age_level; auto.
  case_eq (age1 y); intros.
  apply join_comm in H1.
  destruct (age1_join _ H1 H3) as [p [q [? [? ?]]]].
  hnf in H5; rewrite H5 in H2; discriminate.
  rewrite age1_level0 in H2.
  rewrite age1_level0 in H3.
  congruence.
Qed.

Lemma comparable_fashionR {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} {agA: ageable A} {XA: Age_alg A} : forall x y,
  comparable x y -> fashionR x y.
Proof.
  intros.
  apply comparable_common_unit in H.
  destruct H as [u [H1 H2]].
  hnf; transitivity (level u).
  apply joins_fashionR; eauto.
  symmetry.
  apply joins_fashionR; eauto.
Qed.

Lemma age_identity {A} `{asaA: Age_alg A}: forall phi phi', age phi phi'->
    identity phi -> identity phi'.
Proof.
intros.
unfold identity in *.
intros.
destruct (unage_join _ H1 H) as [y [? [? [? ?]]]].
spec H0 y x H2.
subst.
unfold age in *. congruence.
Qed.

Lemma age_comparable {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} {agA: ageable A}{asaA: Age_alg A}:
    forall phi1 phi2 phi1' phi2', age phi1 phi1' -> age phi2 phi2' ->
      comparable phi1 phi2 -> comparable phi1' phi2'.
Proof.
  intros.
  destruct (comparable_common_unit H1) as [e [? ?]].
  destruct (age1_join _ (join_comm H2) H) as [a [b [? [? ?]]]].
  destruct (age1_join _ (join_comm H3) H0) as [c [d [? [? ?]]]].
  assert (c=a) by (unfold age in *; congruence); subst c.
  assert (b=phi1') by (unfold age in *; congruence). subst b.
  assert (d=phi2') by (unfold age in *; congruence). subst d.
  apply common_unit_comparable.
  exists a.
  split; apply join_comm; auto.
Qed.

  Lemma asa_nat : @Age_alg nat (Join_equiv nat) ag_nat.
  Proof.
    constructor.
    repeat intro. hnf in H; subst; auto.
    intros.
    destruct H; subst.
    exists x'. exists x'.
    intuition.
    intros.
    destruct H; subst.
    exists z'; exists z'; intuition.
    intros. destruct H; subst.
    exists x; exists x. intuition.
    intros. destruct H; subst.
    exists z; exists z; intuition.
  Qed.

Lemma nec_join2 {A} `{asaA : Age_alg A}: forall {x y z z' : A},
       join x y z ->
       necR z z' ->
       exists x',
         exists y',
           join x' y' z' /\ necR x x' /\ necR y y'.
Proof.
intros.
revert x y H; induction H0; intros.
edestruct (age1_join2) as [x' [y' [? [? ?]]]]; eauto.
exists x'; exists y'; split; auto.
split; constructor 1; auto.
exists x0; exists y; split; auto.
destruct (IHclos_refl_trans1 _ _ H) as [x' [y' [? [? ?]]]].
destruct (IHclos_refl_trans2 _ _ H0) as [x'' [y'' [? [? ?]]]].
exists x''; exists y''.
split; auto.
split; econstructor 3; eauto.
Qed.

Lemma nec_join {A} `{asaA : Age_alg A}: forall {x y z x' : A},
       join x y z ->
       necR x x' ->
       exists y' ,
         exists z' ,
           join x' y' z' /\ necR y y' /\ necR z z'.
Proof.
intros.
revert y z H; induction H0; intros.
edestruct age1_join as [y' [z' [? [? ?]]]]; eauto.
exists y'; exists z'; split; auto.
split; constructor 1; auto.
exists y; exists z; split; auto.
destruct (IHclos_refl_trans1 _ _ H) as [y' [z' [? [? ?]]]].
destruct (IHclos_refl_trans2 _ _ H0) as [y'' [z'' [? [? ?]]]].
exists y''; exists z''.
split; auto.
split; econstructor 3; eauto.
Qed.

Lemma nec_join4 {A} `{asaA : Age_alg A}: forall z x' y' z' : A,
       join x' y' z' ->
       necR z z' ->
       exists x,
         exists y,
           join x y z /\ necR x x' /\ necR y y'.
Proof.
intros.
revert x' y' H.
induction H0; intros.
destruct (unage_join2 _ H0 H) as  [x0 [y0 [? [? ?]]]].
exists x0; exists y0; split; auto.
split; constructor 1; auto.
exists x'; exists y'; split; auto.

rename x into z1.
rename y into z2.
destruct (IHclos_refl_trans2 _ _ H) as [x'' [y'' [? [? ?]]]].
destruct (IHclos_refl_trans1 _ _ H0) as [x0 [y0 [? [? ?]]]].
exists x0; exists y0.
split; auto.
split; econstructor 3; eauto.
Qed.

Lemma join_level {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{AgeA: Age_alg A}:
  forall x y z, join x y z -> level x = level z /\ level y = level z.
Proof.
  intros.
  assert (exists n, n = level x) by (eexists; reflexivity).
  destruct H0 as [n  ?].
  revert x y z H0 H; induction n; intros.
  case_eq (level y); intros.
  case_eq (level z); intros.
  split; congruence.
  destruct (levelS_age1 _ _ H2).
  destruct (age1_join2 _ H H3) as [u [v [? [? ?]]]].
  apply age_level in H5. congruence.
  destruct (levelS_age1 _ _ H1).
  destruct (age1_join _ (join_comm H) H2) as [u [v [? [? ?]]]].
  apply age_level in H4. congruence.
  symmetry in H0.
  destruct (levelS_age1 _ _ H0) as [x' ?].
  destruct (age1_join _ H H1) as [y' [z' [? [? ?]]]].
  specialize (IHn x' y' z').
  apply age_level in H1. apply age_level in H3. apply age_level in H4.
  destruct IHn; auto. congruence.
  split; congruence.
Qed.

 Lemma level_core {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
     forall m:A, level (core m) = level m.
 Proof. intros.
  generalize (core_unit m); unfold unit_for; intro.
  apply join_level in H. intuition.
 Qed.

Lemma join_core2 {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a b c, join a b c -> core a = core b.
Proof.
intros. generalize H; intro.
apply join_comm in H.
apply join_core in H0; apply join_core in H. congruence.
Qed.

Lemma age_core_eq {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{agA: ageable A}{AgeA: Age_alg A}:
  forall x y x' y', age x x' -> age y y' -> core x = core y -> core x' = core y'.
Proof.
 intros.
 generalize (core_unit x); unfold unit_for; intro. apply join_comm in H2.
 generalize (core_unit y); unfold unit_for; intro. apply join_comm in H3.
 destruct (age1_join _ H2 H) as [u [v [? [? ?]]]].
 destruct (age1_join _ H3 H0) as [i [j [? [? ?]]]].
 unfold age in *. rewrite H in H6. inv H6. rewrite H0 in H9; inv H9.
 rewrite H1 in *. rewrite H5 in H8; inv H8.
 apply join_core2 in H4. apply join_core2 in H7.
  congruence.
Qed.

Lemma age_twin {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall phi1 phi2 n phi1',
  level phi1 = level phi2 ->
  ageN n phi1 = Some phi1' ->
  exists phi2', ageN n phi2 = Some phi2' /\ level phi1' = level phi2'.
Proof.
intros until n; revert n phi1 phi2.
induction n; intros.
exists phi2.
split; trivial.
inversion H0.
subst phi1'.
trivial.
unfold ageN in H0.
simpl in H0.
revert H0; case_eq (age1 phi1); intros; try discriminate.
rename a into phi.
assert (exists ophi2, age phi2 ophi2 /\ level phi = level ophi2).
generalize (age_level _ _ H0); intro.
rewrite H in H2; apply levelS_age1 in H2. destruct H2 as [y ?].
exists y; split; auto.
apply age_level in H0; apply age_level in H2; omega.
destruct H2 as [ophi2 [? ?]].
specialize (IHn _ _ _ H3 H1).
destruct IHn as [phi2' [? ?]].
exists phi2'.
split; trivial.
unfold ageN.
simpl.
rewrite H2.
trivial.
Qed.

Lemma age1_join_eq {A}  {JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A} : forall phi1 phi2 phi3,
        join phi1 phi2 phi3 ->
        forall phi1', age1 phi1 = Some phi1' ->
        forall phi2', age1 phi2 = Some phi2' ->
        forall phi3', age1 phi3 = Some phi3' ->
        join phi1' phi2' phi3'.
Proof.
intros until phi3.
intros H phi1' H0 phi2' H1 phi3' H2.
destruct (age1_join _ H H0) as [phi4 [x' [? [? ?]]]].
unfold age in *.
rewrite H4 in H1.
inversion H1.
rewrite <- H7.
rewrite H5 in H2.
inversion H2.
rewrite <- H8.
auto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                Abstraction_Tactics.v                               *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

(*
Add LoadPath ".." as IntensionalLib.
*)
Require Import Arith Omega.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Abstraction_calculus.Abstraction_Terms.

Definition termred := Term -> Term -> Prop.

Definition preserve (R : termred) (P : Term -> Prop) :=
  forall x : Term, P x -> forall y : Term, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: Term-> Term -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: Term), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: Term), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_app_multi_step preserves_app_seq .

Ltac eelim_for_equal :=
match goal with
| H: forall _, _ = _ -> _  |- _ => eelim H; clear H; subst; eelim_for_equal
| _ => split_all
end.

Ltac inv1 prop :=
match goal with
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof.
unfold diamond; split_all. elim (H M P H1 N H0); split_all.
inversion H2; exist x; split; auto. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
inversion H3; inversion H4;
exist x0; split; auto.
apply succ_red with x; auto.
inversion H3; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all. inversion H3.
elim(IHmulti_step H x); split_all.  inversion H6.
exist x0; split; auto.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all. inversion H3.
elim(IHmulti_step H x H4); split_all. inversion H6; auto.
exist x0; split; auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all. inversion H9.
elim(H0 N0 x H11 P); split_all. inversion H12.
exist x0; split; auto.
apply seq_red with x; auto.
Qed.

Fixpoint rank (M: Term ) :=
match M with
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all.  omega.
Qed.

Ltac split_all := simpl; intros;
match goal with
| H : _ /\ _ |- _ => inversion_clear H; split_all
| H : exists _, _ |- _ => inversion H; clear H; split_all
| _ =>  try (split; split_all); try contradiction
end; try congruence; auto.